Dark Bit Factory & Gravity
PROGRAMMING => Freebasic => Topic started by: docgen on March 28, 2007
-
Hi!
Just another testcode to become more familiar with FB!
It's a "lavapainter" :)
Code needs FB 0.17 !
or download exe
use LMB; RMB; MMB or spacekey
' Automatic Lava
' by stef
OPTION STATIC
OPTION EXPLICIT
CONST MAXPARTICLES=1000
CONST SCREENW=800
CONST SCREENH=600
declare sub initparticles()
declare sub deleteparticles()
declare sub calcparticles()
declare sub drawparticles()
declare sub createcolours()
dim shared grav as single =0.001
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 =255
dim shared col_green as integer
dim shared col_blue as integer=0
dim shared colfactor as integer =5 ' only: 1; 5; 15
dim shared counter as integer
dim shared cd as integer=MAXPARTICLES
dim shared size as integer =50 '*2
dim shared a as integer
type tparticles
exist as integer
x as single
y as single
dx as single
dy as single
angle as single
speed as single
end type
dim shared particle(MAXPARTICLES) as tparticles
SCREEN 19, 16, 2, 1
SCREENSET 1, 0
RANDOMIZE TIMER
Dim shared screenim As Byte Ptr
screenim = Imagecreate(Screenw,screenh,rgb(0,0,0))
Dim shared maskim As Byte Ptr
maskim = Imagecreate(Screenw,screenh,rgb(0,0,0))
Dim shared phim As Byte Ptr
phim = Imagecreate(size*2,size*2)
for a = size-1 to 10 step-1
Circle phim,(size,size),a,RGB((255-5*a),(255-5*a),(255-5*a)),,,,F
next
DO
GETMOUSE posx, posy,, buttons
IF Bit(buttons, 0) THEN
initparticles()
endif
IF Bit(buttons, 1) THEN
deleteparticles()
endif
IF Bit(buttons, 2) or multikey(&h39) THEN
createcolours()
endif
calcparticles()
drawparticles()
put (0,0),screenim,pset
locate 1,1,0
print " press LMB= more lava; press RMB= less lava; press MMB or SPACE= change colours"
SCREENCOPY
LOOP UNTIL INKEY$=CHR$(27)
imagedestroy screenim
imagedestroy maskim
imagedestroy phim
end
sub initparticles()
if particle(counter).exist=0 then
particle(counter).exist=1
particle(counter).x=posx
particle(counter).y=posy
particle(counter).angle=(Rnd*360)*0.017453293
particle(counter).speed=Rnd*3+0.1
particle(counter).dx=sin(particle(counter).angle)*particle(counter).speed
particle(counter).dy=cos(particle(counter).angle)*particle(counter).speed
endif
counter=counter+1
if counter> MAXPARTICLES then counter=0
end sub
sub deleteparticles()
static cd as integer
if particle(counter).exist=1 then
particle(counter).exist=0
endif
counter=counter-1
if counter<0 then counter=0
end sub
sub calcparticles()
dim x as integer
for x= 0 to MAXPARTICLES
if particle(x).exist=1 then
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
if particle(x).x< 0 then particle(x).dx=-particle(x).dx
if particle(x).x> SCREENW then particle(x).dx=-particle(x).dx
if particle(x).y< 0 then particle(x).dy=-particle(x).dy
if particle(x).y> SCREENH+size then particle(x).dy=-particle(x).dy
endif
next
end sub
sub drawparticles()
dim x as integer
line screenim,(0,0)-(800,600),rgb(0,0,0),BF
line maskim,(0,0)-(800,600),rgb(col_red,col_green,col_blue),BF
for x= 0 to MAXPARTICLES
if particle(x).exist=1 then
put screenim,(particle(x).x-size,particle(x).y-size),phim,add,150
endif
next
put screenim,(0,0),maskim,and
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
-
Excellent version of the classic metaballs effect Stef :)
Have some Karma!
-
Very good, Stef!
-
Nice.
-
Does what it says on the tin! Nice!
Jim
-
Hey, that's cool!
Good job.
-
Good one :D
-
I like that, its quite mezmorising :goodpost: