Spaghetti and Meatballs bplus version

[bplus]

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 Sub

Inspired 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:

[ChiaPet]

Atsa spicy-a meat-a-ball.

Wny don't they sing?

[bplus]

Well that sounds like an idea! or tell jokes? but isn't the whirling dervish routine enough? (the screen shot sure isn't enough)

[bplus]

New way to manufacture Spaghetti by making a "color segment" image.

Code: (Select All)

_Title "ColorSegment test" ' bplus 2026-01-03

Screen _NewImage(800, 600, 32)
_ScreenMove 250, 60

Dim Shared segImg&
OutsideC1~& = _RGB32(128, 64, 32)
InsideC2~& = _RGB32(255, 200, 145)
segImg& = MakeColorSegmentImg&(OutsideC1~&, InsideC2~&)
x = 100: y = 100
For i = 0 To 100
    RotoZoom23r x, y, segImg&, .2, .2, _Pi(.25)
    x = x + 2: y = y + 2
Next

Function MakeColorSegmentImg& (OutsideC1~&, InsideC2~&)
    ' needs Sub cAnalysis(c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    ' needs Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
    cs& = _NewImage(100, 100, 32)
    _Dest cs&
    For y = 0 To 49
        c~& = Ink~&(OutsideC1~&, InsideC2~&, y / 49)
        Line (0, y)-(99, y), c~&
        Line (0, 99 - y)-(99, 99 - y), c~&
    Next
    MakeColorSegmentImg& = cs&
    _Dest 0
End Function

' best  rev 2023-01-20 Jarvis with Steve change for eff  might need _Seamless next to _MapTriangle calls
Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)
    'uses radians
    Dim As Long W, H, Wp, Hp, i, x2, y2
    Dim sinr!, cosr!
    Dim px(3) As Single: Dim py(3) As Single
    W& = _Width(Image&): H& = _Height(Image&)
    Wp& = W& / 2 * xScale
    Hp& = H& / 2 * yScale
    px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&
    px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&
    sinr! = Sin(-radRotation): cosr! = Cos(radRotation)
    For i& = 0 To 3
        ' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
        px(i&) = x2&: py(i&) = y2&
    Next ' _Seamless? below
    _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
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

[bplus]

Faster Spaghetti!

Code: (Select All)

Option _Explicit
_Title "Living Spaghetti and Meatballs 2 faster" 'bplus mod 2026-01-03 from:
'_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

' 2026-01-03 add code to make worm drawing faster! hopefully

' 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 = 50
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 = 250 '  max strand(i).H
Dim Shared XX(1 To nStrand, 1 To maxStrandLength), YY(1 To nStrand, 1 To maxStrandLength)
Dim Shared Head(1 To nStrand, 1 To maxStrandLength)
Dim Shared segImg&

Dim As Long i, img, imgW
Dim y1, y2, y3, xo1, xo2, xo3, d1, d2, d3
Dim OutsideC1~&, InsideC2~&

img = _LoadImage("meat.PNG", 32)
'_PutImage (100, 100)-(200, 200), img, 0
'Sleep
imgW = _Width(img) '574


OutsideC1~& = _RGB32(128, 64, 32)
InsideC2~& = _RGB32(255, 200, 145)
segImg& = MakeColorSegmentImg&(OutsideC1~&, InsideC2~&)

'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)

Function MakeColorSegmentImg& (OutsideC1~&, InsideC2~&)
    ' needs Sub cAnalysis(c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    ' needs Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
    Dim cs&, y, c~&
    cs& = _NewImage(100, 100, 32)
    _Dest cs&
    For y = 0 To 49
        c~& = Ink~&(OutsideC1~&, InsideC2~&, y / 49)
        Line (0, y)-(99, y), c~&
        Line (0, 99 - y)-(99, 99 - y), c~&
    Next
    MakeColorSegmentImg& = cs&
    _Dest 0
End Function

' best  rev 2023-01-20 Jarvis with Steve change for eff  might need _Seamless next to _MapTriangle calls
Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)
    'uses radians
    Dim As Long W, H, Wp, Hp, i, x2, y2
    Dim sinr!, cosr!
    Dim px(3) As Single: Dim py(3) As Single
    W& = _Width(Image&): H& = _Height(Image&)
    Wp& = W& / 2 * xScale
    Hp& = H& / 2 * yScale
    px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&
    px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&
    sinr! = Sin(-radRotation): cosr! = Cos(radRotation)
    For i& = 0 To 3
        ' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
        px(i&) = x2&: py(i&) = y2&
    Next ' _Seamless? below
    _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
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 DrawStrand (i) ' one frame in main loop
    Dim x, y, dir, oldx, oldy
    Dim As Long j, r
    If Rnd < .3111 Then
        oldx = Strand(i).DX
        Strand(i).DX = Strand(i).DX + .2 * Rnd - .1
    Else
        oldy = Strand(i).DY
        Strand(i).DY = Strand(i).DY + .2 * Rnd - .1
    End If
    If Abs(Strand(i).DX) > 1.7 Then Strand(i).DX = oldx 'not too big a change
    If Abs(Strand(i).DY) > 1.7 Then Strand(i).DY = oldy
    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
    dir = _Atan2(y - Strand(i).Y, x - Strand(i).X)
    For r = Strand(i).W To 1 Step -2
        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
            Head(i, j) = Head(i, j - 1)
            If XX(i, j) <> 0 And YY(i, j) <> 0 Then RotoZoom23r XX(i, j), YY(i, j), segImg&, .2, .15, Head(i, j)
        Next
    Next
    XX(i, 1) = x: YY(i, 1) = y: Head(i, 1) = dir ' update head
    RotoZoom23r XX(i, 1), YY(i, 1), segImg&, .2, .15, Head(i, 1)
    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 * .3 * maxStrandLength ' length
    Strand(i).S = 8 ' speed
    Strand(i).C1 = _RGB32(255 - 60 * Rnd, 195 - 60 * Rnd, 105 - 60 * Rnd)
End Sub

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 Sub

   

zip with the meat.png for making meatballs

[Pete]

Bamboo and meatballs? I hope for the panda's sake the meatballs are vegan.

Pete