Proggies - Printable Version

HOT off the press!

Code: (Select All)

_Title " " 'Unseen sphere fire ' b+ 2026-01-23

w = 200: h = 180: hd2 = h / 2

Screen _NewImage(w, h, 32)

img& = _LoadImage("unseen avatar.PNG")

_Source img&

_PutImage ((_Width - _Width(img&)) / 2, 15)-Step(_Width(img&), _Height(img&)), img&, 0

back& = _NewImage(_Width, _Height, 32)

_PutImage , 0, back&

si& = _NewImage(_Width, _Height, 32)

xmax = w: ymax = h

xxmax = 500: yymax = 100 'pixels too slow

xstep = xmax / xxmax: ystep = ymax / yymax

Dim p~&(300) 'pallette

For i = 1 To 100

    fr = 240 * i / 100 + 15

    p~&(i) = _RGB32(fr, 0, 0)

    p~&(i + 100) = _RGB32(200, fr, fr * .5)

    p~&(i + 200) = _RGB32(200, 255, fr)

Next

Dim f(xxmax, yymax + 2) 'fire array and seed

For x = 0 To xxmax

    f(x, yymax + 1) = Int(Rnd * 2) * 300

    f(x, yymax + 2) = 300

Next

Cls

While _KeyDown(27) = 0 'main fire

    Cls

    _Dest si&

    Cls

    _PutImage , back&, si&

    For x = 1 To xxmax - 1 'shift fire seed a bit

        r = Rnd

        If r < .15 Then

            f(x, yymax + 1) = f(x - 1, yymax + 1)

        ElseIf r < .3 Then

            f(x, yymax + 1) = f(x + 1, yymax + 1)

        ElseIf r < .35 Then

            f(x, yymax + 1) = Int(Rnd * 2) * 300

        End If

    Next

    For y = 0 To yymax 'fire based literally on 4 pixels below it like cellular automata

        For x = 1 To xxmax - 1

            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)

            If f(x, y) > 100 Then

                Line (x * xstep, y * ystep)-Step(xstep, ystep), p~&(f(x, y)), BF

            End If

        Next

    Next

    _Dest 0

    xo = (xo + 1) Mod (_Width(si&) - 20)

    projectImagetoSphere si&, w / 2, h / 2, 50, xo

    For x = 1 To xxmax - 1 'shift fire seed a bit

        r = Rnd

        If r < .15 Then

            f(x, yymax + 1) = f(x - 1, yymax + 1)

        ElseIf r < .3 Then

            f(x, yymax + 1) = f(x + 1, yymax + 1)

        ElseIf r < .35 Then

            f(x, yymax + 1) = Int(Rnd * 2) * 300

        End If

    Next

    For y = 0 To yymax 'fire based literally on 4 pixels below it like cellular automata

        For x = 1 To xxmax - 1

            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)

            If f(x, y) > 100 Then

                Line (x * xstep, y * ystep)-Step(xstep, ystep), p~&(f(x, y)), BF

            End If

        Next

    Next

    _Display

    _Limit 30

Wend



Function max (a, b)

    If a > b Then max = a Else max = b

End Function



Sub projectImagetoSphere (image&, x0, y0, sr, xo)

    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

Option _Explicit _Title "Brain Cubed" ' b+ 2026-01-27 Type xy As Single x, y End Type Screen _NewImage(700, 700, 32) _ScreenMove 300, 0 Dim As Long sb1, sb2, sb3 sb1 = _LoadImage("TBrain.PNG") ' rev 3 PM horrible again only the top face is screwed up ??? sb3 = _LoadImage("RBrain.PNG") sb2 = _LoadImage("LBrain.PNG") ' draw cube 3 faces showing Dim c(0 To 6) As xy Dim As Integer i c(0).x = 350: c(0).y = 350 _PrintString (c(0).x - 4, c(0).y - 8), "0" ' drawing points for set up of faces For i = 1 To 6 c(i).x = 350 + 340 * Cos(i * _Pi / 3) c(i).y = 350 + 340 * Sin(i * _Pi / 3) Circle (c(i).x, c(i).y), 8 _PrintString (c(i).x - 4, c(i).y - 8), _Trim$(Str$(i)) 'Sleep Next Cls 'top face ' map image top face _MapTriangle (0, 0)-(_Width(sb1), 0)-(_Width(sb1), _Height(sb1)), sb1 To(c(4).x, c(4).y)-(c(5).x, c(5).y)-(c(6).x, c(6).y), 0 _MapTriangle (0, 0)-(0, _Height(sb1))-(_Width(sb1), _Height(sb1)), sb1 To(c(4).x, c(4).y)-(c(0).x, c(0).y)-(c(6).x, c(6).y), 0 'right face _MapTriangle (0, 0)-(_Width(sb3), 0)-(_Width(sb3), _Height(sb3)), sb3 To(c(0).x, c(0).y)-(c(6).x, c(6).y)-(c(1).x, c(1).y), 0 _MapTriangle (0, 0)-(0, _Height(sb3))-(_Width(sb3), _Height(sb3)), sb3 To(c(0).x, c(0).y)-(c(2).x, c(2).y)-(c(1).x, c(1).y), 0 ftri c(0).x, c(0).y, c(6).x, c(6).y, c(1).x, c(1).y, &H99000000 ' dim face for shadow ftri c(1).x, c(1).y, c(2).x, c(2).y, c(0).x, c(0).y, &H99000000 ' left face 'map image _MapTriangle (0, 0)-(_Width(sb2), 0)-(_Width(sb2), _Height(sb2)), sb2 To(c(4).x, c(4).y)-(c(0).x, c(0).y)-(c(2).x, c(2).y), 0 _MapTriangle (0, 0)-(0, _Height(sb2))-(_Width(sb2), _Height(sb2)), sb2 To(c(4).x, c(4).y)-(c(3).x, c(3).y)-(c(2).x, c(2).y), 0 ftri c(3).x, c(3).y, c(4).x, c(4).y, c(0).x, c(0).y, &H55000000 ftri c(3).x, c(3).y, c(2).x, c(2).y, c(0).x, c(0).y, &H55000000 Sleep Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long) Dim D As Long Static a& D = _Dest If a& = 0 Then a& = _NewImage(1, 1, 32) _Dest a& _DontBlend a& ' '<<<< new 2019-12-16 fix PSet (0, 0), K _Blend a& '<<<< new 2019-12-16 fix _Dest D _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3) End Sub 'Þ _MAPTRIANGLE [{_CLOCKWISE|_ANTICLOCKWISE}] [{_SEAMLESS}] (sx1, sy1)-(sx2, sy2)-(sx3, sy3), source& TO (dx1, 'Þ dy1, dz1)-(dx2, dy2, dz2)-(dx3, dy3, dz3)[, destination&][{_SMOOTH|_SMOOTHSHRUNK|_SMOOTHSTRETCHED}]]

Option _Explicit _Title "T Cubed" ' b+ 2026-01-27 Type xy As Single x, y End Type Screen _NewImage(700, 700, 32) _ScreenMove 300, 0 Dim As Long sb1, sb2, sb3 sb1 = _LoadImage("topFace.PNG") ' rev 3 PM horrible again only the top face is screwed up ??? sb2 = _LoadImage("rFace.PNG") sb3 = _LoadImage("lFace.PNG") ' draw cube 3 faces showing Dim c(0 To 6) As xy Dim As Integer i c(0).x = 350: c(0).y = 350 _PrintString (c(0).x - 4, c(0).y - 8), "0" For i = 1 To 6 c(i).x = 350 + 340 * Cos(i * _Pi / 3) c(i).y = 350 + 340 * Sin(i * _Pi / 3) Circle (c(i).x, c(i).y), 8 _PrintString (c(i).x - 4, c(i).y - 8), _Trim$(Str$(i)) 'Sleep Next Cls 'top face ' map image top face _MapTriangle (0, 0)-(_Width(sb1), 0)-(_Width(sb1), _Height(sb1)), sb1 To(c(4).x, c(4).y)-(c(5).x, c(5).y)-(c(6).x, c(6).y), 0 _MapTriangle (0, 0)-(0, _Height(sb1))-(_Width(sb1), _Height(sb1)), sb1 To(c(4).x, c(4).y)-(c(0).x, c(0).y)-(c(6).x, c(6).y), 0 'right face ' map image _MapTriangle (0, 0)-(_Width(sb3), 0)-(_Width(sb3), _Height(sb3)), sb3 To(c(0).x, c(0).y)-(c(6).x, c(6).y)-(c(1).x, c(1).y), 0 _MapTriangle (0, 0)-(0, _Height(sb3))-(_Width(sb3), _Height(sb3)), sb3 To(c(0).x, c(0).y)-(c(2).x, c(2).y)-(c(1).x, c(1).y), 0 ftri c(0).x, c(0).y, c(6).x, c(6).y, c(1).x, c(1).y, &H99000000 ' dim face for shadow ftri c(1).x, c(1).y, c(2).x, c(2).y, c(0).x, c(0).y, &H99000000 ' left face 'map image _MapTriangle (0, 0)-(_Width(sb2), 0)-(_Width(sb2), _Height(sb2)), sb2 To(c(4).x, c(4).y)-(c(0).x, c(0).y)-(c(2).x, c(2).y), 0 _MapTriangle (0, 0)-(0, _Height(sb2))-(_Width(sb2), _Height(sb2)), sb2 To(c(4).x, c(4).y)-(c(3).x, c(3).y)-(c(2).x, c(2).y), 0 ftri c(3).x, c(3).y, c(4).x, c(4).y, c(0).x, c(0).y, &H55000000 ftri c(3).x, c(3).y, c(2).x, c(2).y, c(0).x, c(0).y, &H55000000 Sleep Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long) Dim D As Long Static a& D = _Dest If a& = 0 Then a& = _NewImage(1, 1, 32) _Dest a& _DontBlend a& ' '<<<< new 2019-12-16 fix PSet (0, 0), K _Blend a& '<<<< new 2019-12-16 fix _Dest D _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3) End Sub 'Þ _MAPTRIANGLE [{_CLOCKWISE|_ANTICLOCKWISE}] [{_SEAMLESS}] (sx1, sy1)-(sx2, sy2)-(sx3, sy3), source& TO (dx1, 'Þ dy1, dz1)-(dx2, dy2, dz2)-(dx3, dy3, dz3)[, destination&][{_SMOOTH|_SMOOTHSHRUNK|_SMOOTHSTRETCHED}]]