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!

[dbox]

[mnrvovrfc]

Psychodelic!

Now if you'll excuse me, I'll have to go to the store to buy Skittles. Now then, will it be the "standard" pack or the tropical one? Argh...

[bplus]

Works great, even response to keypress!

@dbox did you have to change anything? Maybe dim stuff?

@mnrvovrfc Skittles: never had the pleasure, in my day it was Smarties? and see where it got me?

[dbox]

@dbox did you have to change anything? Maybe dim stuff?

I added the Dim on line 13, a _Limit 60 on line 44 and then I made the FCirc conditionally run the QBJS filled circle method.  This last step wasn't absolutely necessary, but it performs better in the browser to use the native fill circle function.

[bplus]

@dbox did you have to change anything? Maybe dim stuff?

I added the Dim on line 13, a _Limit 60 on line 44 and then I made the FCirc conditionally run the QBJS filled circle method.  This last step wasn't absolutely necessary, but it performs better in the browser to use the native fill circle function.

Ah I caught the dims and the FCirc, I should change my QB64 FCirc sub?

Yes! still works fine in QB64:

Code: (Select All)

Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
    $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

I should change my other ones like that too.

Missed the _Limit (posted in some other forums we both are at), I was surprised how the circle drawing was taking so much time that I didn't need _Limit but apparently QBJS through JS can kick butt with circle fills!

[bplus]

Oh will need the Import thing in an $IF also:

Code: (Select All)

$If WEB Then
        Import G2D From "lib/graphics/2d.bas"
$End If

That worked but it didn't work as one-liner (needs to end with $End If).

Need to make a template so when I write something in QB64, it will work in QBJS also. A QBJS .BI and .BM ?