Draw Worms Study

[bplus]

Oh it seems I've already solved the problem of Drawing Worms.

This code was inspired by one of Rho Sigma's Screen Savers. I used the worms for a couple of Halloween apps. Thank you @RhoSigma

Here is how I drew worms that creeped across the Worm Yard, if they started at the top border they crept down, right side then creep left,...

Code: (Select All)

sc& = _ScreenImage
_Title "DrawWorms Test and Demo, worms should avoid Yellow and White" 'b+ 2021-10-06
' This is intended for Crypt-O-Gram Puzzle but may use else where also.
' This needs to be done in background on the side and updated with main loop in program using it.

' Use general Object
Type Object
    X As Single ' usu top left corner   could be center depending on object
    Y As Single ' ditto
    W As Single ' width   or maybe radius
    H As Single ' height
    DX As Single ' moving opjects
    DY As Single ' ditto
    DIR As Single ' short for direction or heading usu a radian angle
    Sz As Single ' perhaps a scaling factor
    Act As Integer ' lives countdown or just plain ACTive TF
    C1 As _Unsigned Long ' a foreground color
    C2 As _Unsigned Long ' a background or 2nd color     OR C1 to c2 Range?
End Type

Const nWorms = 30
Const xmax = 800, ymax = 600
Dim Shared Worms(1 To nWorms) As Object
Dim Shared WormYard As Object
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Color &HFFDDDDDD, &HFF442211
Cls 'set backcolor
NewWormYard _Width / 4, _Height / 4, _Width / 2, _Height / 2 ' for this demo the middle of the screen
init = -1
Do
    'sample main loop action
    lc = lc + 1
    If lc Mod 200 = 199 Then init = -1: Cls
    Locate 1, 1: Print lc
    If Rnd < .5 Then c~& = _RGB32(255, 255, 255) Else c~& = _RGB32(255, 0, 0)
    Line (Rnd * _Width, Rnd * _Height)-Step(Rnd * 50, Rnd * 50), c~&, BF
    DrawWorms init
    _Limit 10
Loop Until _KeyDown(27)

Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_Delay .25
'_ScreenMove _Middle
_FullScreen
_PutImage , sc&, 0
' end perfect
_Delay .25 ' <<<< possible racing problem with change of screen size and _width adn Height update
NewWormYard 0, 0, _Width, _Height ' <<< update WornYard to new screen size
_PutImage , sc&, 0
init = -1 'only way to see sc& ??????????????/
Do
    DrawWorms init
    _Limit 10
Loop Until _KeyDown(27)

Sub DrawWorms (DrawReset) ' one frame in main loop
    Static x(1 To nWorms, 1 To 20), y(1 To nWorms, 1 To 20)
    If DrawReset Then
        For i = 1 To nWorms
            NewWorm i
            For j = 1 To 20
                x(i, j) = 0: y(i, j) = 0
            Next
        Next
        DrawReset = 0
    End If
    For i = 1 To nWorms
        Fcirc Worms(i).X, Worms(i).Y, 8, &HFF000000 ' fix 2021-10-07 to prevent program hangs
        If _KeyDown(27) Then Exit Sub
        For j = 1 To Worms(i).Sz ' blackout old segments
            If x(i, j) And y(i, j) Then Fcirc x(i, j), y(i, j), 8, &HFF000000
        Next
        tryAgain:
        If _KeyDown(27) Then Exit Sub
        If Rnd < .3 Then Worms(i).DX = Worms(i).DX + .8 * Rnd - .4 Else Worms(i).DY = Worms(i).DY + .8 * Rnd - .4
        If Abs(Worms(i).DX) > 2 Then Worms(i).DX = Worms(i).DX * .5
        If Abs(Worms(i).DY) > 2 Then Worms(i).DY = Worms(i).DY * .5
        x = Worms(i).X + Worms(i).DX * 2.0: y = Worms(i).Y + Worms(i).DY * 2.0
        good = -1
        If x >= WormYard.X + 6 And x <= WormYard.X + WormYard.W - 6 Then
            If y >= WormYard.Y + 6 And y <= WormYard.Y + WormYard.H - 6 Then
                For yy = y - 6 To y + 6
                    For xx = x - 6 To x + 6
                        If Point(xx, yy) = _RGB32(255, 255, 255) Or Point(xx, yy) = _RGB32(255, 255, 0) Then good = 0: Exit For
                    Next
                    If good = 0 Then Exit For
                Next
            Else
                good = 0
            End If
        Else
            good = 0
        End If
        If good = 0 Then 'turn the worm
            'Beep: Locate 1, 1: Print x, y
            'Input "enter >", w$
            If Rnd > .5 Then 'change dx
                If Worms(i).DX Then
                    Worms(i).DX = -Worms(i).DX
                Else
                    If Rnd > .5 Then Worms(i).DX = 1 Else Worms(i).DX = -1
                End If
            Else
                If Worms(i).DY Then
                    Worms(i).DY = -Worms(i).DY
                Else
                    If Rnd > .5 Then Worms(i).DY = 1 Else Worms(i).DY = -1
                End If
            End If
            GoTo tryAgain
        End If
        For j = Worms(i).Sz To 2 Step -1
            x(i, j) = x(i, j - 1): y(i, j) = y(i, j - 1)
            If x(i, j) And y(i, j) Then DrawBall x(i, j), y(i, j), 6, Worms(i).C1
        Next
        x(i, 1) = x: y(i, 1) = y
        DrawBall x(i, 1), y(i, 1), 6, Worms(i).C1
        Worms(i).X = x: Worms(i).Y = y
    Next i 'worm index
End Sub

Sub NewWormYard (x, y, w, h)
    WormYard.X = x: WormYard.Y = y: WormYard.W = w: WormYard.H = h
    For i = 1 To nWorms
        NewWorm i
    Next
End Sub

Sub NewWorm (i)
    'pick which side to enter, for dx, dy generally headed towards inner screen
    side = Int(Rnd * 4)
    Select Case side
        Case 0 ' left side
            Worms(i).X = WormYard.X + 6
            Worms(i).Y = WormYard.Y + 6 + (WormYard.H - 12) * Rnd
            Worms(i).DX = 1
            Worms(i).DY = 0
        Case 1 'right side
            Worms(i).X = WormYard.X + WormYard.W - 6
            Worms(i).Y = WormYard.Y + 6 + (WormYard.H - 12) * Rnd
            Worms(i).DX = -1
            Worms(i).DY = 0
        Case 2 ' top
            Worms(i).Y = WormYard.Y + 6
            Worms(i).X = WormYard.X + 6 + (WormYard.W - 12) * Rnd
            Worms(i).DX = 0
            Worms(i).DY = 1
        Case 3 'bottom
            Worms(i).Y = WormYard.Y + WormYard.H - 6
            Worms(i).X = WormYard.X + 6 + (WormYard.W - 12) * Rnd
            Worms(i).DX = 0
            Worms(i).DY = -1
    End Select
    Worms(i).Sz = Int(Rnd * 11) + 10
    side = Int(Rnd * 4): lev = Int(Rnd * 10)
    If side = 0 Then
        Worms(i).C1 = _RGB32(255 - 20 * lev + 50, 180 - 15 * lev, 180 - 15 * lev)
    ElseIf side = 1 Then
        Worms(i).C1 = _RGB32(255 - 20 * lev, 180 - 15 * lev + 50, 180 - 15 * lev)
    ElseIf side = 2 Then
        Worms(i).C1 = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev + 20)
    ElseIf side = 3 Then
        Worms(i).C1 = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev)
    End If
End Sub

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

Sub DrawBall (x, y, r, c As _Unsigned Long)
    Dim rred As Long, grn As Long, blu As Long, rr As Long, f
    rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
    For rr = r To 0 Step -1
        f = 1.25 - rr / r
        Fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
End Sub

Easy enough for them to creep randomly.

Update: Interesting when I originally wrote this code it didn't stop until I used the escape key. Now it stops on some sort of hangup glitch in QB64pe 4.0 ???

But surely this isn't a bug its a feature Steve, @SMcNeill hasn't pointed out to us yet!