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.

Symbolics Volume, Chapter 1

Find an implicit polynomial representation for the parametrized surface 𝒮 given by

{x(φ,ϑ),y(φ,ϑ),z(φ,ϑ)}={2 cos(ϑ)+(Subscript[𝒞, 3]^((1)))(φ,ϑ)cos(ϑ),2 sin(ϑ)+(Subscript[𝒞, 3]^((1)))(φ,ϑ) sin(ϑ),(Subscript[𝒞, 3]^((2)))(φ,ϑ)}

{(Subscript[𝒞, 3]^((1)))(φ,ϑ),(Subscript[𝒞, 3]^((2)))(φ,ϑ)}={((cos(φ)+tan(ϑ/4)cos(n φ) )/(1+tan(ϑ/4))),((sin(φ)-tan(ϑ/4)cos(n φ) )/(1+tan(ϑ/4)))}.

Visualize the parametrized and the implicit surface. (The parametrized form is the n=3 version of the hypocycloidal torus from Subsection 2.3.5 of the Graphics volume.)

𝒞[n_][ϑ_, φ_] = {Cos[φ] + Tan[ϑ/4] Cos[n φ],
                 Sin[φ] - Tan[ϑ/4] Sin[n φ]}/(Tan[ϑ/4] + 1);
                      
𝒮[φ_, ϑ_] = {2 Cos[ϑ] + 𝒞[3][ϑ, φ][[1]] Cos[ϑ], 
             2 Sin[ϑ] + 𝒞[3][ϑ, φ][[1]] Sin[ϑ],  𝒞[3][ϑ, φ][[2]]};

Here is the parametrized surface.

(* cut a hole in a polygon *)
makeHole[Polygon[l_], factor_] :=
Module[{mp = Plus @@ l/Length[l], L, nOld, nNew},
 L = (mp + factor(# - mp))& /@ l;
 {nOld, nNew} = Partition[Append[#, First[#]]&[#], 2, 1]& /@ {l, L};
 {MapThread[Polygon[Join[#1, Reverse[#2]]]&, {nOld, nNew}],
  Line /@ nNew}];

Show[Block[{$DisplayFunction = Identity},
      ParametricPlot3D[Evaluate[Append[𝒮[φ, ϑ], {EdgeForm[], Thickness[0.001],
                        SurfaceColor[Hue[φ/(2Pi)], Hue[φ/(2Pi)], 2.2]}]], 
                       {φ, 0, 2Pi}, {ϑ, 0, 2Pi}, PlotPoints -> 37]] /. 
                                     p_Polygon :> makeHole[p, 0.8],
     Boxed -> False, Axes -> False]

To calculate a implicit polynomial version, we write the three coordinates in the form exp(±i φ) and exp(±i ϑ) .

eqs1 = Numerator[Together[{x, y, z} - 𝒮[φ, ϑ]]] /. ϑ -> 4 θ

eqsφϑ = ExpandAll[Numerator[Together[TrigToExp[
          Numerator[Together[{x, y, z} - 𝒮[φ, ϑ]]] /. ϑ -> 4 θ]]]]

Replacing the exponentials with variables yields three equations from which the two parametrization variables X and Y are to be eliminated.

eqsXY = eqsφϑ //. {Exp[α_ φ + β_ θ] :> X^(α/I) Y^(β/I),
                   Exp[α_ φ] :> X^(α/I), Exp[β_ θ] :> Y^(β/I)}

We start by eliminating the variable X because it appears in a lower degree.

{Exponent[eqsXY, X], Exponent[eqsXY, Y]}

res1 = Cases[#, _Plus?(MemberQ[#, x, Infinity]&), Infinity]& @ 
       Factor[Resultant[eqsXY[[1]], eqsXY[[2]], X, Method -> Modular]]

(res2 = Cases[#, _Plus?(MemberQ[#, x, Infinity]&), Infinity]& @ 
       Factor[Resultant[eqsXY[[1]], eqsXY[[3]], X, Method -> Modular]]) //
                                                              Short[#, 5]&

By introducing a new variable YS via (Y^2)=Y, yields two polynomials of degree 4 and 28 in YS. Another call to Resultant yields the desired implicit representation of the hypocycloidal torus. Because of its relatively large size (1792 terms), we display it in abbreviated form only.

{res1a, res2a} = {res1[[1]], res2[[1]]} /. Y -> YS^(1/2);

res3 = Factor[Resultant[res1a, res2a, YS, 
              Method -> Subresultants]/(268435456 x^24)];
{Head[res3], Length[res3], Exponent[res3, {x, y, z}]}

Short[res3, 12]

By using two random points from the parametrized surface, we can quickly check the correctness of the derived implicit form.

res3 /. Block[{φ = Sqrt[Pi], ϑ = 1/E}, (* check to 1000 digits *)
              Rule @@@ Transpose[{{x, y, z}, N[𝒮[φ, ϑ], 1000]}]]

The following plot shows various cross sections of the implicit surface for z=constant.

Show[Table[
ContourPlot[Evaluate[N[res3 /. z -> ζ]], {x, -4, 4}, {y, -4, 4}, 
            ContourStyle -> {{Hue[0.8 ζ/4], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ζ, 4, 0, -4/24}],
     DisplayFunction -> $DisplayFunction]

Here is a similar plot showing various cross sections of the implicit surface for y=constant.

Show[Table[
ContourPlot[Evaluate[N[res3 /. y -> ψ]], {x, -4, 4}, {z, -2, 2}, 
            ContourStyle -> {{Hue[0.8 (ψ + 4)/8], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ψ, -4, 4, 8/32}],
     DisplayFunction -> $DisplayFunction]

res4 = Factor[res3 //. {x -> r Cos[φ], y -> r Sin[φ]}]/r^4;

By making contour plots for φ=constant in a cylindrical coordinate system, we can visualize how the cross section of the hypocycloidal torus changes.

(* change from Cartesian to polar coordinates *)
res4 = Factor[res3 //. {x -> r Cos[φ], y -> r Sin[φ]}]/r^4;

tab = Table[
ContourPlot[Evaluate[N[res4 /. φ -> ϕ]], {r, 0, 4}, {z, -2, 2}, 
            ContourStyle -> {{Hue[0.8 ϕ/(2Pi)], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ϕ, 0, 2Pi (1 - 1/24), 2Pi/24}];
            
Show[Graphics3D[Table[{Thickness[0.002], Hue[k/24],
            Apply[{#1 Cos[k/24 2Pi], #1 Sin[k/24 2Pi], #2}&,
            Cases[Graphics @ tab[[k]], _Line, Infinity], {-2}]},
           {k, 24}]]]

We end with a visualization of the 3D surface using Graphics`ContourPlot3D. We show the whole surface and the surface cut by the z=0-plane and the y=0-plane.

Needs["Graphics`ContourPlot3D`"]

Show[Graphics3D[{EdgeForm[], 
SurfaceColor[Hue[0.12], Hue[0.32], 2.6], 
({#, Map[{1, 1, -1} #&, #, {-2}]}&[Apply[{#1 Cos[#2], #1 Sin[#2], #3}&, 
        Cases[ContourPlot3D[Evaluate[N[res4]], 
                {r, 0, 4}, {φ, 0, 2Pi}, {z, 0, 2},
                MaxRecursion -> 1, PlotPoints -> {{24, 3}, {32, 3}, {12, 3}},
                DisplayFunction -> Identity], _Polygon, Infinity], {-2}]])}] /. 
     p_Polygon :> DeleteCases[makeHole[p, 0.76], _Line, Infinity]]

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {Show[%, PlotRange -> {All, All, {-2, 0}}, ViewPoint -> {0, 0, 5}],
       Show[%, PlotRange -> {All, {-4, 0}, All}, ViewPoint -> {0, 5, 0}]}]]]