Just checked this in Keybone's QB64 - Lite for Linux, it's been awhile since I've seen this.
Code: (Select All)
Option _Explicit
_Title "Spiral Colored Balls" 'B+ 2019-10-29 mod from
' 2019-10-29 mod be able to draw these balls anywhere
' Rotate colors on a sphere.txt for JB v2.0 bplus 2018-04-16
' from (extremely simplified) Double spiral.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-28
Const xmax = 1200, ymax = 700, pi = _Pi, nBalls = 10, ww = 3.14159 / 2, gravity = 2
Type ball
x As Single
y As Single
a As Single
dx As Single
dy As Single
sc As Single
pr As Single
pg As Single
pb As Single
pn As Single
End Type
Dim Shared b(1 To nBalls) As ball
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20 'this fits my screen yours may be different
Randomize Timer
Dim i As Integer, j As Integer, b As Integer, power, sky As Long
For i = 1 To nBalls
newBall i
Next
sky = _NewImage(xmax, ymax, 32)
_Dest sky&
For i = 0 To ymax
Line (0, i)-(xmax, i), _RGB32(100 + i / ymax * 40, 100 + i / ymax * 50, 160 + i / ymax * 95)
Next
_Dest 0
While _KeyDown(27) = 0
_PutImage , sky&, 0
For i = 1 To nBalls
'ready for collision
b(i).a = _Atan2(b(i).dy, b(i).dx)
power = (b(i).dx ^ 2 + b(i).dy ^ 2) ^ .5
For j = i + 1 To nBalls
If Sqr((b(i).x - b(j).x) ^ 2 + (b(i).y - b(j).y) ^ 2) < 200 * (b(i).sc + b(j).sc) Then
b(i).a = _Atan2(b(i).y - b(j).y, b(i).x - b(j).x)
b(j).a = _Atan2(b(j).y - b(i).y, b(j).x - b(i).x)
Exit For
End If
Next
b(i).dx = power * Cos(b(i).a)
b(i).dy = power * Sin(b(i).a)
b(i).dy = b(i).dy + gravity
b(i).x = b(i).x + b(i).dx
b(i).y = b(i).y + b(i).dy '+ 2 * gravity
If b(i).x < -200 * b(i).sc Or b(i).x > xmax + 200 * b(i).sc Then
newBall i
End If
If b(i).y + 220 * b(i).sc > ymax Then
b(i).y = ymax - 220 * b(i).sc
b(i).dy = b(i).dy * -.8
If b(i).dx = 0 Then b(i).dx = rdir Else b(i).dx = b(i).dx * 1.03
End If
drawBall i
Next
_Display
Wend
Sub drawBall (i)
Dim w, r, e, tmp, p, x, y, lc As Long
w = ww 'fix
For r = 190 To 0 Step -.25
e = w - pi / 4 / (490 - 300)
tmp = e: e = w: w = tmp
For p = 0 To pi Step pi / 144
e = Int((Cos(w) * 380) / 2)
x = b(i).x + e * b(i).sc * Cos(p * 2)
y = b(i).y - 90 * b(i).sc + e * b(i).sc * Sin(p * 2) + r * b(i).sc
lc = lc + 1
If lc Mod 25 = 0 Then
fcirc x, y, 6 * b(i).sc, plasma~&(i)
End If
Next
Next
End Sub
Sub newBall (i)
b(i).x = Rnd * xmax - 40 + 20
b(i).y = Rnd * -200
b(i).dx = rand(1, 3) * rdir
b(i).dy = rand(-5, 5)
b(i).sc = rand(2, 5) / 10
setRGB i
End Sub
Sub setRGB (i)
b(i).pr = Rnd ^ 3: b(i).pg = Rnd ^ 3: b(i).pb = Rnd ^ 3: b(i).pn = 1
End Sub
Function plasma~& (i)
b(i).pn = b(i).pn + .05
plasma~& = _RGBA32(127 + 127 * Sin(b(i).pr * b(i).pn), 127 + 127 * Sin(b(i).pg * b(i).pn), 127 + 127 * Sin(b(i).pb * b(i).pn), 40)
'plasma~& = _RGBA32(127 + 127 * SIN(b(i).pr * b(i).pn), 127 + 127 * SIN(b(i).pg * b(i).pn), 127 + 127 * SIN(b(i).pb * b(i).pn), 255)
End Function
Function rand (lo, hi)
rand = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
Function rdir ()
If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function
'from Steve Gold standard
Sub fcirc (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
b = b + ...
