How to draw a truncated hexagonal tiling?

Question

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?

Answer 1

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 =
  Cases[Thread[{triangles, triangleareas}],
   {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

Answer 2

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"]).

Answer 3

• 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}}] 

• Using the method from @halmir, we count the triangles. https://mathematica.stackexchange.com/a/280439/72111

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}]]}]]

• Test another range such Annulus(Using the method from @cvgmt,doesn't depend on DiscretizeGraphics and MeshConnectivityGraph https://mathematica.stackexchange.com/a/280384/72111).

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}]]}]]

Answer 4

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]]

Answer 5

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}]]
]