Toric Section

Author

Eric W. Weisstein
December 9, 2002

This notebook downloaded from http://mathworld.wolfram.com/notebooks/SolidGeometry/ToricSection.nb.

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

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

Plot

ImplicitPlot3D[(x^2+z^2+c^2)^2==4c^2(x^2+r^2) /. c->1,{x,-3,3},{z,-2,2},{r,-2,.4},PlotPoints->30]

(*
rotm::Singular="Singular value ArcTan[0,0] encounted: (`1`,`2`,`3`)";

rotm[{x_,y_,z_}]:=Module[{a,b,eps=.0001},If[Sqrt[N[y^2+z^2]]<eps&&Abs[N[x]]<0,Message[rotm::Singular,x,y,z],{a,b}={If[Abs[N[y]]<eps&&Abs[N[z]]<eps,0,ArcTan[z,y]],ArcTan[Sqrt[y^2+z^2],x]};
{{Cos[b],0,-Sin[b]},{0,1,0},{Sin[b],0,Cos[b]}}.{{1,0,0},{0,Cos[a],-Sin[a]},{0,Sin[a],Cos[a]}}]]

feq[x_,y_,eps_:10^-10]:=Plus@@Abs[x-y]<eps

ToricSection[{aa_,cc_},{a_,b_,c_,d_}]:=Module[{vec={a,b,c},rot,zs,flat,poly},
poly={x,y,z}/.Simplify[Solve[{(cc-Sqrt[x^2+y^2])^2+z^2==aa^2,a x+b y +c z+d==0} ,{x,y}]];
If[feq[vec,0],Print["Unable to find normal vector"];Return[]];
Take[#,2]&/@(rotm[vec].#&/@poly)
]
*)

ToricSection[{aa_,cc_},{a_,b_,c_,d_}]:=(y^2-aa^2+cc^2+x^2+(-(a x+b y +d)/c)^2)^2==4cc^2(y^2+x^2)

Parallel to xy-Plane

Show[GraphicsArray[{
ImplicitPlot[ToricSection[ {1,2},{0,0,1,0}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,0,1,.7}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,0,1,.9}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,0,1,.99}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}]}],DisplayFunction->$DisplayFunction]

Export["Phosphine:MathOzTeX:gifs:toricz.gif",Table[ImplicitPlot[ToricSection[ {1,2},{0,0,1,yy}],{y,-5,5},AspectRatio->Automatic,Ticks->None,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],{yy,.001,1,.0499}],
"GIF",AnimationDirection->ForwardBackward,DisplayTime->.1]

Oblique

Show[GraphicsArray[{
ImplicitPlot[ToricSection[ {1,2},{0,.27,1,.5}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,.5,1,.5}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,.8,1,.5}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],
ImplicitPlot[ToricSection[ {1,2},{0,1,1,.5}],{x,-3,3},AspectRatio->Automatic,Ticks->None,DisplayFunction->Identity,PlotRange->{{-3.1,3.1},{-3.1,3.1}}]}],DisplayFunction->$DisplayFunction]

Export["Phosphine:MathOzTeX:gifs:torico.gif",Table[ImplicitPlot[ToricSection[ {1,2},{0,yy,1,.5}],{x,-3,3},AspectRatio->Automatic,
PlotPoints->50,Ticks->None,PlotRange->{{-3.1,3.1},{-3.1,3.1}}],{yy,.01,1.6,.05}],"GIF",AnimationDirection->ForwardBackward,DisplayTime->.1]

Close to (and exactly a) lemniscate

Equation of a torus:

Entity["Surface","Torus"]["CartesianEquation"][a,c][x,y,z]

Manipulate[ContourPlot[(((c-(Sqrt[(x^2)+(y^2)])))^2)+(z^2)==(a^2),{x,-2,2},{z,-2,2}],{c,.1,1},{a,.1,1},{y,0,1}]

Take y==c-a, which is tangent to the inner circumference:

ExpandAll[(c-Sqrt[x^2+y^2])^2+z^2-a^2/.y->c-a]

Squaring the above:

eqn1=Factor[(-2 a c+2 (c^2)+(x^2)+z^2)^2-(2 c (Sqrt[(a^2)-2 a c+(c^2)+(x^2)]))^2]

This equation *looks* like a lemniscate:

Block[{c=1,a=.4},ContourPlot[eqn1==0,{x,-1.5,1.5},{z,-.6,.6},AspectRatio->Automatic]]

But isn't, since it differs by terms that can't all be set to 0:

ExpandAll[(c-Sqrt[x^2+y^2])^2+z^2-a^2]

leqn=Entity["PlaneCurve","Lemniscate"]["AlgebraicEquation"][a][x,z]

Manipulate[ContourPlot[{
-4 a c (x^2)+(x^4)-4 a c (z^2)+4 (c^2) (z^2)+2 (x^2) (z^2)+(z^4)==0,
(a^2) (x^2)-(x^4)-(a^2) (z^2)-2 (x^2) (z^2)-(z^4)
},{x,-1.5,1.5},{z,-.6,.6},AspectRatio->Automatic],{c,.1,1},{a,.1,1}]

Coefficient[{eqn1,eqn2},x,2]/.{y->0,z->0}

Coefficient[{eqn1,eqn2},y,2]/.{x->0,z->0}

Here are the half-widths:

Assuming[a>0&&c>0,Simplify@MaxValue[{x,eqn1==0},{x,z}]]

Assuming[a>0&&c>0,Simplify@MaxValue[{x,leqn==0},{x,z}]]/.a->w

Now set the widths equal:

eq1=4 a c (x^2)-(x^4)+4 a c (z^2)-4 (c^2) (z^2)-2 (x^2) (z^2)-(z^4);
eq2=(w^2) (x^2)-(x^4)-(w^2) (z^2)-2 (x^2) (z^2)-(z^4)/.w->2(Sqrt[a c])

And subtract:

eq1-eq2//FullSimplify

So the equations will be the same if the torus has:

%/.c->2a

Block[{a=1},ParametricPlot3D[Evaluate[Entity["Surface","Torus"]["ParametricEquations"][a,2a][u,v]],{u,0,2π},{v,0,2π}]]

Manipulate[With[{w=2(Sqrt[a c])},ContourPlot[
{-4 a c (x^2)+(x^4)-4 a c (z^2)+4 (c^2) (z^2)+2 (x^2) (z^2)+(z^4)==0,
(w^2) (x^2)-(x^4)-(w^2) (z^2)-2 (x^2) (z^2)-(z^4)},{x,-2,2},{z,-2,2},ContourStyle->{Directive[AbsoluteThickness[3],Blue],Darker@Yellow}]],{{a,.5},.1,2},{{c,1.},.1,2}]

Here is the curve actually obtained from cutting a torus with a==0.4 and c==1 with the plane y==0.6:

Entity["Surface","Torus"]["ParametricEquations"]

ParametricPlot3D[Evaluate[Entity["Surface","Torus"]["ParametricEquations"][.4,1][u,v]],{u,0,2π},{v,0,2π}]

FullSimplify[Entity["Surface","Torus"]["CartesianEquation"][(4/10),1][x,y,z]/.y->6/10]

ContourPlot[(((-1+(Sqrt[(9/25)+(x^2)])))^2)+(z^2)==(4/25),{x,-2,2},{z,-1,1},AspectRatio->Automatic]

Expand[(((-1+(Sqrt[(9/25)+(x^2)])))^2)]-((4/25)-(z^2))

Expand[-(((((6/5)+(x^2)+(z^2)))^2) -4((9/25)+(x^2)))]

MaxValue[{x,(((-1+(Sqrt[(9/25)+(x^2)])))^2)+(z^2)==(4/25)},{x,z}]

leqn/.a->2(Sqrt[(2/5)])

ContourPlot[{
((8 (x^2))/5)-(x^4)-((12 (z^2))/5)-2 (x^2) (z^2)-(z^4),
((8 (x^2))/5)-(x^4)-((8 (z^2))/5)-2 (x^2) (z^2)-(z^4)
},{x,-1.3,1.3},{z,-.5,.5},AspectRatio->Automatic,PlotLegends->{"toric section","lemniscate"}]

<<Graphics`Shapes`
<<Hidekazu`Knife`

With[{a=1,b=.4},Show[Graphics3D[{EdgeForm[],knife[Graphics3D[Torus[a,b,50,50]],{0,1,0,a-b},{-.5,0,0},{0,.5,0}][[1]]}],Boxed->False,ViewPoint->{0,-2,2.5}]
]

With[{a=1,b=.17},
Show[Graphics3D[{EdgeForm[],Fold[knife[#1,{Sequence@@#2,0,b-a}]&,Graphics3D[Torus[a,b,60,60]],{{0,1},{0,-1},{1,0},{-1,0}}][[1]]}],Boxed->False]
]