Screen Savers
#48
Hexagonal Star Tiling
Code: (Select All)
_Title "Hexagonal Star Tiling 3" 'B+ 2019-04-19
' Trying to duplicate results shown here by Daniel Shiffman
' https://www.youtube.com/watch?v=sJ6pMLp_IaI&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH&index=70
' but using a completely different method for drawing the tile
' 2019-04-17 Yes! the star tile can be generalized to any N sided regular polygon!
' 2019-04-17 This version try Hexagonal Tiling.
' 2019-04-17 Hexagonal Star Tiling 2, prep one tile and rubber stamp the grid with image.
' 2019-04-18 Go for a dynamic tile, image constantly changing

Const xmax = 1380 'bigger than your screen can hold
Const ymax = 800
Screen _NewImage(xmax, ymax, 32)
'_SCREENMOVE _MIDDLE
_FullScreen
Randomize Timer

Dim Shared tile&, polyRadius, triColor As _Unsigned Long

polyRadius = 60
gridheight = polyRadius * Sqr(3) / 2
triColor = _RGB32(0, 0, 255)
rd = 10
dm = 20
prepTile polyRadius, rd, dm
rDir = 1: dDir = 1
While _KeyDown(27) = 0
    If rDir = 1 Then
        If rd + 1 <= polyRadius * .5 Then
            rd = rd + 1: prepTile polyRadius, rd, dm
        Else

            If Rnd > .8 Then
                polyRadius = rand(20, 200)
                triColor = _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
                rDir = -1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
                Color , _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
            Else
                rDir = -1
            End If
        End If
    End If
    If rDir = -1 Then
        If rd - 1 >= 0 Then
            rd = rd - 1: prepTile polyRadius, rd, dm
        Else
            If Rnd > .8 Then
                triColor = _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
                polyRadius = rand(20, 200)
                rDir = 1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
                Color , _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
            Else
                rDir = 1
            End If
        End If
    End If

    Cls
    gridheight = polyRadius * Sqr(3) / 2
    xoff = 0
    For y = -polyRadius To ymax + gridheight Step gridheight
        xoff = (xoff + 1) Mod 2
        For x = -polyRadius To xmax Step 3 * polyRadius
            _PutImage (x + xoff * 1.5 * polyRadius, y), tile&, 0
        Next
    Next
    _Display
    _Limit .1 * polyRadius
Wend
End

Sub prepTile (pRadius, innerStarRadius, midPtDist)
    If tile& Then _FreeImage tile&
    tile& = _NewImage(2 * pRadius, 2 * pRadius, 32)
    _Dest tile&
    drawRegPolyStar pRadius, pRadius, pRadius, 6, innerStarRadius, midPtDist, triColor
    _Dest 0
End Sub

Sub drawRegPolyStar (cx, cy, pRadius, nSides, innerStarRadius, midPtDist, c1 As _Unsigned Long)
    Dim tilePtsX(1 To nSides), tilePtsY(1 To nSides)
    Dim innerStarX(1 To nSides), innerStarY(1 To nSides)

    pA = _Pi(2 / nSides)
    For i = 1 To nSides
        tilePtsX(i) = cx + pRadius * Cos(pA * i)
        tilePtsY(i) = cy + pRadius * Sin(pA * i)
        'on the same line the innerStar pts
        innerStarX(i) = cx + innerStarRadius * Cos(pA * i)
        innerStarY(i) = cy + innerStarRadius * Sin(pA * i)
        'CIRCLE (innerStarX(i), innerStarY(i)), 3, _RGB32(255, 255, 0)
        'draw tile
        If i > 1 Then
            Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(i - 1), tilePtsY(i - 1)), _RGB32(255, 0, 0, 200)
            If i = nSides Then
                Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(1), tilePtsY(1)), _RGB32(255, 0, 0, 200)
            End If
        End If
        '_DELAY .5
    Next

    'from each innerStarPt 2 lines connect to side midpoints
    'lets calc all the midpoints +/- midPtDist
    Dim mpdX(1 To 2 * nSides), mpdY(1 To 2 * nSides)
    For i = 1 To nSides
        If i - 1 = 0 Then ei = nSides Else ei = i - 1
        mx = (tilePtsX(ei) + tilePtsX(i)) / 2
        my = (tilePtsY(ei) + tilePtsY(i)) / 2
        'check
        'CIRCLE (mx, my), 2, _RGB32(0, 0, 255)
        '_DELAY .5

        'from each mx, my we need a point midPtDist along the angle from mx, my to the ei index point
        a = _Atan2(tilePtsY(ei) - my, tilePtsX(ei) - mx)
        mdx = mx + midPtDist * Cos(a)
        mdy = my + midPtDist * Sin(a)
        'the other point is 180 degrees in opposite direction
        mdx2 = mx + midPtDist * Cos(a - _Pi)
        mdy2 = my + midPtDist * Sin(a - _Pi)
        'check
        'CIRCLE (mdx, mdy), 2, _RGB32(255, 255, 0)
        'CIRCLE (mdx2, mdy2), 2, _RGB32(255, 0, 255)

        'OK store all these points for drawing lines later
        mpdX(2 * i - 1) = mdx: mpdY(2 * i - 1) = mdy
        mpdX(2 * i) = mdx2: mpdY(2 * i) = mdy2

    Next
    Color c1
    'from each point in inner star Radius draw 2 lines to the poly edges
    For i = 1 To nSides
        'now figure the pattern: sequence maps are to 2*i +2 and to 2*i - 1
        If 2 * i + 2 > 2 * nSides Then map = 2 * i + 2 - 2 * nSides Else map = 2 * i + 2
        Line (innerStarX(i), innerStarY(i))-(mpdX(map), mpdY(map))

        If 2 * i - 1 < 1 Then map2 = 2 * i - 1 + 2 * nSides Else map2 = 2 * i - 1
        Line (innerStarX(i), innerStarY(i))-(mpdX(map2), mpdY(map2))

        ftri innerStarX(i), innerStarY(i), mpdX(map), mpdY(map), mpdX(map2), mpdY(map2), c1
        '_DELAY .5
    Next

End Sub

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

' found at QB64.net:    http://www.qb64.net/forum/index.php?topic=14425.0
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest tile&
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

   
b = b + ...
Reply


Messages In This Thread
Screen Savers - by bplus - 04-27-2022, 12:29 AM
RE: Screen Savers - by Dav - 04-27-2022, 02:26 PM
RE: Screen Savers - by bplus - 04-27-2022, 02:33 PM
RE: Screen Savers - by bplus - 04-30-2022, 11:55 PM
RE: Screen Savers - by Dav - 05-01-2022, 07:22 PM
RE: Screen Savers - by bplus - 05-01-2022, 08:26 PM
RE: Screen Savers - by bplus - 05-02-2022, 12:00 AM
RE: Screen Savers - by Coolman - 05-02-2022, 09:42 AM
RE: Screen Savers - by bplus - 05-03-2022, 02:13 AM
RE: Screen Savers - by bplus - 05-09-2022, 01:32 PM
RE: Screen Savers - by bplus - 05-19-2022, 07:22 PM
RE: Screen Savers - by bplus - 05-21-2022, 11:22 PM
RE: Screen Savers - by Pete - 05-21-2022, 11:27 PM
RE: Screen Savers - by bplus - 05-21-2022, 11:38 PM
RE: Screen Savers - by Pete - 05-22-2022, 04:39 AM
RE: Screen Savers - by bplus - 06-17-2022, 01:10 PM
RE: Screen Savers - by johnno56 - 06-18-2022, 12:23 AM
RE: Screen Savers - by Kernelpanic - 06-18-2022, 11:48 AM
RE: Screen Savers - by bplus - 06-18-2022, 01:47 AM
RE: Screen Savers - by bplus - 06-18-2022, 12:33 PM
RE: Screen Savers - by Kernelpanic - 06-18-2022, 03:21 PM
RE: Screen Savers - by RhoSigma - 06-18-2022, 03:51 PM
RE: Screen Savers - by bplus - 06-18-2022, 05:02 PM
RE: Screen Savers - by RhoSigma - 06-18-2022, 10:03 PM
RE: Screen Savers - by Kernelpanic - 06-18-2022, 08:15 PM
RE: Screen Savers - by bplus - 06-19-2022, 01:14 AM
RE: Screen Savers - by SierraKen - 06-20-2022, 09:50 PM
RE: Screen Savers - by bplus - 06-21-2022, 12:15 AM
RE: Screen Savers - by bplus - 06-29-2022, 04:52 PM
RE: Screen Savers - by SierraKen - 06-29-2022, 06:10 PM
RE: Screen Savers - by vince - 07-01-2022, 10:32 PM
RE: Screen Savers - by bplus - 07-01-2022, 11:05 PM
RE: Screen Savers - by bplus - 07-04-2022, 06:54 PM
RE: Screen Savers - by Kernelpanic - 07-04-2022, 09:11 PM
RE: Screen Savers - by bplus - 07-04-2022, 09:54 PM
RE: Screen Savers - by Kernelpanic - 07-05-2022, 02:14 PM
RE: Screen Savers - by bplus - 07-19-2022, 08:28 PM
RE: Screen Savers - by bplus - 08-28-2022, 12:55 AM
RE: Screen Savers - by TempodiBasic - 08-29-2022, 09:26 AM
RE: Screen Savers - by bplus - 09-06-2022, 12:35 AM
RE: Screen Savers - by SierraKen - 09-08-2022, 07:37 PM
RE: Screen Savers - by bplus - 09-09-2022, 02:22 AM
RE: Screen Savers - by SpriggsySpriggs - 09-15-2022, 04:38 PM
RE: Screen Savers - by bplus - 09-15-2022, 05:20 PM
RE: Screen Savers - by bplus - 01-31-2023, 04:21 PM
RE: Screen Savers - by vince - 02-01-2023, 07:27 AM
RE: Screen Savers - by bplus - 02-01-2023, 05:05 PM
RE: Screen Savers - by bplus - 03-13-2023, 10:51 PM
RE: Screen Savers - by vince - 03-31-2023, 11:09 PM
RE: Screen Savers - by bplus - 04-01-2023, 12:09 AM



Users browsing this thread: 24 Guest(s)