_Title "little tree" ' b+ 2025-12-24 mod fixes center screen and star
Screen _NewImage(280, 180, 12)
Color 2
PSet (140 + Cos(0), 20)
For I = 0 To 70 Step 0.1
Line -(I * Cos(I) + 140, 20 - I * (Sin(I) * 0.2 - 2))
Next
Color 14
Line (136, 22)-(140, 12)
Line -(144, 22): Line -(134, 16)
Line -(146, 16): Line -(136, 22)
Sleep
12-24-2025, 07:38 PM (This post was last modified: 12-24-2025, 07:40 PM by bplus.)
Thanks Ken, already have a mod to it! BTW this is mod of something shared long ago.
Color changing, stars and ground added:
Code: (Select All)
_Title "little xmas tree 2" ' b+ 2025-12-24 mod fixes center screen and star
' add color changing, stars and ground
Screen _NewImage(280, 180, 12)
For star = 1 To 25
Circle (Rnd * 280, Rnd * 180), Int(Rnd * 2)
Next
Line (0, 150)-(280, 180), 8, BF
Color 2
PSet (140 + Cos(0), 20)
For I = 0 To 70 Step 0.1
Color Int(Rnd * 15) + 1
Line -(I * Cos(I) + 140, 20 - I * (Sin(I) * 0.2 - 2))
Next
Color 14
Line (136, 22)-(140, 12)
Line -(144, 22): Line -(134, 16)
Line -(146, 16): Line -(136, 22)
Sleep
_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
_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!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.)
Please visit my Website at: http://oldendayskids.blogspot.com/
BTW this is mod of something shared long ago.
