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

A possible 2D generalization of the classical Minkowski function from the triangles {{0,0},{1,0},{1,1}} into the triangle {{0,0},{1,0},{1,1}} is based on the following construction [✶], [✶]: Start with two copies of the triangle {{0,0},{1,0},{1,1}} and recursively subdivide them into six new triangles by inserting a new point along each edge and one point in the interior. The four new points (Subscript[p, 1])⊕(Subscript[p, 2]), (Subscript[p, 1])⊕(Subscript[p, 3]), (Subscript[p, 2])⊕(Subscript[p, 2]), and (Subscript[p, 1])⊕(Subscript[p, 2])⊕(Subscript[p, 3]), are calculated through the generalized additions (Subscript[⊕, F/B]) of the three vertices (Subscript[p, 1]), (Subscript[p, 2]), and (Subscript[p, 3])(with rational coordinates {(Subscript[p, i x])/(Subscript[r, i ]),(Subscript[p, i y])/(Subscript[r, i ])} ) of a triangle according to two possible rules:

a) the Farey addition (Subscript[⊕, F]):

{((Subscript[p, i x])/(Subscript[r, i ])),((Subscript[p, i y])/(Subscript[r, i ]))}(Subscript[⊕, F]){((Subscript[p, j x])/(Subscript[r, j])),((Subscript[p, j y])/(Subscript[r, j]))}={(((Subscript[p, i x])+(Subscript[p, j x]))/((Subscript[r, i ])+(Subscript[r, j]))),(((Subscript[p, i y])+(Subscript[p, j y]))/((Subscript[r, i ])+(Subscript[r, j])))}

a) the Bary addition (Subscript[⊕, B]):

{((Subscript[p, i x])/(Subscript[r, i ])),((Subscript[p, i y])/(Subscript[r, i ]))}(Subscript[⊕, B]){((Subscript[p, j x])/(Subscript[r, j])),((Subscript[p, j y])/(Subscript[r, j]))}={(1/2)(((Subscript[p, i x])/(Subscript[r, i ]))+((Subscript[p, j x])/(Subscript[r, j]))),(1/2)(((Subscript[p, i y])/(Subscript[r, i ]))+((Subscript[p, j y])/(Subscript[r, j])))}

and both additions being associative (Subscript[p, 1])(Subscript[⊕, F/B])(Subscript[p, 2])(Subscript[⊕, F/B])(Subscript[p, 3])=((Subscript[p, 1])(Subscript[⊕, F/B])(Subscript[p, 2]))(Subscript[⊕, F/B])(Subscript[p, 3]).

The 2D Minowski map is then the limit n->∞ of the map, that maps the two sets of identically ordered triangles after n subdivisions into each other.

For n=4 or n=5, embed the map from the first triangle into the second in (ℝ^4) and make an animation showing projections of the resulting surface projected into 3D.

FareyPlus[ps_List] := 
Module[{dens = Max /@ Denominator[ps], nums},
        nums = MapThread[Times, {dens, ps}];
      {Plus @@ (First /@ nums), Plus @@ (Last /@ nums)}/(Plus @@ dens)]

BaryPlus[ps_List] := {Plus @@ (First /@ ps), Plus @@ (Last /@ ps)}/Length[ps]

Next, given an triangle, we define its splitting into six new triangles according to the described rule.

sixNewTriangles[plus_, Polygon[{p1_, p2_, p3_}]] :=
Module[{p12 = plus[{p1, p2}], p13 = plus[{p1, p3}], p23 = plus[{p2, p3}],
        p123 = plus[{p1, p2, p3}]},
        Polygon /@ {{p1, p12, p123}, {p12, p2, p123}, {p2, p23, p123},
                    {p23, p3, p123}, {p3, p13, p123}, {p13, p1, p123}}]

Here are the first few recursive subdivisions in superimposed form for the Farey and the Bary addition.

With[{o = 4},
Show[GraphicsArray[
Function[plus, Graphics[{MapIndexed[{Hue[0.8 (#2[[1]] - 1)/(o + 1)], 
          Thickness[0.025 - 0.025 (#2[[1]] - 1)/o], #}&, 
          NestList[Flatten[sixNewTriangles[plus, #]& /@ #]&, 
                   {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, o]] /. 
                 Polygon[l_] :> Line[Append[l, First[l]]]}, 
             AspectRatio -> Automatic, Frame -> True, 
             FrameTicks -> False]] /@ {FareyPlus, BaryPlus}]]];

To better see the complicated structure of the triangulations, we color the triangles according to their smallest angles.

𝓃 = #/Sqrt[#.#]&;

minMaxAngles[Polygon[{p1_, p2_, p3_}]] := 
Module[{n12 = 𝓃[p2 - p1], n13 = 𝓃[p3 - p1], n23 = 𝓃[p3 - p2]},
       {Min[#], Max[#]}& @ ArcCos[{n12.n13, n12.n23, n13.n23}]]

angleColoredGraphics[polys_] := 
Module[{allAngles = minMaxAngles /@ N[polys], minAngle, maxAngle},
       {minAngle, maxAngle} = {Min[#], Max[#]}& [First /@ allAngles];
       Graphics[{Transpose[{Hue /@ (0.78 ((First /@ allAngles) - minAngle)/
                                      (maxAngle - minAngle)), polys}]},
                AspectRatio -> Automatic, Frame -> False]]

With[{o = 5},
Show[GraphicsArray[Function[plus, 
angleColoredGraphics[Nest[Flatten[sixNewTriangles[plus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, o]]] /@ {FareyPlus, BaryPlus}]]]

Next, we construct the triangles for the animation. These are the two sets of Farey and Bary triangles in identical order.

order = 4;
trianglesFarey = Nest[Flatten[sixNewTriangles[FareyPlus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, order];

trianglesBary = Nest[Flatten[sixNewTriangles[BaryPlus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, order];

By joining the coordinates of the Farey and Bary triangle, we embed them into (ℝ^4).

to4DTriangle[{Polygon[{p1_, p2_, p3_}], Polygon[{q1_, q2_, q3_}]}] :=
              Polygon[{Join[p1, q1], Join[p2, q2], Join[p3, q3]}]

triangles4D = to4DTriangle /@ Transpose[{trianglesFarey, trianglesBary}];

The function project projects the triangles triangles4D into a 3D subspace orthogonal to vector.

project[triangles4D_, vector_] := 
Module[{v4 = 𝓃[vector], v3 = 𝓃[Table[Random[], {4}]],
        v2 = 𝓃[Table[Random[], {4}]], v1 = 𝓃[Table[Random[], {4}]]},
       v3 = 𝓃[v3 - v3.v4 v4];
       v2 = 𝓃[v2 - v2.v4 v4 - v2.v3 v3];
       v1 = 𝓃[v1 - v1.v4 v4 - v1.v3 v3 - v1.v2 v2];
      Map[{v1.#, v2.#, v3.#}&, triangles4D, {3}]]

Here are three random projections.

Show[GraphicsArray[
Table[SeedRandom[k];
     Graphics3D[project[triangles4D, Table[Random[Real, {-1, 1}], {4}]], 
                BoxRatios -> {1, 1, 1},  PlotRange -> All], {k, 3}]]];

For the animation, we want a smooth dependence of the projection subspace from the animation parameter. And to obtain a variety of views on the surface, we use a parametrization through 4D rotation matrices similar to the ones used in Solution 21a) of the second chapter of the Graphics volume.

(* all principle projections *)
reImPathList4D = {{1, 2, 3, 4}, {1, 2, 4, 3}, {1, 4, 2, 3},
                  {3, 4, 2, 1}, {3, 4, 1, 2}, {3, 2, 1, 4}, {1, 2, 3, 4}};

(* construct parametrized rotation matrix that rotates from aL to bL *)
makeTransitionMatrix[{aL_, bL_}, φ_] := 
Module[{m = Table[0, {4}, {4}], c = Cos[φ], s = Sin[φ],
        𝒻 = Function[{𝓂, v}, If[𝓂 === 0, 𝓂 = v], {HoldAll}]},
 (* set rotation matrix elements *)
 Do[{i, j} = {aL[[k]], bL[[k]]}; 
   If[i == j, m[[i, i]] = 1, 𝒻[m[[i, i]],  c]; 𝒻[m[[j, j]], c]; 
                             𝒻[m[[i, j]], -s]; 𝒻[m[[j, i]], s]], 
     {k, 4}]; m]

(* list of rotation matrices *)
ℛs = 
Module[{framesPerSubRotation = 18, 𝓇1, 𝓇2},
  (* all Pi/2 rotations *)
  𝓇1 = makeTransitionMatrix[#, φ]& /@ Partition[reImPathList4D, 2, 1];
  (* cumulative rotation matrix *)
  𝓇2 = FoldList[#1.#2&, IdentityMatrix[4], 𝓇1 /. φ -> Pi/2];
  Table[(* form subrotation matrices *) Table[𝓇2[[k]].𝓇1[[k]], 
                     {φ, 0, Pi/2, Pi/2/framesPerSubRotation}],
        {k, Length[reImPathList4D] - 1}] // Flatten[#, 1]& // N];

Here are some of the resulting views in the 2D Minkowski function.

Show[GraphicsArray[#]]& /@ Partition[
Function[ℛ, Graphics3D[Map[Most[ℛ.#]&, triangles4D, {3}], BoxRatios -> {1, 1, 1},
                  PlotRange -> All]] /@ ℛs[[{1, 27, 43, 54, 69, 106}]], 3]

Here is the corresponding animation.

Function[ℛ, Show[Graphics3D[Map[Most[ℛ.#]&, triangles4D, {3}], BoxRatios -> {1, 1, 1},
                  PlotRange -> All]]] /@ ℛs