+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: Flaming Text (let's make it a challenge) (/showthread.php?tid=4432)
Flaming Text (let's make it a challenge) - SMcNeill - 01-30-2026
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
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!
RE: Flaming Text (let's make it a challenge) - Petr - 01-30-2026
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
RE: Flaming Text (let's make it a challenge) - ahenry3068 - 01-30-2026
(01-30-2026, 11:13 PM)Petr Wrote: My version. Inspired by the BPlus program - solution with mask is perfect.Screen shot please ? Since I can't build this in Linux !
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
Steve's I could build, just had to pick a substitute font !
RE: Flaming Text (let's make it a challenge) - Petr - 01-30-2026
@ahenry3068
Screenshot:
![[Image: image.png]](https://i.ibb.co/tTgHfFTF/image.png)
RE: Flaming Text (let's make it a challenge) - bplus - 01-31-2026
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 FunctionRE: Flaming Text (let's make it a challenge) - bplus - 01-31-2026
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:
RE: Flaming Text (let's make it a challenge) - Pete - 01-31-2026
What??? Nearly every post I make is about FLAMING somebody!
Pete
RE: Flaming Text (let's make it a challenge) - bplus - 01-31-2026
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/975065592929345666/1039574725015392337/1467184074782277775
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!