Villarceau Circles

Author

Eric W. Weisstein
January 13, 2008

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

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

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

Graphics

Eric's Version

<<Graphics`Shapes`

VillarceauCircles[a_:1,r_:.5,phi_:50 Degree,verts_:50]:=Module[{theta=ArcSin[r/a],cost,psi,rotz,CircleBig,CircleLittle,CirclesV},
cost=r Sin[phi]/(a Sin[theta]);
psi=ArcTan[(a Sqrt[1-cost^2]+r)/(a Cos[theta] cost)];rotz[x_]:={{Cos[x],Sin[x],0},{-Sin[x],Cos[x],0},{0,0,1}};
CircleBig=Table[{(a+r Cos[phi])Cos[2Pi t/verts],(a+r Cos[phi])Sin[2Pi t/verts],r Sin[phi]},{t,0,verts}];
CircleLittle=Table[{a+r Cos[2Pi t/verts],0,r Sin[2Pi t/verts]},{t,0,verts}];
CirclesV=Table[rotz[# psi].{-a Cos[theta]Cos[2Pi t/verts],a Sin[2Pi t/verts]+#r,-a Sin[theta]Cos[2Pi t/verts]},{t,0,verts}]&/@{1,-1};
Line/@{CircleBig,CircleLittle,Sequence@@CirclesV}
]

Manipulate[Graphics3D[{Opacity[.5],VillarceauCircles[a,r,phi Degree,n],EdgeForm[],Torus[a,r]},Boxed->False],
{{a,1},.1,10,Appearance->"Labeled"},
{{r,.5},.1,a,Appearance->"Labeled"},
{{phi,50},0,180,Appearance->"Labeled"},
{{n,50},10,100,1,Appearance->"Labeled"}]

LiveGraphcis3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["villar.m",g,Boxed->False]

Brett's Version

Code by Brett Champion, perhaps in collaboration with Stan Wagon
January 2008

p=(2/5);q=(Sqrt[1-(p^2)]);a=(p/q);
circle[ϕ_]:={1+p Cos[ϕ],0,p Sin[ϕ]};
torus=RotationTransform[θ,{0,0,1}][circle[ϕ]];
torusPlot=ParametricPlot3D[torus,{θ,0,2 π},{ϕ,0,2 π},MeshStyle->GrayLevel[0.6]];
stretch[{x_,y_,z_}]:=(tPoint=Append[{Cos[ArcTan[x,y]],Sin[ArcTan[x,y]]},0];tPoint+1.04 ({x,y,z}-tPoint));
vertCircle=ParametricPlot3D[{1+p Cos[t],0,p Sin[t]},{t,0,2 π},PlotStyle->{Thickness[0.02],Green}];
Manipulate[β=ArcTan[x,y]/.{x->q Cos[t],y->-p+Sin[t]}/.t->2 π-((π/2)-ϕval);γ=ArcTan[x,y]/.{x->q Cos[t],y->p+Sin[t]}/.t->(π/2)-ϕval;ρ=Norm[Most[torus]/.{ϕ->ϕval,θ->0}];Show[torusPlot,vertCircle,ParametricPlot3D[Evaluate[{RotationTransform[-β,{0,0,1}][RotationTransform[ArcTan[a],{0,-1,0}][{Cos[t],-p+Sin[t],0}]],RotationTransform[-γ,{0,0,1}][RotationTransform[ArcTan[a],{0,-1,0}][{Cos[t],p+Sin[t],0}]],{ρ Cos[t],ρ Sin[t],p Sin[ϕval]}}],{t,0,2 π},PlotStyle->{Directive[Thickness[0.02],Red],Directive[Thickness[0.02],Blue],Directive[Thickness[0.02],Orange]}],PlotRange->{{-1-p-0.1,1+p+0.1},{-1-p-0.1,1+p+0.1},{-1.1 p,1.1 p}},Boxed->False,SphericalRegion->True,Axes->False],{{ϕval,0,"ϕ"},-π,π},TrackedSymbols->{ϕval}, SaveDefinitions->True]

Stan's Version

Code by Stan Wagon
Sun, 13 Jan 2008

tube[pts_, r_]:={EdgeForm[],Table[Cylinder[c, r],{c,Partition[pts,2,1]}]};
p=(2/5);q=(Sqrt[1-(p^2)]);a=(p/q);
circle[ϕ_]:={1+p Cos[ϕ],0,p Sin[ϕ]};
torus=RotationTransform[θ,{0,0,1}][circle[ϕ]];
torusPlot=ParametricPlot3D[torus,{θ,0,2 π},{ϕ,0,2 π},MeshStyle->GrayLevel[0.6]];
δTube=2π/100.;rTube=0.05;
vertCircle={Green,
 tube[Table[{1+p Cos[t],0,p Sin[t]},{t,0.,2 π,δTube}], rTube]};
vilCircle = tube[Table[
RotationTransform[ArcTan[a],{0,-1,0}][{Cos[t],p+Sin[t],0}], {t,0,2π, δTube}],rTube];
Manipulate[β=ArcTan[q Sin[ϕval],-p-Cos[ϕval]];
ρ=1+p Cos[ϕval];
Show[torusPlot,
Graphics3D[{vertCircle,Red,
t1=GeometricTransformation[vilCircle,RotationTransform[β,{0,0,1}]],
Orange, GeometricTransformation[t1,ReflectionTransform[{0,1,0}]],
Yellow,tube[Table[{ρ Cos[t],ρ Sin[t],p Sin[ϕval]},{t,0,2π,δTube}],rTube]}],PlotRange->{{-1-p-0.1,1+p+0.1},{-1-p-0.1,1+p+0.1},{-1.1 p,1.1 p}},Boxed->False,Axes->False],{{ϕval,0,"ϕ"},-π,π}, SaveDefinitions->True]

Slicing

Get["Hidekazu`knife`"]

torus=Graphics3D[Torus[1,.5,40,20]];

gr=knife[torus,{1,0,N[(Sqrt[3])],0},{0,0,0},{2.5,0,0}];
Show[gr,ViewPoint->{2.050,4.000,2.590},Boxed->False]