Mobius Transformations

2006-08
   Xah
   xah@xahlee.org
 ∑ http://xahlee.org/

Mobius Transformation

Needs["Transform2DPlot`"]

?MobiusTransform

MobiusTransform[a, b, c, d][z]

Clear[ WindowPolygon];
WindowPolygon::"usage" = "WindowPolygon[p_Polygon, s] will cut \
a Polygon p open by the scale of 0<s<1. WindowPolygon[gra,s] will cut every \
Polygon in gra. Usage Example: \
Needs[\"Graphics`Shapes`\"];Show[Graphics3D[WindowPolygon[Sphere[1,10,8],.7]]]\
";
\(\(WindowPolygon[\ poly_Polygon\ , scale_] := \ 
        Module[{centerP, pts1, pts2}, 
		pts1 = First@\ poly; 
          centerP = \((Plus @@ pts1)\)/
              Length@pts1; 
		pts2 = \(\((\((# - centerP)\) scale + 
                    centerP)\)\  &\) /@ \ pts1; 
          Polygon /@ \ 
            Thread[{pts1, RotateLeft[pts1], RotateLeft[pts2], 
                pts2}]];\)\)
WindowPolygon[ g_, scale_] := 
        g /. l_Polygon :> WindowPolygon[l, scale];

Clear[CenterTrianglizePolygon];
\(\(CenterTrianglizePolygon::"usage" = "CenterTrianglizePolygon[gra] breaks Polygon in gra into triangles metting at the center of each Polygon. Usage Example: Show[Graphics3D[CenterTrianglizePolygon@Sphere[1,10,8]]]";\)\)

\(CenterTrianglizePolygon[p_Polygon] := 
      Module[{centerP, pts}, pts = First@\ p; 
        centerP = \((Plus @@ pts)\)/
            Length@pts; 
		Polygon[\(\((# - centerP)\) scale + 
                centerP\  &\) /@ \ pts]; 
        Polygon /@ \((\(Join[{centerP}, #] &\) /@ 
              Partition[Append[pts, First@pts], 2, 1])\)]; 
    CenterTrianglizePolygon[g_] := 
      g /. p_Polygon :> CenterTrianglizePolygon@p;\)

a = Random[Complex, {-2, 2}]; b = Random[Complex, {-2, 2}]; 
    c = Random[Complex, {-2, 2}]; 
    d = Random[Complex, {-2, 2}];
a = 1; b = -1; c = 1; d = 1;

preimage = 
      Show[(WindowPolygon[#,  .5] &)@(IncreaseGraphicsResolution[#, 
                  3] &)@
            RectangularPatchGraphics[{-5, 5, 4,  .1},  {-5, 5, 
                10,  .2}], Frame -> True, 
        AspectRatio -> Automatic, PlotRange -> All, 
        Background -> GrayLevel[0]]
postimage = 
      Transform2DGraphicsPlot[
        preimage, MobiusTransform[a, b, c, d][#1 + #2*I] &, 
        ResolutionLength ->  .1, AspectRatio -> Automatic, 
        Background -> GrayLevel[0], Frame -> True, 
        Axes -> True]

rs = 
      StereographicProjectionPlot3D[postimage, PlotRange -> All, 
        ResolutionLength ->  .5]

preimage = 
      Show[PolarPatchGraphics[{ .1, 6, 4,  .2},  {0, Pi - 0.2, 8,  .2}], 
        Frame -> True, AspectRatio -> Automatic, 
        PlotRange -> All]
postimage = 
      Transform2DGraphicsPlot[
        preimage, (MobiusTransform[a, b, c, d][#1 + #2*I] &), 
        ResolutionLength ->  .025, AspectRatio -> Automatic, 
        Frame -> True, PlotRange -> All]

rs = StereographicProjectionPlot3D[postimage]

e

postimage = 
      Transform2DGraphicsPlot[
        Show[preimage =  
            Graphics[ 
              PolarGrid[{ .1, 3,   .1},  {0,  6,   .2},  {Hue,  
                  GrayLevel}], 
              Background -> GrayLevel@0],   AspectRatio -> Automatic, 
          Frame -> 
            True], MobiusTransform[1, -1, 1, 1][#1 + #2*I] &, 
        ResolutionLength ->  .05, AspectRatio -> Automatic, 
        Axes -> True, Frame -> True, 
        PlotRange -> {{-1, 1}, {-1, 1}} 4, 
        Background -> GrayLevel@0]

rs = StereographicProjectionPlot3D[postimage]

JavaView

Export graphics to file for JavaView

eP = 3;
tt = OpenWrite["x.mgs"];
WriteString[tt, "Graphics3D["];
\(\(WriteString[
        tt, \((StringReplace[#, ", " -> ","] &)\)@\(ToString@
            NumberForm[
              SetPrecision[Chop[First@rs, 10^\(-\((eP + 1)\)\)], eP], 
              ExponentFunction -> \((If[\(-∞\) < #1 < ∞, Null, #1] &)\)]\)];\)\)
WriteString[
        tt, ",Lighting->False]"];
Close@tt;