03-13-2023, 10:51 PM
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 + ...