Dark Bit Factory & Gravity

PROGRAMMING => Freebasic => Topic started by: Clyde on May 05, 2006

Title: Experiment With Types: Fireworks
Post by: Clyde on May 05, 2006

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.

Code: [Select]

'
' 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.

Title: Re: Experiment With Types: Fireworks
Post by: relsoft on May 06, 2006

I don't see what's wrong but I just get a black screen. :*(

BTW, you usage of types seems fine.

Title: Re: Experiment With Types: Fireworks
Post by: Clyde on May 06, 2006

Cool, btw, you need to press TAB to launch a fire work trail.

Title: Re: Experiment With Types: Fireworks
Post by: Shockwave on May 06, 2006

Works well enough here, looks better when there are a lot of fireworks flying around. Thanks for posting it.

Title: Re: Experiment With Types: Fireworks
Post by: Clyde on May 06, 2006

No worries mate, glad to help where I can.
Types are a lot lot different if you've come from a Blitz Background. Unless, ive not found the commands associated with types; like delete, for a.type = each , etc.

Title: Re: Experiment With Types: Fireworks
Post by: Shockwave on May 06, 2006

It's useful for me because I hand't messed with types in FB yet, hopefully they don't have the memboy leakage problems associated with Blitz types. I'm sure other people will find your topic interesting.

Title: Re: Experiment With Types: Fireworks
Post by: Stonemonkey on May 06, 2006

"Unless, ive not found the commands associated with types; like delete, for a.type = each , etc."

yep clyde, types are a fair bit different in fb.

They are just dimmed like any other variable and are local (destroyed on function/sub exit) unless Shared and pointers are also very useful.

Title: Re: Experiment With Types: Fireworks
Post by: Clyde on May 06, 2006

Cheers for the tips Stonemonkey dude :D

Title: Re: Experiment With Types: Fireworks
Post by: gooner on November 04, 2008

Cool firework effect thanks for posting the source. :clap:

Might have a play around with this one :)

Title: Re: Experiment With Types: Fireworks
Post by: Clyde on November 04, 2008

Thanks man and no worries Gooner dude, glad it's of use.

Cheers,
Clyde.

Title: Re: Experiment With Types: Fireworks
Post by: Hezad on November 04, 2008

nice  :D :clap:

I modified a bit the code for it to run with "-lang fb" switch :

Code: [Select]

'
' 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() as integer, 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 as integer
Dim Shared TotalSparks as integer

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  as integer = 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  as integer = 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() as integer, 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 as integer 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 as integer Update
   
    Dim as integer a,b
    Dim as integer Rings
    Dim as integer Speed       'As Single
    Dim Increment   As Single   
   
    Dim as integer 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 as integer Update
    Dim as integer Red, Grn, Blu
    Dim as integer 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