Proggies

[bplus]

Sphere on Fire!

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

EDIT: I think I matched the fire color much closer to the fire in the image!

You can compare fire colors to original code here: https://qb64phoenix.com/forum/showthread...9#pid39229

Updated Zip has image for projectImagetoSphere Sub to demo again!