This notebook contains additional material to the Mathematica GuideBooks  (Springer-Verlag, New York, 2004) http://www.MathematicaGuideBooks.org . It uses the stylesheet of the Mathematica GuideBooks, which is embedded.

Graphics Volume, Chapter 2

Map (a part of) an aperiodic tiling onto a torus. Then make an animation in which two such tori are rotating and display them together with their three projections into the coordinate planes.

tilingPolys  = 
Module[{order = 4, 𝓈 = Sqrt[2]},
(* subdivision of the rhomb *)
subdivide[Polygon[{p1_, p2_, p3_, p4_}]] :=
Module[{p5, p6, p7, p8, p9, p10}, (* new vertices *)
 p5 = p1 + (𝓈 - 1) (p2 - p1); p6 = p2 + (2 - 𝓈) (p3 - p2);
 p7 = p3 + (𝓈 - 1) (p4 - p3); p8 = p4 + (2 - 𝓈) (p1 - p4);
 p9 = p5 - p1 + p8; p10 = p6 + p7 - p3;
 (* 3 new rhombi and 4 new triangles *)
 Polygon /@ {{p1, p5, p9, p8}, {p3, p7, p10, p6},
             {p2, p9, p4, p10}, {p9, p5, p2},
             {p10, p6, p2}, {p10, p7, p4}, {p9, p8, p4}}];
(* subdivision of the triangle *)
subdivide[Polygon[{p1_, p2_, p3_}]] :=
Module[{p5, p6, p7, p8}, (* new vertices *)
 p4 = p1 + (𝓈 - 1) (p2 - p1);  p5 = p2 + 1/(𝓈 + 2) (p3 - p2);
 p6 = p2 + 1/𝓈 (p3 - p2); p7 = p3 + (𝓈 - 1) (p1 - p3);
 p8 = p6 + p7 - p3;
(* 2 new rhombi and 3 new triangles *)
 Polygon /@ {{p5, p8, p1, p4}, {p3, p7, p8, p6},
             {p5, p4, p2}, {p8, p6, p5}, {p8, p7, p1}}];
(* the initial rhomb *)  
startRhombus = Polygon[{{0, 0}, {2, 0}, {2 + 𝓈, 𝓈}, {𝓈, 𝓈}}/2];
(* polygons of the tesselation *)  
Nest[Flatten[subdivide /@ #]&, N[{startRhombus}], order]];

The next graphic shows the resulting list of triangles and quadrilaterals. The pairs of triangles facing each other along their longest side form one quadrilateral of the tiling. The left edge of the patch adjoins to its the right edge. To fit upper edge to the lower we slightly shift the patch to the right with increasing y-values. We map the resulting list of polygons polys1 onto a torus.

Show[Graphics[Function[p, 
              With[{mp = Plus @@ p[[1]]/Length[p[[1]]], f = 0.8},  
                   Polygon[mp + f (# - mp)& /@ p[[1]]]]] /@ 
     (tilingPolys1 = Apply[{#1 + (1 - Sqrt[2]/2)#2/(Sqrt[2]/2), Sqrt[2] #2}&, 
      N[tilingPolys], {-2}])],   AspectRatio -> Automatic, Frame -> True]

The function toTorus parametrizes a torus. By interpreting the {x,y}-coordinates of tilingPolys1 as φ1- and φ2-values (for fixed r and R), we map the tiling onto the torus.

(* mapping from plane to a torus *)  
toTorus[φ_, ϑ_, R_, r_] = {R Cos[φ] + r Cos[φ] Cos[ϑ], 
                           R Sin[φ] + r Sin[φ] Cos[ϑ], r Sin[ϑ]};

The function polygonToTorus cuts holes and colors the mapped polygons from the list tilingPolys1 to the torus. We color the triangles different from the quadrilaterals. In addition, we keep a copy of the 3D polygons without the holes in the expression C[…].

(* the quadrilateral *)
polygonToTorus[Polygon[{p1_, p2_, p3_, p4_}]] := 
Module[{mp = (p1 + p2 + p3 + p4)/4, f = 0.6, λ, q1, q2, q3, q4,
        sf = Sequence[SurfaceColor[RGBColor[1, 0.06, 0.1], 
                                   RGBColor[1, 0.06, 0.1], 2.5],
                      EdgeForm[], GrayLevel[0], Thickness[0.001]]},  
       (* inner points *)
       {q1, q2, q3, q4} = (mp + f (# - mp))& /@ {p1, p2, p3, p4};
       {C[sf, Polygon[{p1, p2, p3, p4}], Line[{p1, p2, p3, p4, p1}]],
       (* contracted polygons *)
        {sf, Polygon /@ {{p1, p2, q2, q1}, {p2, p3, q3, q2}, 
                         {p3, p4, q4, q3}, {p4, p1, q1, q4}},
         Line[{p1, p2, p3, p4, p1}], Line[{q1, q2, q3, q4, q1}]}}]

(* the triangle *)
polygonToTorus[Polygon[{p1_, p2_, p3_}]] := 
Module[{mp = (p2 + p3)/2, f = 0.6, q1, q2, q3,
        sf = Sequence[SurfaceColor[RGBColor[1, 0.66, 0.14], 
                                   RGBColor[1, 0.66, 0.14], 2.5],
                      EdgeForm[], GrayLevel[0.2], Thickness[0.001]]},  
       (* inner points *)
       {q1, q2, q3} = (mp + f (# - mp))& /@ {p1, p2, p3};
       {C[sf, Polygon[{p1, p2, p3}], Line[{p2, p1, p3}]],
        (* contracted polygons *)
        {sf, Polygon /@ {{p1, p2, q2, q1}, {p2, p3, q3, q2}, 
                         {p3, p1, q1, q3}},
         Line[{p2, p1, p3}], Line[{q2, q1, q3}]}}]

The function coloredTorusPolys maps the polygons polys1 to the torus. The variable ω determines the relative orientation of the tiling on the torus and by varying ω, the torus effectively rotates. We chose the radii R and rso that we can interlock the tori without intersections.

(* the polygons of the torus *)  
coloredTorusPolys[polys_, ω_] := polygonToTorus /@   
Apply[toTorus[2Pi #1 + N[ω], 2Pi #2 + N[ω], 3, 11/8]&, polys, {-2}];

Here are two pictures of the resulting tori for two values of ω.

Show[GraphicsArray[
     Graphics3D[DeleteCases[coloredTorusPolys[tilingPolys1, #], 
                       _C, Infinity], Boxed -> False]& /@ {0, Pi/2}]]

The function coloredTorusPairPolys makes two orthogonal tori. We rotate the two tori by an angle ω around the y- and z-axes.

coloredTorusPairPolys[polys_, ω_] := 
Module[{aux = coloredTorusPolys[polys, ω],
        (* rotation matrix *)
        ℛ = N[{{Cos[ω], Sin[ω], 0}, {-Sin[ω], Cos[ω], 0}, {0, 0, 1}}.
              {{Cos[ω], 0, Sin[ω]}, {0, 1, 0}, {-Sin[ω], 0, Cos[ω]}}]},
       (* shift and change orientation *)       
       {aux  /. (pl:(Polygon | Line))[l_] :> pl[{#1, #2 - 3/2, #3}& @@@ l],
        aux  /. (pl:(Polygon | Line))[l_] :> pl[{#3, #1 + 3/2, #2}& @@@ l]} /.
       (* rotate *) (pl:(Polygon | Line))[l_] :> pl[ℛ.#& /@ l]];

Show[Graphics3D[DeleteCases[
     coloredTorusPairPolys[tilingPolys1, Pi/4], _C, Infinity]], Axes -> True];

It remains to implement the projections of the torus into the coordinate planes. The function projectedPolygon does this. Instead of calculating true projections and explicitly calculating the visible polygons, the function projectedPolygon effectively calculates squinched version of the torus with a finite thickness so small that they effectively appear two-dimensional.

projectedPolygon[torusPolys_] := 
Module[{𝓅 = torusPolys, L = 8, ε = 10^-8},
(* projection into the y-z-plane *)
xP = Map[If[Head[#] === List, 
            {-L + 100 ε + ε #[[1]], #[[2]], #[[3]]}, #]&, 𝓅, {-2}];
(* projection into the x-z-plane *)
yP = Map[If[Head[#] === List, 
            {#[[1]], +L - 100 ε - ε #[[2]], #[[3]]}, #]&, 𝓅, {-2}]; 
(* projection into the x-y-plane *)
zP = Map[If[Head[#] === List, 
            {#[[1]], #[[2]], -L + 100 ε + ε #[[3]]}, #]&, 𝓅, {-2}];
(* projection plane polygons *)
cornerPolys = Polygon /@ 
{{{-L, -L, -L}, { L, -L, -L}, { L, L, -L}, {-L,  L, -L}},
 {{-L,  L, -L}, { L,  L, -L}, { L, L,  L}, {-L,  L,  L}},
 {{-L, -L, -L}, {-L,  L, -L}, {-L, L,  L}, {-L, -L,  L}}};
(* color all polygons *)
{{SurfaceColor[RGBColor[0.70, 0.06, 0.63], 
               RGBColor[0.66, 0.52, 0.89], 4], cornerPolys}, 
 (* reverse colors in projections *)
 {xP /. RGBColor[r_, g_, b_] -> RGBColor[1 - r, 1 - g, 1 - b], 
  yP /. RGBColor[r_, g_, b_] -> RGBColor[1 - g, 1 - b, 1 - r], 
  zP /. RGBColor[r_, g_, b_] -> RGBColor[1 - b, 1 - r, 1 - g]} /. 
                              GrayLevel[x_] -> GrayLevel[1 - x]}]

The function torusGraphics3D finally assembles all functions together and, for a given value of ω, generates one frame of the animation.

torusGraphics3D[ω_, opts___] := 
Module[{(* polygons on the torus *) 
        aux = coloredTorusPairPolys[tilingPolys1, ω]},
Graphics3D[{DeleteCases[aux, _C, Infinity], 
             (* the three projections *)
             projectedPolygon[List @@@ Cases[aux, _C, Infinity]]},
           opts, Boxed -> False, ViewPoint -> {3, -3, 2},
           PlotRange -> 8.3 {{-1, 1}, {-1, 1}, {-1, 1}}]]

Here is the resulting animation.

frames = 5;
Show[GraphicsArray[##]]& /@ Partition[
Table[torusGraphics3D[ω], {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}], 3]

frames = 90;
Do[Show[torusGraphics3D[ω]], {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}]

Another aperiodic pattern suited for mapping onto a torus is the labyrinth tiling [✶], [✶]. Here is the labyrinth tiling of order six shown. The three occurring polygon shapes are colored in red, green, and blue.

labyrinthPolygons[order_Integer?Positive] := labyrinthPolygons[order] = 
Module[{abChain, grid1D, grid2D},
 (* chain of two symbols from iterating a substitution *)
 abChain = Flatten[Nest[(# /. {a -> {b}, b -> {b, a, b}})&, {a}, order]];
 (* 1D grid *)
 grid1D = FoldList[Plus, 0, abChain /. {a -> 1, b -> GoldenRatio}];
 (* 2D tensor product grid *)
 grid2D = Outer[List, grid1D, grid1D];
 (* place polygons around odd-odd vertices  *)
 Flatten @ Table[If[(-1)^(i + j) === 1, {},
                    Polygon[{grid2D[[i + 1, j]], grid2D[[i, j + 1]], 
                             grid2D[[i - 1, j]], grid2D[[i, j - 1]]}]],
                 {i, 2, Length[grid1D] - 1}, {j, 2, Length[grid1D] - 1}]];

(* color according to number of different edges *)
colorQuadrilateral[p:Polygon[l_]] := {Hue[Length[Union[#.#& /@ 
   (Subtract @@@ Partition[Append[l, First[l]], 2, 1])]]/3], p}

Show[Graphics[colorQuadrilateral /@ labyrinthPolygons[6]],
     PlotRange -> All, AspectRatio -> Automatic, Frame -> True,
     FrameTicks -> False];

We now use three copies of the labyrinth tiling of order five and map it onto a torus.

quadrilaterals = labyrinthPolygons[5];
(* translation length *)
λ = Sort[Union[Level[quadrilaterals, {4}]], #1 < #2&][[-2]];
torusPattern = 
 Flatten[Table[Map[(k {λ, 0} + #)&, Flatten[quadrilaterals], {3}], {k, 0, 2}]];

Show[Graphics[colorQuadrilateral /@ torusPattern],
     PlotRange -> All, AspectRatio -> Automatic, 
     Frame -> True, FrameTicks -> None];

(* extension in x- and y-direction *)
{xM, yM} = Sort[Union[#], #1 < #2&][[-2]]& /@ 
                    Transpose[Expand[Level[torusPattern, {3}]]];
toφ1φ2Coordinates[{x_, y_}] := Sequence @@ (2Pi {x/xM, y/yM});

quadrilateral3DColor[p_Polygon] := 
             SurfaceColor[#, #, 2.6]& @ colorQuadrilateral[p][[1]]

Show[Graphics3D[{EdgeForm[{Thickness[0.0001]}], quadrilateral3DColor[#], 
   Map[toTorus[toφ1φ2Coordinates[#], 3, 1]&, #, {2}]}& /@ 
       torusPattern], Boxed -> False]