09-08-2023, 01:55 PM
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