Proggies

[bplus]

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