Vince's Corner Takeout

[bplus]

I think vince asked me to post this, it was a mod of his scattering that allowed laser to be set anywhere (by click of mouse) and reflect off a random arrangement of circles. As you move mouse around, the laser points at slightly different angles causing radical changes in reflection outcomes:

Code: (Select All)

_Title "*** Chaotic Scattering *** by vince and mod by bplus 2018-02-15                     click mouse to reset LASER"
DefInt A-Z
Randomize Timer
Const sw = 1200
Const sh = 700

Dim Shared qb(15) As _Integer64
qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

Const nCircs = 25
Const r = 150
Const maxr = 100
Type circles
    x As Integer
    y As Integer
    r As Integer
    c As _Integer64
End Type
Dim Shared cs(nCircs) As circles
Dim i As Integer
Dim c As Integer
Dim ck As Integer
For i = 1 To nCircs
    cs(i).r = Rnd * (maxr - 20) + 20
    cs(i).c = qb(Int(Rnd * 15) + 1)
    If i > 1 Then
        ck = 0
        While ck = 0
            cs(i).x = Int(Rnd * (sw - 2 * cs(i).r)) + cs(i).r
            cs(i).y = Int(Rnd * (sh - 2 * cs(i).r)) + cs(i).r
            ck = 1
            For c = 1 To i - 1
                If ((cs(i).x - cs(c).x) ^ 2 + (cs(i).y - cs(c).y) ^ 2) ^ .5 < cs(i).r + cs(c).r Then ck = 0: Exit For
            Next
        Wend
    Else
        cs(i).x = Int(Rnd * (sw - 2 * cs(i).r)) + cs(i).r
        cs(i).y = Int(Rnd * (sh - 2 * cs(i).r)) + cs(i).r
    End If
Next

Dim t As Double
Dim a As Double, b As Double
Dim a1 As Double, a2 As Double

Dim x As Double, y As Double
Dim x0 As Double, y0 As Double
Dim x1 As Double, y1 As Double


Screen _NewImage(sw, sh, 32)
_ScreenMove 100, 20

'find a place not inside a circle
xx = sw / 2
yy = sh / 2
While checkxy%(xx, yy) = 0
    xx = Int(Rnd * (sw - 2 * maxr)) + maxr
    yy = Int(Rnd * (sh - 2 * maxr)) + maxr
Wend

Do
    If Len(InKey$) Then
        _Delay 5 'to get dang screen shot
    Else
        'get mouse x, y if click
        Do
            mx = _MouseX
            my = _MouseY
            mb = _MouseButton(1)
        Loop While _MouseInput
    End If

    'cls with Fellippes suggestion
    Line (0, 0)-(sw, sh), _RGBA32(0, 0, 0, 30), BF

    'draw circles
    For c = 1 To nCircs
        Color cs(c).c
        fcirc cs(c).x, cs(c).y, cs(c).r
    Next

    'if click make sure click was not inside one of the circles
    If mb Then
        Do While mb
            Do
                mb = _MouseButton(1)
            Loop While _MouseInput
        Loop
        f = checkxy%(mx, my)
        If f Then
            xx = mx
            yy = my
            f = -1
        End If
    End If

    x0 = xx
    y0 = yy
    a = _Atan2(my - yy, mx - xx)
    t = 0
    Do
        t = t + 1
        x = t * Cos(a) + x0
        y = t * Sin(a) + y0
        If x < 0 Or x > sw Or y < 0 Or y > sh Then Exit Do
        For c = 1 To nCircs
            If (x - cs(c).x) ^ 2 + (y - cs(c).y) ^ 2 < cs(c).r * cs(c).r Then
                a1 = _Atan2(y - cs(c).y, x - cs(c).x)
                a2 = 2 * a1 - a - _Pi
                Line (x0, y0)-(x, y), qb(14)
                x0 = x
                y0 = y
                a = a2
                t = 0
                Exit For
            End If
        Next
    Loop
    Line (x0, y0)-(x, y), qb(14)
    _Display
    _Limit 50
Loop Until _KeyHit = 27
System

Function checkxy% (x, y)
    Dim c As Integer
    For c = 1 To nCircs
        If (x - cs(c).x) ^ 2 + (y - cs(c).y) ^ 2 < cs(c).r * cs(c).r Then checkxy% = 0: Exit Function
    Next
    checkxy% = 1
End Function

'Steve McNeil's  copied from his forum   note: Radius is too common a name
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

It's a nice effect and might be used by Indiana Jones to unlock a treasure with a beam of light ;-))

Or maybe laser printers work like this?