Here's something ive been dabbling about with today, with using types. Which hopefully ive got kinda right. Freebasic Help isnt too enlightening. Anyhow It's pretty lame the overall on screen firework particles. It may prove useful to some, and may even inspire.
'
' Experiment with types aka Lame Fire Works.
'
Option Static
Option Explicit
#Include "tinyptc.bi"
Const XRES=640
Const YRES=480
Const XRES2=XRES/2
Const YRES2=YRES/2
Const ARES = XRES*YRES
Const PI = 3.141593
Dim Shared ScreenBuffer( ARES ) As Integer
Dim Shared RunningTime As Double
Declare Sub FeedPixels( buffer(), Byval x As Integer, Byval y As Integer, Byval col As Integer)
Declare Sub InitializeFireworks()
Declare Sub CreateFireworks()
Declare Sub RunFireworks()
'Declare Sub CreateParticle( ByVal x As Single, ByVal y As Single, ByVal speed As Single , ByVal angle As Single)
Declare Sub CreateSparks( ByVal x As Single, ByVal y As Single, ByVal speed As Single, ByVal angle As Single,_
ByVal Red As Integer, ByVal Grn As Integer, ByVal Blu As Integer )
Declare Sub CreateFlares( ByVal x As Single, ByVal y As Single, Byval speed As Single, Byval distance As Single)
Declare Sub UpdateFlares()
Declare Sub UpdateSparks()
Declare Function IntRand ( ByVal lower As Integer, ByVal upper As Integer) As Integer
Declare Function FloatRand( ByVal lower As Double, ByVal upper As Double ) As Double
Declare Function Millisecs( ByVal TimeVal As Double ) As Double
Type Flares
As Integer ID, Distance, Red, Grn, Blu
As Single X, Y, Speed
End Type
Type Sparks
As Integer ID, Duration
As Single X, Y, Angle, Speed, PartTimer
End Type
Const MAXFIREWORKS=20000
Dim Shared Spark( MAXFIREWORKS ) As Sparks
Dim Shared Flare( MAXFIREWORKS ) As Flares
Dim Shared TotalFlares
Dim Shared TotalSparks
InitializeFireworks()
RunFireworks()
Ptc_Close
End
Sub CreateFlares( ByVal x As Single, ByVal y As Single, Byval speed As Single, Byval distance As Single)
Dim Add = TotalFlares
If TotalFlares<MAXFIREWORKS Then
Flare( Add ).ID = 1
Flare( Add ).X = x
Flare( Add ).Y = y
Flare( Add ).Speed = speed
Flare( Add ).Distance = Flare( Add ).Y-distance
Flare( Add ).Red = IntRand( 100, 255 )
Flare( Add ).Grn = IntRand( 100, 155 )
Flare( Add ).Blu = IntRand( 10, 100 )
TotalFlares=TotalFlares+1
End If
End Sub
Sub CreateSparks( ByVal x As Single, ByVal y As Single, ByVal speed As Single, ByVal angle As Single,_
ByVal Red As Integer, ByVal Grn As Integer, ByVal Blu As Integer )
Dim Add= TotalSparks
If TotalSparks<MAXFIREWORKS then
Spark( Add ).ID = 1
Spark( Add ).X = x
Spark( Add ).Y = y
Spark( Add ).Speed = speed
Spark( Add ).Angle = angle
Spark( Add ).PartTimer = MilliSecs( RunningTime )
Spark( Add ).Duration = IntRand(500,2000)
TotalSparks=TotalSparks+1
End IF
End Sub
Sub FeedPixels( buffer(), Byval x As Integer, Byval y As Integer, Byval col As Integer)
If x>0 and x<XRES-1 and y>0 and y<YRES-1 Then
Buffer(y * XRES + x) = col
End If
End Sub
Sub InitializeFireworks()
If( ptc_open( "Fireworks", XRES, YRES ) = 0 ) Then
End -1
End if
Randomize Timer
End Sub
Sub RunFireworks()
Dim Key As String
Dim x,y
While Key<>Chr(27)
RunningTime=Timer()
If Key=Chr(9) Then
CreateFlares( IntRand(10,XRES) , IntRand(YRES-10,YRES) , FloatRand(1.5,3.00) , IntRand(50, YRES-100) )
End If
UpdateFlares()
UpdateSparks()
'
' Reset input key buffer.
'
Key=Inkey()
'
' Render the screen.
'
Ptc_Update @ScreenBuffer(0)
'
' Clear Screen with colour 0.
'
For y=0 to YRES-1
For x=0 to XRES-1
FeedPixels( ScreenBuffer(), x, y, 0 )
Next
Next
Wend
End Sub
Sub UpdateFlares()
Dim Update
Dim a,b
Dim Rings
Dim Speed 'As Single
Dim Increment As Single
Dim Col
For Update=0 to TotalFlares-1
'
' Check if Flare is alive.
'
If Flare( Update ).ID = 1 Then
'
' Update Flare Speed.
'
Flare( Update ).Y = Flare( Update ).Y - Flare( Update ).Speed
'
' Work out colourings.
'
Col = ( Flare( Update ).Red Shl 16 ) Or ( Flare( Update ).Grn Shl 8 ) Or ( Flare( Update ).Blu Shl 0 )
'
' Add Positions and colour to the the ScreenBuffer.
'
FeedPixels( ScreenBuffer(), Flare( Update ).X, Flare( Update ).Y, Col )
'
' Check if flare reaches last position.
'
If Flare( Update ).Y < Flare( Update ).Distance Then
'
' Create Sparks.
'
Rings=IntRand(1,6)
For a=1 To Rings
Speed =FloatRand(0.70,2.00)
Increment =IntRand (10,70)
For b=0 To Increment
CreateSparks( Flare( Update ).X, Flare( Update ).Y ,_
FloatRand( Speed*1.2, Speed*1.2 ), b*( 360/Increment ),_
Flare( Update ).Red, Flare( Update ).Grn, Flare( Update ).Blu )
Next
Next
'
' Delete This Flare.
'
Flare( Update ).ID = 0
TotalFlares = TotalFlares-1
End If
End If
Next
End Sub
Sub UpdateSparks()
Dim Update
Dim Red, Grn, Blu
Dim Col
For Update=0 to TotalSparks-1
If Spark( Update ).ID=1 Then
Spark( Update ).X = Spark( Update ).X + Cos( Spark( Update ).Angle * (PI/180.00) ) * Spark( Update ).Speed
Spark( Update ).Y = Spark( Update ).Y + Sin( Spark( Update ).Angle * (PI/180.00) ) * Spark( Update ).speed
Red =IntRand(100,255)
Grn =IntRand(10, 164)
Blu =IntRand(100,190)
Col = ( Red Shl 16 ) Or ( Grn Shl 8 ) Or ( Blu Shl 0 )
FeedPixels( ScreenBuffer(), Spark( Update ).X, Spark( Update ).Y, Col )
If ( Spark( Update ).PartTimer + Spark( Update ).Duration ) <=Millisecs( RunningTime ) then
'
' Delete this Spark.
'
Spark( Update ).ID = 0
TotalSparks = TotalSparks-1
End If
End If
Next
End Sub
Function FloatRand(ByVal lower As Double, ByVal upper As Double) As Double
Dim As Double value, dist, temp
If upper < lower Then
temp=upper
upper=lower
lower=temp
End If
value=lower
dist = abs(lower-upper)
Return (Rnd(1)*dist) + value
End Function
Function IntRand(ByVal lower As Integer, ByVal upper As Integer) As Integer
Dim As Integer value, dist, temp
If upper < lower Then
temp=upper
upper=lower
lower=temp
End If
value=lower
dist = abs(lower-upper)
Return Int(Rnd(1)*dist) + value
End function
Function Millisecs( ByVal TimeVal As Double ) As Double
Return ( TimeVal * 1000.00 )
End Function
Cheers and hope its of some use,
Clyde.
