Fire Particle System
'Fire Particle System
'Thanks to Shockwave for code help.
'*****************************************'
option explicit
#include "tinyptc.bi"
#define tw 100
#define th 75
#define maxage 70
#define maxpts 40000
#define numcoolmaps 5
'Color type to extract rgb color information
'Posted by Jofers on FB forum
Type Pixel_Color
B As Ubyte
G As Ubyte
R As Ubyte
A As Ubyte
End Type
Union Pixel
Channel As Pixel_Color
Value As Uinteger
End Union
type particle
x as integer
y as integer
age as integer
end type
const cx = tw / 2
const pi = Atn ( 1.0 ) * 4
const fbWhite = RGB(255, 255, 255)
Const cpw = 100
Const cph = 10
dim shared buffer(1 to tw, 1 to th) as integer
dim shared fire as particle ptr
dim shared coolmap(0 to numcoolmaps, 1 to tw, 1 to th) as integer
dim shared pal(1 to maxage) as uinteger
dim shared currcoolmap as integer
dim as double t
Dim Shared cp(1000) As UInteger = { _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&h0,&hFFFFFF, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&hFFFFFF,&h0,&h0,&h0,&h0,&h0,&h0, _
&hFFFFFF,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&hFFFFFF,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&hFFFFFF,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&hFFFFFF,&h0,&hC0C0C0,&hC0C0C0, _
&hC0C0C0,&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0, _
&h0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&hC0C0C0,&hC0C0C0, _
&hC0C0C0,&hFFFFFF,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&hFFFFFF, _
&hC0C0C0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&hFFFFFF,&h0,&h0,&h0,&hC0C0C0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&h0,&h0,&h0,&h0,&hC0C0C0,&hFFFFFF, _
&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF,&h0,&h0,&hFFFFFF,&hFFFFFF, _
&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&h0,&h0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF, _
&hFFFFFF,&h0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&h0, _
&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hC0C0C0,&hFFFFFF,&h0,&h0, _
&hFFFFFF,&h0,&h0,&hFFFFFF,&hFFFFFF,&h0,&h0,&hFFFFFF, _
&hFFFFFF,&h0,&hFFFFFF,&h0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF, _
&h0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&h0,&h0, _
&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0, _
&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0,&hC0C0C0, _
&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&hC0C0C0,&hFFFFFF,&hFFFFFF,&h0, _
&hC0C0C0,&h0,&h0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hFFFFFF, _
&hFFFFFF,&h0,&hC0C0C0,&hFFFFFF,&hC0C0C0,&hC0C0C0,&hFFFFFF,&h0, _
&hC0C0C0,&hC0C0C0,&hFFFFFF,&h0,&hFFFFFF,&h0,&hC0C0C0,&hFFFFFF, _
&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&h0, _
&hC0C0C0,&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&hC0C0C0,&hFFFFFF,&hC0C0C0, _
&hFFFFFF,&h0,&hC0C0C0,&hC0C0C0,&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0, _
&hC0C0C0,&hFFFFFF,&h0,&hFFFFFF,&h0,&hC0C0C0,&hC0C0C0,&hC0C0C0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&h0,&h0,&h0,&h0,&h0,&hFFFFFF, _
&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0, _
&h0,&hFFFFFF,&hFFFFFF,&hC0C0C0,&h0,&h0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&hC0C0C0,&hC0C0C0,&hC0C0C0,&hC0C0C0,&h0,&hFFFFFF, _
&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0,&hFFFFFF,&hC0C0C0, _
&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0, _
&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&h0,&hC0C0C0,&hFFFFFF, _
&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&h0, _
&hFFFFFF,&hFFFFFF,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0, _
&h0,&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&h0,&hC0C0C0, _
&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF, _
&h0,&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0,&h0, _
&h0,&h0,&h0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0, _
&h0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF, _
&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0, _
&h0,&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0, _
&hFFFFFF,&hC0C0C0,&h0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0, _
&h0,&hFFFFFF,&hC0C0C0,&h0,&h0,&hC0C0C0,&hFFFFFF,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&hC0C0C0,&hFFFFFF, _
&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hC0C0C0,&hFFFFFF,&hC0C0C0, _
&h0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&h0,&h0,&h0, _
&hFFFFFF,&hC0C0C0,&h0,&h0,&h0,&h0,&h0,&hFFFFFF, _
&hC0C0C0,&h0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&h0,&hC0C0C0, _
&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF, _
&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF,&h0,&hC0C0C0,&h0, _
&hFFFFFF,&h0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hFFFFFF,&hFFFFFF, _
&h0,&hC0C0C0,&hFFFFFF,&hC0C0C0,&h0,&hFFFFFF,&hC0C0C0,&hFFFFFF, _
&hFFFFFF,&hFFFFFF,&h0,&hC0C0C0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&hC0C0C0,&hC0C0C0, _
&hC0C0C0,&hC0C0C0,&h0,&h0,&hC0C0C0,&h0,&h0,&hC0C0C0, _
&hC0C0C0,&hC0C0C0,&h0,&hC0C0C0,&h0,&h0,&hC0C0C0,&h0, _
&h0,&hC0C0C0,&h0,&h0,&h0,&hC0C0C0,&h0,&h0, _
&h0,&h0,&h0,&h0,&hC0C0C0,&h0,&h0,&h0, _
&hC0C0C0,&hC0C0C0,&hC0C0C0,&h0,&h0,&h0,&hC0C0C0,&hC0C0C0, _
&hC0C0C0,&h0,&h0,&hC0C0C0,&hC0C0C0,&hC0C0C0,&h0,&h0, _
&hC0C0C0,&hC0C0C0,&h0,&h0,&h0,&hC0C0C0,&h0,&hC0C0C0, _
&h0,&h0,&hC0C0C0,&hC0C0C0,&hC0C0C0,&h0,&h0,&hC0C0C0, _
&h0,&h0,&hC0C0C0,&h0,&hC0C0C0,&hC0C0C0,&hC0C0C0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0, _
&h0}
function AlphaBlend(alpha as integer, fcolor as uinteger, bcolor as uinteger) as uinteger
dim as integer invalpha, r, g, b
dim as Pixel fc, bc
invalpha = 255 - alpha
fc.value = fcolor
bc.value = bcolor
r = ((fc.channel.r * alpha) + (bc.channel.r * invalpha)) shr 8
g = ((fc.channel.g * alpha) + (bc.channel.g * invalpha)) shr 8
b = ((fc.channel.b * alpha) + (bc.channel.b * invalpha)) shr 8
return RGB(r, g, b)
end function
function GetRandom(lowerbound as integer, upperbound as integer) as integer
return Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
end function
'Interpolation code by Rattrapmax6
Sub CreatePalette(cpal() as Integer, sr as integer, sg as integer, sb as integer, er as integer, eg as integer, eb as integer)
Dim As Integer i
Dim iStart(3) As Integer
Dim iEnd(3) As Integer
Dim iShow(3) As Integer
Dim Rend(3) As Double
Dim InterPol(3) As Double
InterPol(0) = Ubound(cpal)
iStart(1) = sr
iStart(2) = sg
iStart(3) = sb
iEnd(1) = er
iEnd(2) = eg
iEnd(3) = eb
InterPol(1) = (iStart(1) - iEnd(1)) / InterPol(0)
InterPol(2) = (iStart(2) - iEnd(2)) / InterPol(0)
InterPol(3) = (iStart(3) - iEnd(3)) / InterPol(0)
Rend(1) = iStart(1)
Rend(2) = iStart(2)
Rend(3) = iStart(3)
For i = lbound(cpal) To Ubound(cpal)
iShow(1) = Rend(1)
iShow(2) = Rend(2)
iShow(3) = Rend(3)
cpal(i) = Rgb(iShow(1),iShow(2),iShow(3))
Rend(1) -= InterPol(1)
Rend(2) -= InterPol(2)
Rend(3) -= InterPol(3)
Next
End Sub
function Smooth( arr() as integer, imap as integer, x as integer, y as integer) as integer
dim as integer xx, yy, cnt, v
cnt = 0
v = arr(imap, x, y)
cnt += 1
if x < tw then
xx = x + 1
yy = y
v += arr(imap, xx, yy)
cnt += 1
end if
if x > 0 then
xx = x - 1
yy = y
v += arr(imap, xx, yy)
cnt += 1
end if
if y < th then
xx = x
yy = (y + 1)
v += arr(imap, x, y + 1)
cnt += 1
end if
if y > 0 then
xx = x
yy = (y - 1)
v += arr(imap, x, y - 1)
cnt += 1
end if
v = v / cnt
return v
end function
sub CreateCoolMap
dim as integer i, j, x, y
for i = 0 to numcoolmaps
for x = 1 to tw
for y = 1 to th
coolmap(i, x, y) = GetRandom(-20, 20)
next
next
for j = 1 to 10
for x = 1 to tw
for y = 1 to th
coolmap(i, x, y) = Smooth(coolmap(), i, x, y)
next
next
next
next
end sub
sub ClearBuffer
dim as integer x, y
for x = 1 to tw
for y = 1 to th
buffer(x, y) = 0
next
next
end sub
sub MoveParticles
dim as integer i, xx, yy, r, clr
do while i < maxpts
fire[i].age = fire[i].age + coolmap(currcoolmap, fire[i].x, fire[i].y) + 2
if fire[i].age < 1 then fire[i].age = 1
if fire[i].age < maxage then
r = sin(GetRandom(-pi, pi))
xx = fire[i].x + r
yy = fire[i].y - 1
if xx < 1 or xx > tw or yy < 1 or yy > th then
fire[i].age = maxage
else
fire[i].x = xx
fire[i].y = yy
if buffer(xx, yy) > 0 then
clr = AlphaBlend(fire[i].age, buffer(xx, yy), pal(fire[i].age))
else
clr = AlphaBlend(255 - (fire[i].age * 3), pal(fire[i].age), 0)
end if
buffer(xx, yy) = clr
end if
end if
i += 1
loop
end sub
sub AddParticles
dim as integer i
do while i < maxpts
if fire[i].age >= maxage then
fire[i].x = GetRandom(10, tw - 10)
fire[i].y = th
fire[i].age = GetRandom(1, maxage / 10)
end if
i += 1
loop
end sub
sub DoLogo
dim as integer x, y
for x = 0 to cpw - 1
for y = 0 to cph - 1
if cp(x + y * cpw) > 0 then
buffer(x + 1, y + 1) = cp(x + y * cpw)
end if
next
next
end sub
sub DoFire
dim as integer x, y
ClearBuffer
MoveParticles
AddParticles
DoLogo
cls
for x = 1 to tw
for y = 1 to th
locate y, x
color buffer(x, y)
print chr(219);
next
next
screencopy
end sub
Randomize timer
CreatePalette pal(), 255, 255, 0, 255, 0, 0
print "Generating cooling maps. Please wait..."
CreateCoolMap
'Allocate the fire array
fire = Callocate(maxpts * len(particle))
if fire = 0 then
end -1
end if
AddParticles
screen 19, 32, 2, 1
setmouse ,,0
screenset 0, 1
width tw, th
t = timer
do
if timer > (t + .5) then
currcoolmap = GetRandom(0, numcoolmaps)
t = timer
end if
DoFire
sleep .1
loop until inkey<>""
deallocate fire
setmouse ,,1