7
$\begingroup$

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?

$\endgroup$
  • 2
    $\begingroup$ Please add the code from the attempt you have been working on. $\endgroup$ – MarcoB Jul 26 '15 at 4:43
  • $\begingroup$ Your link show a 2D tiling. What has this question to do with Graphics3D? $\endgroup$ – m_goldberg Jul 26 '15 at 4:52
  • $\begingroup$ Sorry, it could be done in 2d, and I could generalize it to 3d easily. $\endgroup$ – combustion1925 Jul 26 '15 at 4:54
  • $\begingroup$ A Gravatar from a long time ago... $\endgroup$ – J. M. is away Jul 26 '15 at 5:00
14
$\begingroup$
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}]]

tiling

$\endgroup$
12
$\begingroup$

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]

enter image description here

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

enter image description here

Apologies for coloring.

$\endgroup$
8
$\begingroup$

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

small 籠目 lattice

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

籠目 torus

$\endgroup$
  • 1
    $\begingroup$ @J.M. Thank you for this wonderful answer +1, esp torus...:) $\endgroup$ – ubpdqn Jul 26 '15 at 23:42
1
$\begingroup$
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]

enter image description here

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

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.