QB64 Phoenix Edition
Xmas Star - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Christmas Code (https://staging.qb64phoenix.com/forumdisplay.php?fid=48)
+---- Thread: Xmas Star (/showthread.php?tid=1330)

Xmas Star - bplus - 12-25-2022

Code: (Select All)
_Title "Xmas Star" ' b+ 2022-12-25
Screen _NewImage(500, 500, 32)

star& = _NewImage(500, 500, 32)
XmasStar _Width / 2, _Height / 2, .1 * _Height, .2 * _Height, .45 * _Height, 125
_PutImage , 0, star&
s2& = _NewImage(500, 500, 32)
XmasStar _Width / 2, _Height / 2, .1 * _Height, .2 * _Height, .45 * _Height, 75
_PutImage , 0, s2&
d = 1

Do
    Cls
    For r = 0 To .45 * _Height Step 1
        fcirc _Width / 2, _Height / 2, r, _RGB32(255, 255, 255, 5)
    Next
    a = a + d * .05
    If Abs(a) < .05 Then
        If d < 0 Then a = -.05
        If d > 0 Then a = .05
    End If
    If a < -1 Then a = -1: d = 1
    If a > 1 Then a = 1: d = -1
    If a > 0 Then RotoZoom3 _Width / 2, _Height / 2, star&, a, 1, 0 Else RotoZoom3 _Width / 2, _Height / 2, s2&, a, 1, 0
    _Display
    _Limit 60
Loop Until _KeyDown(27)

Sub XmasStar (xc, yc, r1, r2, r3, c As _Unsigned Long)
    a = _Pi(2 / 16)
    For p = 0 To 200
        p1 = p / 200
        For i = 0 To 15
            If i Mod 2 = 1 Then
                x1 = xc + p1 * r1 * Cos(i * a): y1 = yc + p1 * r1 * Sin(i * a)
            ElseIf i Mod 4 = 0 Then
                x1 = xc + p1 * r3 * Cos(i * a): y1 = yc + p1 * r3 * Sin(i * a)
            ElseIf i Mod 4 = 2 Then
                x1 = xc + p1 * r2 * Cos(i * a): y1 = yc + p1 * r2 * Sin(i * a)
            End If
            If i > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60) Else firstx = x1: firsty = y1
            lastx = x1: lasty = y1
        Next
        Line (lastx, lasty)-(firstx, firsty), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60)
    Next
End Sub

Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y
    Dim px(3) As Single: Dim py(3) As Single
    Dim W&, H&, sinr!, cosr!, i&, x2&, y2&
    W& = _Width(Image&): H& = _Height(Image&)
    px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
    px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
    sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation)
    For i& = 0 To 3
        x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle _Seamless(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

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


RE: Xmas Star - bplus - 01-01-2023

Interesting this is still showing no views until after I make a new post.