# How to draw a truncated hexagonal tiling?

The following is the pattern of dodecagons and triangles:

which is called a truncated hexagonal tiling. In the Mathematica documentation there are different methods to tessellate the surface, like VoronoiMesh. Most of these methods seem to produce polygons between 3- to 6-sided polygons. Can one produce the above with Mathematica?

I'm not sure if the scope of the question is to derive the tiling from some more abstract definition or just to reproduce it, but reproducing it is not particularly hard:

With[
{gridbasis =
a {1, 0} +
b RotationTransform[60 Degree][{1, 0}]},
Graphics[
{EdgeForm[Black], FaceForm[LightBlue],
(* Place regular 12-gons,
rotated and sized correctly,
on the hexagonal grid. *)
RegularPolygon[
gridbasis,
{1/(2 Cos[Pi/12]), Pi/12}, 12] /.
Solve[
(* Find hexagonal grid points
inside the specified rectangle
on basis of a and b. *)
RegionMember[
Rectangle[{-3, -3}, {3, 3}],
gridbasis],
{a, b}, Integers]}]]


One could of course just use a basis and reason PlotRange on the formed parallelogram area manually, but it is also quite easy to find polygon positions on a (rectangular) region with Solve.

On counting (whole) 12-gons and triangles in a region - here's a stab at it. Note that this does not scale well, as CylindricalDecomposition is quite a complicated operation.

This is more an example of "we can use brute computational force as a substitute for brainpower" exercise (mostly in computation of triangles) than anything else; one could relatively easily figure out grid positions for triangles on the tiling and perform RegionWithin checks for them, but the task can be performed purely by real algebraic geometry starting from known 12-gons and the constraining area.

gridbasis =
a {1, 0} + b RotationTransform[60 Degree][{1, 0}];

(* List of 12-gons. *)
polys =
RegularPolygon[gridbasis, {1/(2 Cos[Pi/12]), Pi/12}, 12] /.
Solve[
RegionMember[Rectangle[{-3, -3}, {3, 3}], gridbasis],
{a, b}, Integers];

(* Region where we are counting regions.
This region must be completely covered by the tiling. *)
countregion = Rectangle[{-5/2, -5/2}, {5/2, 5/2}];

(* Visualise 12-gons (polys) which are inside in countregion. *)
Cases[polys, poly_RegularPolygon /; RegionWithin[countregion, poly]] //
Graphics[
{FaceForm@LightBlue, polys,
FaceForm@Lighter@Blue, #,
FaceForm[None], EdgeForm[Black], countregion}] &

(* Count them. *)
Count[polys, poly_RegularPolygon /; RegionWithin[countregion, poly]]

(* Construct a region consisting of inside of countregion
which is not overlapped by polys. Convert it to implict equation
form, and separate it to connected components. Convert these
to implicit regions, which correspond to full or partial
(cut by countregion) triangles between polys. *)
triangles =
ImplicitRegion[#, {x, y}] & /@
CylindricalDecomposition[
RegionMember[RegionDifference[countregion,
RegionUnion[polys]], {x, y}], {x, y},
"Components"];

(* Compute areas of triangles and simplify their forms. *)
triangleareas =
RootReduce@*Area /@
triangles;

(* Select those triangles with area equal to largest area seen. *)
completetriangles =
{t_, Max[triangleareas]} :> t];

(* Visualise completetriangles. *)
Graphics[
{FaceForm@LightBlue, polys,
FaceForm@Lighter@Blue,
MeshPrimitives[
Quiet@BoundaryDiscretizeRegion[#],
{2}] & /@
completetriangles,
FaceForm@None, EdgeForm@Black, countregion}]

(* Count them. *)
Count[triangleareas, Max[triangleareas]]


23

54

• @Samane On which region, specifically? Do partial 12-gons and triangles count? Frankly it is likely that manual reasoning is easier than counting triangles while minimising manual reasoning... Feb 28 at 5:52
• @Samane I added some code for counting 12-gons, and triangles. The triangle code is a bit... elaborate. Feb 28 at 7:30
• @Samane Sure, I changed the FaceForm to LightBlue (mostly for better contrast with black than plain darker blue). Feb 28 at 8:06

With IGraph/M,

Needs["IGraphM"]

IGLatticeMesh["TruncatedHexagonal"]


Crop it to a rectangle:

IGLatticeMesh["TruncatedHexagonal", Rectangle[{0, 0}, {30, 30}]]


The result is a MeshRegion.

The unit cells used by IGLatticeMesh were sourced from Wolfram|Alpha and Mathematica's curated data system (Entity["PeriodicTiling", "TruncatedHexagonalTiling"]).

• Since this is the truncated hexagonal,its element can be truncated by a regular polygon.
• We set the cutting ratio to be t=1/4.
Clear["Global*"];
pairs = Partition[CirclePoints[{1, π/2}, 6], 2, 1, 1];
t = 1/4;
subdivides = {{(1 - t), t}, {t, (1 - t)}} . # & /@ pairs;
pts = Flatten[subdivides, {1, 2}];
Graphics[{Red, Arrow[pairs], Blue, AbsolutePointSize[8], Point[pts],
Opacity[.5], Green, Polygon[pts]}]


• And then we translate the polygon to two direction {1,0} and {Cos[π/3], Sin[π/3]}.
basis = Sqrt[3] {{1, 0}, {Cos[π/3], Sin[π/3]}};
p = Tuples[Range[-2, 2], 2] . basis;
Graphics[{EdgeForm[Blue], FaceForm[Green],
Polygon /@ (pts + Threaded[#] & /@ p)}]


• Set PlotRange to cut such parallelogram.
Clear[p];
basis = Sqrt[3] {{1, 0}, {Cos[π/3], Sin[π/3]}};
p = Tuples[Range[-8, 8], 2] . basis;
Graphics[{EdgeForm[Blue], FaceForm[Green],
Polygon /@ (pts + Threaded[#] & /@ p)},
PlotRange -> {{-5, 5}, {-5, 5}}]


Clear["Global*"];
pairs = Partition[CirclePoints[{1, π/2}, 6], 2, 1, 1];
t = 1/4;
subdivides = {{(1 - t), t}, {t, (1 - t)}} . # & /@ pairs;
pts = Flatten[subdivides, {1, 2}];
basis = Sqrt[3] {{1, 0}, {Cos[π/3], Sin[π/3]}};
p = Tuples[Range[-3, 3], 2] . basis;
range = {{xmin, xmax}, {ymin, ymax}} = {{-2, 6}, {-2, 8}};
graphics0 =
Graphics[{EdgeForm[Directive[Thin, Blue]], FaceForm[],
Polygon /@ (pts + Threaded[#] & /@ p)}];
graphics = Show[graphics0, PlotRange -> range];
mesh = graphics // DiscretizeGraphics;
g = mesh // MeshConnectivityGraph;
faces = PlanarFaceList[g][[;; , ;; , 2]];
triangles = Select[faces, Length[#] == 3 &];
Show[graphics0,
Graphics[{EdgeForm[Cyan], FaceForm[],
Rectangle[{xmin, ymin}, {xmax, ymax}], EdgeForm[Red],
MeshRegion[MeshCoordinates[mesh], Polygon /@ triangles],
Text[Framed@Length@triangles, Scaled[{1, 1}]]}]]


Clear["Global*"];
pairs = Partition[CirclePoints[{1, π/2}, 6], 2, 1, 1];
t = 1/4;
subdivides = {{(1 - t), t}, {t, (1 - t)}} . # & /@ pairs;
pts0 = Flatten[subdivides, {1, 2}];
basis = Sqrt[3] {{1, 0}, {Cos[π/3], Sin[π/3]}};
p = Tuples[Range[-3, 3], 2] . basis;
range = Annulus[{0, .2}, {2.5, 5.3}];
lines0 =
Flatten[Line /@ Partition[#, 2, 1, 1] & /@ (pts0 + Threaded[#] & /@
p), {1, 2}];
lines = Cases[RegionIntersection[range, #] & /@ lines0, _Line,
Infinity];
pts = DeleteDuplicates[Flatten[lines[[;; , 1]], {2, 1}]];
edges = Table[
UndirectedEdge @@ Flatten[FirstPosition[pts, #] & /@ d], {d,
lines[[;; , 1]]}];
g = Graph[edges, VertexCoordinates -> Thread[Range@Length@pts -> pts]];
faces = PlanarFaceList[g];
triangles = Select[faces, Length[#] == 3 &];
Show[Graphics[lines0],
Graphics[{EdgeForm[Cyan], FaceForm[], range, EdgeForm[Red],
MeshRegion[pts, Polygon /@ triangles],
Text[Framed@Length@triangles, Scaled[{1, 1}]]}]]


• I'd say the way you count triangles is... obscure in a different way from mine. It's computationally more scalable, though! Feb 28 at 18:35
translations = 2*Cos[π/12]*
{Array[{(# - 1) √3, 1 - Mod[#, 2]}/2 &, {#}], Array[{0, #} &, {#2}]} &;

dodecagonTiling[nc_, nr_] := Fold[Translate,
RegularPolygon @ 12, translations[nc, nr]]


Examples:

Row[{Graphics[{EdgeForm[Gray], LightBlue, dodecagonTiling[7, 4]},
ImageSize -> Medium],
Graphics[{EdgeForm[Gray], LightBlue, dodecagonTiling[5, 6]},
ImageSize -> Medium]}, Spacer[30]]


• (+1)Add * after 2 Cos[π/12]  make the code work. It seems that Mathematica ignore the blank, does not recognize it as Times. Mar 2 at 6:57
• Thank you @cvgmt; edited.
– kglr
Mar 2 at 20:49
• I edit the code. Add 2*Cos[π/12]* since the forum recognize the blank symbols as the return symbols. Mar 2 at 22:40
With[{m=8,n=5,f=Cos[Pi/12.] (√3#+I Mod[#,2]-2I #2)-(-1)^(#3/6+1/12)&},
Graphics[Line/@ReIm@Array[f,{m,n,13}]]
]