6
$\begingroup$

The following is the pattern of dodecagons and triangles:

enter image description here

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?

$\endgroup$

5 Answers 5

5
$\begingroup$

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

enter image description here

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

enter image description here

23

enter image description here

54

$\endgroup$
3
  • $\begingroup$ @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... $\endgroup$
    – kirma
    Feb 28, 2023 at 5:52
  • $\begingroup$ @Samane I added some code for counting 12-gons, and triangles. The triangle code is a bit... elaborate. $\endgroup$
    – kirma
    Feb 28, 2023 at 7:30
  • 1
    $\begingroup$ @Samane Sure, I changed the FaceForm to LightBlue (mostly for better contrast with black than plain darker blue). $\endgroup$
    – kirma
    Feb 28, 2023 at 8:06
6
$\begingroup$

With IGraph/M,

Needs["IGraphM`"]

IGLatticeMesh["TruncatedHexagonal"]

enter image description here

Crop it to a rectangle:

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

enter image description here

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

$\endgroup$
6
$\begingroup$
  • 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]}]

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
1
  • $\begingroup$ I'd say the way you count triangles is... obscure in a different way from mine. It's computationally more scalable, though! $\endgroup$
    – kirma
    Feb 28, 2023 at 18:35
3
$\begingroup$
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]]

enter image description here

$\endgroup$
3
  • $\begingroup$ (+1)Add * after 2 Cos[π/12] make the code work. It seems that Mathematica ignore the blank, does not recognize it as Times. $\endgroup$
    – cvgmt
    Mar 2, 2023 at 6:57
  • $\begingroup$ Thank you @cvgmt; edited. $\endgroup$
    – kglr
    Mar 2, 2023 at 20:49
  • 1
    $\begingroup$ I edit the code. Add 2*Cos[π/12]* since the forum recognize the blank symbols as the return symbols. $\endgroup$
    – cvgmt
    Mar 2, 2023 at 22:40
2
$\begingroup$
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}]]
]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.