Tree + lights + options

[bplus]

Did someone say, "More lights?"

Code: (Select All)

_Title "More Lights" 'b+ 2021-11-28
' ref:   https://justbasiccom.proboards.com/thread/759/polinom-interpolation-3-points
' mod to xmax tree ?
' 2021-12-02 start More Lights mod


Const sw = 600, sh = 700, cx = sw / 2, cy = sh / 2, treeAreaDvPI = 22707
Screen _NewImage(sw, sh, 32)
_ScreenMove 320, 40
Randomize Timer
Dim As Integer topLight
lastTopLight = 2
topLight = 50
Dim Shared pX(1 To 3), pY(1 To 3)
ReDim lx(1 To topLight), ly(1 To topLight)

moreLights:
Cls
'tree
stepper = .75 * sh / 12
For y = .125 * sh To .875 * sh Step stepper
    r = (y - .125 * sh) * Sin(_Pi(1 / 12))
    pX(1) = cx - r: pX(2) = cx: pX(3) = cx + r
    pY(1) = y: pY(2) = y - 1.5 * stepper: pY(3) = y
    'Line (pX(1), pY(1))-(pX(3), pY(3)), &HFF00FF00
    For x = pX(1) To pX(3)
        If Rnd < .75 Then PSet (x, para(x)), &HFF005500
    Next
    pY(2) = y - .5 * stepper
    For x = pX(1) To pX(3)
        If Rnd < .15 Then PSet (x, para(x)), &HFF005500
    Next
Next

'lights

lx(1) = cx: ly(1) = .125 * sh - .5 * stepper - 5
Circle (lx(1), ly(1)), 4, &HFFFFFF88 ' topper
Circle (lx(1), ly(1)), 6, &HFFFFFFFF
For r = 3 To 30 Step 1
    fcirc lx(1), ly(1), r, &H03FFFFFF
Next
dTopSq = Sqr(treeAreaDvPI / (topLight - .5 * topLight)) ' best spread of lights
For i = lastTopLight To topLight ' save 1 for top of tree
    If i Mod 100 = 0 Then 'light the whole area around the tree
        If i > 1200 Then
            For rr = 0 To sh Step 1
                fcirc cx, cy, rr, _RGB32(255, 255 - rr / 2, 200 - rr, 20)
                _Limit 250 + 2 * rr
            Next
            GoTo finished
        Else
            For rr = cy To 0 Step -20
                fcirc cx, cy, rr, _RGB32(255, 255, 255, 1)
            Next
        End If
    End If

    again:
    x = Rnd * sw + 1: y = Rnd * sh + 1
    If y > .125 * sh And y <= .875 * sh Then
        If x > cx - (y - .125 * sh) * Sin(_Pi(1 / 12)) And x < cx + (y - .125 * sh) * Sin(_Pi(1 / 12)) Then

            ' dang have to space them out better
            If i > 2 Then
                ok = -1
                For j = 1 To i - 1
                    d = ((lx(j) - x) ^ 2 + (ly(j) - y) ^ 2) ^ .5
                    If d < dTopSq Then ok = 0: Exit For
                Next
                If ok Then
                    rc~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
                    For r = 0 To 2 Step .5
                        Circle (x, y), r, rc~&
                    Next
                    For r = 3 To 10 Step 1
                        fcirc x, y, r, &H03FFFFFF
                    Next

                    lx(i) = x: ly(i) = y ' save the place
                Else
                    GoTo again
                End If
            End If
        Else
            GoTo again
        End If
    Else
        GoTo again
    End If
Next
' Beep ' make sure we finish in reasonable amount of time  ie balance number of lights to distance d
startLights = Timer
pause = pause + 2
While Timer - startLights < (3 + pause) And _KeyDown(27) = 0
    Locate 1, 1: Print topLight ', dTopSq
    rl = Int(Rnd * (topLight - 1)) + 1
    rc~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
    For r = 0 To 2 Step .5
        If lx(rl) <> 0 And ly(rl) <> 0 Then Circle (lx(rl), ly(rl)), r, rc~&
    Next
    _Limit 15
Wend
Cls
s$ = "More lights!"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$
_Delay 2
topLight = topLight + .5 * topLight
ReDim lx(1 To topLight), ly(1 To topLight)
GoTo moreLights

finished:
Cls
_Delay 2
s$ = "Oops"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$
_Delay 2.15
s$ = "Have a Merry (and safe) Christmas!"
_PrintString ((_Width - Len(s$) * 8) / 2, _Height / 2 - 8), s$

Function para (x) 'thanks tsh73 at Just Basic Forum
    'uses shared arrays  pX(), pY()
    y = 0
    For i = 1 To 3
        p = 1
        For j = 1 To 3
            If i <> j Then
                p = p * (x - pX(j)) / (pX(i) - pX(j))
            End If
        Next
        y = y + pY(i) * p
    Next
    para = y
End Function

'from Steve Gold standard
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned 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), 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