01-24-2026, 03:22 AM (This post was last modified: 01-24-2026, 03:41 AM by 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!
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
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
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
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
