04-23-2022, 11:01 PM
Code: (Select All)
'Pentacle Flux Capacitor 2.bas for QB64 fork 2017-08-23
'translated from: Pentacle Flux Capacitor 2.txt for JB (B+=MGA) 2017-08-23
' updated 2019-09-05 with cleaner more random blackouts, er..., ah, drama!
Randomize Timer
Const xmax = 800
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Title "Pentacle Flux Capacitor #2: Dancing Man"
Common Shared xc, yc, dist, tp(), tp2()
xc = xmax / 2
yc = ymax / 2 + 20
Dim tp(4, 1), tp2(4, 1)
blackout& = _NewImage(xmax, ymax, 32)
_Dest blackout&
Line (0, 0)-(xmax, ymax), &H99000000, BF
PFC& = _NewImage(xmax, ymax, 32)
_Dest PFC&
drawPFC
_Dest 0
While 1
_PutImage , PFC&, 0
_Display
_PutImage , blackout&, 0
_Display
_Delay Rnd * 80 / 1000
Lightning xc, yc - 90, xc, yc + 10, 135
For i = 0 To 4
xe = tp2(i, 0)
ye = tp2(i, 1)
d = rand(.1 * dist, .7 * dist)
Select Case i
Case 0
Lightning xc, yc - 90, xe, ye, d
Lightning xc, yc - 90, xe, ye, d
Case 1, 4
Lightning xc, yc - 70, xe, ye, d
Case 2, 3
Lightning xc, yc + 10, xe, ye, d
End Select
Next
_Display
_Delay Rnd * 40 / 1000 + 20 / 1000
Wend
Sub drawPFC
'3 main points for array tp()
pRadius = 40: cRadius = 1.5 * pRadius
a3 = _Pi(2 / 5): r = ymax / 2 - cRadius
ao = _Pi(-1 / 2): a = ao
For rr = r To 0 Step -10
midInk 255, 255, 255, 0, 0, 128, rr / r
CircleFill xc, yc, rr
Next
For i = 0 To 4
tp(i, 0) = xc + r * Cos(a)
tp(i, 1) = yc + r * Sin(a)
For rr = cRadius To pRadius Step -1
Color _RGB((rr - pRadius) / (cRadius - pRadius) * 255 * (cRadius - rr + pRadius) / cRadius, 0, 0)
xx = tp(i, 0): yy = tp(i, 1)
CircleFill xx, yy, rr
Next
a = a + a3
Next
xx = tp(0, 0): yy = tp(0, 1)
dist = distance##(xx, yy, xc, yc)
For pnt = 0 To 4
For dis = 0 To .5 * dist Step 10
dGray = 255 * dis / dist
xx = tp(pnt, 0): yy = tp(pnt, 1)
midpoint xx, yy, xc, yc, dis / dist, midx, midy
For r = pRadius * (dist - dis) / dist To 0 Step -1
midInk dGray, dGray, dGray, 255, 255, 255, (pRadius - r) / pRadius
CircleFill midx, midy, r
Next
Next
tp2(pnt, 0) = midx
tp2(pnt, 1) = midy
Next
End Sub
Sub Lightning (x1, y1, x2, y2, d)
If d < 5 Then
Color _RGB(225, 225, 245)
Line (x1, y1)-(x2, y2)
Else
mx = (x2 + x1) / 2
my = (y2 + y1) / 2
mx = mx + -.5 * Rnd * d * .4 * rand&&(-2, 2)
my = my + -.5 * Rnd * d * .4 * rand&&(-2, 2)
Lightning x1, y1, mx, my, d / 2
Lightning x2, y2, mx, my, d / 2
End If
End Sub
'Steve McNeil's
Sub CircleFill (CX As Long, CY As Long, R As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 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 midpoint (x1, y1, x2, y2, fraction, midx, midy)
midx = (x2 - x1) * fraction + x1
midy = (y2 - y1) * fraction + y1
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 distance## (x1##, y1##, x2##, y2##)
distance## = ((x1## - x2##) ^ 2 + (y1## - y2##) ^ 2) ^ .5
End Function
Function rand&& (lo&&, hi&&)
rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&
End Function