Double Torus

Author

Eric W. Weisstein
February 1, 2012

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Surfaces/DoubleTorus.nb.

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

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

Version 0

eqn=-81*r^8-54*r^7*R+153*r^6*R^2+108*r^5*R^3-63*r^4*R^4-54*r^3*R^5-9*r^2*R^6+171*r^6*x^2+108*r^5*R*x^2+162*r^4*R^2*x^2+108*r^3*R^3*x^2+27*r^2*R^4*x^2-99*r^4*x^4-54*r^3*R*x^4-27*r^2*R^2*x^4+9*r^2*x^6+171*r^6*y^2+114*r^5*R*y^2-161*r^4*R^2*y^2-120*r^3*R^3*y^2-11*r^2*R^4*y^2+6*r*R^5*y^2+R^6*y^2-198*r^4*x^2*y^2-120*r^3*R*x^2*y^2-20*r^2*R^2*x^2*y^2-12*r*R^3*x^2*y^2-2*R^4*x^2*y^2+27*r^2*x^4*y^2+6*r*R*x^4*y^2+R^2*x^4*y^2-99*r^4*y^4-66*r^3*R*y^4+7*r^2*R^2*y^4+12*r*R^3*y^4+2*R^4*y^4+27*r^2*x^2*y^4+12*r*R*x^2*y^4+2*R^2*x^2*y^4+9*r^2*y^6+6*r*R*y^6+R^2*y^6+27*r^6*z^2+252*r^5*R*z^2+270*r^4*R^2*z^2+36*r^3*R^3*z^2-9*r^2*R^4*z^2-54*r^4*x^2*z^2+36*r^3*R*x^2*z^2-18*r^2*R^2*x^2*z^2+27*r^2*x^4*z^2+45*r^4*z^4+90*r^3*R*z^4+9*r^2*R^2*z^4+27*r^2*x^2*z^4+9*r^2*z^6;

POVCoefficients[eqn/. {r->1,R->3}]

ContourPlot3D[eqn/.{r->1,R->3},{x,-6,6},{y,-4,4},{z,-4,4},Contours->{0},Boxed->False,Mesh->None,Axes->None]

Version 1

Show[Graphics3D[Flatten[{#,Map[#{-1,1,1}&,#,{-2}]}&[Flatten[{#,Map[#{1,-1,1}&,#,{-2}]}&[Flatten[{#,Map[#{1,1,-1}&,#,{-2}]}&[Join[ContourPlot3D[(x^2 (x^2/4-1)+y^2)^2+z^2-1/2,{x,0,1.7},{y,0,1.31},{z,0,0.77},PlotPoints->{5,3},MaxRecursion->1,DisplayFunction->Identity][[1]],ContourPlot3D[(x^2 (x^2/4-1)+y^2)^2+z^2-1/2,{x,1.7,2.147},{y,0,1.31},{z,0,0.77},PlotPoints->{5,3},MaxRecursion->1,DisplayFunction->Identity][[1]]]]]]]]]],Boxed->False,ViewPoint->{0.2,-0.4,0.7},BoxRatios->{2.2,1,0.31}]//Timing

Version 2

Graphic

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;

V5

doubleTorus=Module[{f,cp,polys},f=Product[torusImplicit[{x+i,y,z},1,1/4],{i,-5/4,5/4,5/2}]-2;
cp=ContourPlot3D[Evaluate[f],{x,0,3},{y,0,2},{z,0,0.6},PlotPoints->2{24,20,12},MaxRecursion->0,DisplayFunction->Identity];
polys=Cases[cp,_Polygon,{0,Infinity}];
Flatten[{#,Map[#{-1,1,1}&,#,{-2}]}]&[Flatten[{#,Map[# {1,-1,1}&,#,{-2}]}]&[Flatten[{polys,Map[# {1,1,-1}&,polys,{-2}]}]]]];

Show[Graphics3D[{EdgeForm[],doubleTorus}],Boxed->False]//Timing

V6

Table[i,{i,-5/4,5/4,5/2}]

eqn=Times@@(torusImplicit[{x+#(r+R),y,z},R,r]&/@{-1,1})-a^2

FullSimplify[Maximize[{x,(eqn==0/.{y->0,z->0})&&a>0&&r>0&&R>0},{x}],a>0&&r>0&&R>0]

Maximize[{x,a^2+((((-(r^2)+(R^2)))^2)-2 ((r^2)+(R^2)) ((((-r-R+x))^2)+(y^2))+2 (-(r^2)+(R^2)) (z^2)+((((((-r-R+x))^2)+(y^2)+(z^2)))^2)) ((((-(r^2)+(R^2)))^2)-2 ((r^2)+(R^2)) ((((r+R+x))^2)+(y^2))+2 (-(r^2)+(R^2)) (z^2)+((((((r+R+x))^2)+(y^2)+(z^2)))^2))==0&&a>0},{x,y,z}]

With[{R=1,r=1/4,a=(Sqrt[2])},ContourPlot3D[-a^2+((((-(r^2)+(R^2)))^2)-2 ((r^2)+(R^2)) ((((-r-R+x))^2)+(y^2))+2 (-(r^2)+(R^2)) (z^2)+((((((-r-R+x))^2)+(y^2)+(z^2)))^2)) ((((-(r^2)+(R^2)))^2)-2 ((r^2)+(R^2)) ((((r+R+x))^2)+(y^2))+2 (-(r^2)+(R^2)) (z^2)+((((((r+R+x))^2)+(y^2)+(z^2)))^2))==0,{x,-2(r+R),2(r+R)},{y,-(r+R),(r+R)},{z,-r-a,r+a},BoxRatios->Automatic]]

Properties

ImplicitCurvature

GaussianCurvature[eqn,{x,y,z}]

Version 3

ellipsoid[{x_,y_,z_},a_,b_,c_]:=x^2/a^2+y^2/b^2+z^2/c^2-1;
cylinder[{x_,y_,z_},x0_,y0_,r_]:=(x-x0)^2+(y-y0)^2-r^2

oneEighth=ContourPlot3D[Evaluate[ellipsoid[{x,y,z},1,1/2,0.2]*cylinder[{x,y,z},+1/3,0,1/12]*cylinder[{x,y,z},-1/3,0,1/12]+5 10^-3],{x,0,1.01},{y,0,0.51},{z,0,0.21},PlotPoints->{{24,3},{20,3},{16,3}},MaxRecursion->1,PlotRange->All,DisplayFunction->Identity][[1]];//Timing

Show[Graphics3D[{EdgeForm[],Map[Function[x,# x],oneEighth,{-2}]&/@Flatten[Outer[List,{1,-1},{1,-1},{1,-1}],2]}],Boxed->False,PlotRange->All]