Drawing a trihexagonal tiling

Question

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?

Answer 1

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

Answer 2

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.

Answer 3

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

Answer 4

ClearAll[triHex];
triHex[w_, h_] := Module[{hex = {FaceForm[White], EdgeForm[Black], PointSize[Large], 
 Polygon @ #, Red, Point @ #} & @ CirclePoints[6]}, 
Translate[hex, Join @@ Table[{2 j + i, i Sqrt[3]}, {i, 0, h - 1}, {j, 0, w - 1}]]]

Examples:

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

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