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
Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-Share Alike 2.5 License.