# Drawing a trihexagonal tiling

I am trying to draw a trihexagonal tiling of the following form

using Mathematica. I attempted to begin by using the result given in this Stack Overflow Q & A. However, I couldn't figure out how to get it to work by placing adjacent hexagons into the triangles.

Could anyone perhaps present an easy version of a code using Graphics3D to generate this kind of lattice?

• Please add the code from the attempt you have been working on. – MarcoB Jul 26 '15 at 4:43
• Your link show a 2D tiling. What has this question to do with Graphics3D? – m_goldberg Jul 26 '15 at 4:52
• Sorry, it could be done in 2d, and I could generalize it to 3d easily. – combustion1925 Jul 26 '15 at 4:54
• A Gravatar from a long time ago... – J. M.'s ennui Jul 26 '15 at 5:00

unitcell[i_, j_] := Translate[
{Line[{{1/2, Sqrt[3]/2}, {0, 0}, {1, 0}}],
Line[{{1/4, Sqrt[3]/4}, {1/2, 0}}],
Line[{{1, Sqrt[3]/2}, {5/4, Sqrt[3]/4}}], PointSize[Large],
Point[{{0, 0}, {1/4, Sqrt[3]/4}, {1/2, 0}}]},
{i + j/2, Sqrt[3]/2 j}]

Graphics[Array[unitcell, {5, 5}]]


• You might also consider getting the coordinates from an Entity: kagome = Entity["PeriodicTiling", "TrihexagonalTiling"]; pgons = kagome["PrimitiveUnit"] // Cases[#, _Polygon, Infinity] &; {vec1, vec2} = kagome["TranslationVectors"][]; unitcell[i_, j_] := Translate[pgons, i*vec1 + j*vec2]; Graphics[{Opacity[0.1], EdgeForm[GrayLevel[0.3]], Array[unitcell, {5, 5}]}]; – Searke Dec 26 '19 at 16:31

Just for fun:

c[p_, m_, n_, v_] :=
Join @@ CoordinateBoundingBoxArray[{p, p + {m, n} v}, v]
tile[m_, n_] :=
With[{pts =
CirclePoints[{##}, 1, 6] & @@@
Join @@ (c[#, m, n, {2, 2 Sqrt[3]}] & /@ {{0, 0}, {1, Sqrt[3]}})},
Graphics[{EdgeForm[Black], FaceForm[White], Polygon /@ pts,
PointSize[0.01], Point /@ pts}, ImageSize -> 400]
]


So tile[20,5]

Now to make torus:

tor[u_, v_, m_, n_] := {(m + n Cos[v]) Cos[u], (m + n Cos[v]) Sin[u],
n Sin[v]}
f[x_, m_, n_] := Rescale[x, {m, n}, {0, 2 Pi}]
torp[m_, n_, a_, b_] :=
With[{pts =
CirclePoints[{##}, 1, 6] & @@@
Join @@ (c[#, m, n, {2, 2 Sqrt[3]}] & /@ {{0, 0}, {1, Sqrt[3]}})},
Map[tor[f[#[[1]], -1, 2 m + 2],
f[#[[2]], -Sqrt[3]/2, (4 n + 3) Sqrt[3]/2], a, b] &, pts, {2}]]
gv[m_, n_] :=
Graphics3D[{EdgeForm[{Red, Thick}], FaceForm[None],
Polygon /@ torp[m, n, (2 m + 3)/(2 Pi), (4 n + 3) Pi/(4 Pi)],
Yellow, PointSize[0.02],
Point /@ torp[m, n, (2 m + 3)/(2 Pi), (4 n + 3) Pi/(4 Pi)]},
Background -> Black, Boxed -> False, ImageSize -> 400]


Visualizing:

Manipulate[
Row[{tile[p, q], gv[p, q]}], {p, Range[10, 40, 10]}, {q,
Range[3, 11, 2]}]


Apologies for coloring.

I'm not quite yet willing to reveal how I did the fancy woven 籠目 torus in my comment, but I will at least reveal how to make a GraphicsComplex[] object for this lattice. (I in fact asked this question as I needed the function in the course of building Archimedean lattices.)

multisegment[lst_List, scts_List] := Block[{acc},
acc = Prepend[Accumulate[PadRight[scts, Length[lst]/Mean[scts], scts]], 0];
Inner[Take[lst, {#1, #2}] &, Most[acc] + 1, Rest[acc], List]]

kagome[m_Integer?Positive, n_Integer?Positive] := GraphicsComplex[Flatten[
Table[If[EvenQ[j] && EvenQ[k], Unevaluated[Sequence[]],
{j + (k - 3)/2, (k - 1) Sqrt[3]/2}],
{k, 2 n + 1}, {j, 2 m + 1}], 1],
Polygon[Flatten[
Apply[{Append[Most[#1], First[#2]],
Flatten[Riffle[#2, {Rest[#1], Reverse[Most[#3]]}]],
Prepend[Rest[#3], Last[#2]]} &,
Transpose /@ Partition[MapIndexed[
With[{l = Mod[First[#2], 2]},
Partition[#1, l + 2, l + 1]] &,
Most[multisegment[Range[(n + 1) (3 m + 2)],
{2 m + 1, m + 1}]]], 3, 2],
{2}], 2]]]


Test:

Graphics[{Directive[FaceForm[], EdgeForm[Black]], kagome[5, 3]}]


To embed this on a torus while preserving the angles, one needs a conformal map. I'll use the one from this paper:

torus[s_, t_][{u_, v_}] := {s Cos[2 π u/s], s Sin[2 π u/s],
t Sin[2 π v/t]}/(Sqrt[s^2 + t^2] - t Cos[2 π v/t])

With[{m = 24, n = 12},
Graphics3D[MapAt[Map[torus[2 m, n Sqrt[3]], N[#]] &, kagome[m, n], 1],
Boxed -> False]]


• @J.M. Thank you for this wonderful answer +1, esp torus...:) – ubpdqn Jul 26 '15 at 23:42
ClearAll[triHex];
triHex[w_, h_] := Module[{hex = {FaceForm[White], EdgeForm[Black], Polygon@#,
Red, PointSize[Large], Point@#} &@ Table[{Cos[2 Pi k /6], Sin[2 Pi k /6]}, {k, 6}]},
Fold[Translate[#, {{0, 0}, ## & @@ #2}] &, hex,
{Table[{4 k Cos[Pi/3], 0}, {k, 1, w }], Table[2 k {Cos[Pi/3], Sin[Pi/3]}, {k, 1, h }]}]]


Examples:

Graphics[triHex[10, 5], ImageSize -> 600]


Graphics[triHex[7, 7] /. White -> LightBlue, ImageSize -> 600]