Plasma Snake

[bplus]

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!