Small exploding image and fade-out effect

[johnno56]

Cool...

[James D Jarvis]

You know how you can tell someone else's original program was good? When you can't quit fiddling with it because they laid down such a good foundation and inspired you.

Code: (Select All)

'=================
'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

[Dav]

Wow! Great version, James!  Some nice effects going on there.  I especially like the zaps and delayed flash and flickering debris.   

You inspired me too, so I tried to add a little of what you did.  Not as advanced as yours, but maybe a little better than my previous one.  Works in QBJS, so here it is.

- Dav

[dbox]

This is really great!  Couldn't resist adding some sound:

[grymmjack]

This is really great!  Couldn't resist adding some sound:

Haha awesome @dbox!

[James D Jarvis]

Boom!

[Dav]

Perfect, @dbox!  That's exactly the sound it needed.

I thought it would be neat to have a routine that did the opposite of explode.  Instead of exploding pixels away, have a way to assemble pixels into an image instead.  Easier than I thought, just reverse explode it using the same arrays.  Here's that.  It runs in QBJS too but a bit slower because it's doing every pixel, not skipping any.  On QB64 it's smooth, even can do a photo fairly smooth.

- Dav

[bplus]

Now what's the sound for that?

[dbox]

That is a very cool effect!