# Hat Polykite Shape

How can I create the hat polykite shape, also known as the "einstein" in mathematics?

• For tilings also look at the Wolfram Function Repository function: HatHexagons Commented Oct 11, 2023 at 15:35
• See numerous related discussions: hat-1, hat-2, hat-3, hat-4, hat-5 Commented Oct 11, 2023 at 15:55

"HatPolykite" is also available in LaminaData:

hatpolykite = LaminaData["HatPolykite"];

hatpolykite["Diagram"]


The property "BoundaryMeshRegion" returns a function that gives a BoundaryMeshRegion as a function of a:

hatpolykite["BoundaryMeshRegion"]


For a = 1

hatpolykite["BoundaryMeshRegion"][1]


Similarly for the property "Vertices":

vertices = hatpolykite["Vertices"][1]


Show[hatpolykite["BoundaryMeshRegion"][1],
Graphics[{Red, PointSize@Large, Point /@ vertices}]]


This interesting topic can be exposed form various points of view allowing to have a better grasp of the subject. Rewriting vertices cyclically

vrts = {{{-1, -Sqrt[3]}, {1, -Sqrt[3]}, {3/2, -(Sqrt[3]/2)}, {3, -Sqrt[3]},
{9/2, -(Sqrt[3]/2)}, {4, 0}, {3, 0}, {3, Sqrt[3]}, {3/2, (3 Sqrt[3])/2},
{1, Sqrt[3]}, {0, Sqrt[3]}, {0, 0}, {-(3/2), -(Sqrt[3]/2)}, {-1, -Sqrt[3]}}};


we can plot the hat polykite without external information simply with

Graphics[ Line[vrts]]


We can elucidate several symmetries of the hat polykite on the various lattices of circles with different radii. First with a lattice of circles of radius $$1$$:

Graphics[{Thick,
Circle @@@ {{{0, 0}, 1}, {{2, 0}, 1}, {{1, Sqrt[3]}, 1}, {{4, 0}, 1},
{{3, -Sqrt[3]}, 1}, {{3, Sqrt[3]}, 1}, {{-1, -Sqrt[3]}, 1},
{{1, -Sqrt[3]}, 1}}, Red, Line[vrts]}]


or a denser lattice with more circles

Graphics[{Darker @ Magenta,
Circle @@@ {{{0, 0}, 1}, {{2, 0}, 1}, {{1, Sqrt[3]}, 1}, {{4, 0}, 1},
{{3, -Sqrt[3]}, 1}, {{3, Sqrt[3]}, 1}, {{-1, -Sqrt[3]}, 1}, {{1,-Sqrt[3]}, 1}},
Darker @ Cyan,
Circle @@@ {{{2, Sqrt[3]}, 1}, {{2, -Sqrt[3]}, 1}, {{1, 0}, 1},
{{3, 0}, 1}, {{0, -Sqrt[3]}, 1}, {{0, Sqrt[3]}, 1}, {{-1, 0}, 1},
{{-2, -Sqrt[3]}, 1}, {{4, -Sqrt[3]}, 1}},
Darker @ Blue, Thickness[0.005], Line[vrts]}]


We need not restrict to circles of radius $$1$$, here we have circles of radii $$2$$ and $$\sqrt{3}$$:

Graphics[{Darker @ Magenta,
Circle @@@ {{{1, Sqrt[3]}, 2}, {{3, Sqrt[3]}, 2}, {{1, -Sqrt[3]}, 2},
{{3, -Sqrt[3]}, 2}},
Darker @ Cyan,
Circle @@@ {{{-(3/2), Sqrt[3]/2}, Sqrt[3]}, {{3/2, Sqrt[3]/2}, Sqrt[3]},
{{3/2, -(Sqrt[3]/2)}, Sqrt[3]}, {{-(3/2), -(Sqrt[3]/2)}, Sqrt[3]},
{{9/2, Sqrt[3]/2}, Sqrt[3]}, {{9/2, -(Sqrt[3]/2)}, Sqrt[3]}},
Darker @ Blue, Thickness[0.005], Line[vrts]}]


$$6$$ vertices lie on any cyan circle of one or more hat polykites on the tiling of the plane.

Try this:

reg = Entity["Lamina", "HatPolykite"]["BoundaryDiagram"] //
BoundaryDiscretizeGraphics


The polygon coordinates are:

MeshPrimitives[reg, 0] /. Point[a_] :> a

• Where did you get the word Lamina from? Commented Oct 11, 2023 at 12:44
• It showed up when I started the query with = sign and entered hat polykite.
– Syed
Commented Oct 11, 2023 at 12:46
• To guess that word would take me much more time than figuring out coordinates of the shape by hand. I think more appropriate world would be Tile. Commented Oct 11, 2023 at 12:50
• No need to guess anything, that's why there is Free-Form Input. For "hat polykite", it returns Entity["Lamina", "HatPolykite"]. Commented Oct 11, 2023 at 12:53
• It works correctly with "HatPolykite tile". Also, read the description for lamina at the MathWorld (Polygon), paragraph "While the "filled" usage ...". Lastly, I don't think the users' usage of the word matters here; these polygons are simply stored under the Lamina entity in the Wolfram Language. Commented Oct 11, 2023 at 13:07

It's also easy to represent as an AnglePath

path = With[{t1 = 60 °, t2 = 90 °, r = Sqrt[3]},
AnglePath[{{1, 0}, {1, t1}, {r, -t2}, {r, -t1}, {1, t2},
{1, -t1}, {r, -t2}, {r, -t1}, {1, t2},
{2, -t1}, {1, -t1}, {r, -t2}, {r, t1}}]];

Graphics[Line[path], AspectRatio -> 1, PlotRange -> {{-5, 5}, {-5, 5}}]

• Use the lattice to directly draw the polygon( we start from {0,0}).
basis = {e1, e2, e3, e4, e5, e6} = CirclePoints[{1, 0}, 6];
lattice =
Tuples[{Range[0, 5], Range[0, 4], Range[0, 2], Range[0, 1],
Range[0, 1], Range[0, 1]}] . basis;
pts = FoldList[
Plus, {0, 0}, {e1 + e1, e2, e1 + e6, e1 + e2, e3, e4, e3 + e2,
e3 + e4, e5, e4, e6 + e5, e5 + e4, e6}];
Graphics[{LightYellow, Polygon@pts, Green, AbsolutePointSize[5],
Arrow@Partition[pts, 2, 1, 1], Brown, Point /@ lattice},
Axes -> True, Method -> {"AxesInFront" -> False}]


Clear[e1, e2, lattice, five, polys];
{e1, e2} = {AngleVector[0], AngleVector[π/3]};
lattice = Table[{i, j} . {e1, e2}, {i, -4, 4}, {j, -3, 4}];
five = Polygon[{{0, 0}, {0, -1}, {2, -2}, {3, -1}, {2, 0}} . {e1, e2}];
polys = {five,
TransformedRegion[five,
RotationTransform[π, {0, -1} . {e1, e2}]],
TransformedRegion[five,
RotationTransform[(2 π)/3, {0, 0} . {e1, e2}]],
TransformedRegion[five,
ReflectionTransform[RotationTransform[π/2]@e2, {0, 0}]]};
Graphics[{{RandomColor[], #} & /@ polys, Point /@ lattice}]


reg = RegionUnion[BoundaryDiscretizeGraphics /@ polys];
Graphics[{LightYellow, reg, Green,
MeshPrimitives[reg, 1] /. Line -> Arrow}]