'=================

'zapa_boom_2?

' a varaintion of

'EXPLODEPLANET.BAS

'=================

'Explodes a small planet on the screen, fading out screen.

'It does this loading all image pixel data into arrays,

'and changing the x/y position of pixels on the screen.

'----Alpha transparency is used for screen fading effect. <<< changed to fade of particles

'Tested & Working under QBJS & Windows/Linux QB64-PE 3.8.

'Coded by Dav, SEP/2023

'rearranged some of the drawing order, added a few additional features and have the particles fade out instead of whole screen fading

'v2  the exploding particles are now a pair of mistly overlapping circles to hopepfully  get the tumbling and buring out cinders look

'    planets are different sizes... haven't got the burn effect working as well with the new size and range of colors however.

'$dynamic

Randomize Timer



Screen _NewImage(800, 600, 32)

_FullScreen _SquarePixels



Dim star&

star& = _NewImage(800, 600, 32)



Dim planet&, x, y, x2, y2, r, g, b, a, c, n '<-- for qbjs to use

Dim pixels&, pix&, alpha

Dim zapa(30), zapx(30), zapy(30), zapds(30), zapde(30), zapl(30)

Dim zapk(30) As _Unsigned Long

Dim PixX(0), PixY(0)

Dim PixXDir(0), PixYDir(0)

Dim PixClr~&(0), PixGro(0)

Do

    wsize = Int(20 + Rnd * 80 + Rnd * 80)

    'show some stars

    For x = 1 To 1000

        c = Rnd * 4

        If Rnd * 10 < 5 Then fcirc Rnd * _Width, Rnd * _Height, c / 2, _RGBA(200, 200, 200, 25 + Rnd * 200) Else Line (Rnd * _Width, Rnd * _Height)-Step(c, c), _RGBA(200, 200, 200, 25 + Rnd * 200), BF

    Next

    _PutImage (0, 0), 0, star&

    'make a planet image

    planet& = _NewImage(wsize * 2, wsize * 2, 32): _Dest planet&

    x = wsize: y = wsize: r = Int(100 + Rnd * 100): g = Int(50 + Rnd * 100): b = Int(50 + Rnd * 100): a = 255

    perb1 = Int(1 + Rnd * 30): perb2 = Int(1 + Rnd * 12): perb3 = Int(30 + Rnd * wsize)

    fcirc x, y, wsize * .97, _RGBA32(r * .9, g * .9, b * .9, a)

    fcirc x, y, wsize * .95, _RGBA32(r, g, b, a)

    fcirc x + 2, y - 2, wsize * .90, _RGBA32(r + 3, g + 3, b + 3, a)

    fcirc x + 4, y - 4, wsize * .80, _RGBA32(r + 8, g + 8, b + 8, a)

    For y2 = y - wsize To y + wsize

        For x2 = x - wsize To x + wsize

            If Sqr((x2 - x) ^ 2 + (y2 - y) ^ 2) <= wsize Then

                c = (wsize - (Sqr((x2 - x) * (x2 - x) + (y2 - y) * (y2 - y)))) / perb3

                n = 20 * Sin((x2 + y2) / perb1) + 10 * Sin((x2 + y2) / perb2)

                PSet (x2, y2), _RGBA(Int(Rnd * (c * r - n)), c * g - n * .8, c * b - n, (c * a - n))

            End If

        Next

    Next



    Line (-1, -1)-(0, 0), _RGB(0, 0, 0) 'a qbjs fix



    _Dest 0



    'compute center spot for placing image on screen

    x = _Width / 2 - (_Width(planet&) / 2) 'x center image on screen

    y = _Height / 2 - (_Height(planet&) / 2) 'y center image on screen





    '====================================================================

    _PutImage (x, y), planet& '<<-- why won't this show in qbjs?

    '====================================================================



    Print "Press any key to Explode the planet..."

    _Display

    Sleep 3



    pixels& = _Width(planet&) * _Height(planet&)

    ReDim PixX(pixels&), PixY(pixels&)

    ReDim PixXDir(pixels&), PixYDir(pixels&)

    ReDim PixClr~&(pixels&), PixGro(pixels&)

    'Read all pixels from image into arrays,

    'and generate x/y movement values

    _Source planet&

    _Dest planet&

    pix& = 0

    For x2 = 0 To _Width(planet&) - 1

        For y2 = 0 To _Height(planet&) - 1

            PSet (x2, y2), burn~&(Point(x2, y2)) 'let's set that planet on fire

            PixClr~&(pix&) = Point(x2, y2) 'pixel color

            PixX(pix&) = x + x2 'pixel x pos

            PixY(pix&) = y + y2 'pixel y pos

            'generate random x/y dir movement values

            Do

                'assign a random x/y dir value (from range -8 to 8)

                PixXDir(pix&) = Rnd * 8 - Rnd * 8 'go random +/- x pixels

                PixYDir(pix&) = Rnd * 8 - Rnd * 8 'go random +/- y pixels

                'Keep looping until both directions have non-zero values

                If PixXDir(pix&) <> 0 And PixYDir(pix&) <> 0 Then Exit Do

            Loop

            'make some pixels get larger as they explode (3d effect)

            If Int(Rnd * 200) = 2 Then

                PixGro(pix&) = 2

            Else

                PixGro(pix&) = 1

            End If

            pix& = pix& + 1 'goto next pixels

        Next

    Next

    _Source 0

    _Dest 0

    rays = 10 + Int(1 + Rnd * 20)

    For a = 1 To rays 'build boom zaps

        zapa(a) = Int(Rnd * 360)

        zapx(a) = x + (_Width(planet&)) / 2

        zapy(a) = y + (_Height(planet&)) / 2

        zapds(a) = Int(1 + Rnd * 2)

        zapde(a) = Int(zapds(a) + Rnd * (2 * (zapds(a))))

        zapl(a) = Int(3 + Rnd * 6) * 50

        zr = 240 + Int(Rnd * 10)

        zapk(a) = _RGBA32(zr + Int(Rnd * 6), zr, 255 - zr, Int(12 + Rnd * 40))

    Next a



    'Explode palnet and fade out particles

    z = 1

    boomit = Int(5 + Rnd * 15)

    For alpha = 0 To 225 Step .8

        _Limit 30

        Cls

        _PutImage (0, 0), star&, 0 'lets keep the stars in place

        If alpha < boomit Then 'oh no she's a gona blow!!!  Lets show planet heating and "swelling"

            _PutImage (x - alpha * 3, y - alpha * 3)-(x + _Width(planet&) + alpha * 3, y + _Height(planet&) + alpha * 3), planet&, 0, (0, 0)-(_Width(planet&) - 1, _Height(planet&) - 1)

        End If

        'bright flash makes this explosion more visually substanitial and improves the transsiton from planet to no planet

        If alpha > boomit - 3 And alpha < boomit + 3 Then Line (0, 0)-(_Width - 1, _Height - 1), _RGBA32(255, 255, 255, 255 - alpha * 5), BF

        If z < 31 Then 'update boom zaps

            For n = 1 To rays

                zz = Int(z + Rnd(31 - z))

                zzz = 30 - Int(Rnd * 3)

                zap_line zapx(n), zapy(n), zapl(n), zapa(n), zapds(n), zapde(n), zz, zzz, aklr~&(zapk(n), alpha)

            Next n

            z = z + .7

            If rays > 2 And z > 5 Then rays = rays - 1

        End If

        'display all pixels

        For pix& = 0 To pixels& - 1 Step 8

            'pixel x pos, +/- dir value

            PixX(pix&) = PixX(pix&) + PixXDir(pix&)

            'pixel y pos, +/- dir value

            PixY(pix&) = PixY(pix&) + PixYDir(pix&)

            If PixX(pix&) > 0 And PixX(pix&) < _Width Then

                If PixY(pix&) > 0 And PixY(pix&) < _Height Then

                    ' Line (PixX(pix&), PixY(pix&))-Step(PixGro(pix&), PixGro(pix&)), aklr~&(PixClr~&(pix&), 255 - alpha), BF

                    fcirc PixX(pix&), PixY(pix&), PixGro(pix&) * .7, aklr~&(PixClr~&(pix&), 255 - alpha)

                    If Rnd * 10 < 8 Then

                        fcirc PixX(pix&) + Int(-1 + Rnd * PixGro(pix&)), PixY(pix&) + Int(-1 + Rnd * PixGro(pix&)), PixGro(pix&) * .7, aklr~&(PixClr~&(pix&), 255 - alpha)

                    End If

                End If

            End If

            If PixGro(pix&) > 1 Then

                PixGro(pix&) = PixGro(pix&) + .05

                If PixGro(pix&) > 10 Then PixGro(pix&) = 10

            End If

        Next

        _Display

    Next

    Input "Seek another world to destory or quit "; ask$

    ask$ = UCase$(_Trim$(ask$))

    If ask$ = "Q" Then ask$ = "QUIT"

    Cls

    _FreeImage planet&

Loop Until ask$ = "QUIT"

End

Function aklr~& (klr As _Unsigned Long, alpha)

    'let's make the debris  flicker out and fade away

    al = alpha

    If al > 0 Then al = Int(al / 5 + Rnd * (al))

    aklr~& = _RGBA32(_Red32(klr), _Green32(klr), _Blue32(klr), al)

End Function







Function burn~& (klr As _Unsigned Long)

    rr = (_Red32(klr)) * (1.0 + (Rnd * .4))

    If rr > 255 Then rr = 255

    gg = (_Green32(klr)) * 1.1

    If gg > 255 Then gg = 255

    If bb > 0 Then bb = _Blue32(klr) * .7

    If bb < 1 Then bb = 0



    '  aa = _Alpha32(klr) - Int(1 + Rnd * 20)

    aa = _Alpha32(klr)

    If aa > 255 Then aa = 255

    burn~& = _RGBA32(rr, gg, bb, aa)

End Function

Sub zap_line (x, y, Lnth, ang, thks, thke, ss, es, klr As _Unsigned Long)

    Dim zseg(30, 2)

    Dim thk(30)

    thk(1) = thks

    tc = (thke - thks) / 30



    zseg(1, 1) = x: zseg(1, 2) = y

    st = ss: If st = 1 Then st = 2

    For s = 2 To 30

        zseg(s, 1) = zseg(s - 1, 1) + (Lnth / 30) * Cos(0.01745329 * ang)

        zseg(s, 2) = zseg(s - 1, 2) + (Lnth / 30) * Sin(0.01745329 * ang)

        thk(s) = thk(s - 1) + tc

    Next s

    For s = st To es

        If Int(Rnd * 10) < 8 Then fatline zseg(s - 1, 1), zseg(s - 1, 2), zseg(s, 1), zseg(s, 2), thk(s), klr

        If Int(Rnd * 10) < 7 Then fatline zseg(s - 1, 1), zseg(s - 1, 2), zseg(s, 1), zseg(s, 2), thk(s) + thk(2) / 5, klr

    Next s

End Sub

Sub angle_line (x, y, Lnth, ang, thk, klr As _Unsigned Long)

    'draw a line from x,y lnth units long (from center of line) at angle ang of radial thickness thk in color klr

    ox = x: oy = y

    nx = ox + Lnth * Cos(0.01745329 * ang)

    ny = oy + Lnth * Sin(0.01745329 * ang)

    fatline ox, oy, nx, ny, thk, klr

End Sub

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

    'draw a filled circle with the quickest filled circle routine in qb64, not my development

    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

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

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

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

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

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

    Wend

End Sub



Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)

    'draw a line with dots with a radial thickness of r    from x0,y0 to x1,y1 in color klr

    If r > 0.5 Then

        If Abs(y1 - y0) < Abs(x1 - x0) Then

            If x0 > x1 Then

                lineLow x1, y1, x0, y0, r, klr

            Else

                lineLow x0, y0, x1, y1, r, klr

            End If

        Else

            If y0 > y1 Then

                lineHigh x1, y1, x0, y0, r, klr

            Else

                lineHigh x0, y0, x1, y1, r, klr

            End If

        End If

    Else

        Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen

    End If

End Sub

Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0: dy = y1 - y0: yi = 1

    If dy < 0 Then

        yi = -1: dy = -dy

    End If

    d = (dy + dy) - dx: y = y0

    For x = x0 To x1

        fcirc x, y, r, klr

        If d > 0 Then

            y = y + yi: d = d + ((dy - dx) + (dy - dx))

        Else

            d = d + dy + dy

        End If

    Next x

End Sub

Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0: dy = y1 - y0: xi = 1

    If dx < 0 Then

        xi = -1: dx = -dx

    End If

    D = (dx + dx) - dy: x = x0

    For y = y0 To y1

        fcirc x, y, r, klr

        If D > 0 Then

            x = x + xi: D = D + ((dx - dy) + (dx - dy))

        Else

            D = D + dx + dx

        End If

    Next y

End Sub

(09-08-2023, 06:37 PM)dbox Wrote: This is really great!  Couldn't resist adding some sound: