Here's a quite cool code about a fire simulation.
Would like to see your FPS
I got around 25.
Have Fun.
Rem -.-.-.-.-.-.-.-.-.-.-.-.-
Rem -------FireExample-------
Rem .-.-.-.-.-.-.-.-.-.-.-.-.
Rem 30. November 2006
Rem by Azrael
Rem ._._._._._._._._._._._._.
``Konstanten
#constant CDetail 1000
#constant ScreenX 480
#constant ScreenY 320
#constant RFromX 80
#constant RFromY 25
#constant RToX 400
#constant RToY 295
#constant MProject 1
#constant MView 2
#constant MWorld 3
#constant VResult 10
#constant GRAVKONS 0.01*TPS
null = Make matrix4( MProject )
null = Make matrix4( MView )
null = Make matrix4( MWorld )
null = Make vector3( VResult )
Sync on : Sync rate 0 : Sync
Randomize timer()
Set display mode ScreenX, ScreenY, 32
Set window off
Type TParticle
dx As float
dy As float
dz As float
px As float
py As float
pz As float
visible As boolean
Endtype
``Variablen
Dim Palette( CDetail ) As dword
Dim FireBuffer( ScreenX, ScreenY ) As dword
Dim CoolBuffer( ScreenX, ScreenY*2 ) As float
Dim Particles( 500 ) As TParticle
ptr As dword
a As integer
b As integer
c As integer
i As integer
j As integer
k As integer
x As integer
y As integer
z As integer
TPS As float
lt As float
lr As float
cama As float = 0
camd As float = 500.0
camh As float = 30.0
CoolScroll As integer
``Setze Variablen
ptr = Make memory( 4 + 5*4 )
*ptr = 5
Inc ptr, 4 : *ptr = Rgb(000, 000, 000)
Inc ptr, 4 : *ptr = Rgb(128, 000, 000)
Inc ptr, 4 : *ptr = Rgb(255, 000, 000)
Inc ptr, 4 : *ptr = Rgb(255, 128, 000)
Inc ptr, 4 : *ptr = Rgb(255, 255, 128)
CreateGradient( ptr - 5*4 )
Gosub CreateCoolmap
Do
Rem Spricht für sich
Gosub ControleParticles
'If timer() - lr > 50.0
Gosub ControleCamera
lr = timer()
Rem Blurre FireBuffer und bewege Pixel um 1 nach oben
For y = RFromY To RToY + 5
For x = RFromX - 5 To RToX
FireBuffer( x, y - 1 ) = (( FireBuffer( x + 1, y ) + FireBuffer( x - 1, y ) + FireBuffer( x, y + 1 ))*.33333)*CoolBuffer( x, y + CoolScroll )
Next
Next
Rem Dynamische Coolmap - sieht besser aus
Inc CoolScroll
If CoolScroll >= 310 Then CoolScroll = 10
Rem Übertrage den FireBuffer auf den Screen
Lock pixels
For j = RFromY To RToY
For i = RFromX To RToX
Dot i, j, Palette( FireBuffer( i, j ))
Next
Next
Unlock pixels
'Endif
Rem Berechne TimePerSync
TPS = timer() - lt
lt = timer()
Rem INFOS
Ink 0, 0
Box 0, 0, RToX, RFromY
Ink 0xffffff, 0xffffff
Set cursor 0, 0
Print Screen fps()
Rem Na was wohl
Fastsync
Loop
Function CreateGradient( ptr As dword )
dr As float
dg As float
db As float
Cr As float
Cg As float
Cb As float
pcr As float
pcg As float
pcb As float
i As integer
j As integer = 0
Colors As Integer
Colors = *ptr
Inc ptr, 4
For i = 1 To Colors - 1
Cr = Rgbr( *ptr )
Cg = Rgbg( *ptr )
Cb = Rgbb( *ptr )
Inc ptr, 4
dr = Rgbr( *ptr ) - Cr
dg = Rgbg( *ptr ) - Cg
db = Rgbb( *ptr ) - Cb
pcr = dr/CDetail*(Colors - 1)
pcg = dg/CDetail*(Colors - 1)
pcb = db/CDetail*(Colors - 1)
Repeat
Inc j
Inc Cr, pcr
Inc Cg, pcg
Inc Cb, pcb
Palette( j ) = Rgb( Int( Cr ), Int( Cg ), Int( Cb ))
Until j >= CDetail/(Colors - 1)*i
Next
Endfunction
ControleParticles:
Rem 3D Gelumpe ..
World matrix4 MWorld
Projection matrix4 MProject
View matrix4 MView
Rem Hmm, das komische Gridfeld
For j = -100 To 100 Step 10
For i = -100 To 100 Step 10
Set vector3 VResult, i, 0, j
Project vector3 VResult, VResult, MProject, MView, MWorld
If X vector3( VResult ) > RFromX And X vector3( VResult ) < RToX
If Y vector3( VResult ) > RFromY And Y vector3( VResult ) < RToY
If Z vector3( VResult ) > 0 And Z vector3( VResult ) < 1.0
FireBuffer( Int( X vector3( VResult )), Int( Y vector3( VResult ))) = CDetail
Endif
Endif
Endif
Next
Next
Rem Die Partikel
For i = 0 To 300
If Particles( i ).visible
Inc Particles( i ).px, Particles( i ).dx*TPS*.05
Inc Particles( i ).py, Particles( i ).dy*TPS*.05
Inc Particles( i ).pz, Particles( i ).dz*TPS*.05
Dec Particles( i ).dy, GRAVKONS
If Particles( i ).py < 0 Then Particles( i ).visible = 0
Set vector3 VResult, Particles( i ).px, Particles( i ).py, Particles( i ).pz
Project vector3 VResult, VResult, MProject, MView, MWorld
If X vector3( VResult ) > RFromX And X vector3( VResult ) < RToX
If Y vector3( VResult ) > RFromY And Y vector3( VResult ) < RToY
If Z vector3( VResult ) > 0 And Z vector3( VResult ) < 1.0
For y = -1 To 1
For x = -1 To 1
FireBuffer( Int( X vector3( VResult )) + x, Int( Y vector3( VResult )) + y ) = CDetail
Next
Next
Endif
Endif
Endif
Else
If Rnd( 100 ) < 5
Repeat
j = Rnd( 300 )
Until Not Particles( j ).visible
Particles( j ).visible = 1
Particles( j ).px = 0 : Particles( j ).py = 0 : Particles( j ).pz = 0
k = Rnd( 360 )
Set vector3 VResult, Cos( k ), Rnd( 10 ), Sin( k )
Normalize vector3 VResult, VResult
Scale vector3 VResult, VResult, Rnd( 100 )*0.1
Particles( j ).dx = X vector3( VResult )
Particles( j ).dy = Y vector3( VResult )
Particles( j ).dz = Z vector3( VResult )
Endif
Endif
Next
Return
Rem Weiteres spricht für sich
ControleCamera:
Set camera to follow 0, 0, 0, cama, camd, camh, 60, 0
Point camera 0, 0, 0
Inc camd, Mousemovez()
Inc cama, Mousemovex()*2
Inc camh, Mousemovey()
Return
CreateCoolmap:
For i = 1 To 20000
CoolBuffer( Rnd( ScreenX ), Rnd( ScreenY*2 )) = 12.0
Next
For k = 1 To 30
For j = 1 To 2*ScreenY - 1
For i = 1 To ScreenX - 1
CoolBuffer( i, j ) = (CoolBuffer( i + 1, j ) + CoolBuffer( i - 1, j ) + CoolBuffer( i, j + 1) + CoolBuffer( i, j - 1 ))*.25
Next
Next
Next
For j = 0 To ScreenY*2
For i = 0 To ScreenX
If CoolBuffer( i, j ) < 0 Then CoolBuffer( i, j ) = 0
If CoolBuffer( i, j ) > 1.0 Then CoolBuffer( i, j ) = 1.0
Next
Next
Return
You can change the palette by changing these rgb values:
Inc ptr, 4 : *ptr = Rgb(000, 000, 000)
Inc ptr, 4 : *ptr = Rgb(128, 000, 000)
Inc ptr, 4 : *ptr = Rgb(255, 000, 000)
Inc ptr, 4 : *ptr = Rgb(255, 128, 000)
Inc ptr, 4 : *ptr = Rgb(255, 255, 128)
Also adding new colors is possible. But the allocated space has to be big enough and make sure that you pass the right pointer.
