Fireworks thru the years - Printable Version

Code: (Select All)

_Title "Fireworks 3 translation to QB64 2017-12-26 bplus"

'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09

'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris

'fireworks 3.bas try with map variables make bursts around a central point



Const xmax = 1000

Const ymax = 720



Screen _NewImage(xmax, ymax, 32)

_ScreenMove 180, 0

Type placeType

    x As Single

    y As Single

End Type

Type flareType

    x As Single

    y As Single

    dx As Single

    dy As Single

    c As Long

End Type

Type debrisType

    x As Single

    y As Single

    c As Long

End Type

Common Shared debris() As debrisType

flareMax = 1000: debrisMax = 5000: debrisStack = 0

Dim flare(flareMax) As flareType

Dim debris(debrisMax) As debrisType

Dim burst As placeType

While 1

    rndCycle = Rnd * 30

    loopCount = 0

    burst.x = .75 * xmax * Rnd + .125 * xmax

    burst.y = .5 * ymax * Rnd + .125 * ymax

    While loopCount < 7

        Cls

        'color 14 : locate 0,0: ? debris_stack; " Debris" 'debug line

        For i = 1 To 200 'new burst using random old flames to sim burnout

            nxt = Int(Rnd * flareMax)

            angle = Rnd * _Pi(2)

            flare(nxt).x = burst.x + Rnd * 5 * Cos(angle)

            flare(nxt).y = burst.y + Rnd * 5 * Sin(angle)

            angle = Rnd * _Pi(2)

            flare(nxt).dx = Rnd * 15 * Cos(angle)

            flare(nxt).dy = Rnd * 15 * Sin(angle)

            rc = Int(Rnd * 3)

            If rc = 0 Then

                flare(nxt).c = _RGB32(255, 100, 0)

            ElseIf rc = 1 Then

                flare(nxt).c = _RGB32(0, 0, 255)

            Else

                flare(nxt).c = _RGB32(255, 255, 255)

            End If

        Next

        For i = 0 To flareMax

            If flare(i).dy <> 0 Then 'while still moving vertically

                Line (flare(i).x, flare(i).y)-Step(flare(i).dx, flare(i).dy), _RGB32(98, 98, 98)

                flare(i).x = flare(i).x + flare(i).dx

                flare(i).y = flare(i).y + flare(i).dy

                Color flare(i).c

                Circle (flare(i).x, flare(i).y), 1

                flare(i).dy = flare(i).dy + .4 'add  gravity

                flare(i).dx = flare(i).dx * .95 'add some air resistance

                If flare(i).x < 0 Or flare(i).x > xmax Then flare(i).dy = 0 'outside of screen

                'add some spark bouncing here

                If flare(i).y > ymax Then

                    If Abs(flare(i).dy) > .5 Then

                        flare(i).y = ymax: flare(i).dy = flare(i).dy * -.25

                    Else

                        flare(i).dy = 0

                    End If

                End If

            End If

        Next

        For i = 0 To debrisStack

            PSet (debris(i).x, debris(i).y), debris(i).c

            debris(i).x = debris(i).x + Rnd * 3 - 1.5

            debris(i).y = debris(i).y + Rnd * 3.5 - 1.5

            If debris(i).x < 0 Or debris(i).y < 0 Or debris(i).x > xmax Or debris(i).y > ymax Then NewDebris (i)

        Next

        _Display

        _Limit 20

        loopCount = loopCount + 1

    Wend

    If debrisStack < debrisMax Then

        For i = 1 To 20

            NewDebris i + debrisStack

        Next

        debrisStack = debrisStack + 20

    End If

Wend

Sub NewDebris (i)

    debris(i).x = Rnd * xmax

    debris(i).y = Rnd * ymax

    c = Rnd * 255

    debris(i).c = _RGB32(c, c, c)

End Sub

Code: (Select All)

_Title "Happy Trails 2020" 'from Happy Trails 2018

' 2017-12-29 another redesign of fireworks

' 2017-12-28 redesign fireworks

' now with lake refelction 2017-12-27 forget the bouncing sparks

' combine Welcome Plasma Font with landscape

'_title "Fireworks 3 translation to QB64 2017-12-26 bplus"

'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09

'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris

'fireworks 3.bas try with map variables make bursts around a central point





Randomize Timer

Const xmax = 1200

Const ymax = 720

Const waterline = 600 ' 600 = ratio 5 to 1 sky to water

'                       raise and lower waterline as desired  highest about 400?

Const lTail = 15

Const bluey = 5 * 256 ^ 2 + 256 * 5 + 5

Const debrisMax = 28000



Screen _NewImage(xmax, ymax, 32)

_ScreenMove 120, 20



Type fireWorkType

    x As Integer

    y As Integer

    seed As Integer

    age As Integer

    life As Integer

End Type





Type debrisType

    x As Single

    y As Single

    c As Long

End Type



Common Shared fw() As fireWorkType

Common Shared debris() As debrisType

Common Shared cN, pR!, pG!, pB!



Screen _NewImage(xmax, ymax, 32)



'prepare message font

mess$ = " Happy New Year 2020"

Print mess$

w = 8 * Len(mess$): h = 16

Dim p(w, h)

black&& = Point(0, 10)

For y = 0 To h

    For x = 0 To w

        If Point(x, y) <> black&& Then

            p(x, y) = 1

        End If

    Next

Next

xo = 0: yo = 15: m = 7.2

resetPlasma



'prepare landscape

Cls

land& = _NewImage(xmax, ymax, 32)

_Dest land&

drawLandscape

_Dest 0



'prepare fire works

nFW = 3

Dim fw(1 To 10) As fireWorkType

For i = 1 To nFW

    initFireWork (i)

Next



''debris feild

'DIM debris(debrisMax) AS debrisType



'OK start the show

While 1

    'cls screen with land image

    _PutImage , land&, 0



    'draw fireworks

    For f = 1 To nFW

        If fw(f).age <= fw(f).life Then drawfw (f) Else initFireWork f

    Next



    ''debris

    'FOR i = 0 TO debrisStack

    '    PSET (debris(i).x, debris(i).y), debris(i).c

    '    debris(i).x = debris(i).x + RND * 3 - 1.5

    '    debris(i).y = debris(i).y + RND * 3.5 - 1.5

    '    IF debris(i).x < 0 OR debris(i).y < 0 OR debris(i).x > xmax OR debris(i).y > waterline + RND * 20 THEN NewDebris (i)

    'NEXT



    'text message in plasma

    For y = 0 To h - 1

        For x = 0 To w - 1

            If p(x, y) Then

                changePlasma

            Else

                Color 0

            End If

            Line (xo + x * m, yo + y * m)-(xo + x * m + m, yo + y * m + m), , BF

        Next

    Next

    lc = lc + 1

    If lc Mod 200 = 0 Then resetPlasma



    'reflect sky

    skyWaterRatio = waterline / (ymax - waterline) - .05

    For y = waterline To ymax

        For x = 0 To xmax

            c&& = Point(x, waterline - ((y - waterline - 1) * skyWaterRatio) + Rnd * 5)

            PSet (x, y + 1), c&& + bluey

        Next

    Next



    _Display

    _Limit 200 'no limit needed on my system!



    ''accumulate debris

    'IF lc MOD 2000 THEN

    '    IF debrisStack < debrisMax THEN

    '        FOR i = 1 TO 2

    '            NewDebris i + debrisStack

    '        NEXT

    '        debrisStack = debrisStack + 2

    '    END IF

    'END IF

Wend



'SUB NewDebris (i)

'    debris(i).x = RND * xmax

'    debris(i).y = RND * ymax

'    c = RND * 155

'    debris(i).c = _RGB32(c, c, c)

'END SUB



Sub changePlasma ()

    cN = cN + .01

    Color _RGB(127 + 127 * Sin(pR! * .3 * cN), 127 + 127 * Sin(pG! * .3 * cN), 127 + 127 * Sin(pB! * .3 * cN))

End Sub



Sub resetPlasma ()

    pR! = Rnd ^ 2: pG! = Rnd ^ 2: pB! = Rnd ^ 2

End Sub



Sub drawLandscape

    'the sky

    For i = 0 To ymax

        midInk 0, 0, 0, 78, 28, 68, i / ymax

        Line (0, i)-(xmax, i)

    Next

    'the land

    startH = waterline - 80

    rr = 10: gg = 20: bb = 15

    For mountain = 1 To 6

        Xright = 0

        y = startH

        While Xright < xmax

            ' upDown = local up / down over range, change along Y

            ' range = how far up / down, along X

            upDown = (Rnd * .8 - .35) * (1 / (1 * mountain))

            range = Xright + rand&&(5, 35) * 2.5 / mountain

            lastx = Xright - 1

            For X = Xright To range

                y = y + upDown

                Color _RGB32(rr, gg, bb)

                Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right

                lastx = X

            Next

            Xright = range

        Wend

        rr = rand&&(rr + 5, rr): gg = rand&&(gg + 5, gg): bb = rand&&(bb + 4, bb)

        If rr < 0 Then rr = 0

        If gg < 0 Then gg = 0

        If bb < 0 Then bb = 0

        startH = startH + rand&&(1, 10)

    Next

    'LINE (0, waterline)-(xmax, ymax), _RGB32(0, 0, 0), BF

End Sub



Sub midInk (r1, g1, b1, r2, g2, b2, fr)

    Color _RGB(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)

End Sub



Function rand&& (lo&&, hi&&)

    rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&

End Function



Sub drawfw (i)

    'here's how to "save" a bunch of random numbers without data and arrays but tons of redundant calculations

    Randomize Using fw(i).seed 'this repeats all random numbers generated by seed in same sequence

    'recreate our firework from scratch!

    red = rand&&(200, 255)

    green = rand&&(200, 255)

    blue = rand&&(200, 255)

    x = rand&&(1, 4)

    If x = 1 Then

        red = 0

    ElseIf x = 2 Then

        green = 0

    ElseIf x = 3 Then

        blue = 0

    Else

        x = rand&&(1, 4)

        If x = 1 Then

            red = 0: green = 0

        ElseIf x = 2 Then

            green = 0: blue = 0

        ElseIf x = 3 Then

            blue = 0: red = 0

        End If

    End If

    ne = rand&&(80, 300)

    Dim embers(ne, 1)

    For e = 0 To ne

        r = Rnd * 3

        embers(e, 0) = r * Cos(e * _Pi(2) / 101)

        embers(e, 1) = r * Sin(e * _Pi(2) / 101)

    Next

    start = fw(i).age - lTail ' don't let tails get longer than lTail const

    If start < 1 Then start = 1

    For e = 0 To ne

        cx = fw(i).x: cy = fw(i).y: dx = embers(e, 0): dy = embers(e, 1)

        For t = 1 To fw(i).age

            cx = cx + dx

            cy = cy + dy

            If t >= start Then

                'too much like a flower?

                midInk 60, 60, 60, red, green, blue, (t - start) / lTail

                'midInk 60, 60, 60, 128, 160, 150, (t - start) / lTail

                fcirc cx, cy, (t - start) / lTail

            End If



            dx = dx * .99 'air resitance

            dy = dy + .01 'gravity

        Next

        Color _RGB32(255, 255, 255)

        'COLOR _RGB32(red, green, blue)

        cx = cx + dx: cy = cy + dy

        fcirc cx, cy, (t - start) / lTail

    Next

    fw(i).age = fw(i).age + 1

End Sub



Sub initFireWork (i)

    fw(i).x = rand&&(.1 * xmax, .9 * xmax)

    fw(i).y = rand&&(.1 * ymax, .5 * ymax)

    fw(i).seed = rand&&(0, 32000)

    fw(i).age = 0

    fw(i).life = rand&&(20, 120)

End Sub



'Steve McNeil's  copied from his forum   note: Radius is too common a name

Sub fcirc (CX As Long, CY As Long, R As Long)

    Dim subRadius As Long, RadiusError As Long

    Dim X As Long, Y As Long



    subRadius = Abs(R)

    RadiusError = -subRadius

    X = subRadius

    Y = 0



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



    ' Draw the middle span here so we don't draw it twice in the main loop,

    ' which would be a problem with blending turned on.

    Line (CX - X, CY)-(CX + X, CY), , 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), , BF

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

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

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

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

    Wend

End Sub

Code: (Select All)

DefInt A-Z

_Title "ASCII Fireworks  !!! Move Mousewheel !!! to Expand or Contract #2" '2020-01-01

' 2020-01-02 update with graivity effect by tsh73 from JB forum

' 2020-08-11 modified for xpanding and contracting screen size

' 2020-08-11 Steve catches memory leak, fixed!

' 2020-08-12 manstersoft gives me idea for Font 8, added more works and switched color to more! RGB32



Const nR = 9, t = "     Happy New Year QB64 Forum, ASCII Fireworks Brought To You By Bplus Inspired by Pete, TempodiBasic and Code Hunter Recent Efforts, Gravity Effect by tsh73 at JB Forum, Thanks Steve for saving memory and manstersoft for Font 8 idea, Go In Peace 2020!....."

Type rocket

    x As Single

    y As Single

    bang As Integer

    age As Integer

    c As _Unsigned Long

End Type



Dim Shared r(1 To nR) As rocket

For i = 1 To nR

    new i

Next

Dim Shared fire&

fire& = _NewImage(640, 400, 32)

Dim tmp&(0 To 10)

lastt = 20

sc& = _NewImage(640, 400, 32)

_Font 8

Do

    _Dest fire&

    _Font 16

    Cls

    Color &HFFFF88AA

    lc = lc + 1

    If lc Mod 3 = 0 Then p = (p + 1) Mod Len(t)

    Locate 2, 20: Print Mid$(t, p + 1, 40);

    _Font 8

    rocs = rocs + 1

    If rocs > nR Then rocs = nR

    For i = 1 To rocs

        drawRocket i

    Next





    _Dest 0

    While _MouseInput

        scroll = scroll + _MouseWheel

    Wend

    If scroll < 800 And scroll > -400 Then

        tp = (tp + 1) Mod 10

        tmp&(tp) = _NewImage(640 + scroll, 400 + scroll, 32)

        Screen tmp&(tp)

        _PutImage , fire&, 0

    Else

        lastt = 20

    End If



    'debug

    'COLOR qb(15)

    'LOCATE 1, 1: PRINT lastt, tp, scroll



    If lastt <> 20 Then _FreeImage tmp&(lastt)

    lastt = tp



    _Display

    _Limit 20

Loop Until _KeyDown(27)



Sub new (i)

    r(i).x = Rnd * 60 + 10

    r(i).y = 50

    r(i).bang = Rnd * 30

    r(i).age = 0

    r(i).c = _RGB32(200 * Rnd + 55, 200 * Rnd + 55, 200 * Rnd + 55)

End Sub



Sub drawRocket (i)

    If r(i).y > r(i).bang Then

        Color r(i).c

        Locate r(i).y, r(i).x: Print Chr$(24);

        r(i).y = r(i).y - 1

    Else

        r(i).age = r(i).age + 1

        If r(i).age > 50 Then

            new i

        Else

            Color r(i).c

            If r(i).age > 4 Then start = r(i).age - 4 Else start = 1

            For a = start To r(i).age

                For j = 1 To 12

                    xx = r(i).x + 1 * a * Cos(j * _Pi / 6)

                    yy = r(i).y + .5 * a * Sin(j * _Pi / 6)

                    yy = yy + (r(i).y - a) ^ 2 / 15 '<<<< tsh73 gravity

                    If xx > 0 And xx < 81 And yy > 0 And yy < 51 Then

                        Locate Int(yy), Int(xx)

                        Print "*";

                    End If

                Next

            Next

        End If

    End If

End Sub

Option _Explicit _Title "Fireworks for 2025" ' b+ 2024-12-30 Randomize Timer Const xmax = 1280, ymax = 720 Const nR = 10 Type rocket x As Single y As Single bang As Single seed As Integer age As Integer fini As Integer r As Integer c As _Unsigned Long End Type Dim Shared r(1 To nR) As rocket, distant As Long, i As Long, lc As Long distant = _SndOpen("distant.wav", "vol,sync") For i = 1 To nR new i Next Screen _NewImage(xmax, ymax, 32) _FullScreen Dim rocs As Integer, sky As Long sky = DrawSky&(8) Color , 0 Do _PutImage , sky, 0 lc = lc + 1 If lc Mod 30 = 1 And rocs < nR Then rocs = rocs + 1: lc = 1 For i = 1 To rocs drawRocket i Next _Display _Limit 30 Loop Until _KeyDown(27) System Sub new (i) Dim As Integer b, g Randomize Timer r(i).x = Rnd * (xmax - 30) + 10 r(i).y = ymax - 60 r(i).bang = .5 * ymax * Rnd + 30 r(i).seed = Int(32000 * Rnd) + 1 r(i).age = 0 r(i).fini = Rnd * 75 + 25 r(i).r = Int(Rnd * 4) + 1 b = Int(Rnd * 2): g = Int(Rnd * 2) r(i).c = _RGB32(Rnd * 220 + 35, (g = 1) * -(Rnd * 220 + 35), (b = 1) * -(Rnd * 220 + 35), 50) End Sub Sub drawRocket (i) Dim As Integer k, e, start, tt Dim ne, a, cx, cy, dx, dy, R If r(i).y >= r(i).bang Then Color r(i).c For k = 1 To 12 Locate r(i).y \ 16, r(i).x \ 8: Print Chr$(24); Next r(i).y = r(i).y - 16 Else If r(i).age = 0 Then ' flash and bang! Line (0, 0)-(xmax, ymax), &H44FFFFFF, BF: _Display _SndVol distant, .9 _SndPlay distant End If r(i).age = r(i).age + 1 If r(i).age > r(i).fini Then new i Else Randomize Using r(i).seed ne = Rnd * 500 + 100 Dim embers(ne - 1, 1) For e = 0 To ne - 1 R = Rnd * 12 a = Rnd * _Pi(2) embers(e, 0) = R * Cos(a) embers(e, 1) = R * Sin(a) Next If r(i).age > 10 Then start = r(i).age - 10 Else start = 1 ' don't let tails get longer than lTail const For e = 0 To ne - 1 cx = r(i).x: cy = r(i).y: dx = embers(e, 0): dy = embers(e, 1) For tt = 1 To r(i).age cx = cx + dx cy = cy + dy If tt > start Then If tt <> r(i).age Then FC3 cx, cy, r(i).r, r(i).c Else FC3 cx, cy, r(i).r, &H99FFFFFF End If End If dx = dx * .97 'air resitance dy = .97 * dy + .1 'gravity Next Next End If End If End Sub Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double Dim As Long r2, x, y ' for Option _Explicit If r < 1 Then Exit Sub Line (cx - r, cy)-(cx + r, cy), clr~&, BF r2 = r * r Do y = y + 1 x = Sqr(r2 - y * y) Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF Loop Until y = r End Sub Function DrawSky& (light As Long) ' light = 0 to 100 as percent ' needs MidInk~&() Function Dim As _Unsigned Long saveColor, c Dim As Long i, rtn, saveDest Dim r, rn, xx, yy, lite lite = 2 * light saveDest = _Dest saveColor = _DefaultColor(saveDest) rtn = _NewImage(_Width, _Height, 32) _Dest rtn& For i = 0 To _Height - 1 c = midInk(.75 * lite + 10, .75 * lite + 5, 35 + .75 * lite, 25 + lite, lite, 55 + lite, i / (_Height - 1)) Line (0, i)-(_Width, i), c Next 'stars only in low lite If lite <= 100 Then For i = 1 To _Width * _Height / 1500 rn = Rnd: xx = Rnd * _Width: yy = Rnd * _Height If rn < .01 Then For r = 0 To 2 Step .5 Circle (xx, yy), r, _RGB32(185, 185, 185) Next ElseIf rn < .2 Then Circle (xx, yy), 1, _RGB32(185, 185, 185) PSet (xx, yy), _RGB32(185, 185, 185) Else PSet (xx, yy), _RGB32(185, 185, 185) End If Next End If _Dest saveDest Color saveColor DrawSky& = rtn End Function Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##) midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##) End Function