The Cover Image

Making the Escher-style hyperbolic dodecahedron symbolizing Mathematica 5

Michael Trott
Copyright Michael Trott 2003

Outline of the Procedure

Step 1:
We construct a regular dodecahedron centered at the origin.

Step 2:
The faces of the dodecahedron are then subdivided into right triangles (similar to M. C. Escher’s Quadratlimit work), each of which is then scaled down so that gaps are introduced between them.

Step 3:
Each triangle is further subdivided so that, when the surfaces are transformed in the next step, the resulting surfaces are relatively smooth.

Step 4:
Outlines of all triangles are constructed.

Step 5:
A radial transformation is applied to each triangle. Then each triangle is given depth by connecting it to a slightly smaller copy moved closer to the origin.

Step 1: The Regular Dodecahedron

Show[Polyhedron[Dodecahedron]];

Step 2: Dividing into Triangles

SolidToTriangles[solid_] := 
      With[{f = 
            Length[Faces[
                  solid][[1]]]}, 
        Flatten[Function[
              l, ({Polygon[{#[[1]], #[[2]], 
                          Plus @@ l[[1]]/f}]} &) /@ Partition[
                  Append[l[[1]], 
                    First[l[[1]]]], 2, 
                  1]] /@ Polyhedron[
                solid][[1]]]];

Show[
        Graphics3D[(Subscript[𝒽, 1]) = 
            SolidToTriangles[Dodecahedron]]];

Step 3: Subdividing the Triangles

TriangulatedTriangle = Polygon[Append[#, 
                  0] &  /@  #] & /@ ({{{0, 
                  0}, {-2, -2}, {0, -4}}, {{0, -4}, {-4, -4}, {-2, -2}}, {{0, 
                  0}, {0, -4}, {2, -2}}, {{0, -4}, {2, -2}, {4, -4}}, {{-4, -4}, {-5, -5}, {-4, -6}}, {{-4, -6}, {-6, -6}, {-5, -5}}, {{0, -4}, {-2, -4}, {-2, -6}}, {{0, -4}, {-1, -5}, {0, -6}}, {{0, -6}, {-2, -6}, {-1, -5}}, {{-4, -4}, {-2, -4}, {-2, -6}}, {{-4, -4}, {-3, -5}, {-4, -6}}, {{-4, -6}, {-2, -6}, {-3, -5}}, {{4, -4}, {2, -4}, {2, -6}}, {{4, -4}, {3, -5}, {4, -6}}, {{4, -6}, {2, -6}, {3, -5}}, {{0, -4}, {2, -4}, {2, -6}}, {{0, -4}, {1, -5}, {0, -6}}, {{0, -6}, {2, -6}, {1, -5}}, {{4, -4}, {4, -6}, {5, -5}}, {{4, -6}, {5, -5}, {6, -6}}}/6);

Show[Graphics3D[TriangulatedTriangle]];

MapTo3DTriangle[Polygon[{p1_, p2_, p3_}]] := 
      Module[{mp = (p1 + p2)/2, dirx, diry}, diry = p3 - mp; 
        dirx = p1 - mp; 
        Map[p3 + #[[1]] dirx + #[[2]] diry &, 
          N[TriangulatedTriangle], {-2}]]

Show[
      Graphics3D[(Subscript[𝒽, 2]) = 
          Polygon /@ (N[
                First /@ Flatten[
                    MapTo3DTriangle /@ Take[(Subscript[𝒽, 1]), All]]])], 
      PlotRange -> All, Axes -> False];

Steps 4: Triangle Edge Construction

TriangleBorders[{plato_,  
          lateralContractionFactor_, {δppl_, ppq_}}, 
        Polygon[{p1_, p2_, 
            p3_}]] := 
Module[{mp =  (p1 + p2 + p3)/3, 
          p1i, p2i, p3i, 
          ppl}, {p1i, p2i, 
            p3i} = (mp + 
                  lateralContractionFactor (# - mp) &) /@ {p1, p2, 
              p3}; 
ppl = 
          Ceiling[(1/δ)ppl 
              Max[(Sqrt[# . #]) & /@ 
                  Apply[Subtract, 
                    Partition[{p1i, p2i, p3i, p1i}, 2, 
                      1], {1}]]]; 
{Apply[
            Function[{q1, q1i, q2i, 
                q2}, Function[pn, 
                  Table[Polygon[{pn[[i, 
                          j]], 
                        pn[[i + 1, j]], 
                        pn[[i + 1, 
                          j + 1]], 
                        pn[[i, 
                          j + 1]]}], {i, ppl}, {j, 
                      ppq}]][
                Table[q1 + ((ix (q2 - q1))/ppl) + (((1 - ix/ppl) iy (q1i - q1))/ppq) + ((ix iy (q2i - q2))/(ppl ppq)), {ix, 0, 
                    ppl}, {iy, 0, ppq}]]], {{p1, p1i, p2i, p2}, {p2, p2i, 
                p3i, p3}, {p3, p3i, p1i, p1}}, {1}], 
          Line[Join @@ (Table[#[[1]] + ((i (#[[2]] - #[[1]]))/ppl), {i, 0, 
                        ppl}] &) /@ {{p1i, p2i}, {p2i, p3i}, {p3i, 
                    p1i}}]}]

Show[
      Graphics3D[{EdgeForm[],  (Subscript[𝒽, 3]) = 
            Transpose[TriangleBorders[{Dodecahedron, 
                      0.8, {0.08, 
                        1}}, #] & /@ (Subscript[𝒽, 2])]}]];

Steps 5: Radial Transformation and Thickening

attract[r_] := 
        Re[(1/2) (ArcSin[2 r - 1] + (π/2))];
makeContractFunction[] := (
contract[x_] = 
            Module[{xMin, xMax, xm, 
                dx}, {xMax, 
                  xMin} = (Sqrt[({Max[#], Min[#]} &)])[(# . # &) /@ Level[(Subscript[𝒽, 2]), {-2}]]; 
              attract[((x - xMin)/(xMax - xMin))]]);
makeContractFunction[];
contract[
          x_List] := ((x contract[(Sqrt[x . x])])/(Sqrt[x . x]));

Plot[contract[x], {x, 0.7, 1.2}, Frame -> True, 
      Axes -> False, PlotRange -> All];

Show[Graphics3D[Map[contract, (Subscript[𝒽, 2]), {-2}]], 
      PlotRange -> All, Axes -> False];

Hyperbolicize[f_, {polys_, edges_}, radialContractionFactor_] := 
      Module[{l = First /@ Map[f, edges, {-2}], 
          p = First /@ Map[f, Flatten[polys], {-2}], outerPolys, 
          innerPolys, radialPolys, outerEdges, innerEdges}, 
        outerPolys = Polygon /@ p; 
        innerPolys = 
          Polygon /@ Map[radialContractionFactor #1 &, p, {-2}]; 
        radialPolys = 
          Polygon /@ (Join[#[[1]], 
                    Reverse[#[[2]]]] &) /@ Transpose[{Flatten[(Partition[#, 2, 1] &) /@ l, 1], 
                  Flatten[(Partition[#1, 2, 1] &) /@ 
                      Map[radialContractionFactor #1 &, l, {-2}], 
                    1]}]; {outerPolys, innerPolys, 
          radialPolys}];

(Subscript[𝒽, 4]) = 
      Hyperbolicize[contract, (Subscript[𝒽, 3]), 0.9];

CoverGraphicsMathematicaV5 = 
      Show[Graphics3D[{EdgeForm[], 
            SurfaceColor[Hue[0.08], Hue[0.12], 2.4], (Subscript[𝒽, 4])}], 
        PlotRange -> All, Boxed -> False];

A Variant

(Subscript[𝒽, 1]) = SolidToTriangles[Hexahedron];
(Subscript[𝒽, 2]) = 
        Polygon /@ (N[
              First /@ Flatten[
                  MapTo3DTriangle /@ 
                    Take[(Subscript[𝒽, 1]), All]]]);
 (Subscript[𝒽, 3]) = 
        Transpose[TriangleBorders[{Hexahedron, 
                  0.8, {0.08, 1}}, #] & /@ (Subscript[𝒽, 2])];
makeContractFunction[];
(Subscript[𝒽, 4]) = 
        Hyperbolicize[contract, (Subscript[𝒽, 3]), 0.9];

rainbowColor[
        p : Polygon[l_]] := {(SurfaceColor[#, #, 2.2] &)[
          Hue[2 (Sqrt[ # . #]) &[Plus @@ (l/Length)[l]]/π]], 
        p}

Show[Graphics3D[{EdgeForm[], rainbowColor /@ Flatten[(Subscript[𝒽, 4])]}], 
      PlotRange -> All, Boxed -> False];