sparks and fireworks

[BasicCoder2]

Press left mouse button to make sparks. Only 1000 presses possible unless you change the source code.

Code: Select all

'PRESS LEFT MOUSE BUTTON TO MAKE SPARKS. In this code only 1000 sparks can be made.

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32


type SPARK
    as single px
    as single py
    as single vx
    as single vy
    as ulong  c
    as integer a
end type

dim shared as SPARK sparks(0 to 1000)
dim shared as integer total

sub drawSparks()
    dim as single dx,dy,angle,rr
    dim as ulong  r,g,b,cc
    screenlock
    cls
    if total<>0 then
        for i as integer = 0 to total-1
            cc = sparks(i).c
            'fade the color by width
            r = cc shr 16 and 255
            g = cc shr 8 and 255
            b = cc and 255
            r = r\(sparks(i).a\10)
            g = g\(sparks(i).a\10)
            b = b\(sparks(i).a\10)
            if r < 0 then r = 0
            if g < 0 then g = 0
            if b < 0 then b = 0
            'random sparks within circle radius rr
            for j as integer = 0 to 29
                rr = int(rnd(1)*sparks(i).a)  'gets wider each time
                angle = int(Rnd(1)*360)*DtoR
                dx = cos(angle)*rr
                dy = sin(angle)*rr
                circle(sparks(i).px+dx,sparks(i).py+dy),2,rgb(r,g,b),,,,f
            next j
            sparks(i).px = sparks(i).px + sparks(i).vx
            sparks(i).py = sparks(i).py + sparks(i).vy
            sparks(i).vy = sparks(i).vy + 0.1          'gravity
            sparks(i).a  = sparks(i).a + 1             'increase width
        next i
    end if
    screenunlock
end sub

dim as integer mx,my,mb

do
    getmouse mx,my,,mb

    if mb = 1 then
        sparks(total).a = 10
        sparks(total).px = mx
        sparks(total).py = my
        sparks(total).vx = int(rnd(1)*5)-2
        sparks(total).vy = -1
        sparks(total).c = rgb(int(rnd(1)*256),int(rnd(1)*256),int(rnd(1)*256))
        if total < 1000 then
            total = total + 1
        end if
    end if
    
    drawSparks()
    sleep 2
loop until multikey(&H01)

[srvaldez]

works ok on macOS, however I think it would be even better if the sparks faded away slower to emulate fireworks.

[counting_pine]

Looks pretty!
I made some changes:
- allow user to exit the program by clicking the close window button or pressing any key, instead of reaching for Escape
- change N to a configurable constant (it was effectively 1001)
- use With blocks to reduce the amount of array lookups in the code
- use 'r = (r * 10) \ .a' instead of 'r = r \ (.a \ 10)', for better precision
- make the code use a "circular buffer" - when it reaches the end, go back to the start and overwrite the oldest sparks

Code: Select all

'PRESS LEFT MOUSE BUTTON TO MAKE SPARKS. In this code only 1000 sparks can be made.

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32


type SPARK
    as single px
    as single py
    as single vx
    as single vy
    as ulong  c
    as integer a
end type

const N=100

dim shared as SPARK sparks(0 to N-1)
dim shared as integer total

sub drawSparks()
    dim as single dx,dy,angle,rr
    dim as ulong  r,g,b,cc
    screenlock
    cls
    if total<>0 then
        for i as integer = 0 to total-1: if i < total-N then i=total-N
            with sparks(i mod N)
                cc = .c
                'fade the color by width
                r = cc shr 16 and 255
                g = cc shr 8 and 255
                b = cc and 255
                r = (r*10)\.a
                g = (g*10)\.a
                b = (b*10)\.a
                if r < 0 then r = 0
                if g < 0 then g = 0
                if b < 0 then b = 0
                'random sparks within circle radius rr
                for j as integer = 0 to 29
                    rr = int(rnd(1)*.a)  'gets wider each time
                    angle = int(Rnd(1)*360)*DtoR
                    dx = cos(angle)*rr
                    dy = sin(angle)*rr
                    circle(.px+dx,.py+dy),2,rgb(r,g,b),,,,f
                next j
                .px = .px + .vx
                .py = .py + .vy
                .vy = .vy + 0.1          'gravity
                .a  = .a + 1             'increase width
            end with
        next i
    end if
    screenunlock
end sub

dim as integer mx,my,mb

do
    getmouse mx,my,,mb

    if mb = 1 then
        with sparks(total mod N)
            .a = 10
            .px = mx
            .py = my
            .vx = int(rnd(1)*5)-2
            .vy = -1
            .c = rgb(int(rnd(1)*256),int(rnd(1)*256),int(rnd(1)*256))
        end with
        total += 1
    end if
   
    drawSparks()
    sleep 2
loop until len(inkey)

[BasicCoder2]

Thanks counting_pine for the improvements. A circular list is kind of obvious now I think about it :)

To make them more like fireworks I shoot them from the ground and have added an exploding flag. They fade too quickly so I have removed it until I figure out a better way to fade a spark out. Also to keep them bright I make sure at least one color is fully saturated.

I thought it might be cool to add a whistle sound as the rocket goes up, explosion sound and then some sizzle sounds but couldn't find anything suitable on the internet. It also occurred to me that somehow you would need to run more than one sound file (wave) at the same time when more than one firework display was taking place.

Code: Select all

'written by BasicCoder with improvements by counting_pine 28th May 2018

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32

type SPARK
    as single px    'position
    as single py
    as single vx    'velocity
    as single vy
    as ulong  c     'color
    as integer a    'radius of explosion
    as integer exploding  
end type

const N=100

dim shared as SPARK sparks(0 to N-1)
dim shared as integer total

sub drawSparks()
    dim as single dx,dy,angle,rr
    screenlock
    cls
    if total<>0 then
        for i as integer = 0 to total-1: if i < total-N then i=total-N
            with sparks(i mod N)
                if .py < 240 then .exploding = 1
                'random sparks within circle radius rr
                for j as integer = 0 to 29
                    rr = int(rnd(1)*.a)  'gets wider each time
                    angle = int(Rnd(1)*360)*DtoR
                    dx = cos(angle)*rr
                    dy = sin(angle)*rr
                    circle(.px+dx,.py+dy),int(rnd(1)*2)+1,.c,,,,f
                next j
                .px = .px + .vx
                .py = .py + .vy
                .vy = .vy + 0.1          'gravity
                if .exploding = 1 then
                    .a  = .a + 1             'increase width
                end if
            end with
        next i
    end if
    screenunlock
end sub

dim as ulong r,g,b
dim as integer f    'red,green or blue sparks

do

    if int(rnd(1)*50)=0 then
        with sparks(total mod N)
            .a = 2
            .px = 320
            .py = 430
            .vx = int(rnd(1)*5)-2
            .vy = -8
            .exploding = 0
            r = int(rnd(1)*255)
            g = int(Rnd(1)*255)
            b = int(Rnd(1)*255)
            'choose a bright color
            f = int(rnd(1)*3)
            if f = 0 then r = 255
            if f = 1 then g = 255
            if f = 2 then b = 255
            .c = rgb(r,g,b)
        end with
        total += 1
    end if
   
    drawSparks()
    sleep 2
loop until len(inkey)