A major point behind the video is that Mobius transformations are simplest when viewed on the sphere. Thus, we'll never actually define a Mobius transformation - we'll do that part on the sphere. Of course, we will need to project back and forth. Here are the stereo graphic projection and it's inverse implemented as compiled functions for speed. This is actually a little more general then plain stereographic projection, as we need to account for the sphere being in general position.
(* Projection from the sphere to the plane *)
stereo = Compile[{{xyz, _Real, 1}, {XYZ, _Real, 1}}, Module[{
r = Sqrt[(xyz[[1]] - XYZ[[1]])^2 + (xyz[[2]] - XYZ[[2]])^2],
theta = ArcTan[(xyz[[1]] - XYZ[[1]]), (xyz[[2]] - XYZ[[2]])]},
{(r (1 + xyz[[3]]))/(1 - XYZ[[3]] + xyz[[3]]) Cos[theta + Pi] + xyz[[1]],
(r (1 + xyz[[3]]))/(1 - XYZ[[3]] + xyz[[3]]) Sin[theta + Pi] + xyz[[2]], 0}]];
(* Projection from the plane to the sphere *)
stereoInv = Compile[{{pq, _Real, 1}, {xyz, _Real, 1}},
{2 pq[[1]], 2 pq[[2]],
pq[[1]]^2 + pq[[2]]^2 - 1}/(pq[[1]]^2 + pq[[2]]^2 + 1) + xyz];
Here's a rectangular grid of points to work with.
(* The initial grid in the xy-plane *)
gridSpan = 1.2; step = 0.2;
plotSpan = 12;
xGrid = Table[{x, y, 0}, {y, -gridSpan, gridSpan, step},
{x, -gridSpan, gridSpan, step/10}];
yGrid = Table[{x, y, 0}, {x, -gridSpan, gridSpan, step},
{y, -gridSpan,
gridSpan, step/10}];
grid = Join[xGrid, yGrid];
(* {0,0} is problematic. *)
grid = DeleteCases[grid, {_?(NumericQ[#] &), _, _}?(Norm[#] < 0.0001 &), Infinity];
The following function accepts a sphere configuration (specified as an $xy, z$ position and $\varphi$, $\theta$ rotation) and returns a picture.
mtrPic[phi_, theta_, vp_, showSphere_, xy_, z_] := Module[{warpedGrid},
Quiet[warpedGrid = Normal[Rotate[
Rotate[Line[Map[stereoInv[#, Flatten[{xy, z}]] &, grid, {2}]],
theta, {0, 0, 1}, Flatten[{xy, 0}]],
phi, {-Sin[theta], Cos[theta], 0}, Flatten[{xy, z}]]];
Graphics3D[{
If[showSphere === True,
{{Opacity[0.8], Sphere[Flatten[{xy, z}]]}, warpedGrid}, {}],
{Map[stereo[Flatten[{xy, z}], #] &, warpedGrid, {3}]},
{Opacity[0.5],
Polygon[plotSpan {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]},
{Specularity[White, 20], ColorData["StarryNightColors"][1],
Tube[{{-12, 0, 0}, {12, 0, 0}}, 0.02],
Tube[{{0, -12, 0}, {0, 12, 0}}, 0.02],
Tube[{{0, 0, 0}, {0, 0, 3.8}}, 0.02],
Cone[{{0, 0, 3.7}, {0, 0, 4}}, 0.1]}
}, ImageSize -> 500, ViewPoint -> vp,
ViewAngle -> 30 Degree, Boxed -> False,
PlotRange -> {plotSpan {-1, 1}, plotSpan {-1, 1}, {-1, 4}}],
Power::infy]
];
It's quite easy to use this with Manipulate.
Manipulate[mtrPic[phi, theta, vp, showSphere, xy, z],
{{phi, 0}, 0, Pi}, {{theta, 0}, -Pi, Pi},
{{vp, {1.77141, -2.5135, 1.4121}/4, "view point"},
{{1.77141, -2.5135, 1.4121}/4 -> "perspective", {0, 0, 2} -> "ortho"}},
{{showSphere, True, "show sphere"}, {True, False}},
{{xy, {0, 0}}, (plotSpan - 1) {-1, -1}, (plotSpan - 1) {1, 1},
ControlPlacement -> Left},
{{z, 1}, 0, 3, VerticalSlider, ControlPlacement -> Left},
TrackedSymbols -> {phi, theta, vp, xy, z, showSphere},
SaveDefinitions -> True]
We can also use mtrPic to generate a movie by programatically generating the frames.
xyMotion = Table[4 Sin[2 t] {Cos[t], Sin[t]}, {t, 0, Pi/2, Pi/(99)}];
xyPics = Table[Labeled[mtrPic[0, 0, {1.77141, -2.5135, 1.4121}/4, True, xy, 1],
"translation", Top], {xy, xyMotion}];
thetaMotion = Table[theta, {theta, 0, Pi/2, Pi/99}];
thetaPics = Table[Labeled[
mtrPic[0, theta, {1.77141, -2.5135, 1.4121}/4, True, {0, 0}, 1],
"rotation", Top], {theta, thetaMotion}];
(* The bounce effect is ripped from the Mathematica documentation *)
bounceEqns = {y''[t] == -9.81, y[0] == 1, y'[0] == 0};
c = .9; events = {WhenEvent[y[t] == 0, y'[t] -> -c y'[t]]};
bounce = NDSolveValue[{bounceEqns, events}, y, {t, 0, 5}];
bot1 = t /. FindRoot[bounce[t] == 0, {t, 0.5}];
bot3 = t /. FindRoot[bounce[t] == 0, {t, 2.5}];
zMotion = Table[bounce[t] + 1, {t, bot1, bot3, (bot3 - bot1)/50}];
zPics = Table[Labeled[mtrPic[0, 0, {1.77141, -2.5135, 1.4121}/4, True, {0, 0}, z],
"dilation", Top], {z, zMotion}];
phiMotion = Table[phi, {phi, 0, 2 Pi, 2 Pi/49}];
phiPics = Table[
Labeled[mtrPic[phi, 0, {1.77141, -2.5135, 1.4121}/4, True, {0, 0}, 1],
"inversion", Top],
{phi, phiMotion}];
allTogetherNow = Transpose[{xyMotion, thetaMotion, phiMotion}];
comboPics = Map[Labeled[
mtrPic[#[[3]], #[[2]], {1.77141, -2.5135, 1.4121}/4, True, #[[1]], 1],
"combination", Top] &,
allTogetherNow];
thetaPics2 = First /@ Partition[thetaPics, 2];
allPics = Join[xyPics, thetaPics2, zPics, phiPics, comboPics];
When passed to ListAnimate, this generates a movie that looks something like so:
Note that the animation as shown here can be made much nicer, but stackexhange limits the size of GIFs that we can upload. Again, we've never defined a Mobius transformation but we can see one on the plane. We can also hide the sphere and look at the animation in orthographic perspective.
Obviously, there's more that could be done. It would be interesting to know how nice the image could be by tweaking the graphics directives. I'm sure that adding color by using ParametricPlot3D would be easy, but I'm not sure how responsive the result would be. We might also add color via graphics directives applied to polygons. In both cases, it might be challenging to deal with polygons containing the point that maps to infinity under the Mobius transformation, though.
