Draw Worms Study

[bplus]

Ok less flat spaghetti but much slower too:

Code: (Select All)

Option _Explicit
_Title "From DrawWorm to Living Spaghetti 2" 'bplus mod 2026-01-01 from:
'_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.
' 2026-01-01 attempting to make living spaghetti from this worm program
' 1. no more black background where worm crawls
' 2. no more black ouline of segmented worm
' 3. color greasy spaghetti on very light brown pasta
' 4. makeover drawWorms to DrawStrand
' 5. no worm Yard
' Living Spaghetti 2 color strands in Fake 3D

' 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  or length
    DX As Single ' moving opjects
    DY As Single ' ditto
    DIR As Single ' short for direction or heading usu a radian angle
    S As Single ' perhaps a scaling factor, speed or size
    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 nStrand = 20
Const xmax = 800, ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Delay .1
_ScreenMove _Middle

Dim Shared Strand(1 To nStrand) As Object
Dim Shared maxStrandLength
maxStrandLength = 1500 '  max strand(i).H
Dim Shared XX(1 To nStrand, 1 To maxStrandLength), YY(1 To nStrand, 1 To maxStrandLength)
Dim As Long i, j

'init
For i = 1 To nStrand
    NewStrand i
Next
For j = 1 To maxStrandLength
    Cls
    For i = 1 To nStrand
        DrawStrand i
    Next
    _Display
Next
Do
    Cls
    For i = 1 To nStrand
        DrawStrand i
    Next
    _Display
Loop Until _KeyDown(27)

Sub DrawStrand (i) ' one frame in main loop
    Dim x, y
    Dim As Long j, r
    Dim As _Unsigned Long colr
    If Rnd < .5 Then
        Strand(i).DX = Strand(i).DX + .4 * Rnd - .2
    Else
        Strand(i).DY = Strand(i).DY + .4 * Rnd - .2
    End If
    If Abs(Strand(i).DX) > .65 * Strand(i).S Then Strand(i).DX = Strand(i).DX * .5 'not too big a change
    If Abs(Strand(i).DY) > .65 * Strand(i).S Then Strand(i).DY = Strand(i).DY * .5
    x = Strand(i).X + Strand(i).DX * Strand(i).S
    y = Strand(i).Y + Strand(i).DY * Strand(i).S
    If x < 0 Or x > _Width - 1 Then 'stay inbounds of screen
        Strand(i).DX = -Strand(i).DX
        x = x + Strand(i).S * 2 * Strand(i).DX ' double back
    End If
    If y < 0 Or y > _Height - 1 Then 'stay inbounds of screen
        Strand(i).DY = -Strand(i).DY
        y = y + Strand(i).S * 2 * Strand(i).DY ' double back
    End If
    For r = Strand(i).W To 1 Step -1
        colr = Ink~&(Strand(i).C1, _RGB32(255, 200, 150), (Strand(i).W - r) / Strand(i).W)
        For j = Strand(i).H To 2 Step -1
            XX(i, j) = XX(i, j - 1): YY(i, j) = YY(i, j - 1) ' crawl towards head
            'If XX(i, j) And YY(i, j) Then Fcirc XX(i, j), YY(i, j), Strand(i).W, Strand(i).C1
            Fcirc XX(i, j), YY(i, j), r, colr
        Next
    Next
    XX(i, 1) = x: YY(i, 1) = y ' update head
    Fcirc XX(i, 1), YY(i, 1), Strand(i).W, colr
    Strand(i).X = x: Strand(i).Y = y
End Sub

Sub NewStrand (i)
    Strand(i).X = _Width * Rnd
    Strand(i).Y = _Height * Rnd
    Strand(i).DIR = _Pi(2 * Rnd)
    Strand(i).DX = Cos(Strand(i).DIR)
    Strand(i).DY = Sin(Strand(i).DIR)
    Strand(i).W = 6 ' radius
    Strand(i).H = maxStrandLength - Rnd * 300 ' length
    Strand(i).S = 2 ' speed
    Strand(i).C1 = _RGB32(180 - 90 * Rnd, 195 - 60 * Rnd, 85 - 60 * Rnd)
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 cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub

Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
    Dim R1, G1, B1, A1, R2, G2, B2, A2
    cAnalysis c1, R1, G1, B1, A1
    cAnalysis c2, R2, G2, B2, A2
    Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function