01-01-2026, 10:50 PM
Code: (Select All)
Option _Explicit
_Title "Living Spaghetti and Meatballs" 'bplus mod 2026-01-01 from:
'_Title "From DrawWorm to Living Spaghetti 2" 'bplus mod 2026-01-01 from:
'_Title "From DrawWorm to Living Spaghetti" '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.
' 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
' 2026-01-01 Living Spaghetti 2 color strands in Fake 3D
' 2026-01-01 add meatballs
' 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 = 40
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, img, xo, imgW
Dim y1, y2, y3, xo1, xo2, xo3, d1, d2, d3
img = _LoadImage("meat.PNG", 32)
'_PutImage (100, 100)-(200, 200), img, 0
'Sleep
imgW = _Width(img) '574
'init
For i = 1 To nStrand
NewStrand i
Next
xo2 = 554: y1 = 100: y2 = 150: y3 = 450: d1 = 1: d2 = -3: d3 = 5
Color , _RGB32(140, 20, 0)
Do
Cls
For i = 1 To nStrand
DrawStrand i
Next
xo1 = xo1 + 5.5
If xo1 > 554 Then xo1 = xo1 Mod 554
xo2 = xo2 - 10
If xo2 < 0 Then xo2 = 554 + xo2
xo3 = xo3 + 1
y1 = y1 + d1
If y1 > _Height - 51 Then d1 = -d1: y1 = _Height - 51
If y1 < 51 Then d1 = -d1: y1 = 51
y2 = y2 + d2
If y2 > _Height - 76 Then d2 = -d2: y2 = _Height - 76
If y2 < 75 Then d2 = -d2: y2 = 76
y3 = y3 + d3
If y3 > _Height - 126 Then d3 = -d3: y3 = _Height - 126
If y3 < 126 Then d3 = -d3: y3 = 126
projectImagetoSphere img, 100, y1, 50, xo1
projectImagetoSphere img, 650, y2, 75, xo2
projectImagetoSphere img, 400, y3, 125, xo3
_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 < -100 Or x > _Width + 100 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 < -100 Or y > _Height + 100 Then 'stay inbounds of outside 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 -2
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(255 - 60 * Rnd, 195 - 60 * Rnd, 105 - 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
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
Dim r, iW, iH, scale, y, x1, tv, x, tu, pc~&
r = _Height(image&) / 2
iW = _Width(image&) - 20
iH = _Height(image&)
scale = sr / r
For y = -r To r
x1 = Sqr(r * r - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 + 1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source image&
pc~& = Point((xo + tu * iW) Mod iW, tv * iH)
_Dest 0
PSet (x * scale + x0, y * scale + y0), pc~&
Next x
Next y
End SubInspired by Steve's version I saw this morning been working it all day!
zip package has the meat image I use to make meatballs plus source of course:
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever