Post by bplus on Sept 8, 2023 22:49:37 GMT
'Option _Explicit 'edit for QBJS 2023-09-08
_Title "le bombe"
'QB64 X 64 version 1.2 20180228/86 from git b301f92
'2018-07-28 translated from
'bomb.bas for SmallBASIC 0.12.2 [B+=MGA] 2016-05-09
'from explosion study
Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 360, 60
Const max_particles = 1000
Const gravity = .25
Const air_resistance = .95
Type particle
x As Single
y As Single
dx As Single
dy As Single
size As Single
kolor As Long
tf As Integer
End Type
Dim Shared dots(max_particles) As particle
Dim As Long i, rounds, loop_count
'main
While Not _KeyDown(27)
For i = 1 To 100
NewDot i
Next
rounds = 100
For i = 12 To 0 Step -1
If _KeyDown(27) Then End
Cls
DrawSky
DrawGround
DrawBomb
DrawFuse i
_Display
If i = 0 Then _Delay Rnd * 3 Else _Delay .100
Next
Line (0, 0)-(xmax, ymax), _RGB32(255, 255, 255), BF
_Display
_Delay .02
For loop_count = 0 To 150
If _KeyDown(27) Then End
DrawSky
DrawGround
If loop_count < 4 Then
Color _RGB(64 - 8 * loop_count, 40 - 4 * loop_count, 32 - 4 * loop_count)
If loop_count < 8 Then fcirc xmax / 2, ymax / 2, 30 * (1 - loop_count * .25)
End If
For i = 1 To rounds
dots(i).x = dots(i).x + dots(i).dx
dots(i).y = dots(i).y + dots(i).dy
If Rnd < .2 And rounds > 10 And dots(i).y > ymax / 2 Then dots(i).dx = 0: dots(i).dy = 0
dots(i).dx = dots(i).dx * air_resistance
If dots(i).dy <> 0 Then dots(i).dy = air_resistance * dots(i).dy + .4 'air resistance and gravity
If dots(i).tf Then
Line (dots(i).x, dots(i).y)-Step(dots(i).size, dots(i).size), dots(i).kolor, BF
Else
Color dots(i).kolor
fcirc dots(i).x, dots(i).y, dots(i).size / 2
End If
Next
If rounds < max_particles Then
For i = 1 To 100
NewDot (rounds + i)
Next
rounds = rounds + 100
End If
Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
Locate 1, 1: Print loop_count
_Display
_Limit 60
Next
Wend
Sub NewDot (i)
Dim angle, r
angle = _Pi(Rnd * 2)
dots(i).x = xmax / 2 + Rnd * 30 * Cos(angle)
dots(i).y = ymax / 2 + Rnd * 30 * Sin(angle)
r = Rnd 'STxAxTIC recommended for rounder spreads
dots(i).dx = r * 45 * Cos(angle)
dots(i).dy = r * 45 * Sin(angle)
dots(i).size = Rnd * 7
dots(i).kolor = _RGB32(10 + Rnd * 100, 5 + Rnd * 50, 3 + Rnd * 25)
dots(i).tf = (Rnd * 2) \ 1
End Sub
Sub DrawSky
Dim i
For i = 0 To ymax / 2
Line (0, i)-Step(xmax, 0), _RGB32(0, 0, 95 * i \ (ymax / 2) + 160)
Next
End Sub
Sub DrawBomb
Dim cx, cy, radius, angle, rad_angle, x1, y1
Dim As Long i
cx = xmax / 2: cy = ymax / 2 - 70: radius = 10
For i = 60 To 0 Step -1 'main body
Color _RGB32(240 - 4 * i, 180 - 3 * i, 120 - 2 * i)
fcirc cx, ymax / 2, i
Next
For angle = 0 To 180 'fuse shaft
rad_angle = _D2R(angle)
x1 = cx + radius * Cos(rad_angle)
y1 = cy + radius * .25 * Sin(rad_angle)
Line (x1, y1)-Step(0, 20), _RGB32(127 + 127 * Cos(rad_angle), 127 + 127 * Cos(rad_angle), 127 + 127 * Cos(rad_angle))
Next
Color _RGB32(0, 0, 0)
fEllipse cx, cy, radius, .25 * radius
End Sub
Sub DrawFuse (length)
Dim cx, cy, rn, rad_angle, x1, y1, x2, y2
Dim As Long i
cx = xmax / 2: cy = ymax / 2 - 70
If length <= 0 Then Exit Sub
Color _RGB32(255, 255, 0)
Line (cx, cy - (5 + 2 * length))-Step(2, 5), , BF
fcirc cx, cy - (1 + 2 * length), 2
rn = (Rnd * 5) \ 1 + 3
For i = 1 To rn
rad_angle = _Pi(Rnd) + _Pi
x1 = cx + 7 * Cos(rad_angle): x2 = cx + 14 * Cos(rad_angle)
y1 = cy - (1 + 2 * length) + 9 * Sin(rad_angle): y2 = cy - (1 + 2 * length) + (Rnd * 13 + 9) * Sin(rad_angle)
Line (x1, y1)-(x2, y2), _RGB32(255, 255, 255)
Next
For i = 1 To length
rad_angle = _Pi(Rnd * 2)
x1 = 3 * Cos(rad_angle)
y1 = 3 * .25 * Sin(rad_angle)
Line (cx, cy - 2 * i)-Step(x1, y1), _RGB32(Rnd * 65 + 190, Rnd * 65 + 190, Rnd * 20 + 235), BF
Next
End Sub
Sub DrawGround
Dim As Long i
For i = ymax / 2 To ymax
Line (0, i)-Step(xmax, 0), _RGB32(0, 160 - 96 * (i - ymax / 2) \ (ymax / 2), 0)
Next
End Sub
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
Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long)
Dim scale As Single, x As Long, y As Long
scale = yRadius / xRadius
Line (CX, CY - yRadius)-(CX, CY + yRadius), , BF
For x = 1 To xRadius
y = scale * Sqr(xRadius * xRadius - x * x)
Line (CX + x, CY - y)-(CX + x, CY + y), , BF
Line (CX - x, CY - y)-(CX - x, CY + y), , BF
Next
End Sub
le bombe