Create a torus with a hexagonal mesh for 3D-printing

Question

I am new to Mathematica, and I'm looking for a way to create patterns on the surface of 3D objects. One thing I have not been able to do is to create a hexagonal mesh on a torus. What I would like to have is a hexagonal mesh that has a certain thickness (so that it would be 3D-printable). So far, I have been able to create the torus itself. I am not sure of how to create the hexagonal pattern on the surface, and the process of mapping it onto the torus.

ParametricPlot3D[{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]},
  {t, 0, 2 Pi}, {u, 0, 2 Pi}]

Answer 1

We can do this by building a regular hexagon tile and wrapping it onto a torus:

hexTile[n_, m_] := 
    With[{hex = Polygon[Table[{Cos[2 Pi k/6] + #, Sin[2 Pi k/6] + #2}, {k, 6}]] &},
        Table[hex[3 i + 3 ((-1)^j + 1)/4, Sqrt[3]/2 j], {i, n}, {j, m}] /. 
            {x_?NumericQ, y_?NumericQ} :> 2 π {x/(3 m), 2 y/(n Sqrt[3])}
    ]

ht = With[{torus = {Cos[#] (3 + Cos[#2]), Sin[#] (3 + Cos[#2]), Sin[#2]} &},
    Graphics3D[hexTile[20, 20] /. Polygon[l_List] :> Polygon[torus @@@ l], Boxed -> False]
]

You can now convert this to a wire frame by changing the polygons to lines or tubes, whichever is convenient for you:

ht /. Polygon[x__] :> {Thick, Line@x}

ht /. Polygon -> Tube

Answer 2

I propose a small modification of the parametrization for the torus that addresses issues with conformality. Try

F[t_, u_, r_] := {Cos[t] (r + Cos[u + Sin[u]/r]),
                  Sin[t] (r + Cos[u + Sin[u]/r]),
                  Sin[u + Sin[u]/r]}

instead. Next, we wish to choose suitable values for $m, n$ for a given $r$ such that the mapping of the regular hexagonal tiling preserves angles as much as possible. We see that this requires us to choose $m, n$ such that $$\frac{\sqrt{3}}{2} \frac{n}{m} = r.$$ As we also require $n$ to be even (or else the tiling does not fit properly on the torus), we can let $n = 2k$ and this gives us $k \sqrt{3} = rm$; thus for a given $r$ we should try to choose $k, m$ as the nearest integers satisfying this equation. This gives us a very nearly angle-preserving tiling. For example, with $r = 2 \sqrt{3}$, we can choose $m = 11$, $n = 44$ to get something that looks like this:

Notice how much more regular the hexagons are throughout the torus--the "inner" ones are not squashed, and the outer ones are not stretched.

---

Addendum. So, the above seems to work reasonably well for large $r$, but when $r = 1 + \epsilon$ for small $\epsilon$, it doesn't work because the mapping I chose is not truly conformal. I found the relevant information here.

This suggests that the correct form of $f$ should be

F[t_, u_, r_] := {Cos[t], Sin[t], Sin[# u]/#} #^2/(r - Cos[# u]) &[Sqrt[r^2 - 1]]

And whereas $t$ is still plotted on the same interval, we need to plot $u$ on $\left(-\frac{\pi}{\sqrt{r^2-1}}, \frac{\pi}{\sqrt{r^2-1}}\right)$. So we modify the plotting command as well:

P[r_, m_, n_] := Graphics3D[Polygon /@ 
     Table[F[4 Pi/(3 n) (Cos[Pi k/3] + i 3/2),
           2 Pi/(Sqrt[3 (r^2 - 1)] m) (Sin[Pi k/3] + (j + i/2) Sqrt[3]), 
           r], {i, n}, {j, m}, {k, 6}], Boxed -> False]

And now the selection of $m, n$ based on $r$ is also more complicated. $n = 2m \sqrt{\frac{r^2 - 1}{3}}$ seems to give good results. Here is a picture for $r = 1.1$, $m = 30$, $n = 20$:

---

This solution calculates exact coordinates. However, for 3D-printing, machine precision is usually enough, and affords a significant speedup. We can force machine arithmetic by adding dots after some of the constants (e.g. 2 Pi to 2. Pi). We can also achieve a 3× speed up by only calculating the location of each vertex once, and using GraphicsComplex to share the locations with each hexagon. (This is how 3D formats like .stl work internally. If you need regular polygon objects to process further, just use Normal to eliminate GraphicsComplex.)

Pfast[r_, m_, n_] := 
 Graphics3D[
  GraphicsComplex[
   Flatten[Table[
     F[2. Pi (i + k/3.)/n, Pi (1. + i + 2 j)/m/Sqrt[r^2 - 1.], 
      r // N], {j, m}, {i, n}, {k, {-1, +1}}], 2], 
   Polygon[Join @@ 
     Table[Mod[(j - 1) (2 n) + {1, 2, 3 + If[i == n, n (n - 2), 0]}~
         Join~({2, 1, If[i == 1, n (2 - n), 0]} + 2 n) + 2 (i - 1), 
       2 n m, 1], {i, n}, {j, m}]]], Boxed -> False]

The code is almost the same as before, except that we now only need to generate two new coordinates for each cell, so Cos[Pi k/3] only takes on two values and Sin[Pi k/3] only takes on one value, allowing the arithmetic to be simplified considerably. We don't need to change F; it's already extremely fast due to the two-stage calculation it does to avoid recomputing the expensive square root multiple times.

We can do a timing and memory usage comparison of the two versions:

ByteCount[P2[2, 50, 100]] // Timing
(* {0.343750, 1440448} *)
ByteCount[P[2, 50, 100]] // Timing
(* {5.921875, 60849648} *)

The numerical version is around 20 times faster and gives a result 40 times smaller. It's actually now fast enough to quickly make a nice table of tori with different parameters:

GraphicsGrid[
 ParallelTable[
  With[{n = 2 Round[m Sqrt[(r^2 - 1)/3]]}, 
   Show[P2[r, m, n], PlotLabel -> {r, m, n}]], {r, {1.1, 1.5, 2, 3, 
    5}}, {m, {6, 10, 15, 20, 30, 50}}], ImageSize -> Full]

Answer 3

There is an explicit formula

n = 30;
m = 10;

f[t_, u_] := {Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]), Sin[u]};

Graphics3D[Polygon /@ Table[
  f[(4 π)/(3 n) (Cos[π k/3] + i 3/2), (2 π)/(Sqrt[3] m) (Sin[π k/3] + (j + i/2) Sqrt[3])], 
    {i, n}, {j, m}, {k, 6}]]

% /. Polygon -> Tube

I find it a bit simpler than rm -rf's solution.

Here f transforms from toroidal coordinates to Cartesian coordinates. Without f it is a plain hexagonal tiling

Graphics[{White, EdgeForm[Black], 
  Polygon /@ Table[{Cos[π k/3] + i 3/2, Sin[π k/3] + (j + i/2) Sqrt[3]}, 
   {i, n}, {j, m}, {k, 6}]}]

Answer 4

As The Toad remarked in a (now deleted) comment, I have had some experience with building hexagonal meshes (after seeing previous work by Mark McClure). In fact, this was one of the reasons why I asked this question on generalizing Partition[]; I wanted to be able to construct a GraphicsComplex[] mesh that is easier to manipulate, and uses up less space than having things as explicit Polygon[]s. Thus, I shall now (partially) reveal how I did one of my earlier Gravatars:

multisegment[lst_List, scts : {__Integer?Positive}, offset : {__Integer?Positive}] :=
             Module[{n = Length[lst], k, offs},
                    k = Ceiling[n/Mean[offset]];
                    offs = Prepend[Accumulate[PadRight[offset, k, offset]], 0];
                    Take[lst, #] & /@ 
                    TakeWhile[Transpose[{offs + 1, offs + PadRight[scts, k + 1, scts]}],
                              Apply[And, Thread[# <= n]] &]] /;
             Length[scts] == Length[offset];

multisegment[lst_List, scts : {__Integer?Positive}] := 
             multisegment[lst, scts, scts] /; Mod[Length[lst], Total[scts]] == 0

hexMesh[{uMin_, uMax_}, {vMin_, vMax_}, {n_Integer, m_Integer}, dirs___] := 
   GraphicsComplex[
           AffineTransform[{DiagonalMatrix[{uMax - uMin, vMax - vMin}/{3 n, Sqrt[3] m}],
                            {uMin, vMin}}] @
           Flatten[Delete[NestList[TranslationTransform[{0, Sqrt[3]}], 
                                   FoldList[Plus, {-1/2, Sqrt[3]/2}, 
                                            Table[Through[{Cos, Sin}[-π Sin[k π/2]/3]],
                                                  {k, 4 n + 1}]], m],
                          {{1, -1}, {-1, 1}}], 1],
           {dirs, 
            Polygon[Flatten[{multisegment[#1, {4, 2}, {3, 1}], 
                             Reverse /@ multisegment[Rest[#2], {2, 4}, {1, 3}]} & @@@ 
                           Partition[Join[{PadRight[Range[4 n + 1], 4 n + 2]}, 
                                     Partition[Range[4 n + 2, m (4 n + 2) - 1], 4 n + 2],
                                     {PadLeft[m (4 n + 2) - 1 + Range[4 n + 1], 4 n + 2]}],
                                      2, 1], {{1, 3}, {2, 4}}]]}]

That's one half of my secret. The other is in the use of a conformal parametrization of the torus. heropup used one particular conformal parametrization in his answer; mine is a touch different (previously used in this answer; see this paper for more details):

flatTorus[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])

Here, then is a conformally parametrized torus on a hexagonal mesh:

With[{s = 21 3, t = 12 Sqrt[3]}, 
     Graphics3D[MapAt[(flatTorus[s, t] @@@ N[#]) &, 
                      hexMesh[{0, s}, {0, t}, {s, t}/{3, Sqrt[3]}], 1],
                Boxed -> False]]

Of course, I need to keep some secrets of my own ;), so let me finish this post with the following picture: