Flaming Text (let's make it a challenge)

[SMcNeill]

Code: (Select All)

Type FlameParticle

    x As Single

    y As Single

    dx As Single

    dy As Single

    life As Integer

    maxlife As Integer

End Type



Const MAXP = 800

Dim Shared FP(MAXP) As FlameParticle



Sub SpawnFlame (x As Single, y As Single, explode)

    Dim i As Long

    For i = 1 To MAXP

        If FP(i).life <= 0 Then

            FP(i).x = x + Rnd * 4 - 2

            FP(i).y = y + Rnd * 2

            FP(i).dx = (Rnd * 1.2) - 0.6

            FP(i).dy = -(1 + Rnd * 1.5)

            FP(i).maxlife = 20 + Int(Rnd * 20)

            FP(i).life = FP(i).maxlife

            If explode = 0 Then Exit Sub

        End If

    Next

End Sub



'===========================================================



Sub FireText (txt$, x As Long, y As Long, fnt As Long)

    Dim c As _Unsigned Long, i As Long, flicker As Integer

    Dim As Single emitY, t



    flicker = Int(Rnd * 8)

    _Font fnt



    ' --- Outer red glow ---

    Color _RGB(255, 40, 0), 0

    _PrintString (x - 3 - flicker, y + 3), txt$

    _PrintString (x + 3 + flicker, y - 3), txt$



    ' --- Mid orange glow ---

    Color _RGB(255, 120, 0), 0

    _PrintString (x - 2 - flicker / 2, y + 1), txt$

    _PrintString (x + 2 + flicker / 2, y - 1), txt$



    ' --- Inner yellow glow ---

    Color _RGB(255, 200, 0), 0

    _PrintString (x - 1 - flicker / 4, y), txt$

    _PrintString (x + 1 + flicker / 4, y), txt$



    ' --- Bright core ---

    Color _RGB(255, 255, 120), 0

    _PrintString (x, y), txt$



    ' --- Spawn flame particles above the text ---

    Dim tw As Long

    tw = _PrintWidth(txt$)



    For i = 1 To MAXP ' number of flames per frame

        emitY = (y - _FontHeight / 4) + Rnd * (1.25 * _FontHeight)

        SpawnFlame x + Rnd * tw, emitY, 0

        If i Mod 20 = 0 Then 'I don't want as many little firework style flame explosions

            emitY = (y - _FontHeight / 4) + Rnd * (.5 * _FontHeight)

            SpawnFlame x + Rnd * tw, emitY, -1

        End If

    Next



    For i = 1 To MAXP

        If FP(i).life > 0 Then

            FP(i).x = FP(i).x + FP(i).dx

            FP(i).y = FP(i).y + FP(i).dy

            FP(i).life = FP(i).life - 1

        End If

    Next



    For i = 1 To MAXP

        If FP(i).life > 0 Then

            t = FP(i).life / FP(i).maxlife

            c = _RGB(255 * t, 120 * t, 20 * t) ' Flame color gradient: yellow ? orange ? red ? dark

            Line (FP(i).x, FP(i).y)-Step(2, 3), c, BF

        End If

    Next

End Sub

'===========================================================

Screen _NewImage(800, 600, 32)



fnt = _LoadFont("arial.ttf", 64, "BOLD")

If fnt = 0 Then Print "Font load failed": End



Randomize Timer



Do

    Cls

    FireText "STEVE IS AMAZING!", 100, 300, fnt

    _Display

    _Limit 60

Loop Until _KeyHit

System

So I was playing around with trying to produce some sort of flaming text using particles and such.  What I've came up with is the above.  It's... not bad, but quite the "flame" I was looking for.

Still, it's a place to start with, and since you guys like various challenges and such, here's one for you:  Make your own flaming text routine.  Let's see what you guys can come up with.  I've always been one who liked to do various things with text (I have rainbow text routines, and circle text, and rotating text, and scaling text, and faux-3d text, and lots of others), so I figured "Why not shoot for something with a flame style effect?"

Here's my go at that attempt.  Let's see what you guys can come up with.  Everybody needs a nice flaming text routine -- if just for a title screen or something sometime!  Let's go guys!  Show me your best (and worst so I don't feel so bad).

@Pete is disqualified, as I know his version already:

Code: (Select All)

SCREEN 0
PRINT "My text is";
COLOR 20
PRINT " FLAMING ";
COLOR 7
PRINT "hot."

Pete loses before he's even began!  He's the worst, so none of the rest of you have any pressure at all to do better than he has! 

[Petr]

My version. Inspired by the BPlus program - solution with mask is perfect.

Code: (Select All)

Option _Explicit

Randomize Timer



Type POINTAPI

    X As Long

    Y As Long

End Type



Declare Dynamic Library "user32" '                        transparent program window, clickable as in my DLL demos. Tested in 64bit IDE in Windows only.

    Function GetCursorPos& (lpPoint As POINTAPI)

    Function GetWindowLongPtrA%& (ByVal hwnd As _Offset, ByVal nIndex As Long)

    Function SetWindowLongPtrA%& (ByVal hwnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)

    Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, ByVal crKey As Long, ByVal bAlpha As _Unsigned _Byte, ByVal dwFlags As Long)

    Function SetWindowPos& (ByVal hwnd As _Offset, ByVal Zorder As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal Flags As Long)

    Function GetAsyncKeyState% (ByVal vKey As Long)

End Declare



Const GWL_STYLE& = -16

Const GWL_EXSTYLE& = -20

Const VK_LBUTTON& = 1

Const WS_CAPTION%& = &HC00000

Const WS_THICKFRAME%& = &H40000

Const WS_SYSMENU%& = &H80000

Const WS_MINIMIZEBOX%& = &H20000

Const WS_MAXIMIZEBOX%& = &H10000

Const WS_EX_LAYERED%& = &H80000

Const LWA_COLORKEY& = 1

Const SWP_NOSIZE& = &H1

Const SWP_NOMOVE& = &H2

Const SWP_NOZORDER& = &H4

Const SWP_NOACTIVATE& = &H10

Const SWP_FRAMECHANGED& = &H20

Const SWP_SHOWWINDOW& = &H40

Const HWND_TOPMOST& = -1

Const HWND_NOTOPMOST& = -2





Dim Shared As Long W, H, N, Scrn, MaskImg, FontSize, FontH, DefaultFontH, Pad, FlameSpace, DragDX, DragDY, Fs

ReDim Shared As _Unsigned _Byte Heat(0), MaskAll(0), MaskTop(0)

ReDim Shared Wind(0) As Integer

Dim Shared As Integer PrevDown, DragOn 'program window mouse move

Dim Shared MemScr As _MEM

Dim Shared As String Txt, FontFile



Txt$ = "System's on fire! Hell yeah, Basic!"

FontFile$ = "impact.ttf" '

FontSize& = 96

Pad = 20



DefaultFontH& = _Font

FontH& = _LoadFont(FontFile$, FontSize&, "BOLD")

Fs = _NewImage(800, 600, 32)

Screen Fs

If FontH& > 0 Then

    _Font FontH&

Else

    _Font 16 ' fallback built-in

    FontH& = _Font

End If



W = _PrintWidth(Txt$) + Pad * 2

H = _FontHeight + Pad * 8 + FlameSpace

N = W * H

Scrn& = _NewImage(W, H, 256)

Screen Scrn&

If FontH& > 0 Then _Font FontH&



_FreeImage Fs

FlameSpace = _FontHeight / 3



Cls , 0



' Make screen memory handle once (fast rendering)

MemScr = _MemImage(0)



' Palette for fire (index 0 stays black = transparent key); palette solution is inspired with BPlus fire demo!

BuildFirePalette



' Build text masks

MaskImg& = _NewImage(W, H, 256)

BuildTextMasks



' Setup window: borderless + layered colorkey black + optionally topmost

SetupLayeredBorderless 1



' Center window (safe after screen exists)

Do: Loop Until _ScreenExists

_ScreenMove _Middle



ReDim Heat(N - 1) As _Unsigned _Byte

ReDim MaskAll(N - 1) As _Unsigned _Byte

ReDim MaskTop(N - 1) As _Unsigned _Byte

ReDim Wind(H - 1) As Integer



' Copy mask bytes into MaskAll/MaskTop (once)

CopyMasksFromImage





Do

    HandleDrag

    UpdateWind

    UpdateFire

    RenderFire



    _Display

    _Limit 60

Loop Until _KeyDown(27)



' Cleanup

Screen 0

_MemFree MemScr

If MaskImg& < -1 Then _FreeImage MaskImg&

If Scrn& < -1 Then _FreeImage Scrn&

End





Sub SetupLayeredBorderless (TopMost As Integer)

    Dim As _Offset hwnd, style, exstyle

    Dim As Long flags, z, N



    hwnd%& = _WindowHandle



    ' Remove borders/caption/system buttons

    style%& = GetWindowLongPtrA%&(hwnd%&, GWL_STYLE)

    style%& = style%& And Not (WS_CAPTION Or WS_THICKFRAME Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

    N = SetWindowLongPtrA%&(hwnd%&, GWL_STYLE, style%&)



    ' Enable layered window

    exstyle%& = GetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE)

    exstyle%& = exstyle%& Or WS_EX_LAYERED

    N = SetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE, exstyle%&)



    ' Color key = black (COLORREF 0) => transparent + click-through on those pixels

    N = SetLayeredWindowAttributes&(hwnd%&, 0, 0, LWA_COLORKEY)



    ' Apply style changes

    flags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_SHOWWINDOW Or SWP_NOACTIVATE

    If TopMost Then z = HWND_TOPMOST Else z = HWND_NOTOPMOST

    N = SetWindowPos&(hwnd%&, z, 0, 0, 0, 0, flags)

End Sub



Sub BuildFirePalette

    Dim As Long i, r, g, b, t



    ' index 0 MUST be black (transparent key)

    _PaletteColor 0, _RGB32(0, 0, 0)



    For i = 1 To 255

        ' 0..255 => black->red->yellow->white

        If i < 86 Then

            r = i * 3

            g = 0

            b = 0

        ElseIf i < 171 Then

            r = 255

            g = (i - 85) * 3

            b = 0

        Else

            r = 255

            g = 255

            b = (i - 170) * 3

        End If



        If r > 255 Then r = 255

        If g > 255 Then g = 255

        If b > 255 Then b = 255



        _PaletteColor i, _RGB32(r, g, b)

    Next i

End Sub



Sub BuildTextMasks

    Dim tx As Long, ty As Long



    _Dest MaskImg&

    Cls , 0

    _Font FontH&

    Color 255, 0



    tx = Pad

    ty = FlameSpace + Pad



    _PrintString (tx, ty), Txt$

    _Dest 0

End Sub



Sub CopyMasksFromImage

    Dim m As _MEM

    Dim As Long i, x, y, idx

    Dim v As _Unsigned _Byte



    m = _MemImage(MaskImg&)



    ' Fill MaskAll from mask image bytes

    For i = 0 To N - 1

        v = _MemGet(m, m.OFFSET + i, _Unsigned _Byte)

        If v <> 0 Then

            MaskAll(i) = 1

        Else

            MaskAll(i) = 0

        End If

    Next i



    ' MaskTop = text pixel that has NO text pixel above it (top edge) => feeds flames

    For y = 0 To H - 1

        For x = 0 To W - 1

            idx = y * W + x

            If MaskAll(idx) Then

                If y = 0 Then

                    MaskTop(idx) = 1

                Else

                    If MaskAll(idx - W) = 0 Then

                        MaskTop(idx) = 1

                    Else

                        MaskTop(idx) = 0

                    End If

                End If

            Else

                MaskTop(idx) = 0

            End If

        Next x

    Next y



    _MemFree m

End Sub



Sub UpdateWind

    Dim As Long y, WindRichtung

    For y = 0 To H - 1

        If Rnd * 6 > 3 Then WindRichtung = -1 Else WindRichtung = 1

        Wind(y) = Int(Rnd * 5) * WindRichtung - 1 ' -1,0,1

    Next y

End Sub



Sub UpdateFire

    Dim As Long x, y, idx, sx, v, cool, fuel, zaklad 'to jsem na to zvedavej.



    ' Clear last 2 rows to prevent "fire from nowhere"

    zaklad = (H - 2) * W

    For idx = zaklad To N - 1

        Heat(idx) = 0

    Next idx



    ' Propagate upward (top-to-bottom in-place)

    For y = 0 To H - 3

        cool = (y * 40) \ H ' small cooling gradient



        For x = 1 To W - 2

            sx = x + Wind(y)

            If sx < 1 Then sx = 1

            If sx > W - 2 Then sx = W - 2



            idx = y * W + x



            v = Heat((y + 1) * W + sx)

            v = v + Heat((y + 1) * W + (sx - 1))

            v = v + Heat((y + 1) * W + (sx + 1))

            v = v + Heat((y + 2) * W + sx)

            v = v \ 4



            If v > cool Then v = v - cool Else v = 0

            Heat(idx) = v

        Next x



        ' edges

        Heat(y * W) = 0

        Heat(y * W + (W - 1)) = 0

    Next y



    ' Keep letters glowing + feed flames mainly from top edges

    For idx = 0 To N - 1

        If MaskAll(idx) Then

            If Heat(idx) < 110 Then Heat(idx) = 110

        End If



        If MaskTop(idx) Then

            fuel = 220 + Int(Rnd * 35) ' 220..254

            If Heat(idx) < fuel Then Heat(idx) = fuel

        End If

    Next idx

End Sub



Sub RenderFire

    Dim idx As Long

    Dim o As _Offset



    o = MemScr.OFFSET



    'make it faster

    $Checking:Off

    For idx = 0 To N - 1

        _MemPut MemScr, o + idx, Heat(idx) As _UNSIGNED _BYTE

    Next idx

    $Checking:On

End Sub



Sub HandleDrag

    Dim p As POINTAPI

    Dim As Long wndX, wndY, mx, my, N, idx

    Dim ks As Integer

    Dim down As Integer



    N = GetCursorPos&(p)



    ' Globální stav tlacitka

    ks = GetAsyncKeyState%(VK_LBUTTON)

    down = (ks And &H8000) <> 0



    wndX = _ScreenX

    wndY = _ScreenY



    mx = p.X - wndX

    my = p.Y - wndY



    ' Start drag jen na HRANE stisku (edge detect)

    If down And (PrevDown = 0) Then

        If mx >= 0 And mx < W And my >= 0 And my < H Then

            idx = my * W + mx



            ' Hit-test

            If Heat(idx) <> 0 Then

                DragDX = p.X - wndX

                DragDY = p.Y - wndY

                DragOn = -1

            End If

        End If

    End If



    ' Tah  move

    If DragOn Then

        If down Then

            _ScreenMove p.X - DragDX, p.Y - DragDY

        Else

            DragOn = 0

        End If

    End If



    PrevDown = down

End Sub

[ahenry3068]

My version. Inspired by the BPlus program - solution with mask is perfect.

Code: (Select All)

Option _Explicit

Randomize Timer



Type POINTAPI

    X As Long

    Y As Long

End Type



Declare Dynamic Library "user32" '                        transparent program window, clickable as in my DLL demos. Tested in 64bit IDE in Windows only.

    Function GetCursorPos& (lpPoint As POINTAPI)

    Function GetWindowLongPtrA%& (ByVal hwnd As _Offset, ByVal nIndex As Long)

    Function SetWindowLongPtrA%& (ByVal hwnd As _Offset, ByVal nIndex As Long, ByVal dwNewLong As _Offset)

    Function SetLayeredWindowAttributes& (ByVal hwnd As _Offset, ByVal crKey As Long, ByVal bAlpha As _Unsigned _Byte, ByVal dwFlags As Long)

    Function SetWindowPos& (ByVal hwnd As _Offset, ByVal Zorder As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal Flags As Long)

    Function GetAsyncKeyState% (ByVal vKey As Long)

End Declare



Const GWL_STYLE& = -16

Const GWL_EXSTYLE& = -20

Const VK_LBUTTON& = 1

Const WS_CAPTION%& = &HC00000

Const WS_THICKFRAME%& = &H40000

Const WS_SYSMENU%& = &H80000

Const WS_MINIMIZEBOX%& = &H20000

Const WS_MAXIMIZEBOX%& = &H10000

Const WS_EX_LAYERED%& = &H80000

Const LWA_COLORKEY& = 1

Const SWP_NOSIZE& = &H1

Const SWP_NOMOVE& = &H2

Const SWP_NOZORDER& = &H4

Const SWP_NOACTIVATE& = &H10

Const SWP_FRAMECHANGED& = &H20

Const SWP_SHOWWINDOW& = &H40

Const HWND_TOPMOST& = -1

Const HWND_NOTOPMOST& = -2





Dim Shared As Long W, H, N, Scrn, MaskImg, FontSize, FontH, DefaultFontH, Pad, FlameSpace, DragDX, DragDY, Fs

ReDim Shared As _Unsigned _Byte Heat(0), MaskAll(0), MaskTop(0)

ReDim Shared Wind(0) As Integer

Dim Shared As Integer PrevDown, DragOn 'program window mouse move

Dim Shared MemScr As _MEM

Dim Shared As String Txt, FontFile



Txt$ = "System's on fire! Hell yeah, Basic!"

FontFile$ = "impact.ttf" '

FontSize& = 96

Pad = 20



DefaultFontH& = _Font

FontH& = _LoadFont(FontFile$, FontSize&, "BOLD")

Fs = _NewImage(800, 600, 32)

Screen Fs

If FontH& > 0 Then

    _Font FontH&

Else

    _Font 16 ' fallback built-in

    FontH& = _Font

End If



W = _PrintWidth(Txt$) + Pad * 2

H = _FontHeight + Pad * 8 + FlameSpace

N = W * H

Scrn& = _NewImage(W, H, 256)

Screen Scrn&

If FontH& > 0 Then _Font FontH&



_FreeImage Fs

FlameSpace = _FontHeight / 3



Cls , 0



' Make screen memory handle once (fast rendering)

MemScr = _MemImage(0)



' Palette for fire (index 0 stays black = transparent key); palette solution is inspired with BPlus fire demo!

BuildFirePalette



' Build text masks

MaskImg& = _NewImage(W, H, 256)

BuildTextMasks



' Setup window: borderless + layered colorkey black + optionally topmost

SetupLayeredBorderless 1



' Center window (safe after screen exists)

Do: Loop Until _ScreenExists

_ScreenMove _Middle



ReDim Heat(N - 1) As _Unsigned _Byte

ReDim MaskAll(N - 1) As _Unsigned _Byte

ReDim MaskTop(N - 1) As _Unsigned _Byte

ReDim Wind(H - 1) As Integer



' Copy mask bytes into MaskAll/MaskTop (once)

CopyMasksFromImage





Do

    HandleDrag

    UpdateWind

    UpdateFire

    RenderFire



    _Display

    _Limit 60

Loop Until _KeyDown(27)



' Cleanup

Screen 0

_MemFree MemScr

If MaskImg& < -1 Then _FreeImage MaskImg&

If Scrn& < -1 Then _FreeImage Scrn&

End





Sub SetupLayeredBorderless (TopMost As Integer)

    Dim As _Offset hwnd, style, exstyle

    Dim As Long flags, z, N



    hwnd%& = _WindowHandle



    ' Remove borders/caption/system buttons

    style%& = GetWindowLongPtrA%&(hwnd%&, GWL_STYLE)

    style%& = style%& And Not (WS_CAPTION Or WS_THICKFRAME Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

    N = SetWindowLongPtrA%&(hwnd%&, GWL_STYLE, style%&)



    ' Enable layered window

    exstyle%& = GetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE)

    exstyle%& = exstyle%& Or WS_EX_LAYERED

    N = SetWindowLongPtrA%&(hwnd%&, GWL_EXSTYLE, exstyle%&)



    ' Color key = black (COLORREF 0) => transparent + click-through on those pixels

    N = SetLayeredWindowAttributes&(hwnd%&, 0, 0, LWA_COLORKEY)



    ' Apply style changes

    flags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_SHOWWINDOW Or SWP_NOACTIVATE

    If TopMost Then z = HWND_TOPMOST Else z = HWND_NOTOPMOST

    N = SetWindowPos&(hwnd%&, z, 0, 0, 0, 0, flags)

End Sub



Sub BuildFirePalette

    Dim As Long i, r, g, b, t



    ' index 0 MUST be black (transparent key)

    _PaletteColor 0, _RGB32(0, 0, 0)



    For i = 1 To 255

        ' 0..255 => black->red->yellow->white

        If i < 86 Then

            r = i * 3

            g = 0

            b = 0

        ElseIf i < 171 Then

            r = 255

            g = (i - 85) * 3

            b = 0

        Else

            r = 255

            g = 255

            b = (i - 170) * 3

        End If



        If r > 255 Then r = 255

        If g > 255 Then g = 255

        If b > 255 Then b = 255



        _PaletteColor i, _RGB32(r, g, b)

    Next i

End Sub



Sub BuildTextMasks

    Dim tx As Long, ty As Long



    _Dest MaskImg&

    Cls , 0

    _Font FontH&

    Color 255, 0



    tx = Pad

    ty = FlameSpace + Pad



    _PrintString (tx, ty), Txt$

    _Dest 0

End Sub



Sub CopyMasksFromImage

    Dim m As _MEM

    Dim As Long i, x, y, idx

    Dim v As _Unsigned _Byte



    m = _MemImage(MaskImg&)



    ' Fill MaskAll from mask image bytes

    For i = 0 To N - 1

        v = _MemGet(m, m.OFFSET + i, _Unsigned _Byte)

        If v <> 0 Then

            MaskAll(i) = 1

        Else

            MaskAll(i) = 0

        End If

    Next i



    ' MaskTop = text pixel that has NO text pixel above it (top edge) => feeds flames

    For y = 0 To H - 1

        For x = 0 To W - 1

            idx = y * W + x

            If MaskAll(idx) Then

                If y = 0 Then

                    MaskTop(idx) = 1

                Else

                    If MaskAll(idx - W) = 0 Then

                        MaskTop(idx) = 1

                    Else

                        MaskTop(idx) = 0

                    End If

                End If

            Else

                MaskTop(idx) = 0

            End If

        Next x

    Next y



    _MemFree m

End Sub



Sub UpdateWind

    Dim As Long y, WindRichtung

    For y = 0 To H - 1

        If Rnd * 6 > 3 Then WindRichtung = -1 Else WindRichtung = 1

        Wind(y) = Int(Rnd * 5) * WindRichtung - 1 ' -1,0,1

    Next y

End Sub



Sub UpdateFire

    Dim As Long x, y, idx, sx, v, cool, fuel, zaklad 'to jsem na to zvedavej.



    ' Clear last 2 rows to prevent "fire from nowhere"

    zaklad = (H - 2) * W

    For idx = zaklad To N - 1

        Heat(idx) = 0

    Next idx



    ' Propagate upward (top-to-bottom in-place)

    For y = 0 To H - 3

        cool = (y * 40) \ H ' small cooling gradient



        For x = 1 To W - 2

            sx = x + Wind(y)

            If sx < 1 Then sx = 1

            If sx > W - 2 Then sx = W - 2



            idx = y * W + x



            v = Heat((y + 1) * W + sx)

            v = v + Heat((y + 1) * W + (sx - 1))

            v = v + Heat((y + 1) * W + (sx + 1))

            v = v + Heat((y + 2) * W + sx)

            v = v \ 4



            If v > cool Then v = v - cool Else v = 0

            Heat(idx) = v

        Next x



        ' edges

        Heat(y * W) = 0

        Heat(y * W + (W - 1)) = 0

    Next y



    ' Keep letters glowing + feed flames mainly from top edges

    For idx = 0 To N - 1

        If MaskAll(idx) Then

            If Heat(idx) < 110 Then Heat(idx) = 110

        End If



        If MaskTop(idx) Then

            fuel = 220 + Int(Rnd * 35) ' 220..254

            If Heat(idx) < fuel Then Heat(idx) = fuel

        End If

    Next idx

End Sub



Sub RenderFire

    Dim idx As Long

    Dim o As _Offset



    o = MemScr.OFFSET



    'make it faster

    $Checking:Off

    For idx = 0 To N - 1

        _MemPut MemScr, o + idx, Heat(idx) As _UNSIGNED _BYTE

    Next idx

    $Checking:On

End Sub



Sub HandleDrag

    Dim p As POINTAPI

    Dim As Long wndX, wndY, mx, my, N, idx

    Dim ks As Integer

    Dim down As Integer



    N = GetCursorPos&(p)



    ' Globální stav tlacitka

    ks = GetAsyncKeyState%(VK_LBUTTON)

    down = (ks And &H8000) <> 0



    wndX = _ScreenX

    wndY = _ScreenY



    mx = p.X - wndX

    my = p.Y - wndY



    ' Start drag jen na HRANE stisku (edge detect)

    If down And (PrevDown = 0) Then

        If mx >= 0 And mx < W And my >= 0 And my < H Then

            idx = my * W + mx



            ' Hit-test

            If Heat(idx) <> 0 Then

                DragDX = p.X - wndX

                DragDY = p.Y - wndY

                DragOn = -1

            End If

        End If

    End If



    ' Tah  move

    If DragOn Then

        If down Then

            _ScreenMove p.X - DragDX, p.Y - DragDY

        Else

            DragOn = 0

        End If

    End If



    PrevDown = down

End Sub

   Screen shot please ?   Since I can't build this in Linux !

Steve's I could build, just had to pick a substitute font !

[Petr]

@ahenry3068

Screenshot:

[bplus]

Nice @Petr

Here is a few less LOC

Code: (Select All)

_Title "Text on Fire" ' b+ 2026-01-30

' from Jolly Roger on Fire 'b+ 2022-01-17



Const xmax = 800, ymax = 600

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 260, 60



Dim p&(300) ' fire pallette

For i = 1 To 100

    fr = 240 * i / 100 + 15

    p&(i) = _RGB(fr, 0, 0)

    p&(i + 100) = _RGB(255, fr, 0)

    p&(i + 200) = _RGB(255, 255, fr)

Next



w~& = _RGB32(55, 55, 0) ' the text

Color w~&

_Font _LoadFont("Arial.ttf", 128)

_PrintString (45, 236), "Text on Fire!"



xxmax = 400: yymax = 300 'screen pixels too slow cut in half

xstep = xmax / xxmax: ystep = ymax / yymax

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

For y = 0 To yymax - 1

    For x = 0 To xxmax - 1

        If Point(x * xstep, y * ystep) = w~& Then f(x, y) = 300: ff(x, y) = 300

    Next

Next



While 1 'main fire

    Cls

    For y = 1 To yymax - 2

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

            r! = Rnd

            If r! < .2 Then

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

            ElseIf r! < .4 Then

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

            ElseIf r! < .47 Then

                If ff(x, y) Then f(x, y) = 300

            End If

        Next

    Next

    For y = 0 To yymax - 2 '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)

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

        Next

    Next

    _Display

    _Limit 30

Wend



Function max (a, b)

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

End Function

[bplus]

Here is some Global Warming for Steve!

Code: (Select All)

_Title "Text on Fire in Sphere" ' b+ 2026-01-30

' from Jolly Roger on Fire 'b+ 2022-01-17



Const xmax = 800, ymax = 600

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 260, 60



Dim p&(300) ' fire pallette

For i = 1 To 100

    fr = 240 * i / 100 + 15

    p&(i) = _RGB(fr, 0, 0)

    p&(i + 100) = _RGB(255, fr, 0)

    p&(i + 200) = _RGB(255, 255, fr)

Next



w~& = _RGB32(55, 55, 0) ' the text

Color w~&

_Font _LoadFont("Arial.ttf", 128)

_PrintString (45, 260), "Text on Fire!"



e& = _LoadImage("bluemarble_small.png", 32)



xxmax = 400: yymax = 300 'screen pixels too slow cut in half

xstep = xmax / xxmax: ystep = ymax / yymax

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

For y = 0 To yymax - 1

    For x = 0 To xxmax - 1

        If Point(x * xstep, y * ystep) = w~& Then f(x, y) = 300: ff(x, y) = 300

    Next

Next

sphere& = _NewImage(_Width - 1, _Height - 1, 32)

While 1 'main fire

    _Dest sphere&

    _PutImage , e&, sphere&

    For y = 1 To yymax - 2

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

            r! = Rnd

            If r! < .2 Then

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

            ElseIf r! < .4 Then

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

            ElseIf r! < .47 Then

                If ff(x, y) Then f(x, y) = 300

            End If

        Next

    Next

    For y = 0 To yymax - 2 '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)

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

        Next

    Next

    _Dest 0

    Cls

    projectImagetoSphere sphere&, 400, 300, 250, xo

    xo = xo + 5 Mod _Width

    _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

   

Image source, bluemarble_small.png:

[Pete]

What??? Nearly every post I make is about FLAMING somebody!  

Pete

[bplus]

To save the phone people from having to scroll so much here is my latest Text on Fire in a Sphere on Cube Faces all zipped up.

EDIT: testing link 
https://discord.com/channels/97506559292...4782277775

result: takes me directly to my Discord post and the intended short video! but I was already logged into that Discord site.
If this works for others, no need for You Tube Channel, yet!