Post by bplus on Feb 26, 2024 1:05:30 GMT
a little challenge from Just Basic Forum:
Didn't look quite right in QBJS but at least can see a bit of it without compiling in QB64.
'Option _Explicit
$If WEB Then
Import G2D From "lib/graphics/2d.bas"
$End If
_Title "Spinning Black Hole Attraction" ' b+ 2024-02-25
Screen _NewImage(600, 600, 32)
Dim nstars, cx, cy, i, dx, dy, d, b, r, a
nstars = 100
Dim Shared sx(1 To nstars), sy(1 To nstars), sr(1 To nstars)
cx = _Width / 2: cy = _Height / 2
'setup start stars
For i = 1 To nstars
sx(i) = Rnd * _Width
sy(i) = Rnd * _Height
sr(i) = Rnd * 3 + 1
Next
Color , &HFF400035
Do
Line (0, 0)-(_Width, _Height), &H11390034, BF
'Cls
'show stars
For i = 1 To 100
dx = cx - sx(i): dy = cy - sy(i)
b = _Atan2(dy, dx)
d = (dx * dx + dy * dy) ^ .5
For r = 0 To sr(i) Step .25
FCirc cx + d * Cos(a + b), cy + d * Sin(a + b), sr(i), &HFFFFFFFF
Next
'now update stars falling into black hole
dx = cx - sx(i): dy = cy - sy(i)
d = (dx * dx + dy * dy) ^ .5
If d < 50 Then 'black hole radius
newStar i
Else ' move it
dx = 30 * dx / (d * d)
dy = 30 * dy / (d * d)
sx(i) = sx(i) + dx
sy(i) = sy(i) + dy
End If
Next
a = a + .001
FCirc cx, cy, 50, &H15FF0000
FCirc cx, cy, 48, &HFF000000
_Display
_Limit 120
Loop Until _KeyDown(27)
Sub newStar (i)
Dim r
r = Int(Rnd * 4) ' 0 to 3
Select Case r
Case 0
sx(i) = Rnd * _Width
sy(i) = 0
Case 1
sx(i) = Rnd * _Width
sy(i) = _Height - 1
Case 2
sy(i) = Rnd * _Height
sx(i) = 0
Case 3
sy(i) = Rnd * _Height
sx(i) = _Width - 1
End Select
End Sub
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
' !!! NEED THIS IN MAIN AT THE VERY TOP BEFORE ANYTHING ELSE !!!
'$If WEB Then
' Import G2D From "lib/graphics/2d.bas"
'$End If
$If WEB Then
G2D.FillCircle CX, CY, R, C
$Else
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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 If
End Sub
Didn't look quite right in QBJS but at least can see a bit of it without compiling in QB64.