New Years Eve Fireworks!

[SierraKen]

Thanks. I was wondering that too. I might experiment with it a bit more.

[SierraKen]

I fixed it! Now it's not square anymore. I also doubled the sparks for each explosion.

Code: (Select All)

'Fireworks 2 by SierraKen



'Thanks B+ for the inspiration.



Screen _NewImage(800, 600, 32)

Dim x(200), y(200), xx(200), yy(200)

Dim centerx(200), centery(200)

Dim c(200)



_Title "Fireworks"



GoSub more



Randomize Timer

Do

    ce = ce + 1

    If ce > 200 Then ce = 1

    centerx(ce) = (Rnd * 400) + 200

    centery(ce) = (Rnd * 300) + 200

    red = (Rnd * 200) + 55: green = (Rnd * 200) + 55: blue = (Rnd * 200) + 55

    If red > green And red > blue And red < 200 Then red = 255

    If green > red And green > blue And green < 200 Then green = 255

    If blue > red And blue > green And blue < 200 Then blue = 255



    c(ce) = _RGB32(red, green, blue)



    GoSub trajectile



    For b = 1 To 300

        For e = 1 To 200

            x(e) = x(e) + xx(e)

            y(e) = y(e) + yy(e)

            cx = x(e) + centerx(ce)

            cy = y(e) + centery(ce)

            fillCircle cx, cy, 2, c(ce)

        Next e

        _Delay .005

        Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF

    Next b

    t = 1

    GoSub more

Loop Until InKey$ = Chr$(27)

End



more:

For t = 1 To 200

    r = Rnd * 4

    a = Rnd * _Pi

    x(t) = r * Cos(a)

    y(t) = r * Sin(a)

    If t < 50 Then xx(t) = r * Cos(a)

    If t < 50 Then yy(t) = r * Sin(a)

    If t > 49 Then xx(t) = r * -Cos(a)

    If t > 49 Then yy(t) = r * -Sin(a)



Next t

Return



trajectile:

For ty = 600 To centery(ce) Step -1

    fillCircle centerx(ce), ty, 2, _RGB32(255, 255, 255)

    _Delay .002

    Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF

Next ty

Return



'from Steve Gold standard

Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)

    Dim Radius As Integer, RadiusError As Integer

    Dim X As Integer, Y As Integer

    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0

    If Radius = 0 Then PSet (CX, CY), C: Exit Sub

    Line (CX - X, CY)-(CX + X, CY), C, BF

    While X > Y

        RadiusError = RadiusError + Y * 2 + 1

        If RadiusError >= 0 Then

            If X <> Y + 1 Then

                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF

    Wend

End Sub

[SierraKen]

OK, I changed my mind and added sound to this, because I like it so much.  
Put both files in the same folder as usual.
I tried to match the sound with the fireworks as much as I could. Please try it out, thanks. 

Here is the zip file, it is called: Ken's Fireworks 2.zip

When you play it, it will stop after 40 explosions, or you can press Esc to stop anytime.

Edit: I removed this download because of a better one below that has a double-grand finale.

[James D Jarvis]

Neato. I remember doing something like this about 30 years ago on Qbasic and wowing the family on New Year's Eve. Your version is much cooler.

[bplus]

+1 Yeah!

[SierraKen]

Thanks guys!!!

I put it on YouTube too...

[SierraKen]

Well, I just made it even better!!! I added a double-grand finale at the end of it. This one has 2 sound files and the .bas file in the .zip to download here.
I'll put it on YouTube later today. But also download it if you want. The file is called: Ken's Fireworks 3.zip

Check it out!

@bplus 

Edit: I made it a bit better on my next post and removed this zip.

[bplus]

Better?

Can perfection be improved? mayb+

Code: (Select All)

'Fireworks 3 by SierraKen mod b+ 2024-12-29 Ken inspires me too!
'Firework sound from https://pixabay.com/sound-effects/search/fireworks/

'Thanks B+ for the inspiration.

Screen _NewImage(800, 600, 32)
Dim x(200), y(200), xx(200), yy(200)
Dim centerx(200), centery(200)
Dim c(200) As _Unsigned Long  ' <<< best Type for RGB colors

_Title "Fireworks"

file$ = "firework_single.mp3"
file2$ = "firework_single_small.mp3"
Song = _SndOpen(file$)
song2 = _SndOpen(file2$)
If Song < 1 Or song2 < 1 Then '  <<< for some reason not getting 2nd sound, oh my mistake later maybe make sure both loaded here
    Print "Failed to load a sound file!"
    End
End If

GoSub more

Randomize Timer
Do
    ce = ce + 1
    If ce > 200 Then ce = 1
    centerx(ce) = (Rnd * 400) + 200
    centery(ce) = (Rnd * 100) + 300
    red = (Rnd * 200) + 55: green = (Rnd * 200) + 55: blue = (Rnd * 200) + 55

    ' vvvv why?  <<<<
    'If red > green And red > blue And red < 200 Then red = 255
    'If green > red And green > blue And green < 200 Then green = 255
    'If blue > red And blue > green And blue < 200 Then blue = 255
    'If blue < 150 Then blue = 255
    'If green < 150 Then green = 255
    'If red < 150 Then red = 255

    c(ce) = _RGB32(red, green, blue)

    If booms < 11 Then _SndPlay Song Else _SndPlay song2
    'If booms > 10 Then _SndPlay song2 ' <<< combine lines above
    If booms < 11 Then GoSub trajectile

    For b = 1 To 300
        For e = 1 To 200
            x(e) = x(e) + xx(e)
            y(e) = y(e) + yy(e)
            cx = x(e) + centerx(ce)
            cy = y(e) + centery(ce)
            fillCircle cx, cy, 2, c(ce)
        Next e
        If booms < 11 Then _Limit (300 - b) + 60  ' <<< here I slow blast down as airs out
        'If booms < 30 Then _Delay .005  ' <<< see above
        'If booms > 29 Then _Limit 500  ' <<< see above
        Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
    Next b
    t = 1
    GoSub more

    booms = booms + 1
    _Title "Fireworks Boom:" + Str$(booms)  ' <<< to watch count to 10 not previous 40? Ken had
    If booms = 10 Then
        _SndStop Song
    End If
    If booms = 20 Then
        _SndStop song2
        Cls
        End
    End If

Loop Until InKey$ = Chr$(27)
End

more:
For t = 1 To 200
    r = Rnd * 2 '  <<< from 4 to 2 to contain spread a little more??
    a = Rnd * _Pi(2) ' <<<< (2) = pi times 2, does whole circle not half so angle is from 0 to 360 in degrees equivalent
    x(t) = r * Cos(a)
    y(t) = r * Sin(a)
    'If t < 50 Then xx(t) = r * Cos(a)
    'If t < 50 Then xx(t) = r * Cos(a) ' <<< this is error !!! , never mind I must of screwed up this line??? It's good in Ken's zip
    'If t > 49 Then xx(t) = r * -Cos(a)
    'If t > 49 Then yy(t) = r * -Sin(a)
    xx(t) = r * Cos(a): yy(t) = r * Sin(a) '<<<  (2) does whole circle not half
Next t
Return

trajectile:
For ty = 600 To centery(ce) Step -1
    fillCircle centerx(ce), ty, 2, _RGB32(255, 255, 255)
    _Delay .002
    Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
Next ty
Return

'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

note: my changes marked with ' <<<

[SierraKen]

Thanks again @Bplus! I took most of your recommendations and used them. I kept a lot more explosions though but I did reduce them a bit. Plus I added your name to this because much of the code is by you. I hope that's OK with you, I just thought you should have some credit.
 
Here is the newest zip file, it's called: Fireworks 3.zip which has Fireworks 3.bas and 2 mp3 files.

[bplus]

Thanks again @Bplus! I took most of your recommendations and used them. I kept a lot more explosions though but I did reduce them a bit. Plus I added your name to this because much of the code is by you. I hope that's OK with you, I just thought you should have some credit.
 
Here is the newest zip file, it's called: Fireworks 3.zip which has Fireworks 3.bas and 2 mp3 files. 

Dang you need:
Dim C() As _Unsigned Long
to get full range of colors, all your colors look mostly the same to me?

and I am sorry you disabled the limit I put in on explosions. Here is a fix:

Code: (Select All)

'If booms < 20 Then _Limit (300 - b) + 60
' If booms < 20 Then _Delay .005 ' <<<  this messes up the above line
'If booms > 19 Then _Limit 500
If booms < 30 Then _Limit (300 - b) + 60 Else _Limit 500    ' <<< 30 is your new amount before rapid fire

In explosions, the initial spread speed is fast but slows due to air friction.

Oh also a CLS right after trajectile: clears the "trails" off the black screen. Come to think a night sky would be excellent background to this!
I think I have code handy, stay tuned...

update: nope background doesn't work with the fade trick for drawing the trails.