47
$\begingroup$

Möbius Transformations Revealed is a short video that vividly illustrates the simplicity of Möbius transformations when viewed as rigid motions of the Riemann sphere. It was one of the winners in the 2007 Science and Engineering Visualization Challenge and the various YouTube versions have been viewed some 2,000,000 times.

In the still image below, the colored portion corresponds to a simple square in the plane. The colored portion on the sphere is the image of the square in the plane under (inverse) stereographic projection; the sphere is then rotated into the position shown and finally projected back to the plane. The colored portion on the plane is the image of the original square under a Möbius transformation.

frame from Möbius transformations revealed

How can we implement this in Mathematica? Is it possible to create a dynamic version with Manipulate that allows us to interact with the image? Can we recreate a portion of the movie? Obviously, Mathematica can't create images of the quality of the original (which was produced with POV-Ray) but how close can we get? Can we generate color or should we stick with simple graphics primitives?

$\endgroup$
  • 5
    $\begingroup$ ... I really hope a self-answer is in progress? $\endgroup$ – Yves Klett Sep 9 '14 at 13:25
  • $\begingroup$ @YvesKlett Seems like a reasonable expectation. :) I do have an implementation based on simple graphics primitives that I'll post soon. $\endgroup$ – Mark McClure Sep 9 '14 at 13:32
  • $\begingroup$ That I am much looking forward to :D $\endgroup$ – Yves Klett Sep 9 '14 at 13:35
  • 1
    $\begingroup$ Very nice. Thanks for sharing this. $\endgroup$ – user29527 May 16 '15 at 20:37
  • 1
    $\begingroup$ I remember first watching this on the Dimensions-Math.org video series, at a higher resolution. It's good to have the code for a part of its contents :) If you haven't watched these videos, it's totally a must see. $\endgroup$ – Alfonso F R May 31 '15 at 8:52
13
$\begingroup$

This is nowhere near as remarkable as Mark McClure's answer (which I have voted for and would upvote more if I could) but I only post it in relation to coloring to illustrated correspondence.

spc[x_, y_] := {2 x, 2 y, -1 + x^2 + y^2}/(1 + x^2 + y^2)
mt[a_, b_, c_, d_][x_, y_] := 
 Through[{Re, Im}[(a x + a I y + b)/(c x + c I y + d)]]
q = Flatten[
   Table[{{i - 0.1, j - 0.1}, {i - 0.1, j}, {i, j}, {i, j - 0.1}}, {i,
      0.1, 1, 0.1}, {j, 0.1, 1, 0.1}], 1];
col = ColorData["Rainbow"][#/100] & /@ Range[100];
Manipulate[
 qm = Map[
   mt[Complex @@ a, Complex @@ b, Complex @@ c, Complex @@ d] @@ # &, 
   q, {2}];
 planm = Map[##~Join~{0} &, qm, {2}];
 Graphics3D[{Opacity[0.4], 
   InfinitePlane[{0, 0, 0}, {{1, 0, 0}, {0, 1, 0}}], LightBlue, 
   Sphere[], Opacity[1], 
   MapThread[{#1, Polygon@#2} &, {col, Map[spc @@ # &, qm, {2}]}], 
   MapThread[{#1, Polygon@#2} &, {col, planm}]}, Boxed -> False, 
  Background -> White, FaceGrids -> All, 
  PlotRange -> Table[{-3, 3}, {3}]], {{a, {1, 0}}, {0.1, 0.1}, {1, 
   1}}, {b, {0, 0}, {1, 1}}, {c, {0, 0}, {1, 1}}, {{d, {1, 0}}, {0.1, 
   0.1}, {1, 1}}, ControlPlacement -> Left]

enter image description here

$\endgroup$
  • 1
    $\begingroup$ Nice - and, it deals with the colors much better than I anticipated! $\endgroup$ – Mark McClure Jun 3 '15 at 0:47
  • 2
    $\begingroup$ @MarkMcClure thank you very much...it was a first attempt and if I had time I would improve it...thany you for accept :) $\endgroup$ – ubpdqn Jun 3 '15 at 1:41
66
+100
$\begingroup$

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]

enter image description here

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:

enter image description here

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.

enter image description here

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.

$\endgroup$
  • 8
    $\begingroup$ I'd give you a thousand +1's if I could. :) $\endgroup$ – rcollyer Sep 9 '14 at 14:19
  • 4
    $\begingroup$ Whoa! Glad this popped up on "active" - I'd not seen this answer. +100 bounty coming your way... $\endgroup$ – ciao May 16 '15 at 23:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.