Fireworks (particle-test-demo)

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
stef
Posts: 2
Joined: Mar 31, 2007 20:01

Fireworks (particle-test-demo)

Post by stef »

A fireworkscode of mine

click mousebutton (there is a different effect for left/right/middle)

Code: Select all

' Fireworks 
' by stef
    
    OPTION STATIC
    OPTION EXPLICIT

    CONST MAXPARTICLES=3600 '300;600;900;1500;3000; 6000; 12000;24000;48000
    
    CONST SCREENW=800 					
    CONST SCREENH=600 					
   
 
    declare sub initparticles()
    declare sub calcparticles()
    declare sub drawparticles()
    declare sub createcolours()
    declare sub createstars()
    declare sub drawstars()
    
    

dim shared grav as single =0.02
dim shared posx as integer
dim shared posy as integer
dim shared buttons as integer

dim shared col as integer
dim shared col_red as integer 
dim shared col_green as integer
dim shared col_blue as integer=255
dim shared colfactor as integer =5 ' only: 1; 5; 15
     
dim shared counter as integer 
dim shared mousestatus as integer
dim shared colourstatus as integer  
    
type tstars
    x as integer
    y as integer
end type   

type tparticles
    x as single  
    y as single
    dx as single  
    dy as single
    size as integer
    angle as single
    speed as single
    col as integer
end type


dim shared stars(100) as tstars

dim shared particle(MAXPARTICLES) as tparticles
    
    SCREEN 19, 16, 2, 1
    
    SCREENSET 1, 0

    RANDOMIZE TIMER

    Dim Im As Byte Ptr
    Im = Imagecreate(SCREENW, SCREENH, RGB(5, 5, 5))
   
   createstars()
  
DO
       
    GETMOUSE posx, posy,, buttons
    
    if buttons=0 then
   'if not Bit(buttons, 0) THEN  
     mousestatus=0
     endif
    
    if mousestatus=0 then
        IF Bit(buttons, 0) THEN 
            initparticles()
            mousestatus=1
            colourstatus=1
        endif
        IF Bit(buttons, 2) THEN 
            initparticles()
            mousestatus=1
            colourstatus=2
        endif
         IF Bit(buttons, 1) THEN 
            initparticles()
            mousestatus=1
            colourstatus=3
        endif
        
    endif

    drawstars()
      
    calcparticles()
         
    drawparticles()
    
    put (0,0),im,alpha,5
     
    locate 1,1,0
    print "click LM/RM/MM"
   
   
    SCREENCOPY
  
LOOP UNTIL INKEY$=CHR$(27)

Imagedestroy Im

end



sub initparticles()
    dim x as integer
   
    for x= 0 to MAXPARTICLES
     
        createcolours()
        particle(x).col=rgb(col_red,col_green,col_blue)
             
        particle(x).x=posx 
        particle(x).y=posy
        particle(x).size=Rnd*3+1
        particle(x).angle=(Rnd*360)*0.017453293
        particle(x).speed=Rnd*5+0.1
        particle(x).dx=sin(particle(x).angle)*particle(x).speed
        particle(x).dy=cos(particle(x).angle)*particle(x).speed
           
    next
    
end sub

sub calcparticles()
    
    dim x as integer
    
   if colourstatus= 1 then
        createcolours()
        col=rgb(col_red,col_green,col_blue)
    endif
    
   
    for x= 0 to MAXPARTICLES
        if colourstatus= 2 then
            createcolours()
            col=rgb(col_red,col_green,col_blue)
             particle(x).size=1
        endif
        if colourstatus<3 then
            particle(x).col=col  
        endif
        
        particle(x).x=particle(x).x+particle(x).dx
        particle(x).y=particle(x).y+particle(x).dy
        particle(x).dy=particle(x).dy+grav 
        
      
    next

end sub

sub drawparticles()
    dim x as integer
    
    for x= 0 to MAXPARTICLES
        circle (particle(x).x,particle(x).y),particle(x).size,particle(x).col,,,,F
    next

end sub

sub createcolours()
    If col_red<255 And col_green =0 And col_blue =255 Then col_red=col_red+colfactor
    If col_red=255 And col_green=0 And col_blue >0 Then	col_blue=col_blue-colfactor
    If col_red=255 And col_green < 255 And col_blue =0 Then col_green=col_green+colfactor
    If col_red>0 And col_green = 255 And col_blue =0 Then col_red=col_red-colfactor
    If col_red=0 And col_green = 255 And col_blue <255 Then col_blue=col_blue+colfactor		
    If col_red=0 And col_green >0 And col_blue =255 Then col_green=col_green-colfactor
end sub 
 
sub drawstars()
    dim c as integer
     
    for counter =0 to 100
        c=rnd*255
        if c>127 then
            circle  (stars(counter).x,stars(counter).y),rnd*2,rgb(c,c,c),,,,F
        endif
    next
 
end sub

sub createstars()
    dim c as integer
        
    for counter =0 to 100
        stars(counter).x=rnd*SCREENW
        stars(counter).y=rnd*SCREENH
    next
 
end sub
 
redcrab
Posts: 623
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Post by redcrab »

Whaoooo ! that's a fest

I love it !

I would like to see several explosion at the same time ... should be more beautiful

"Ohh the pretty blue.... OOOh the nice red"


That's fun !
Hexadecimal Dude!
Posts: 360
Joined: Jun 07, 2005 20:59
Location: england, somewhere around the middle
Contact:

Post by Hexadecimal Dude! »

wow!!!
cha0s
Site Admin
Posts: 5319
Joined: May 27, 2005 6:42
Location: USA
Contact:

Post by cha0s »

Looks really pretty ^^
Alexa
Posts: 56
Joined: May 01, 2007 20:22

Post by Alexa »

Wow!, very Beautiful !!
Hezad
Posts: 469
Joined: Dec 17, 2006 23:37
Contact:

Post by Hezad »

Simply Awesome !
phishguy
Posts: 1201
Joined: May 05, 2006 16:12
Location: West Richland, Wa

Post by phishguy »

Kewl, but i don't have a middle mouse button ;(
Don
Posts: 14
Joined: May 07, 2007 23:41
Location: USA

Problem compiling FIREWORKS with FB-v0.17b-May-01-2007

Post by Don »

Stef's FIREWORKS code compiled with previous version, but will not with the new version unless the OPTION STATIC and OPTION EXPLICIT lines are removed.

Apparently the new build of FB-v0.17b no longer allows either of these two OPTION statements.

Don
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Post by counting_pine »

The default language setting of the latest release doesn't allow Options because they cause context sensitivity - i.e. an Option statement hidden somewhere in your program can change the way it behaves.
In this case it's safe to remove both since the new mode requires explicit variable declaration anyway, and arrays are always static by default anyway.

Still, I often think the new mode should let Option Explicit slip by, with just a warning.
MythGuyDK
Posts: 22
Joined: Sep 21, 2006 20:01

Post by MythGuyDK »

Very nice.

I modified it to act as a screensaver.

Code: Select all

' Fireworks 
' by stef
'   Modified by MythGuy

    Option Static
   
    
    goodds = val(command$(1))
    if goodds = 0 then goodds = 150
    Const MAXPARTICLES=3600 '300;600;900;1500;3000; 6000; 12000;24000;48000
    
    Const SCREENW=800                                         
    Const SCREENH=600                                         
   
 
    Declare Sub initparticles()
    Declare Sub calcparticles()
    Declare Sub drawparticles()
    Declare Sub createcolours()
    Declare Sub createstars()
    Declare Sub drawstars()
    
    

Dim Shared grav As Single =0.02
Dim Shared posx As Integer
Dim Shared posy As Integer
Dim Shared buttons As Integer

Dim Shared col As Integer
Dim Shared col_red As Integer 
Dim Shared col_green As Integer
Dim Shared col_blue As Integer=255
Dim Shared colfactor As Integer =5 ' only: 1; 5; 15
     
Dim Shared counter As Integer 
Dim Shared mousestatus As Integer
Dim Shared colourstatus As Integer  
    
Type tstars
    x As Integer
    y As Integer
End Type   

Type tparticles
    x As Single  
    y As Single
    dx As Single  
    dy As Single
    size As Integer
    angle As Single
    speed As Single
    col As Integer
End Type


Dim Shared stars(100) As tstars

Dim Shared particle(MAXPARTICLES) As tparticles
    
    Screen 19, 16, 2, 1
    setmouse 0,0,0
    Randomize Timer

    Dim Im As Byte Ptr
    Im = Imagecreate(SCREENW, SCREENH, RGB(5, 5, 5))
   
   createstars()
  
Do
       
    posx = int(rnd*screenw+1)
    posy = int(rnd*screenh+1)
    buttons = int(rnd*goodds)

    if buttons <= 2 then
        If buttons = 0 Then 
            initparticles()
            mousestatus=1
            colourstatus=1
        Endif
        If buttons = 2 Then 
            initparticles()
            mousestatus=1
            colourstatus=2
        Endif
        If buttons = 1 Then 
            initparticles()
            mousestatus=1
            colourstatus=3
        Endif
    Endif

    drawstars()
      
    calcparticles()
         
    drawparticles()
    
    Put (0,0),im,alpha,5
     
   
   
    SCREENCOPY
  
Loop Until Inkey$=Chr$(27)

Imagedestroy Im

End



Sub initparticles()
    Dim x As Integer
   
    For x= 0 To MAXPARTICLES
     
        createcolours()
        particle(x).col=rgb(col_red,col_green,col_blue)
             
        particle(x).x=posx 
        particle(x).y=posy
        particle(x).size=Rnd*3+1
        particle(x).angle=(Rnd*360)*0.017453293
        particle(x).speed=Rnd*5+0.1
        particle(x).dx=Sin(particle(x).angle)*particle(x).speed
        particle(x).dy=Cos(particle(x).angle)*particle(x).speed
           
    Next
    
End Sub

Sub calcparticles()
    
    Dim x As Integer
    
   If colourstatus= 1 Then
        createcolours()
        col=rgb(col_red,col_green,col_blue)
    Endif
    
   
    For x= 0 To MAXPARTICLES
        If colourstatus= 2 Then
            createcolours()
            col=rgb(col_red,col_green,col_blue)
             particle(x).size=1
        Endif
        If colourstatus<3 Then
            particle(x).col=col  
        Endif
        
        particle(x).x=particle(x).x+particle(x).dx
        particle(x).y=particle(x).y+particle(x).dy
        particle(x).dy=particle(x).dy+grav 
        
      
    Next

End Sub

Sub drawparticles()
    Dim x As Integer
    
    For x= 0 To MAXPARTICLES
        Circle (particle(x).x,particle(x).y),particle(x).size,particle(x).col,,,,F
    Next

End Sub

Sub createcolours()
    If col_red<255 And col_green =0 And col_blue =255 Then col_red=col_red+colfactor
    If col_red=255 And col_green=0 And col_blue >0 Then        col_blue=col_blue-colfactor
    If col_red=255 And col_green < 255 And col_blue =0 Then col_green=col_green+colfactor
    If col_red>0 And col_green = 255 And col_blue =0 Then col_red=col_red-colfactor
    If col_red=0 And col_green = 255 And col_blue <255 Then col_blue=col_blue+colfactor                
    If col_red=0 And col_green >0 And col_blue =255 Then col_green=col_green-colfactor
End Sub 
 
Sub drawstars()
    Dim c As Integer
     
    For counter =0 To 100
        c=Rnd*255
        If c>127 Then
            Circle  (stars(counter).x,stars(counter).y),Rnd*2,rgb(c,c,c),,,,F
        Endif
    Next
 
End Sub

Sub createstars()
    Dim c As Integer
        
    For counter =0 To 100
        stars(counter).x=Rnd*SCREENW
        stars(counter).y=Rnd*SCREENH
    Next
 
End Sub
 
 
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Post by 1000101 »

That's rather pretty. Much better then other particle explosions I've seen posted.
Alexa
Posts: 56
Joined: May 01, 2007 20:22

Post by Alexa »

How can i Convert it to .SCR for Windows Screensaver ...
redcrab
Posts: 623
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Post by redcrab »

Alexa wrote:How can i Convert it to .SCR for Windows Screensaver ...
rename your .exe file into .scr and copy it to you c:\windows\system32 folder
then go to your screen saver controller (Desktop setting) and choose the program...

It's simple as that
... Is a quick and easy(dirty?) way to do the stuff


Have fun !
Last edited by redcrab on May 23, 2007 15:57, edited 1 time in total.
anonymous1337
Posts: 5494
Joined: Sep 12, 2005 20:06
Location: California

Post by anonymous1337 »

Whoo! O_O;; Very amazing. So tempting to mess with the code. I think I will!
redcrab
Posts: 623
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Post by redcrab »

redcrab wrote:
Alexa wrote:How can i Convert it to .SCR for Windows Screensaver ...
rename your .exe file into .scr and copy it to you c:\windows\system32 folder
then go to your screen saver controller (Desktop setting) and choose the program...

It's simple as that
... Is a quick and easy(dirty?) way to do the stuff


Have fun !
You've to not forget that Screen Saver is started with parameter.

so in "command" variable you can have :
"/p 541524" : when preview on tiny screen is requested
the number may refer to DC handle value to use to draw preview (I guess, not sure)
"/c:8762837" : configuration is requested
the number may refer to the HWND (window handle) value of the parent window to use (if you want to use modal dialog box it is important)
"/s" : when a normal start is requested

the typical quick and easy stuff i do is :

Code: Select all

if command = "" or command ="/s" then
 showscreensaver
else
  end ' do nothing
end if
Post Reply