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