Picturing the Reeb Foliation

Jonathan Love

Introduction

The Hopf fibration is too mainstream. Instead of covering the 3-sphere with smooth curves, let’s cover it with surfaces. 

The Reeb foliation of the 3-sphere has a relatively simple explanation:
- Embedding a central torus C in the 3-sphere partitions it into two solid tori
- Within each solid torus, the leaves are all identical, just rotated copies of each other. Each can be interpreted as the surface of revolution of a curve that starts with a vertical tangent then tends to a horizontal asymptote, but wrapped around itself inside the torus.

First Parametrization: Naïve Approach

For our first attempt in visualizing the Reeb foliation, we will use the stereographic projection of the 3-sphere onto (ℝ^3) and simply consider everything as happening in (ℝ^3). We set some parameters, including the leaf-shape function we want to use, and demonstrate how this function will give us the desired leaves inside the torus.

c=0.4; (* determines the ratio of the torus' tube radius to full radius *)
F[x_]:=(Sqrt[(2/π)ArcTan[x]]); (* The leaf's shape function *)
TorusPoints[θ_,α_,f_]:={Cos[θ],Sin[θ],0}+c f[θ] (Cos[α] {Cos[θ],Sin[θ],0}+Sin[α] {0,0,1});(* Plotting points around the torus but with varying depth parameter f depending on θ *)

Plot[{F[x],1},{x,0,5},PlotRange->All] 
ParametricPlot3D[{x,Sin[t]F[x],Cos[t]F[x]},{x,0,5},{t,0,2π},Mesh->None,MaxRecursion->5]
ParametricPlot[{TorusPoints[θ,0,F][[1;;2]],{Cos[θ],Sin[θ]},(1+c){Cos[θ],Sin[θ]}},{θ,0,2.5π},Mesh->None]
ParametricPlot3D[TorusPoints[θ,α,F],{θ,0,2.5π},{α,0,2π},PlotStyle->Opacity[0.5],Mesh->None,MaxRecursion->5]

We will set up a standard torus C and foliate the inside as above:

insides=Table[ParametricPlot3D[TorusPoints[θ,α,F[#+k]&],{θ,-k,π-k},{α,-π,0},Mesh->None,PlotStyle->{Hue[k/30],Specularity[White,100]},MaxRecursion->5],{k,0,2π-π/6,π/6}];
sampleinside=ParametricPlot3D[TorusPoints[θ,α,F],{θ,0,4π/3},{α,-π,π},Mesh->None,PlotStyle->{Hue[0],Specularity[White,100]},MaxRecursion->5];
Ctorus=ParametricPlot3D[TorusPoints[θ,α,1&],{θ,0,2π},{α,-π-.4,.4},Mesh->None,PlotStyle->{Blue,Specularity[White,100]},MaxRecursion->5];

Show[{sampleinside,insides,Ctorus},PlotRange->All,Boxed->False,Axes->False]//Rasterize

Foliating the outer solid torus takes a bit more thinking. We had a nice parametrization of the inside of C; now we need one for the exterior. One parameter will simply be angle around the z-axis, but then we have to parametrize a half-plane-minus-a-circle (the cross-section of the exterior of C at a given angle around the z-axis). The idea is that we can use a Mobius transformation to parametrize this space by comparing it to a suitable annulus. 

The function Mobius takes the unit circle to the vertical axis:

Mobius[{x_,y_}]:={Re[(((x+I y)-1)/((x+I y)+1))],Im[(((x+I y)-1)/((x+I y)+1))]};

We can identify the annulus we need by finding the preimage of three points on the circle to be removed from the half-plane; it is straightforward to see that the circle centered at 1 with radius c comes from the circle centered at -1 with radius 2/c. Thus, we parametrize the annulus between this circle and the unit circle (the level sets must meet the unit circle at right angles), and push the parametrization forward using the Mobius function.

AnnulusParam[β_,t_]:=(maxt=-Cos[β]+(Sqrt[((((2/c)))^2)-((Sin[β])^2)]);(1+t (maxt-1)){Cos[β],Sin[β]})

Illustrating the parametrization of the annulus, and how it transforms into a parametrization of the half-plane-minus-disk. Also included are the desired cross-sections of leaves. Note that they must meet the z-axis at right angles in order for their surface of revolution to be smooth.

coordEx=Table[{AnnulusParam[#1,#2],0,2π,{LightGray}}&[xx,t],{t,0,1,1/6}] ~Join~Table[{AnnulusParam[#1,#2],0,1,{LightGray}}&[β,xx],{β,0,2π,π/8}]~Join~
Table[{AnnulusParam[#1,F[#1+#2]],If[#2==π,-1.01π,-#2],
2π-#2,{Hue[#2/(2π)]}}&[xx,k],{k,0,2π-π/4,π/4}];
Show[ParametricPlot[#[[1]]/.xx->x,{x,#[[2]],#[[3]]},PlotStyle->#[[4]]]&/@coordEx,PlotRange->All]//Rasterize
Show[ParametricPlot[Mobius[#[[1]]]/.xx->x,{x,#[[2]],#[[3]]},PlotStyle->#[[4]]]&/@coordEx,PlotRange->{{0,1+2c},{-3c,3c}}]//Rasterize

We can finally define a function OuterTorusPoints that will allow us to plot the outer leaves, and then we simply need to put all the pieces together!

OuterTorusPoints[θ_,β_,f_]:={Cos[θ]Mobius[AnnulusParam[β,f[β]]] [[1]],Sin[θ]Mobius[AnnulusParam[β,f[β]]] [[1]],Mobius[AnnulusParam[β,f[β]]] [[2]]};

qual=8; (* 2 for quick results. Up to 8 for very high resolution *)

leaves={-0.93π,-0.8π,-0.65π,-0.45π,0,0.55π,0.7π,0.84π,0.93π,π};
outers1=ParametricPlot3D[OuterTorusPoints[θ,β,Function[x,F[x+#]]],{θ,0,π},{β,-#,2π},
Mesh->None,PlotStyle->{Hue[#/(10π)+1/3],Specularity[White,100]},MaxRecursion->qual]&/@leaves;
insides1=Table[ParametricPlot3D[TorusPoints[θ,α,F[#+k]&],{θ,-k,π-k},{α,-π-.4,-.4},Mesh->None,PlotStyle->{Hue[k/30],Specularity[White,100]},MaxRecursion->qual],{k,0,2π-π/6,π/6}];
sampleinside1=ParametricPlot3D[TorusPoints[θ,α,F[#+π/6]&],{θ,-π/6,4π/3},{α,-π,π},Mesh->None,PlotStyle->{Hue[Pi/90],Specularity[White,100]},MaxRecursion->qual];
Ctorus1=ParametricPlot3D[TorusPoints[θ,α,1&],{θ,0,2π},{α,-π+.2,-.2},Mesh->None,PlotStyle->{Blue,Specularity[White,100]},MaxRecursion->qual];

I could use a new desktop background...

Show[{insides1,outers1,sampleinside1,Ctorus1},PlotRange->{{-8,4},{-4,8},{-4,4}},Boxed->False,Axes->False,Background->Gray,ImageSize->{1296,768},ViewVector->{{10,-20,10},{-0.9,0,0}},ViewAngle->π/24]//Rasterize

Second Parametrization

Let’s look for a more natural parametrization of the Reeb foliation by considering where it lies in (S^3)⊂(ℝ^4). Setting up:

F1[x_]:=((((2/π)ArcTan[x]))^(3/4)); (* The square root looks too blunt-ended in this case *)
qual=6; 
p=5; (* torus ratio *)

The torus naturally embeds in (S^3) as (1/(Sqrt[2]))(cosθ,sinθ,cosψ,sinψ), i.e. (x^2)+(y^2)=(z^2)+(w^2), and divides the sphere into solid tori (x^2)+(y^2)>(z^2)+(w^2) and (x^2)+(y^2)<(z^2)+(w^2). Thus the 3-sphere will be parametrized by level sets of (((x^2)+(y^2))/((z^2)+(w^2))).

Stereographic projection from (0,0,0,1) maps a point (x',y',z',w') on (S^3) to (((x')/(1-w')),((y')/(1-w')),((z')/(1-w'))) in (R^3). Given r=(((x^2)+(y^2))/((z^2)+(w^2))), we know (1+r)((z^2)+(w^2))=1, hence (z^2)+(w^2)=(1/(1+r)), so (x^2)+(y^2)=(r/(1+r)). So the points on a “torus of ratio r” satisfy (1/(Sqrt[1+r]))((Sqrt[r]) cosθ,(Sqrt[r]) sinθ,cosψ,sinψ). This is pushed forward to the following, which we use to plot roughly the same picture as above.

TorusPoints2[θ_,ψ_,r_]:={(((Sqrt[r]) Cos[θ])/((Sqrt[1+r])-Sin[ψ])),(((Sqrt[r]) Sin[θ])/((Sqrt[1+r])-Sin[ψ])),((Cos[ψ])/((Sqrt[1+r])-Sin[ψ]))};

And now we make the picture. One thing to point out is the fact that I’m plugging in cubes or fifth powers. The reason for this is that originally, the rendered picture looked terrible, because this parametrization moves incredibly quickly away from r=0. No matter how high I increased MaxRecursion or PlotPoints, Mathematica simply didn’t use enough points to make the generated surfaces smooth (or by the time it sampled enough points, the execution time was far too long). By composing with a function that is very flat around 0, I force Mathematica to sample many points where needed, and fewer elsewhere.

leaves2={0,π/2,1.1π,1.25π,1.38π,1.45π,1.495π,1.55π,1.62π,1.75π};
outers2=ParametricPlot3D[TorusPoints2[θ,(β^5)-#,p F1[(β^5)]],{θ,0,π},{β,0,(((2π))^(1/5))},
Mesh->None,PlotStyle->{Hue[Mod[#-1.49π,2π]/30+1/4],Specularity[White,100]},MaxRecursion->qual]&/@leaves2;
insides2=Table[ParametricPlot3D[TorusPoints2[(θ^3)-k,α,p/F1[(θ^3)]],{θ,0,(π^(1/3))},{α,π/2+.2,3π/2+.2},Mesh->None,PlotStyle->{Hue[k/30],Specularity[White,100]},MaxRecursion->qual],{k,0,2π-π/6,π/6}];
sampleinside2=ParametricPlot3D[TorusPoints2[(θ^3)-π/6,α,p/F1[(θ^3)]],{θ,0,(((3π/2))^(1/3))},{α,-π,π},Mesh->None,PlotStyle->{Hue[Pi/90],Specularity[White,100]},MaxRecursion->qual];
Ctorus2=ParametricPlot3D[TorusPoints2[θ,α,p],{θ,0,2π},{α,π/2+.2,3π/2+.2},Mesh->None,PlotStyle->{Blue,Specularity[White,100]},MaxRecursion->qual];

Show[{insides2,outers2,sampleinside2,Ctorus2},PlotRange->{{-10,4},{-2,10},{-8,4}},Boxed->False,Axes->False,Background->Gray,ImageSize->{1296,768},ViewVector->{{12,-24,12},{-0.9,0,0}},ViewAngle->π/24,ViewVertical->{0,0,1}]//Rasterize

MUCH simpler than last time!

Third Parametrization (and solving a challenge question)

Maybe by using a different projection of the torus we can obtain another, more symmetrical picture? Let’s rotate the main torus so that the point (0,(1/(Sqrt[2])),0,(1/(Sqrt[2]))) is sent to (0,0,0,1); that is, (x,y,z,w) is sent to (x,(1/(Sqrt[2]))(y-w),z,(1/(Sqrt[2]))(y+w)). Thus, the point on the “torus of ratio r” (1/(Sqrt[1+r]))((Sqrt[r]) cosθ,(Sqrt[r]) sinθ,cosψ,sinψ) is sent to (1/(Sqrt[1+r]))((Sqrt[r]) cosθ,(1/(Sqrt[2]))((Sqrt[r])sinθ-sinψ),cosψ,(1/(Sqrt[2]))((Sqrt[r])sinθ+sinψ)), which is then projected to (ℝ^3):

TorusPoints3[θ_,ψ_,r_]:={(((Sqrt[2r]) Cos[θ])/((Sqrt[2+2r])-(Sqrt[r])Sin[θ]-Sin[ψ])),(((Sqrt[r])Sin[θ]-Sin[ψ])/((Sqrt[2+2r])-(Sqrt[r])Sin[θ]-Sin[ψ])),(((Sqrt[2])Cos[ψ])/((Sqrt[2+2r])-(Sqrt[r])Sin[θ]-Sin[ψ]))};

Incidentally, this answers another of the challenge problems: Find a parametrization of the torus with an obvious nontrivial 4-fold symmetry!

ParametricPlot3D[TorusPoints3[θ,ψ,1],{θ,0,2π},{ψ,0,2π},RegionFunction->Function[{x,y,z},Max[Abs/@{x,y,z}]<3],Mesh->{{π/2,π,3π/2}},BoundaryStyle->Thin,Boxed->False,Axes->False]

And now, the pretty picture.

tops=Table[ParametricPlot3D[TorusPoints3[(θ^3)-k,α,1/F[(θ^3)]],{θ,0,(((4π/3))^(1/3))},{α,π/2,3π/2},Mesh->None,PlotStyle->{Hue[Mod[k-3π/2,2π]/30],Specularity[White,100]},MaxRecursion->qual],{k,0,2π-π/6,π/6}];
bottoms=Table[ParametricPlot3D[TorusPoints3[θ,(α^3)-k,F[(α^3)]],{θ,π/2,3π/2},{α,0,(π^(1/3))},Mesh->None,PlotStyle->{Hue[Mod[k-5π/3,2π]/30+1/4],Specularity[White,100]},MaxRecursion->qual],{k,0,2π-π/6,π/6}];
Ctorus3=ParametricPlot3D[TorusPoints3[θ,α,1],{θ,0,2π},{α,0,2π},Mesh->None,PlotStyle->{Blue,Specularity[White,100]},MaxRecursion->qual,RegionFunction->Function[{x,y,z},Max[Abs/@{x,y,z}]<20&&z<1.5]];
yellow=ParametricPlot3D[TorusPoints3[(θ^3)-4π/3,α,1/F[(θ^3)]],{θ,0,(((2π))^(1/3))},{α,0,2π},Mesh->None,PlotStyle->{Hue[Mod[4π/3-3π/2,2π]/30],Specularity[White,100]},MaxRecursion->qual,RegionFunction->Function[{x,y,z},z<1.5]];
cyan=ParametricPlot3D[TorusPoints3[θ,(α^3)-3π/2,F[(α^3)]],{θ,0,2π},{α,0,(((2π))^(1/3))},Mesh->None,PlotStyle->{Hue[(11π/6)/30+1/4],Specularity[White,100]},MaxRecursion->qual,RegionFunction->Function[{x,y,z},z<1.5]];
back=ParametricPlot3D[TorusPoints3[θ,(α^3)-11π/6,F[(α^3)]],{θ,0,2π},{α,(((0.39π))^(1/3)),(((3π/2))^(1/3))},Mesh->None,PlotStyle->{Hue[(π/6)/30+1/4],Specularity[White,100]},MaxRecursion->qual,RegionFunction->Function[{x,y,z},z<50]];

Show[{tops,bottoms,Ctorus3,yellow,cyan,back},PlotRange->{{-5,20},{-20,5},{-20,10}},Boxed->False,Axes->False,Background->Gray,ImageSize->{1296,768},ViewVector->{{12,8,32},{0.8,0,0}},ViewAngle->π/24,ViewVertical->{0,1,0}]//Rasterize