@vince I see your mod and raise you a mod 
Code: (Select All)
_Title "vince rot xmas tree w star mod b+" ' 2024-02-16
Dim Shared pi, sw, sh, d, z0, p, q
pi = 4 * Atn(1)
d = 700
z0 = 2500
sw = 800
sh = 600
Dim As Double a, b, x, y, z, xx, yy, zz, r2
Screen _NewImage(sw, sh, 32)
Dim As _Unsigned Long clr
'tree
Color , &HFF000000
Cls
For a = 0 To 20 * 2 * pi Step 0.1
x = 5 * a * Cos(a)
y = -a * 10
z = 5 * a * Sin(a)
yy = (y + 350) * Cos(b) - z * Sin(b)
zz = (y + 350) * Sin(b) + z * Cos(b)
y = yy - 350
z = zz
xx = x * Cos(b) - z * Sin(b)
zz = x * Sin(b) + z * Cos(b)
x = xx
z = zz
xx = x * Cos(b) - (y + 350) * Sin(b)
yy = x * Sin(b) + (y + 350) * Cos(b)
x = xx
y = yy - 350
proj x, y, z
If a = 0 Then PSet (p, q), _RGB(0, 155, 0) Else Line -(p, q), _RGB(0, 155, 0)
If Rnd > .9 Then
clr = _RGB32(100 + Rnd * 155, (Rnd < .35) * -255, (Rnd < .35) * -255)
For r2 = 0 To 5 Step .25
Circle (p, q), r2, clr
Next
End If
Next
' star stuff
sx = 400: sy = 120
Dim Shared top&
top& = _NewImage(64, 64, 32) ' copy tree top wo star
_PutImage , 0, top&, (sx - 32, sy - 32)-(sx + 32, sy + 32)
Dim TheStar&
TheStar& = _NewImage(64, 64, 32)
_Dest TheStar&
For ir = 9 To 0 Step -1
star 32, 32, ir, 30, 5, 0, _RGB32(100 + (10 - ir) * 15, 200 + (10 - ir) * 5, (10 - ir) * 20)
Next
_Dest 0
dx = .02: dy = .1: rot = 0
xscale = 1: yscale = 1
While _KeyDown(27) = 0
_PutImage (sx - 32, sy - 32)-(sx + 32, sy + 32), top&, 0
xscale = xscale + dx
If xscale > 1 Then xscale = 1: dx = -dx
If xscale < .2 Then xscale = .2: dx = -dx
yscale = yscale + dy
If yscale > 1 Then yscale = 1: dy = -dy
If yscale < .2 Then yscale = .2: dy = -dy
RotoZoom23r sx, sy, TheStar&, xscale, yscale, rot
rot = rot + pi / 60
_Limit 30
Wend
Sub proj (x, y, z)
p = sw / 2 + x * d / (z + z0)
q = sh / 2 - (100 + y) * d / (z + z0) - 150
End Sub
Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long
pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
FillTriangle x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), K
Line (x2, y2)-(x3, y3), K
Line (x3, y3)-(x1, y1), K
x1 = x3: y1 = y3
Next
Paint (x, y), K, K
End Sub
Sub FillTriangle (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
$Checking:Off
Static a&, m As _MEM
If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
_MemPut m, m.OFFSET, K
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
$Checking:On
End Sub
' best rev 2023-01-20 Jarvis with Steve change for eff might need _Seamless next to _MapTriangle calls
Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)
'uses radians
Dim As Long W, H, Wp, Hp, i, x2, y2
Dim sinr!, cosr!
Dim px(3) As Single: Dim py(3) As Single
W& = _Width(Image&): H& = _Height(Image&)
Wp& = W& / 2 * xScale
Hp& = H& / 2 * yScale
px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&
px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&
sinr! = Sin(-radRotation): cosr! = Cos(radRotation)
For i& = 0 To 3
' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
px(i&) = x2&: py(i&) = y2&
Next ' _Seamless? below
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
b = b + ...
