09-21-2022, 03:46 PM
Meandering Circuits Struck by Lightning
Code: (Select All)
_Title "Adding some lightning, press any on beep" ' b+ 2020-09-17 so much better in living color!!
' ah much better response on on escape or Q to quit! too.
Screen _NewImage(1024, 620, 32)
_Delay .25
_ScreenMove _Middle
'_FULLSCREEN
Randomize Timer
Const flashy = &HFFFFFF00
Type box
x As Single
y As Single
w As Single
h As Single
K As _Unsigned Long
hit As Integer
End Type
Type move
x As Single
y As Single
'd AS INTEGER
End Type
Dim Shared beeLineK As _Unsigned Long, gSize As Integer
ReDim Shared VS(_Width, _Height)
Dim backColor As _Unsigned Long, hc As Integer
Do
'whole new set
ReDim VS(_Width, _Height)
gSize = units(Int(20 * Rnd) + 6, 5)
nBoxes = Int(Sqr(_Width * _Height) / gSize * Rnd) + 1
If nBoxes < 40 Then nBoxes = 40
If nBoxes > 100 Then nBoxes = 100
Color &HFFFFFFFF, &HFF000000
Print gSize, nBoxes
'_DISPLAY
ReDim b(1 To nBoxes) As box 'new box set
For i = 1 To nBoxes
tryAgain:
b(i).x = units(Rnd * (_Width - 2 * (gSize + 1)) + gSize + 1, gSize) 'get x, y off the edges of screen!
b(i).y = units(Rnd * (_Height - 2 * (gSize + 1)) + gSize + 1, gSize)
If i > 1 Then
OK = -1
For j = 1 To i - 1
If _Hypot(b(j).x - b(i).x, b(j).y - b(i).y) < 3 * gSize Then OK = 0: Exit For
Next
If OK = 0 Then GoTo tryAgain
End If
b(i).w = gSize + Rnd * gSize * .5
b(i).h = gSize + Rnd * gSize * .5
b(i).K = _RGB32(Rnd * 85 + 170, Rnd * 85 + 170, Rnd * 85 + 170)
Next
backColor = _RGB32(Rnd * 65, Rnd * 65, Rnd * 65)
hc = maxC(backColor)
If hc = 1 Then beeLineK = _RGB32(0, Rnd * 85 + 85, Rnd * 85 + 85)
If hc = 2 Then beeLineK = _RGB32(Rnd * 85 + 85, 0, Rnd * 85 + 85)
If hc = 3 Then beeLineK = _RGB32(Rnd * 85 + 85, Rnd * 85 + 85, 0)
Color , backColor
Cls
drawGrid gSize, gSize, _Width - 1, _Height - 1, gSize, &HFF404040
'SLEEP
For i = 2 To nBoxes ' draw the meanderings
meander2 b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
Line (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-Step(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
Next
For i = 1 To nBoxes
Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
Next
' and now for some lightning!!!
grd& = _NewImage(_Width, _Height, 32)
_PutImage , 0, grd&
Dim i As Long
i = 0
ReDim flash As box, moves(0) As move, mItem As move
r = Int(Rnd * nBoxes) + 1 'pick a place to strike, light it up
moves(i).x = b(r).x: moves(i).y = b(r).y: flash.w = b(r).w: flash.h = b(r).h: flash.K = flashy
Line (moves(i).x - .5 * flash.w, moves(i).y - .5 * flash.h)-Step(flash.w, flash.h), flashy, BF
GoSub checkoutThePlace
oldUB = 0
circuit:
ub = UBound(moves)
If ub > oldUB Then
_PutImage , grd&, 0
For i = 1 To nBoxes
If b(i).hit Then Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), &HFF551100, BF
Next
For i = oldUB To ub
fcirc moves(i).x, moves(i).y, .33 * gSize, flashy - Rnd * 150
For j = 1 To nBoxes
If moves(i).x = b(j).x And moves(i).y = b(j).y Then b(j).hit = 1
Next
GoSub checkoutThePlace
Next
oldUB = ub
_Display
_Limit 10
GoTo circuit
End If
_PutImage , grd&, 0
For i = 1 To nBoxes
If b(i).hit Then Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), &HFF551100, BF
Next
Beep
_FreeImage grd&
_AutoDisplay
Sleep
Loop Until _KeyDown(27) Or UCase$(InKey$) = "Q"
End
checkoutThePlace:
If moves(i).x + .5 * gSize >= 0 And moves(i).x + .5 * gSize < _Width Then
If VS(moves(i).x + .5 * gSize, moves(i).y) = 1 Then
mItem.x = moves(i).x + gSize: mItem.y = moves(i).y
sAppend moves(), mItem
VS(moves(i).x + .5 * gSize, moves(i).y) = 0
End If
End If
If moves(i).y + .5 * gSize >= 0 And moves(i).y + .5 * gSize < _Height Then
If VS(moves(i).x, moves(i).y + .5 * gSize) = 1 Then
mItem.x = moves(i).x: mItem.y = moves(i).y + gSize
sAppend moves(), mItem
VS(moves(i).x, moves(i).y + .5 * gSize) = 0
End If
End If
If moves(i).x - .5 * gSize >= 0 And moves(i).x - .5 * gSize < _Width Then
If VS(moves(i).x - .5 * gSize, moves(i).y) = 1 Then
mItem.x = moves(i).x - gSize: mItem.y = moves(i).y
sAppend moves(), mItem
VS(moves(i).x - .5 * gSize, moves(i).y) = 0
End If
End If
If moves(i).y - .5 * gSize >= 0 And moves(i).y - .5 * gSize < _Height Then
If VS(moves(i).x, moves(i).y - .5 * gSize) = 1 Then
mItem.x = moves(i).x: mItem.y = moves(i).y - gSize
sAppend moves(), mItem
VS(moves(i).x, moves(i).y - .5 * gSize) = 0
End If
End If
Return
Sub meander2 (x1, y1, x2, y2) ' snap to grid! gSize is shared
startx = x1: starty = y1: endx = x2: endy = y2
x = startx: y = starty
GoSub dist
If dist > 100 Then
time = Int(Rnd * 8 + 4) ' total amount allowed to move The More the time the more the meander!!!!
Else
time = 3
End If
startTime = time ' > 20 is too much!!
If Rnd < .5 Then lastmoveX = 0 Else lastmoveX = -1
lastx = startx: lasty = starty
Do
GoSub dist
If Rnd < .5 Then d = -1 Else d = 1
If lastmoveX = 0 Then
lastx = x
If time <= 2 Then
x = endx
Else
dx = units(d * (.4 * distx * Rnd + gSize), gSize)
If dx = 0 Then dx = gSize
If x + dx > 0 And x + dx < _Width Then
x = x + dx
Else
x = x + -dx
End If
End If
'LINE (lastx, y)-(x, y)
beeline lastx, y, x, y
lastmoveX = -1
Else
lasty = y
If time <= 2 Then
y = endy
Else
dy = units(d * (.3 * disty * Rnd + gSize), gSize)
If dy = 0 Then dy = gSize
If y + dy > 0 And y + dy < _Height Then
y = y + dy
Else
y = y + -dy
End If
End If
'LINE (x, lasty)-(x, y)
beeline x, lasty, x, y
lastmoveX = 0
End If
time = time - 1
'_LIMIT 10
Loop Until time <= 0
Exit Sub
dist:
distx = endx - x: disty = endy - y
Return
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub beeline (x1, y1, x2, y2)
If x1 = x2 Then
If y1 <= y2 Then For y = y1 To y2: fcirc x1, y, 1, beeLineK: VS(Int(x1), Int(y)) = 1: Next
If y1 > y2 Then For y = y1 To y2 Step -1: fcirc x1, y, 1, beeLineK: VS(Int(x1), Int(y)) = 1: Next
Else
If x1 <= x2 Then For x = x1 To x2: fcirc x, y1, 1, beeLineK: VS(Int(x), Int(y1)) = 1: Next
If x1 > x2 Then For x = x1 To x2 Step -1: fcirc x, y1, 1, beeLineK: VS(Int(x), Int(y1)) = 1: Next
End If
End Sub
Function maxC (K As _Unsigned Long)
If _Red32(K) >= _Green32(K) And _Red32(K) >= _Blue32(K) Then maxC = 1: Exit Function
If _Green32(K) >= _Blue(K) Then maxC = 2 Else maxC = 3
End Function
' this sub needs FUNCTION units (x, unit)
Sub drawGrid (x1, y1, x2, y2, gsize, gridClr As _Unsigned Long) ' grid of square gsize X gsize
' fit a grid between x1, x2 and y1, y2
' x1, y1 top right corner and x2, y2 expected bottom right corner of boundary line
Dim x As Integer, y As Integer, gx1 As Integer, gy1 As Integer, gx2 As Integer, gy2 As Integer
gx1 = units(x1, gsize): gy1 = units(y1, gsize) 'convert to grid coordinates
gx2 = units(x2, gsize): gy2 = units(y2, gsize)
If gx1 < x1 Then gx1 = gx1 + gsize 'stay inside boundarys passed to sub
If gy1 < y1 Then gy1 = gy1 + gsize
If gx1 >= gx2 Or gy1 >= gy2 Then Exit Sub 'that's not even a single square!
For x = gx1 To gx2 Step gsize: Line (x, gy1)-(x, gy2), gridClr: Next
For y = gy1 To gy2 Step gsize: Line (gx1, y)-(gx2, y), gridClr: Next
End Sub
Function units (x, unit)
units = Int(x / unit) * unit
End Function
Sub sAppend (arr() As move, addItem As move)
ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As move
arr(UBound(arr)) = addItem
End Sub
b = b + ...