Posts: 415
Threads: 75
Joined: Apr 2022
Reputation:
22
07-06-2022, 05:27 PM
(This post was last modified: 07-06-2022, 05:46 PM by SierraKen.)
Here's an even better version. I fixed the proportions as good as I could do it with an equation I made up and I made the orbit of the Moon going around the Earth and Sun close to real life compared to the Earth going around the Sun.
Code: (Select All) '3D Earth Orbit and Moon by SierraKen
'Made on July 6, 2022.
_Title "3D Earth Orbit and Moon by SierraKen"
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Do
_Limit 20
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 120) / _Pi / 1.5 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If y2 < 293.75 Then
'Earth
For S = .25 To r2 Step .25
cc = cc + .25
Circle (x2, y2), S, _RGB32(cc, cc, 100 + cc)
Next S
cc = 0
'Moon
For S = .25 To r3 Step .25
cc4 = cc4 + 2
Circle (x3, y3), S, _RGB32(cc4, cc4, cc4)
Next S
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(200 + cc2, 200 + cc2, 64 + cc2)
Next sun
cc2 = 0
If y2 >= 293.75 Then
'Earth
For S = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), S, _RGB32(cc3, cc3, 100 + cc3)
Next S
cc3 = 0
'Moon
For S = .25 To r3 Step .25
cc5 = cc5 + 2
Circle (x3, y3), S, _RGB32(cc5, cc5, cc5)
Next S
cc5 = 0
If y3 < y2 Then
'Earth
For S = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), S, _RGB32(cc3, cc3, 100 + cc3)
Next S
cc3 = 0
End If
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
Posts: 3,978
Threads: 177
Joined: Apr 2022
Reputation:
220
Hi Ken,
I reversed the coloring so spheres get darker as you approach the outer edge, not lighter, looks more like sheres instead of vacuum holes (have you seen any? LOL )
Code: (Select All) '3D Earth Orbit and Moon by SierraKen
'Made on July 6, 2022.
_Title "3D Earth Orbit and Moon by SierraKen"
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Do
_Limit 20
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 120) / _Pi / 1.5 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If y2 < 300 Then
'Earth
cc = 0
For S = .25 To r2 Step .25
cc = cc + .25
Circle (x2, y2), S, _RGB32(100 - cc, 100 - cc, 200 - cc)
Next S
cc = 0
'Moon
cc4 = 200
For S = .25 To r3 Step .25
cc4 = cc4 - 2
Circle (x3, y3), S, _RGB32(cc4, cc4, cc4)
Next S
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
If y2 > 300 Then
'Earth
cc3 = 0
For S = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), S, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next S
cc3 = 0
'Moon
cc5 = 200
For S = .25 To r3 Step .25
cc5 = cc5 - 2
Circle (x3, y3), S, _RGB32(cc5, cc5, cc5)
Next S
cc3 = 0
If y3 < y2 Then
'Earth
cc3 = 0
For S = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), S, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next S
cc3 = 0
End If
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
b = b + ...
Posts: 3,978
Threads: 177
Joined: Apr 2022
Reputation:
220
Oh hey, wouldn't it be nice to do crescents for waxing and waning moons and earths!
b = b + ...
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(07-06-2022, 06:03 PM)bplus Wrote: Oh hey, wouldn't it be nice to do crescents for waxing and waning moons and earths!
Yup. definetly possible to shove that into that code.
Posts: 415
Threads: 75
Joined: Apr 2022
Reputation:
22
Wow now they actually look like marbles in space! Thanks B+! I added a starfield around them but that's all I can do for now. I wouldn't know where to start on the crescents, etc. because of the way the Sun always changes angles as well as the Earth. So anyway, here is one with a starfield and the fixed orbs, thanks again. Feel free to add anything you wish to it guys.
Code: (Select All) '3D Earth Orbit and Moon by SierraKen
'Made on July 6, 2022.
Dim starx(1000), stary(1000)
Dim dx(1000), dy(1000)
Dim sz(1000)
Dim speed(1000)
Dim cx As Integer, cy As Integer, ra As Integer, cl As _Unsigned Long
_Title "3D Earth Orbit and Moon by SierraKen"
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Do
_Limit 20
'Starfield
fillCircle cx, cy, 5, cl
If sp < .0005 Then sp = .0005
If sp > .1 Then sp = .1
warp = (sp * 100) + 1
If warp > 10 Then warp = 10
warp = Int(warp)
stars = Int(Rnd * 100) + 1
If stars > 25 Then
ss = ss + 1
If ss > 950 Then ss = 1
'Set starting position.
startx = Rnd * 490
starty = Rnd * 390
st = Int(Rnd * 360)
xx = (Sin(st) * startx) + 400
yy = (Cos(st) * starty) + 300
starx(s) = xx
stary(s) = yy
'Set direction to move.
dx(s) = ((xx - 400) / 30)
dy(s) = ((yy - 300) / 30)
'Set size.
sz(s) = Rnd
'Set speed
speed(s) = .1
End If
If yy > 640 Then yy = 0
For tt = 1 To 950
speed(tt) = speed(tt) * (1.05 + sp)
stary(tt) = stary(tt) + dy(tt) * speed(tt)
starx(tt) = starx(tt) + dx(tt) * speed(tt)
cx = starx(tt): cy = stary(tt)
ra = sz(tt) + .5
cl = _RGB32(255, 255, 255)
fillCircle cx, cy, ra, cl
'skip:
Next tt
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 120) / _Pi / 1.5 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If y2 < 293.75 Then
'Earth
For s = .25 To r2 Step .25
cc = cc + .5
Circle (x2, y2), s, _RGB32(100 - cc, 100 - cc, 200 - cc)
Next s
cc = 0
'Moon
cc4 = 200
For s = .25 To r3 Step .25
cc4 = cc4 - 2
Circle (x3, y3), s, _RGB32(cc4, cc4, cc4)
Next s
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
If y2 >= 293.75 Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .5
Circle (x2, y2), s, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next s
cc3 = 0
'Moon
cc5 = 200
For s = .25 To r3 Step .25
cc5 = cc5 - 2
Circle (x3, y3), s, _RGB32(cc5, cc5, cc5)
Next s
cc5 = 0
If y3 < y2 Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .5
Circle (x2, y2), s, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next s
cc3 = 0
End If
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Posts: 415
Threads: 75
Joined: Apr 2022
Reputation:
22
07-06-2022, 08:46 PM
(This post was last modified: 07-06-2022, 08:49 PM by SierraKen.)
I had to fix an annoying problem I had where one side (sometimes both sides) had the Moon go completely in front of Earth on one orbit through the entire year. So I finally found a fix for it. 
Code deleted: Made a new problem.. lol
Posts: 415
Threads: 75
Joined: Apr 2022
Reputation:
22
07-06-2022, 09:08 PM
(This post was last modified: 07-06-2022, 09:36 PM by SierraKen.)
OK here is the 100% fixed version (I hope!). I also fixed an orbital tilt issue I just found as well.
Code: (Select All) '3D Earth Orbit and Moon by SierraKen
'Made on July 6, 2022.
Dim starx(1000), stary(1000)
Dim dx(1000), dy(1000)
Dim sz(1000)
Dim speed(1000)
Dim cx As Integer, cy As Integer, ra As Integer, cl As _Unsigned Long
_Title "3D Earth Orbit and Moon by SierraKen"
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
t2 = 1800
cc4 = 100
cc5 = 100
Do
_Limit 20
'Starfield
fillCircle cx, cy, 5, cl
If sp < .0005 Then sp = .0005
If sp > .1 Then sp = .1
warp = (sp * 100) + 1
If warp > 10 Then warp = 10
warp = Int(warp)
stars = Int(Rnd * 100) + 1
If stars > 25 Then
ss = ss + 1
If ss > 950 Then ss = 1
'Set starting position.
startx = Rnd * 490
starty = Rnd * 390
st = Int(Rnd * 360)
xx = (Sin(st) * startx) + 400
yy = (Cos(st) * starty) + 300
starx(s) = xx
stary(s) = yy
'Set direction to move.
dx(s) = ((xx - 400) / 30)
dy(s) = ((yy - 300) / 30)
'Set size.
sz(s) = Rnd
'Set speed
speed(s) = .1
End If
If yy > 640 Then yy = 0
For tt = 1 To 950
speed(tt) = speed(tt) * (1.05 + sp)
stary(tt) = stary(tt) + dy(tt) * speed(tt)
starx(tt) = starx(tt) + dx(tt) * speed(tt)
cx = starx(tt): cy = stary(tt)
ra = sz(tt) + .5
cl = _RGB32(255, 255, 255)
fillCircle cx, cy, ra, cl
'skip:
Next tt
If t < 90 Then t = 1800
If t2 < 90 Then t2 = 1800
oldx3 = x3
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2
y3 = (Cos(t2) * 80) / _Pi / 2 + y2
r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5
t = t - .025
t2 = t2 - .3
If y2 < 290 Then
'Earth
For s = .25 To r2 Step .25
cc = cc + .5
Circle (x2, y2), s, _RGB32(100 - cc, 100 - cc, 200 - cc)
Next s
cc = 0
'Moon
cc4 = 200
For s = .25 To r3 Step .25
cc4 = cc4 - 2
Circle (x3, y3), s, _RGB32(cc4, cc4, cc4)
Next s
cc4 = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
If y2 >= 290 Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .5
Circle (x2, y2), s, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next s
cc3 = 0
'Moon
cc5 = 200
For s = .25 To r3 Step .25
cc5 = cc5 - 2
Circle (x3, y3), s, _RGB32(cc5, cc5, cc5)
Next s
cc5 = 0
If y3 < y2 Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .5
Circle (x2, y2), s, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next s
cc3 = 0
End If
End If
If x3 > oldx3 And y2 < 290 And (Point(x3 + r3 + 1, y3) <> _RGB32(0, 0, 0) Or Point(x3 + r3 + 1, y3)) <> _RGB32(255, 255, 255) Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .5
Circle (x2, y2), s, _RGB32(100 - cc3, 100 - cc3, 200 - cc3)
Next s
cc3 = 0
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)
Next sun
cc2 = 0
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Posts: 415
Threads: 75
Joined: Apr 2022
Reputation:
22
Here is a video of it. I added free YouTube background music:
https://www.youtube.com/watch?v=NFI1q-3aAIk
Posts: 88
Threads: 8
Joined: May 2022
Reputation:
3
Solar System ?
Write name of program in 1st line to copy & paste & save filename.bas
Insert program pictures: press print-screen-shot button
Open paint & Paste & Save as PNG
Add picture file to program topic
Russia looks world from future. Big data is peace data.
I never recommend anything & always write only about myself
Posts: 272
Threads: 24
Joined: Apr 2022
Reputation:
59
(07-06-2022, 07:03 PM)SierraKen Wrote: Wow now they actually look like marbles in space! Thanks B+! I added a starfield around them but that's all I can do for now. I wouldn't know where to start on the crescents, etc. because of the way the Sun always changes angles as well as the Earth. So anyway, here is one with a starfield and the fixed orbs, thanks again. Feel free to add anything you wish to it guys.
Nice @SierraKen! It looks great online too:
Earth Orbit
View Source
|
