(01-01-2026, 02:02 PM)bplus Wrote: But surely this isn't a bug its a feature Steve, @SMcNeill hasn't pointed out to us yet! 

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)



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

        trycount = 0

        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

            trycount = trycount + 1

            if trycount < 10 then 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

(01-01-2026, 02:53 PM)SMcNeill Wrote: (code fixed)

Issue fixed.  Problem was, as suspected, an endless loop.

One of your worms was simply getting stuck in a corner and couldn't move.  All I did was implement a simple limit to it trying to avoid the WHITE and then after 10 tries, it just shrugs and eats it way forward regardless.  I might not *like* to eat white, but it won't just starve to death avoiding it constantly in an endless loop.  10 times of trying to find a random way around it, then it just wrinkles its none and moves forward anyway.