06-27-2023, 03:14 PM
Code: (Select All)
_Title "Plasma Snake - any key to change color" 'b+ 2023-06-27
' inspired once again by Paul Dunn aka ZXDunny here:
' https://retrocoders.phatcode.net/index.php?topic=634.0
' and my mod? hopefully I can do same or similar PLUS allow you to change plasma schemes!
' Plus put a face on it!
' lets see!
Screen _NewImage(800, 600, 32) ' 32 = all colors of _RGBA32() = millions!
_ScreenMove 250, 60 ' you may want different
Randomize Timer ' + so we start different each time, who wants to see same old snake?
Dim Shared PR, PG, PB, CN ' for setup and changing Plasma Color Schemes
PR = Rnd ^ 2: PG = Rnd ^ 2: PB = Rnd ^ 2 ' setup one to start
da = 1: r = 60
Do
CN = 0 ' reset plasma index to 0 for consistent color bands
For x = r To 800 - r ' make a snake body
CN = CN + .5
Color _RGB32(127 + 127 * Sin(PR * CN), 127 + 127 * Sin(PG * CN), 127 + 127 * Sin(PB * CN))
FCirc x, 300 + (300 - r) * Sin(_D2R(x + a)), r, _DefaultColor
Next
' Put a face on it!
x = x - 1
y = 300 + (300 - r) * Sin(_D2R(x + a))
' eyes
FCirc x - .625 * r, y - .1 * r, .125 * r, &HFF000000
FCirc x + .625 * r, y - .1 * r, .125 * r, &HFF000000
Circle (x - .62 * r, y - .1 * r), .1 * r, &HFFFFFFFF
Circle (x + .62 * r, y - .1 * r), .1 * r, &HFFFFFFFF
' nose
FCirc x - .1 * r, y + .35 * r, .025 * r, &HFF000000
FCirc x + .1 * r, y + .35 * r, .025 * r, &HFF000000
' mouth
Line (x - 4, y + .65 * r)-(x + 4, y + .655 * r), &HFFFF0000, BF
' and a little tongue of course
If m Mod 20 = 0 Then ' flash every 10 loops
Line (x - 2, y + .655 * r)-(x + 2, y + .9 * r), &HFFFF0000, BF
Line (x - 2, y + .9 * r)-(x - .08 * r, y + r), &HFFFF0000
Line (x + 2, y + .9 * r)-(x + .08 * r, y + r), &HFFFF0000
End If
_Display
If m Mod 20 = 0 Then ' erase the tongue flash every 10 loops
Line (x - 2, y + .655 * r)-(x + 2, y + .9 * r), _DefaultColor, BF
Line (x - 2, y + .9 * r)-(x - .08 * r, y + r), _DefaultColor
Line (x + 2, y + .9 * r)-(x + .08 * r, y + r), _DefaultColor
End If
m = m + 1
a = a + da
If Len(InKey$) Then PR = Rnd ^ 2: PG = Rnd ^ 2: PB = Rnd ^ 2
Loop Until _KeyDown(27)
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
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 Sub
Much more fun to watch animation!
b = b + ...