Is it possible that? - Printable Version

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