Post by bplus on Sept 20, 2023 12:52:43 GMT
Short and sweet QB64 and QBJS: (this came up at Discord GotBasic.com when talking about Just Basic)
Shell of Another Color
'Option _Explicit
'_Title "Shell of another color 3" 'b+2020-01-25
'inspired by "shell-like thing" by tsh73 Jan 2020 at JB
' 2020-01-27 Shell of another color 3 adds more improvements
Screen _NewImage(660, 660, 32)
Dim cx, cy, a, dr, R, G, B, PN, size, i, ra, dx, dy, dist, j, shade
'_ScreenMove 300, 40
Dim x(1600), y(1600), c As _Unsigned Long
cx = 340: cy = 390
For a = 0 To _Pi(8) Step _Pi(2 / 400) ' load x, y arrays
x(i) = cx + ra * Cos(a): y(i) = cy + ra * Sin(a)
dr = dr + 1 / 1700: ra = ra + dr ^ 2: i = i + 1
Next
While 1
R = Rnd ^ 2: G = Rnd ^ 2: B = Rnd ^ 2: PN = 0: size = 1
For i = 0 To 1139
dx = x(i + 400) - x(i): dy = y(i + 400) - y(i)
dist = Sqr(dx * dx + dy * dy): dx = dx / dist: dy = dy / dist: PN = PN + .73
If i > 820 Then
size = 3
ElseIf i > 380 Then
size = 2
End If
For j = 0 To dist
shade = 1 - ((dist / 2 - j + 1 / 2) / (dist / 2)) ^ 2
c = _RGB32(shade * Int(127 + 127 * Sin(R * PN)), shade * Int(127 + 127 * Sin(G * PN)), shade * Int(127 + 127 * Sin(B * PN)))
fcirc x(i) + j * dx, y(i) + j * dy, size, c
Next
Next
_Display
_Delay 2
Wend
'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
Shell of Another Color
