Automatic Lava

[docgen]

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

Code: [Select]

' 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




[Shockwave]

Excellent version of the classic metaballs effect Stef

Have some Karma!

[benny!]

Very good, Stef!

[rdc]

Nice.

[Jim]

Does what it says on the tin!  Nice!

Jim

[ferris]

Hey, that's cool!

Good job.

[Clyde]

Good one

[Tetra]

I like that, its quite mezmorising