Triple Torus

Author

Eric W. Weisstein
July 7, 2009

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Topology/TripleTorus.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/TripleTorus.html.

©2009 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Double torus code by
Michael Trott
V5: July 16, 2002
V6: July 7, 2009

Graphic 1

V5

Needs["Graphics`ContourPlot3D`"]

torusImplicit[{x_, y_, z_}, R_, r_] = (x^2 + y^2 + z^2)^2 - 2(R^2 + r^2) (x^2 + y^2) + 2(R^2 - r^2) z^2 + (R^2 - r^2)^2;

ℛ1 = {{-1, +Sqrt[3], 0}, {-Sqrt[3], -1, 0}, {0, 0, 2}}/2.;
ℛ2 = {{-1, -Sqrt[3], 0}, {+Sqrt[3], -1, 0}, {0, 0, 2}}/2.;

tripleTorus = 
Module[{f, cp, polys, cartPolys, cartPolys1},
(* implicit polynomial *)
f = Product[torusImplicit[{x - 1.5 Cos[i 2Pi/3], 
                           y - 1.5 Sin[i 2Pi/3], z}, 1, 1/4],
            {i, 0, 2}] - 10;
(* contour plot of 1/12th in cylindrical coordinates *)
cp = ContourPlot3D[
Evaluate[f /. {x -> r Cos[φ], y -> r Sin[φ]}],
         {r, 0, 3}, {φ, 0, Pi/3}, {z, 0, 3/4},
         PlotPoints -> {24, 16, 12}, 
         MaxRecursion -> 0, DisplayFunction -> Identity];
polys = Cases[cp, _Polygon, {0, Infinity}];
(* transform into Cartesian coordinates *)
cartPolys = Apply[
 {#1 Cos[#2], #1 Sin[#2], #3}&, polys, {-2}];
cartPolys = Flatten[{#, Map[# {1, 1, -1}&, #, {-2}]}]&[
           Flatten[{cartPolys, Map[# {1, -1, 1}&, cartPolys, {-2}]}]];
(* polygon of the double torus *)
Flatten[{cartPolys, Map[ℛ1.#&, cartPolys, {-2}],
                    Map[ℛ2.#&, cartPolys, {-2}]}]];

Show[Graphics3D[{EdgeForm[Thickness[0.001]], tripleTorus}], 
     Boxed->False,Axes->False];

V6

torusImplicit[{x_,y_,z_},R_,r_]=(x^2+y^2+z^2)^2-2(R^2+r^2) (x^2+y^2)+2(R^2-r^2) z^2+(R^2-r^2)^2;

tripleTorus=Module[{f,cp,polys,cartPolys,cartPolys1},(*implicit polynomial*)f=Product[torusImplicit[{x-1.5 Cos[i 2Pi/3],y-1.5 Sin[i 2Pi/3],z},1,1/4],{i,0,2}]-10;
cp=ContourPlot3D[Evaluate[f==0],{x,-3,3},{y,-3,3},{z,-1/2,1/2},PlotPoints->{24,24,16},MaxRecursion->1,ContourStyle->Directive[Darker[Blue],Specularity[Yellow,16]],Mesh->False,BoxRatios->Automatic]]

Graphic 2

V5

torus[φ1_, φ2_, r1_, r2_] = {r1 + r2, 0, 0} +
        {r1 Cos[φ1] + r2 Cos[φ1] Cos[φ2],
         r1 Sin[φ1] + r2 Sin[φ1] Cos[φ2], r2 Sin[φ2]};

torus[φ1_, φ2_, r1_, r2_] = 
  torus[φ1, φ2, r1, r2] + {(Sqrt[3]/2 - 1) (r1 + r2), 0, 0};

makeSeams[{f_, {{x_, x1_, x2_}, {y_, y1_, y2_}}, {ppx_, ppy_}}] :=
Line /@ {Table[f /. x -> x1, {y, y1, y2, (y2 - y1)/(ppy - 1)}],
         Table[f /. x -> x2, {y, y1, y2, (y2 - y1)/(ppy - 1)}],
         Table[f /. y -> y1, {x, x1, x2, (x2 - x1)/(ppx - 1)}],
         Table[f /. y -> y2, {x, x1, x2, (x2 - x1)/(ppx - 1)}]} // N

ppφ1 = 24; ppφ2 = 24;
parts = (* parametrizations, domains, and plot points *)
{{torus[φ1, φ2, 3, 1], {{φ1, 0, Pi/3}, {φ2, 0, Pi}},
  {ppφ1 + 1, ppφ2 + 1}},
 {torus[Pi/3, φ2, 3, 1] + t {-Sin[Pi/3], Cos[Pi/3], 0},
  {{t, 0, 3}, {φ2, 0, Pi/2}}, {3/2 ppφ1 + 1, ppφ2/2 + 1}},
 {torus[φ1, φ2, 3, 1], {{φ1, Pi/3, Pi}, {φ2, Pi/2, Pi}},
  {2ppφ1 + 1, ppφ2/2 + 1}},
 {(1 - s) (torus[Pi/3, Pi/2, 3, 1] + 
  t {-Sin[Pi/3], Cos[Pi/3], 0}) +
  s torus[Pi/3 + t/3 1/2 Pi, Pi/2, 3, 1], {{t, 0, 3}, {s, 0, 1}},
 {3/2ppφ1 + 1, ppφ2/2 + 1}},
{s {0, 0, 1} + (1 - s) torus[φ1, Pi/2, 3, 1],
 {{s, 0, 1}, {φ1, 5Pi/6, Pi}}, {ppφ1 + 1, ppφ2/2 + 1}}};

polys = Cases[ParametricPlot3D[#1, Evaluate[Sequence @@ #2],
              PlotPoints -> #3, DisplayFunction -> Identity],
              _Polygon, Infinity]& @@@ parts;

seams = makeSeams /@ parts;

ℛ = {{ Cos[2Pi/3], Sin[2Pi/3], 0}, 
     {-Sin[2Pi/3], Cos[2Pi/3], 0}, {0, 0, 1}} // N;

makeAll12Pieces[l_] := (* mirror and rotate *)
   Join[#, Map[{1, 1, -1}#&, #, {-2}]]&[
   Join[#, Map[ℛ.#&, #, {-2}], Map[ℛ.ℛ.#&, #, {-2}]]&[
                      Join[l, Map[{1, -1, 1}#&, l, {-2}]]]]

tripleTorus = {EdgeForm[], Thickness[0.001],
{Map[{SurfaceColor[Hue[Random[]], Hue[Random[]], 2.5], #}&,
     makeAll12Pieces[polys], {-5}]}, makeAll12Pieces[seams]};

Show[Graphics3D[{EdgeForm[], tripleTorus}], Boxed -> False];

g1[{x_, y_, z_}] := 
With[{φ = If[x == 0. && y == 0., 0., ArcTan[x, y]], 
      r = Sqrt[x^2 + y^2]},
     {(1 - Cos[3/2(φ + Pi/3)]^2 Sin[r/8Pi/2]/4) x, 
      (1 - Cos[3/2(φ + Pi/3)]^2 Sin[r/8Pi/2]/4) y, 
      (1 + Exp[-r^2/5]) z}];
      
𝒯[f_] := (pl:(Polygon | Line))[l_] :> pl[f /@ l]

Show[Graphics3D[tripleTorus /. 𝒯[g1]], Boxed -> False];