Fireworks (particle-test-demo)

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

Fireworks (particle-test-demo)

Postby stef » Apr 06, 2007 22:10

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: 619
Joined: Feb 07, 2006 15:29
Location: France / Luxemburg
Contact:

Postby redcrab » Apr 06, 2007 22:22

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:

Postby Hexadecimal Dude! » Apr 06, 2007 22:23

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

Postby cha0s » Apr 07, 2007 2:28

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

Postby Alexa » May 03, 2007 11:24

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

Postby Hezad » May 03, 2007 23:53

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

Postby phishguy » May 04, 2007 0:49

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

Postby Don » May 07, 2007 23:52

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: 6200
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Postby counting_pine » May 08, 2007 12:46

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

Postby MythGuyDK » May 08, 2007 17:06

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

Postby 1000101 » May 08, 2007 21:27

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

Postby Alexa » May 23, 2007 12:48

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

Postby redcrab » May 23, 2007 12:59

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

Postby anonymous1337 » May 23, 2007 13:29

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

Postby redcrab » May 24, 2007 6:52

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

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests