Horisontal Curves, Hopf Fibration, and Lens Spaces

by Anton Lukyanenko, April 2009, UIUC
some of the resulting pictures to appear in a Notices paper by De Angelo and Tyson

Horisontal Curves

The Heisenberg group is (R^3)with the addition law (x,y,t)+(u,v,s) = (x+u, y+v, s+t+.5(xv-yu) ).
It has a Sub - Riemannian structure by taking the standard inner product on the x-y tangent plane at the origin and the resulting group-invariant distribution elsewhere.
A curve is "horisontal" if its derivative lies in the horisontal distribution.
Given a point on a surface, the corresponding tangent space usually does not agree with the horisontal plane thorugh that point (a result of complete non-integrability). Thus, a single line is horisontal, and the horisontal tangent distribution on the surface constists at most points of single lines. 
This section of the notebook uses numerical methods to compute horisontal curves on parametrized surfaces.

Introduction to DrawHorisontalCurves

Here is the main function:

Off[NDSolve::mxst]
Off[NDSolve::ndsz]
DrawHorisontalCurves[Parametrization_,a0_,b0_,maxTime_:10]:=Module[{x,y,t,xp,yp,tp,sol,a,b,s},
{x,y,t}=Parametrization[a[s],b[s]];
{xp, yp, tp}=D[Parametrization[a[s],b[s]],s];
Sol=NDSolve[{tp + .5 y xp - .5 x yp ==0, xp^2+yp^2==1,a[0]==a0,b[0]==b0},{a[s],b[s]},{s,0,maxTime}];
{ParametricPlot3D[
Parametrization[Evaluate[a[s]/.Sol[[1,1]]], Evaluate[b[s]/.Sol[[1,2]]]],Evaluate[Flatten[{s,Sol[[1,1,2,0,1]]}]],PlotStyle->Directive[Black],Boxed->False,Axes->False],
ParametricPlot3D[
Parametrization[Evaluate[a[s]/.Sol[[2,1]]], Evaluate[b[s]/.Sol[[2,2]]]],Evaluate[Flatten[{s,Sol[[2,1,2,0,1]]}]],PlotStyle->Directive[Black],Boxed->False,Axes->False]
}
];

Given a parametrization, provide DrawHorisontalCurve with a parametrization coordinates to draw the curve thorugh:

Paraboloid[θ_,r_]:={r Cos[θ],r Sin[θ],r^2};
DrawHorisontalCurves[Paraboloid,1,2]

These are the two curves extending in the two directions from the point. To combine them, use Show:

Show[DrawHorisontalCurves[Paraboloid,1,2],PlotRange->All]

To add further objects to the picture, use braces and "Flatten":

Show[
   Flatten[
   {
	DrawHorisontalCurves[Paraboloid, 1, 2],
	ParametricPlot3D[Paraboloid[x, y], {x, -5, 5}, {y, -5, 5}, Mesh -> False]
    }
    ],
PlotRange->All]

Multiple lines can be drawn quicly using the Map command (abbreviated /@). See the help files for how to use it.

Show[Flatten[
{
ParametricPlot3D[Paraboloid[x,y],{x,-10,10},{y,-10,10},Mesh->False],
DrawHorisontalCurves[Paraboloid,#,2]&/@(Range[10]*2π/10)
}
],PlotRange->{{-10,10},{-10,10},{0,20}}
]

A few examples

Paraboloid[θ_,r_]:={r Cos[θ],r Sin[θ],r^2};
Show[Flatten[
{
ParametricPlot3D[Paraboloid[x,y],{x,-10,10},{y,-10,10},Mesh->False],
DrawHorisontalCurves[Paraboloid,#,2]&/@(Range[10]*2π/10)
}
],PlotRange->{{-10,10},{-10,10},{0,20}}
]

RoundSphere[ϕ_,θ_]:={Sin[ϕ] Cos[θ], Sin[ϕ]Sin[θ],Cos[ϕ]}
Show[Flatten[
{Graphics3D[Sphere[{0,0,0},1]],
DrawHorisontalCurves[RoundSphere,π/2,#]&/@(Range[0,5]*2π/5)
}
]]

ATorus [ϕ_,θ_]:= {{Cos[ϕ], -Sin[ϕ],0},{Sin[ϕ],Cos[ϕ],0},{0,0,1}}.{0,.5 Cos[θ]+1, .5 Sin[θ]}
Show[Flatten[
{ParametricPlot3D[ATorus[ϕ,θ],{ϕ,0,2π},{θ,0,2π},Mesh->False],
DrawHorisontalCurves[ATorus,#,0,20]&/@(Range[0,5]*2π/5)
}
]]

BTorus[ϕ_,θ_]:={{Cos[ϕ],0, -Sin[ϕ]},{0,1,0},{Sin[ϕ],0,Cos[ϕ]}}.{0,.5Cos[θ],.5 Sin[θ]+1};
Show[Flatten[
{
ParametricPlot3D[BTorus[ϕ,θ],{ϕ,0,2π},{θ,0,2π},Mesh->False],
DrawHorisontalCurves[BTorus,π,#,20]&/@{0,π/6,-π/6,-π/3,-7π/16,-9π/16},
DrawHorisontalCurves[BTorus,0,#,20]&/@{0,-π/6,π/6,π/3,5π/6},
(DrawHorisontalCurves[BTorus,#,-π/2,40]&/@{-((9 π)/10),-((4 π)/5),-((7 π)/10),-((3 π)/5),-((3 π)/10),-(π/5),-(π/10),(π/5),((3 π)/10),(π/2),((7 π)/10),((4 π)/5),((9 π)/10),π})
}
],ViewPoint->{5,5,2}]

Hopf Fibration - Horisontal curves

The Hopf Fibration views the 3-sphere as a circle bundle over the 2-sphere.
That is, the 3-sphere can be split up into a collection of circles such that the circles themselves form a 2-sphere.
We're interested in 1) viewing the Hopf fibration, and 2) drawing horisontal lines on the resulting surfaces.

To visualize the fibration, we use stereographic projection to draw things in (R^3). 
The circles of the Hopf fibration can be organized into Clifford Tori, which fill out all of the 3-sphere except for two circles.
A Clifford torus is the preimage of a circle in (S^2) under the Hopf map.
After stereographic projection, a Clifford torus is just a torus "along the XY plane", such that the intersection with the XY plane gives two circles of inverse radius.

GeneralTorus[ϕ_,θ_,r_,R_]:={{Cos[ϕ], -Sin[ϕ],0},{Sin[ϕ],Cos[ϕ],0},{0,0,1}}.{0,r Cos[θ]+R, r Sin[θ]};
CliffordTorus[r_]:=GeneralTorus[#1,#2,(r-1/r)/2,(r+1/r)/2]&;

Here are 3 Clifford tori. Imagine that there are infinitely many, filling out most of (R^3).

Show[
{
ParametricPlot3D[CliffordTorus[3][θ,ψ],{θ,0,2π},{ψ,0,2π},PlotStyle->Opacity[.5],Mesh->False,Boxed->False,Axes->False],
ParametricPlot3D[CliffordTorus[5][θ,ψ],{θ,0,2π},{ψ,0,2π},PlotStyle->Opacity[.5],Mesh->False,Boxed->False,Axes->False],
ParametricPlot3D[CliffordTorus[12][θ,ψ],{θ,0,2π},{ψ,0,2π},PlotStyle->Opacity[.5],Mesh->False,Boxed->False,Axes->False]
}
,PlotRange->{{-5,5},{-5,5},{-4,4}},ViewPoint->(1000{0,5,2})
]

While we could draw in the circles of the Hopf fibration, we're not set up for that at the moment, and this parametrization of the Clifford tori doesn't allow us to draw them too easily. You can find an illustration on Wikipedia or at bugman123.com.

We can now fill in the horisontal curves as in the first section. For each torus, we pick five curves, equally spaced around the origin, and all corresponding to the same point in the parametrization.

Show[
(r|->{
ParametricPlot3D[CliffordTorus[r][θ,ψ],{θ,0,2π},{ψ,0,2π},PlotStyle->Opacity[.5],Mesh->False,Boxed->False,Axes->False],
DrawHorisontalCurves[CliffordTorus[r],#,0,100]&/@(Range[0,5]*2π/5)
})
/@{3,5,12}

,PlotRange->{{-5,5},{-5,5},{-4,4}},ViewPoint->(1000{0,5,2})
]

The horisontal lines are very sensitive to the radius of the Clifford torus. 
In fact, each curve is either dense in the torus or closes up, depending on the rationality of the perturbation parameter (probably not the one we're using here).
Focusing on the center torus (of outer radius 3), we perturb the radius in intervals of .0002.
WARNING: the calculation takes a while since it's computing 100 tori with curves.

First, we perform the calculation.

PerturbedTorus=Table[Show[
{
ParametricPlot3D[CliffordTorus[3+ϵ][θ,ψ],{θ,0,2π},{ψ,0,2π},PlotStyle->Opacity[.5],Mesh->False,Boxed->False,Axes->False],

DrawHorisontalCurves[CliffordTorus[3+ϵ],#,0,100]&/@(Range[0,5]*2π/5)
}
,PlotRange->{{-5,5},{-5,5},{-4,4}},ViewPoint->(1000{0,5,2})
],{ϵ,0,.02,.0002}];

Now, view the results. I recommend expanding the image selector, hitting "play", and slowing down the animation.

Manipulate[PerturbedTorus[[n]],{n,1,100,1}]

You can export to a video file:

Export["PerturbedTorus.swf",PerturbedTorus, "FrameRate"->10]

To see where your file ended up, run

Directory[]

HopfFibration2 - The Fibration

For the original Hopf fibration pictures illustrating horizontal curves, we did not need a parametrization of Clifford tori in (S^3). This necessary to illustrate the fibration itself.

The preimage of a point c in (CP^1) is a circle in (S^3)⊂(C^2)of points (z,w) such that z/w=c. A circle of fixed non-zero radius r in (CP^1) yields a Clifford torus.

DrawHopfCircle[r_,ϕ_,options__]:=ParametricPlot3D[StereographicProjection[((E^(I θ))/(Sqrt[(r^2)+1])){r  (E^(I ϕ)),1}],{θ,0,2π},options]

Show[
DrawHopfCircle[ 1, #]&/@Range[0,2π,π/18],
DrawHopfCircle[ 2, #,PlotStyle->Red]&/@Range[0,2π,π/18],
PlotRange->All]

I now want to make each torus a surface rather than just a collection of circles. DrawHopfCircle could be extended to do this using the "natural" coordinates, but this yeilds low-quality pictures.

Instead, we notice that the tori are actually "normal" tori, swept out by Euclidean circles. To confirm this, take a HopfCircle and draw it in just the (r, z) coordinates:

ToRZ[{x_,y_,z_}]:={(Sqrt[(x^2)+(y^2)]),z}

Show[ParametricPlot[ToRZ[StereographicProjection[((E^(I θ))/(Sqrt[((#)^2)+1])){#,1}]],{θ,0,2π}]&/@{1,2,3},PlotRange->{{0,2.5},{-1,1}},AxesOrigin->{0,0}]

We now establish the relationship between r (the radius of the Clifford torus in (CP^1) and the x-intercepts of the circle.

Assuming[{θ>0,r>0},
FullSimplify[ToRZ[StereographicProjection[((E^(I θ))/(Sqrt[(r^2)+1])){r,1}]]]]

{(r/(Sqrt[1+(r^2)-2 (Sqrt[1+(r^2)]) Sin[θ]+((Sin[θ])^2)])),((Cos[θ])/((Sqrt[1+(r^2)])-Sin[θ]))}/.θ->π/2//Simplify
{(r/(Sqrt[1+(r^2)-2 (Sqrt[1+(r^2)]) Sin[θ]+((Sin[θ])^2)])),((Cos[θ])/((Sqrt[1+(r^2)])-Sin[θ]))}/.θ->3π/2//Simplify

The first is always greater than 1, and we can use it in the CliffordTorus comand in the previous section.

CliffordTorus2[r_]:=CliffordTorus[(r/(Sqrt[2+(r^2)-2 (Sqrt[1+(r^2)])]))]

Show[
ParametricPlot3D[CliffordTorus2[1][θ,ϕ],{θ,0,2π},{ϕ,0,2π},Mesh->False,PlotStyle->Opacity[.5]],
DrawHopfCircle[ 1, #]&/@Range[0,2π,π/18]
]

We can now recreate the 3 - Torus picture in the previous section while showing the Hopf fibration:

Show[
ParametricPlot3D[CliffordTorus2[.2][θ, ϕ], {θ, 0, 2π}, {ϕ, 0,  2π}, Mesh -> False, PlotStyle -> Opacity[.8],PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2],
ParametricPlot3D[CliffordTorus2[.4][θ, ϕ], {θ, 0, 2π}, {ϕ, 0,  2π}, Mesh -> False, PlotStyle -> Opacity[.3],PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2],
ParametricPlot3D[CliffordTorus2[.8][θ, ϕ], {θ, 0, 2π}, {ϕ, 0,  2π}, Mesh -> False, PlotStyle -> Opacity[.3],PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2],
 DrawHopfCircle[ .8, 0,PlotStyle->{Red,Thickness[.003]},PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2] ,
 DrawHopfCircle[ .4, 2π/3,PlotStyle->{Blue,Thickness[.003]},PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2] ,
 DrawHopfCircle[ .2, 4π/3,PlotStyle->{Black,Thickness[.003]},PerformanceGoal->"Quality",PlotPoints->100,MaxRecursion->2] ,
PlotRange->{{-5.1,5.1},{-5.1,5.1},{-4,4}}, Axes->False, Boxed->False
]

SetDirectory[NotebookDirectory[]]

Export["HopfMarch5.jpg",Out[20],ImageSize->{2000,2000}]

Show[Out[20],ViewPoint->{10,0,10}]

Export["NewHopf3.jpg",Out[192],"CompressionLevel"->0,ImageSize->{2000,2000}]

ParametricPlot3D[CliffordTorus2[1][θ, ϕ], {θ, 0, 2π}, {ϕ, 0,  2π}, Mesh -> False]

Lens Spaces

The p,q-Lense space is the quotient of (S^3) by the diagonal (C^2)-action (({{ω, 0}, {0, (ω^p)}})) where ω is a (q^th) root of unity. Note: I mgiht have the roles of p and q reversed.

We draw the corresponding tessellation of (S^3) and view it using stereographic projection:

StereographicProjection[{x_,y_,z_,t_}]:=(({x,y,z})/(1-t));
StereographicProjection[{z_,w_}]:=(({Re[z],Im[z],Re[w]})/(1-Im[w]));

We construct the tessellation using the Ford fundamental region. The construction is as follows:
1) Pick a point on (S^3) and find all the images of the point under the action of (Subscript[Z, q]).
2) For each image, construct the equidistant region between the image and the original point. That is, all the points of equal distance from the original point and the image. This splits the sphere into 2 parts.
3) The intersection of all the parts containing the original point forms a fundamental domain. That is, a region whose interior corresponds exactly to points in the quotient, but whose boundary might have some equivalences.

We observe that the equidistant regions on the 3-sphere are just great circles, and find a way to parametrize them.

EquidistantSphere[{a_,b_},{c_,d_}]:=Module[{v1,v2,v3,NullSp},
NullSp=NullSpace[{{Re[a],Im[a],Re[b],Im[b]},{Re[c],Im[c],Re[d],Im[d]}}];
If[MatrixRank[NullSp]==3,{v1,v2,v3}=NullSp, {v1,v2}=NullSp; v3 = ({Re[a],Im[a],Re[b],Im[b]}+{Re[c],Im[c],Re[d],Im[d]})/2];
v1=v1/Norm[v1];
v2=v2/Norm[v2];
v3=v3/Norm[v3];
Sin[#2]Cos[#1]v1+Sin[#2]Sin[#1]v2+Cos[#2]v3&
];

Here's a sample equidistant sphere viewed under stereographic projection:

Param = EquidistantSphere[{I,1},{1,2+I}];
ParametricPlot3D[StereographicProjection[Param[ϕ,θ]],{ϕ,0,2π},{θ,0,2π}]

The second observation is that we don't actually neeed to construct all those equidistant planes. We just need to find the closest ones to the base point.  To find it, we need to write down the distance between two points. We also declare two useful functions.

SphericalDistance[u_,v_]:=ArcCos[((u.v)/(Norm[u]Norm[v]))];
C2ToR4[{u_,v_}]:={Re[u],Im[u],Re[v],Im[v]};
R4ToC2[{a_,b_,c_,d_}]:={a+b I, c+d I};

Picking the origin in (R^3) as the base point (corresponding to (0,-I) in (C^2)), we find the closest images and draw the equidistant spheres for the 3,5-Lens space:

DrawEquidistantSphere[u_,v_,options__]:=Module[{Param},
Param = EquidistantSphere[u,v];
ParametricPlot3D[StereographicProjection[Param[ϕ,θ]],{ϕ,0,2π},{θ,0,2π},options]
];
p=3; q=5;
ω=Exp[2π I / q];
Distances=(t|->{t,SphericalDistance[{0,0,0,-1},C2ToR4[{0,-I (ω^(t p))}]]})/@Range[q-1];
{p1,p2}=#[[1]]&/@(Sort[Distances,#1[[2]]<#2[[2]]&][[{1,2}]]);
Show[
(t|->DrawEquidistantSphere[{0,-I},{0,-I (ω^(t p))},PlotStyle->Opacity[.5]])/@{p1,p2},
PlotRange->Automatic
]

The "rotational" action moved the origin vertically, and the equidistant spheres projected to Euclidean spheres.

The intersection of their interiors gives the fundamental region, the LENS of the Lens space. Note that it depends only on q.

LensFundamentalRegion[p_,q_]:=Module[{ω,Param1,Param2,r1,r2, Distances,t1,t2},
ω=Exp[2π I / q];
Distances=(t|->{t,SphericalDistance[{0,0,0,-1},C2ToR4[{0,-I (ω^(t p))}]]})/@Range[q-1];
{t1,t2}=#[[1]]&/@(Sort[Distances,#1[[2]]<#2[[2]]&][[{1,2}]]);
{EquidistantSphere[{0,-I},{0,-I (ω^(t1 p))}],Param1 = EquidistantSphere[{0,-I},{0,-I (ω^(t2 p))}]}
];

DrawLensFundamentalRegion[p_,q_]:=Show[ParametricPlot3D[#[θ,ϕ],{θ,0,2π},{ϕ,0,π/2},PlotStyle->Opacity[.8]]&/@LensFundamentalRegion[p,q],PlotRange->Automatic,Boxed->False, Axes->False]

DrawLensFundamentalRegion[3,5]

To get the full tessellation, we apply the transformations to the fundamental image (actually, just the top surface), cutting slit out to show where points go (change 3π/2 to 2π if you don't want the slit).

DrawLensTessellation1[p_,q_,Options__]:=Show[
Flatten[Table[
ParametricPlot3D[StereographicProjection[{Exp[2π I t/q],Exp[ 2π I t p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},Options],
{t,Range[q]},{Param,LensFundamentalRegion[p,q][[{1}]]}]],
PlotRange->Automatic]

DrawLensTessellation1[2,5,Mesh->5]

Coloring the top of the fundamental region red, we color the other images with other colors:

p=3;q=5;
Param = LensFundamentalRegion[p,q][[1]];
Op=.8;
Show[
{
ParametricPlot3D[StereographicProjection[R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Red]
],

ParametricPlot3D[StereographicProjection[{Exp[2π  I/q],Exp[ 2π I    p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Blue]
],

ParametricPlot3D[StereographicProjection[{Exp[2π 2 I/q],Exp[ 2π I  2  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Green]
],

ParametricPlot3D[StereographicProjection[{Exp[2π 3 I/q],Exp[ 2π I  3  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Yellow]
],

ParametricPlot3D[StereographicProjection[{Exp[2π 4 I/q],Exp[ 2π I 4  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Purple]
]
}
]

To give a better feel for the rotational action,"slow down" the rotational action - fill it in with intermediate rotations.

DrawLensTessellation2[p_,q_,perturbation_,Options__]:=Show[
Flatten[Table[
ParametricPlot3D[StereographicProjection[{Exp[2π I(t+perturbation)/q],Exp[ 2π I(t+perturbation) p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},Options],
{t,Range[q]},{Param,LensFundamentalRegion[p,q][[{1}]]}]]
];

p=2;
q=5;
Param = LensFundamentalRegion[p,q][[1]];
Op=.8;
PerturbedLens=Table[Show[
{
ParametricPlot3D[StereographicProjection[{Exp[2π Perturbation I/q],Exp[ 2π I  Perturbation  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Red]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+1) I/q],Exp[ 2π I  (Perturbation+1)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Blue]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+2) I/q],Exp[ 2π I  (Perturbation+2)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Green]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+3) I/q],Exp[ 2π I  (Perturbation+3)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Yellow]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+4) I/q],Exp[ 2π I  (Perturbation+4)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,3π/2},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Purple]
]
}
],{Perturbation,0,1,.01}];

NOTE: we only show ONE iteration of the rotation.

Manipulate[PerturbedLens[[n]],{n,1,100,1}]

Pictures for paper

Op=.6;
Perturbation=0;
View1=Show[
{
ParametricPlot3D[StereographicProjection[{Exp[2π Perturbation I/q],Exp[ 2π I  Perturbation  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[5 Op/6],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Red]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+1) I/q],Exp[ 2π I  (Perturbation+1)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[.4],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Blue]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+2) I/q],Exp[ 2π I  (Perturbation+2)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Green]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+3) I/q],Exp[ 2π I  (Perturbation+3)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},RGBColor[.8,.8,0]]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+4) I/q],Exp[ 2π I  (Perturbation+4)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Purple]
]
},ViewPoint->{∞,0,0}
]

Op=.6;
View2=Show[
{
ParametricPlot3D[StereographicProjection[{Exp[2π Perturbation I/q],Exp[ 2π I  Perturbation  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[ Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Red]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+1) I/q],Exp[ 2π I  (Perturbation+1)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[.4],Mesh->5, PlotRange->{{-1,1},{-1,1},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Blue]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+2) I/q],Exp[ 2π I  (Perturbation+2)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[.4],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Green]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+3) I/q],Exp[ 2π I  (Perturbation+3)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},RGBColor[.8,.8,0]]
],

ParametricPlot3D[StereographicProjection[{Exp[2π (Perturbation+4) I/q],Exp[ 2π I  (Perturbation+4)  p /q]}*R4ToC2[Param[θ,ϕ]]],{θ,0,7π/4},{ϕ,0,π/2},
PlotStyle->Opacity[Op],Mesh->5, PlotRange->{{-2,2},{-2,2},{-2,2}},ViewPoint->{-3,-10,5},Axes->False,Boxed->False,BoundaryStyle->Black,
Lighting->"Neutral",ColorFunction->Function[{x,y,z},Purple]
]
},ViewPoint->(2000{4,-2,2.5}), PlotRange->{{-1.5,1.5},{-1.5,1.5},{-1.5,1.5}}
]

Show[View1,ImageSize->Large]