The Cover Image

Making the perforated hyperbolic dodecahedron symbolizing Mathematica 4

Michael Trott
Copyright Michael Trott 1998

Outline of the Procedure

Step 1:
We start by building a regular dodecahedron with its center at the origin and with each vertex a unit distance from the origin.

Step 2:
The faces of the dodecahedron are then subdivided into right triangles, each of which is then scaled down a bit 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 surfaces which result will remain comparatively smooth.

Step 4:
All coordinates are transformed by  \(TraditionalForm
      \`r\&⇀⟶r\&⇀\ \(f(r)\)\), where the function f(r) maps each distance from the origin onto a new distance. In particular, f(r) moves the center of each face of the dodecahedron toward the origin but moves the vertices further away, up to a fixed maximum distance. Since f(r) is scalar, this transformation does not change the direction between the origin and each point, just the distance; we'll call it the radial transformation.

Step 5:
Each triangle is given depth by connecting it to a slightly smaller copy moved closer to the origin.

Step 6:
The faces of the resulting body are assigned colors.

Step 1: The Regular Dodecahedron

Show[Polyhedron[Dodecahedron]]

Step 2: Dividing into Triangles

Show[
      Graphics3D[
        Polygon /@ ((Subscript[𝒽, 1]) = SolidToTriangles[Dodecahedron])]]

Show[
      Graphics3D[
        Polygon /@ ((Subscript[𝒽, 2]) = Triangulate[(Subscript[𝒽, 1]), 2])]]

ShrinkTriangles scales each triangle toward its center of gravity—that is, toward the average of its vertices—by a given factor. A scaling factor of 1 means no change; a factor of 1/2 halves the size.

Show[
      Graphics3D[
        Polygon /@ ((Subscript[𝒽, 3]) = ShrinkTriangles[(Subscript[𝒽, 2]), 0.8])]]

Step 3: Subdividing the Triangles

Show[
      Graphics3D[
        Polygon  /@  
          ((Subscript[𝒽, 5  a]) = Subdivide[(Subscript[𝒽, 4]), 4]) ]]

\(Show[
      Graphics3D[
        {{Hue[0], 
            Line /@ \((\ 
                𝒽\_\(5  b\) = 
                  SubdivideEdges[𝒽\_4, 
                    3])\)}, \ \ \ 
			\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {PointSize[ .02], 
            Map[Point, \ 𝒽\_\(5  b\), \ {2}]}}\ ]]\)

Steps 4 and 5: Radial Transformation and Thickening

The next task is to create a function for calculating the radial transformation.

As the following plot shows, this function has one of three different behaviors, depending on the initial distance of a point from the origin. For points nearest the origin, the transformation draws them closer still. All points beyond a certain distance from the origin are moved to a fixed limit. And points between these two ranges are moved away from the origin.

\(\(\(Plot[attract[x, \ 0.6, 0.96, 𝒽\_2], 
      {x, 0.795, 1}, 
	\ \ \ \ \ \ \ \ \ PlotRange -> All, 
      Frame -> True, Axes -> False, PlotStyle -> {Hue[0]}]\)\(;
    \)\)\)

Each polygon has zero thickness, so the ThickenTransform builds solid 3D shapes by matching each polygon with a slightly offset, slightly smaller copy of itself, and then joining the corresponding edges with new polygons.

\(\(\(Show[
      Graphics3D[
        ThickenTransform[
\ \ \ 				Evaluate[
              attract[Sqrt[# . #], 0.6, 0.94, 𝒽\_2]\ #/Sqrt[# . #]] 
            &, 
			\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 𝒽\_4, 𝒽\_\(5\ a\), 𝒽\_\(5\ b\), 0.88, 
          0.6]], 
	\ \ \ \ \ \ \ \ \ \ \ PlotRange -> All, 
      Axes -> True]\)\(;\)\)\)

And here is a cross-section through the resulting surface.

Show[%, PlotRange -> {All, {0, 1}, All}, 
      ViewPoint -> {0, -4, 0}];

Final Assembly and Coloring the Faces Individually

Incorporating the individual functions defined above leads us directly to the function CoverImage.

\(CoverImage[solid_, {n_Integer, m_Integer, ξ_, σ_}, η_, 
        ϕ_] := 

      Module[{l = Length[First[Polyhedron[solid]]], h1, h2, h3, h4a, h4b, 
          h5}, 
h1 = SolidToTriangles[solid]; 
h2 = Triangulate[h1, n]; 

        h3 = ShrinkTriangles[h2, σ]; 
h4a = Subdivide[h3, m]; 

        h4b = SubdivideEdges[h3, m]; 

        h5 = Apply[
            ThickenTransform[
                GG = Evaluate[
                      attract[Sqrt[# . #], η, ϕ, h2]\ #/
                          Sqrt[# . #]] &, ##, ξ, 0.6] &, 

            Transpose[
              {Partition[h3, Length[h3]/l], 
                Partition[h4a, 
                  Length[h4a]/
                    l], \ \ \ \ \ \ \ \ 
						\ \ \ \ \ \ \ \ \ \ \ Partition[h4b, Length[h3]/l]}], {1}]]\)

CoverImage[Dodecahedron,{3,4,0.96,.85},0.6,0.955];

\(\(\(With[
      {colors\  = 
          {0.63, 0.97, 0.7, 0.7, 0.38, 0.15, 0.7, 0.7, 0.7, 0.85, 0.6, 
            0.7}}, 
	
      Show[Graphics3D[
          {EdgeForm[], 
            Thickness[0.00023], \ 
				\ \ \ \ \ \ \ Transpose[
              {\(SurfaceColor[Hue[#, 0.85, 1], Hue[#, 0.2, 1], 3.2] &\) /@ 
                  colors, \ 
						\ \ \ \ \ \ \ \ CoverImage[
                  Dodecahedron, {3, 4, 0.96,  .85}, 0.6, 
                  0.955]}]}], 
\ \ \ \ \ \ \ \ \ 		Boxed -> False, 
        PlotRange -> All, ViewPoint -> {2, \(-3\), 3.3}]]\)\(;
    \)\)\)

By taking out one of the faces, you can have a look inside the previous example.

Show[MapAt[Delete[#, 2] &, %, {1, 3}], 
      ViewPoint -> {0.9206, 0, 0.4604}];

\(\(With[
      {colors\  = 
          {0.63, 0.97, 0.7, 0.7, 0.38, 0.15, 0.7, 0.7, 0.7, 0.85, 0.6, 
            0.7}}, 
	
      Show[Graphics3D[
          {EdgeForm[], Thickness[0.00001], 
            Transpose[
              {\(SurfaceColor[Hue[#, 0.85, 1], Hue[#, 0.2, 1], 3.2] &\) /@ 
                  colors, 
                CoverImage[Dodecahedron, {6, 6, 0.96, 0.85}, 0.6, 
                  0.955]}]}], 
		Boxed -> False, 
        PlotRange -> All, ViewPoint -> {2, \(-3\), 3.3}]]; \)\)

Some Variants

\(\(\(With[{colors\  = Table[Random[], {6}]}, 
	
      Show[Graphics3D[
          {EdgeForm[], Thickness[0.00023], 
            Transpose[
              {\(SurfaceColor[Hue[#, 0.35, 0.8], Hue[#, 0.28, 0.9], 2.7] &\) /@ 
                  colors, 
                CoverImage[Hexahedron, {4, 4, 0.9, 0.9}, 1.4, 
                  1]}]}], 
\ \ \ \ \ \ \ \ \ 		Boxed -> False, 
        PlotRange -> All]]\)\(;\)\)\)

Show[%, PlotRange -> {All, {0, 1.2}, All}, 
        ViewPoint -> {0.3, -2.6, 0.4}];

\(\(\(With[{colors\  = Range[20]/20}, 
	
      Show[Graphics3D[
          {EdgeForm[], GrayLevel[1], Thickness[0.0001], 
            Transpose[
              {\(SurfaceColor[Hue[#, 0.6, 1], Hue[#, 0.7, 0.7], 3.4] &\) /@ 
                  colors, 
                CoverImage[Icosahedron, {3, 3, 0.95, 0.8}, 0.7, 
                  0.99]}]}], 
\ \ \ \ \ \ \ \ 		Boxed -> False, 
        PlotRange -> All, Background -> GrayLevel[0]]]\)\(;\)\)\)

\(\(\(With[{colors\  = Table[0.18, {4}]}, 
	
      Show[Graphics3D[
          {EdgeForm[], Hue[0], Thickness[0.0001], 
            Transpose[
              {\(SurfaceColor[Hue[#], Hue[#], 2.1] &\) /@ colors, 
                CoverImage[Tetrahedron, {3, 3, 0.98, 0.92}, 1.6, 
                  1]}]}], 
\ \ \ \ \ \ \ \ \ \ 		Boxed -> False, 
        PlotRange -> All, Background -> Hue[0.72]]]\)\(;\)\)\)

\(\(\(Module[
      {cv = CoverImage[Tetrahedron, {3, 5, 0.96, 0.86}, 1.6, 1], zMin, zMax, 
        ℛ}, 

      {zMin, zMax} = 
        \({Min[#], Max[#]} &\)[
          Last[Transpose[Level[Cases[cv, _Line, ∞], {\(-2\)}]]]]; 

      ℛ[{x_, y_, z_}] := 
        Module[{φ = \((z - zMin)\)/\((zMax - zMin)\)\ 0.8  π}, 
          {{Cos[φ], Sin[φ], 0}, 
              {\(-Sin[φ]\), Cos[φ], 0}, {0, 0, 1}} . 
            {x, y, 2  z}]; 

      With[{colors\  = Table[0.28, {4}]}, 
	
        Show[Graphics3D[
            {EdgeForm[], Hue[0], Thickness[0.0001], 
              Transpose[
                {\(SurfaceColor[Hue[#], Hue[#], 2.1] &\) /@ colors, 
                  cv /. \((lp : \((Line | Polygon)\))\)[l_] :> 
                      lp[ℛ /@ l]}]}], 
		Boxed -> 
            False, PlotRange -> All, Background -> Hue[0.72]]]]\)\(;
    \)\)\)