Proggies

[bplus]

OK now that we practiced with that:

Polygon Orbits

Code: (Select All)

Option _Explicit
_Title "Polygon Orbits 2" 'b+ 2020-02-25
' Fellippe's post 2020-02-25 https://www.qb64.org/forum/index.php?topic=2234.msg114766#msg114766
' Inspired by this post: https://www.reddit.com/r/gifs/comments/f91c99/every_addtional_shape_adds_one_more_corner_and/

Const xmax = 550, ymax = 550, side = 100, center = 275, P1 = _Pi, P2 = P1 * 2, PD2 = P1 * .5
Dim Shared poly$(3 To 15) 'point strings we will turn into arrays as needed
Dim Shared c(3 To 15) As _Unsigned Long 'colors
c(3) = &HFF550000: c(4) = &HFFAA0000: c(5) = &HFFFF0000: c(6) = &HFFDD4400: c(7) = &HFF888800: c(8) = &HFFFF8800
c(9) = &HFF00FF00: c(10) = &HFF00FF88: c(11) = &HFF00FFFF: c(12) = &HFF0088FF: c(13) = &HFF0000FF: c(14) = &HF88F0088: c(15) = &HFF330033
Dim Shared rate(3 To 15), radii(3 To 15), a 'for dots

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 20
Dim i, n, isoA, isoA2, turn, r, x1, y1, currA, x2, y2
For i = 3 To 15
    rate(i) = (16 - i) / 12 'rate as angle mult that disc will move in circle
Next
For n = 3 To 15
    a = P2 / n '                  central angle
    isoA = (P1 - a) / 2 '         angle of one iso triangle at base
    isoA2 = isoA * 2 '            2 iso's is interior angle at each node
    turn = P1 - isoA2 '           for turtle drawing, turn this much at each point
    r = .5 * side / Sin(a / 2) ' << so  << 1/2 * side = r * sin(1/2 * a)
    radii(n) = r
    x1 = center + r * Cos(a / 2 + PD2): y1 = center + r * Sin(a / 2 + PD2)
    poly$(n) = Str$(x1) + "," + Str$(y1) 'our first point for polygon
    currA = P1 'turtle draw the rest of the poly and save the points
    For i = 2 To n + 1
        currA = currA + turn
        x2 = x1 + side * Cos(currA): y2 = y1 + side * Sin(currA)
        Line (x1, y1)-(x2, y2)
        x1 = x2: y1 = y2
        poly$(n) = poly$(n) + "," + Str$(x1) + "," + Str$(y1)
    Next
Next
While _KeyDown(27) = 0
    Cls
    drawPolys
    a = a + _Pi(2 / 120)
    _Display
    _Limit 30
Wend

Sub drawPolys
    Dim n, i, Px, Py, dist, Rx, Ry, r, g, b
    For n = 15 To 3 Step -1
        'here is where we want our dot but we have to place on a line segment between two closest points to Px, Py
        Px = center + radii(n) * Cos(rate(n) * a + PD2)
        Py = center + radii(n) * Sin(rate(n) * a + PD2)
        ReDim pts(0)
        Split poly$(n), ",", pts()
        ReDim min(1), save(1)
        min(0) = 1000: min(1) = 1100: save(0) = -1: save(1) = -2 'dummy
        For i = 0 To UBound(pts) Step 2
            If i < 2 * n - 1 Then
                dist = Sqr((Px - pts(i)) ^ 2 + (Py - pts(i + 1)) ^ 2)
                If dist <= min(0) Then
                    min(1) = min(0): min(0) = dist: save(1) = save(0): save(0) = i
                ElseIf dist <= min(1) Then
                    min(1) = dist: save(1) = i
                End If
            End If
            If i = 0 Then
                PSet (pts(0), pts(1)), c(n)
            Else
                Line -(pts(i), pts(i + 1)), c(n)
            End If
        Next
        'now we have the two closest points of poly to px, py find Rx, RY on that line closest to Px, Py
        If Abs(pts(save(0)) - pts(save(1))) < .001 Then 'have perpendicular line get Rx, Ry directly
            Rx = pts(save(0)): Ry = Py
        Else
            PointOnLinePerp2Point pts(save(0)), pts(save(0) + 1), pts(save(1)), pts(save(1) + 1), Px, Py, Rx, Ry
        End If
        r = _Red32(c(n)): g = _Green32(c(n)): b = _Blue32(c(n))
        For i = 9 To 0 Step -1
            fcirc Rx, Ry, i, midInk(r, g, b, 255, 255, 255, (9 - i) / 9)
        Next
    Next
End Sub

Sub slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
    If X1 = X2 Then
        slope = X1
        Yintercept = Y2
    Else
        slope = (Y2 - Y1) / (X2 - X1)
        Yintercept = slope * (0 - X1) + Y1
    End If
End Sub

Sub PointOnLinePerp2Point (Lx1, Ly1, Lx2, Ly2, Px, Py, Rx, Ry)
    '
    'this sub needs  SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
    '
    'Lx1, Ly1, Lx2, Ly2     the two points that make a line
    'Px, Py is point off the line
    'Rx, Ry Return Point is the Point on the line perpendicular to Px, Py
    Dim m, Y0, AA, B
    slopeYintersect Lx1, Ly1, Lx2, Ly2, m, Y0
    AA = m ^ 2 + 1
    B = 2 * (m * Y0 - m * Py - Px)
    Rx = -B / (2 * AA)
    Ry = m * Rx + Y0
End Sub

Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function

'this sub modified for splitting into an single array!!!
Sub Split (SplitMeString As String, delim As String, loadMeArray())
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Val(Mid$(SplitMeString, curpos, dpos - curpos))
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000)
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Val(Mid$(SplitMeString, curpos))
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) 'get the ubound correct
End Sub

Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    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