2025 and ANOTHER Tree! :)

[PhilOfPerth]

Code: (Select All)

_Title "little xmas tree 4" ' b+ 2025-12-24 mod fixes center screen and star
' #2 add color changing, stars and ground
' #3 add "plasma" animations for different lighting:  PRESS SPACEBAR...
' #4 attracting aliens
Screen _NewImage(280, 180, 32)
Dim Shared cN, pR, pG, pB, pA
ResetPal
For star = 1 To 25
    Circle (Rnd * 280, Rnd * 180), Int(Rnd * 2)
Next
Line (0, 150)-(280, 180), _RGB32(50), BF
Color _RGB32(255, 255, 0) 'tree star
Line (136, 22)-(140, 12)
Line -(144, 22): Line -(134, 16)
Line -(146, 16): Line -(136, 22)
back& = _NewImage(280, 180, 32)
_PutImage , 0, back&
While _KeyDown(27) = 0
    Cls
    _PutImage , back&, 0
    If _KeyDown(32) Then ResetPal
    While _MouseInput: Wend
    drawShip _MouseX, _MouseY, Pal~&
    PSet (140 + Cos(0), 20)
    For I = 0 To 70 Step 0.01
        Line -(I * Cos(I) + 140, 20 - I * (Sin(I) * 0.2 - 2)), Pal~&
    Next
    _Limit 10
Wend
Function Pal~& ()
    cN = cN + 2 ''Dim Shared cN, pR, pG, pB, pA
    Pal~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN),_
     127 + 127 * Sin(pA * cN))
End Function
Sub ResetPal ()
    ''Dim Shared CN, PR, PG, PB, PA
    pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: pA = Rnd ^ 2: cN = 0
End Sub

'               Merry Christmas QB64 Fans!

Sub drawShip (x, y, colr As _Unsigned Long) 'shipType     collisions same as circle x, y radius = 30
    Static ls
    Dim light As Long, r As Long, g As Long, b As Long
    r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
    fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    fellipse x, y, 30, 7, _RGB32(r, g, b)
    For light = 0 To 5
        fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    Next
    ls = ls + 1
    If ls > 5 Then ls = 0
End Sub
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
    If xr = 0 Or yr = 0 Then Exit Sub
    Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
    Dim x As Long, y As Long
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    Line (CX - xr, CY)-(CX + xr, CY), C, BF
    Do While y < yr
        y = y + 1
        x = Sqr((h2w2 - y * y * w2) \ h2)
        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
    Loop
End Sub
Sub fcirc (x As Long, y As Long, R As Long, C As _Unsigned Long) 'vince version  fill circle x, y, radius, color
    Dim x0 As Long, y0 As Long, e As Long
    x0 = R: y0 = 0: e = 0
    Do While y0 < x0
        If e <= 0 Then
            y0 = y0 + 1
            Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
            Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
            e = e + 2 * y0
        Else
            Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
            Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
            x0 = x0 - 1: e = e - 2 * x0
        End If
    Loop
    Line (x - R, y)-(x + R, y), C, BF
End Sub

Oh boy!

No wonder our pine plantations are getting depleted!