6
$\begingroup$

I would like to visualize the complex map $f(z)=z^2$ as the following picture (see Visual Complex Analysis by Tristan Needham) shows: enter image description here

Naively applying the code in an answer I got something far from being satisfatory:

dphi = Pi/30;
rend = 3;
pts = Table[
   r*Exp[I N[phi, 30]], {phi, 0, Pi/3 - dphi/2, dphi}, {r, 1, rend, 
    rend/10}];

line[pts_] := line[pts, Identity];
line[pts_, func_] := Line[ReIm[func[pts]]]
p1 = Graphics[{line /@ pts,
   line /@ Transpose[pts],
   Circle[]}, ImageSize -> 200]

F[z_] = z^2;
p2 = Graphics[{Circle[],
   line[#, F] & /@ pts,
   line[#, F] & /@ Transpose[pts]}, ImageSize -> 200]

enter image description here

enter image description here

The axes should not be very difficult to add. I now have the following problems

  • How can I get that little black T shape?
  • The arcs in the second picture should not be straight lines. How can I change this without adding the grids?
$\endgroup$
5
  • $\begingroup$ Since you're not coloring the mesh here, why not use ParametricPlot[]? $\endgroup$ Commented Sep 22, 2017 at 14:26
  • $\begingroup$ @J.M.: Thanks for your comment. It seems that I can solve the straight line problem with ParametricPlot. I'm now stumped at getting the black T shape. $\endgroup$
    – user664
    Commented Sep 22, 2017 at 14:57
  • $\begingroup$ Could you explain what you mean with "a complex map of f(Z)=Z^2"? What is Z (I guess a complex number) and how is it related to the figure you show? $\endgroup$
    – Ruud3.1415
    Commented Sep 22, 2017 at 16:32
  • $\begingroup$ @Ruud3.1415: $z$ is a complex number. The first figure represents a domain (shaded area) of the function $f$. The second figure shows image of the shaded area under the map $f(z)=z^2$. $\endgroup$
    – user664
    Commented Sep 22, 2017 at 17:07
  • 1
    $\begingroup$ Since you seem to be very interested in this: if you can, try to look up Maeder's Programming in Mathematica. The first chapter of this book deals with how to implement these mappings from scratch in Mathematica. $\endgroup$ Commented Sep 24, 2017 at 13:00

4 Answers 4

9
$\begingroup$

Mathematica graphics

Initially, we start with a set of points for the grid. I want to create a single graphics which contains the same original and the transformed image and I want to create the transformed image from the original one. The move variable is the amount we want to shift the transformed image to the right.

theta = Pi/3;
move = 7;
pts = Table[r*{Cos[phi], Sin[phi]}, 
        {phi, 0, theta, theta/10},
       {r, 1, 2.5, 1.5/10}];

To select the points for the black "T" we can access the coordinates by pts[[phi,r]]

mark = Join[pts[[7, {1, 2, 3}]], pts[[6, {3, 4}]], 
   pts[[{6, 7, 8, 9}, 4]], pts[[{9, 8}, 3]], pts[[8, {2, 1}]]];

The basic image contains only one complicated part which is the transformation of the coordinate list so that we can plot single polygons for each little "rectangle". Therefore, we need to bring it in a form where the grid is given as many elements {p1,p2,p3,p4} that are the corners of each polygon in the correct, counter-clockwise order:

grid = Graphics[{
   EdgeForm[{Black, Thin}],
   Arrowheads[.02],
   FaceForm[LightGray],
   (* Take the time to study this! *)
   Polygon[Join[#1, Reverse[#2]]] & @@@ Transpose[#] & /@
     Partition[Partition[#, 2, 1] & /@ pts, 2, 1],
   FaceForm[Black],
   Polygon[mark],
   Circle[],
   Arrow[{{0, 0}, {3, 0}}],
   Arrow[{{0, 0}, 3*{Cos[theta], Sin[theta]}}]
   }]

Now we define 2 functions that are used to turn the original graphics into the transformed one. f is for the grid itself. fArrow is a bit different, since the arrows would be too long under the transformation z^2, therefore we scale it a bit down:

f[{x_, y_}] := With[{z = x + I*y}, ReIm[z^2]];
fArrow[{x_, y_}] := With[{zs = (x + I*y)^2}, ReIm[.8 zs]]

These two functions can now be used to create rules to transform the graphics primitives. In addition to that, we define a moveRule that shifts the graphics to the right:

rules = {
   Polygon[pts_] :> Polygon[f /@ pts],
   Arrow[{a_, b_}] :> Arrow[{a, fArrow[b]}]
   };
moveRule = {{x_?NumericQ, y_?NumericQ} :> {x + move, y}}

With this, we can create the basic figure by simply using grid two times and transforming one of it with the rules:

Show[{grid, grid /. rules /. moveRule}, Frame -> True, 
 FrameTicks -> False, Axes -> False]

Mathematica graphics

Finally, we need to add the labels. For the neat wiggly arrow, we can use a damped oscillator

s[text_] := Style[text, 14];
arrow = Graphics[{CapForm["Round"], 
       Text[s["\!\(\*SuperscriptBox[\(z\), \(2\)]\)"], {3.5, 2.5}], 
       Arrowheads[0.03], Thick, Arrow[BSplineCurve[
     Table[{t + 3, Exp[-10*(t/3)]*Sin[15*t] + 2}, {t, 0, 1.7, 1.3/20}]]]}]

The text is manual work, but we use polar coordinates for correct placement where appropriate

text = {
   Text[s["1"], {1.2, -.2}],
   Text[s["θ"], 2/3 {Cos[theta/2], Sin[theta/2]}],
   Text[s["∞"], {3.2, 0}],
   Text[s["∞"], 3.2 {Cos[theta], Sin[theta]}],
   Text[s["1"], {1.2 + move, -.2}],
   Text[s["2θ"], 
    1/2 f[{Cos[theta/2], Sin[theta/2]}] + {move, 0}]
   };

The final image is then given by adding text and the arrow:

Show[{grid, grid /. rules /. moveRule, Graphics[text], arrow}, 
 Frame -> True, FrameTicks -> False, Axes -> False,ImageSize -> 712]

Appendix

To make the circular grid more smooth, the plot-points need to be increased. Then, we cannot use the raw polygon outlines anymore and as in functions like ParametricPlot too, the grid must be plotted as lines on top of the gray surface. Still, it's not really much more work to make this happen. I'm showing only the code that was adjusted:

theta = Pi/3;
move = 7;
pts = Table[
   r*{Cos[phi], Sin[phi]}, {phi, 0, theta, theta/100}, {r, 1, 2.5, 
    1.5/10}];

mark = Join[
   pts[[71, {1, 2, 3}]],
   pts[[71 ;; 61 ;; -1, 3]],
   pts[[61, {3, 4}]],
   pts[[61 ;; 91, 4]],
   pts[[91 ;; 81 ;; -1, 3]],
   pts[[81, {2, 1}]]];

grid = Graphics[{
   EdgeForm[LightGray],
   Arrowheads[.02], 
   FaceForm[LightGray],
   Polygon[Join[#1, Reverse[#2]]] & @@@ Transpose[#] & /@ 
    Partition[Partition[#, 2, 1] & /@ pts, 2, 1], FaceForm[Black],
   Polygon[mark],
   Black,
   Line[pts[[;; ;; 10]]],
   Line[Transpose[pts]],
   Circle[], Arrow[{{0, 0}, {3, 0}}], 
   Arrow[{{0, 0}, 3*{Cos[theta], Sin[theta]}}]}]

rules = {
   Polygon[pts_] :> Polygon[f /@ pts],
   Line[pts_] :> Line[Map[f, pts, {2}]],
   Arrow[{a_, b_}] :> Arrow[{a, fArrow[b]}]};
moveRule = {{x_?NumericQ, y_?NumericQ} :> {x + move, y}}

Show[{grid, grid /. rules /. moveRule}, Frame -> True, 
 FrameTicks -> False, Axes -> False]

Mathematica graphics

The final image for this can be found at the top of the article.

$\endgroup$
2
  • $\begingroup$ Thanks! Is it possible to make the arcs in the second figure be more close to "arcs"? In ParametricPlot, one can increase PlotPoints, can we do it similarly here? $\endgroup$
    – user664
    Commented Sep 24, 2017 at 12:37
  • 1
    $\begingroup$ Yes, this is surely possible but what I used here is that the grid-lines are created by the underlying plot-points. Plotting commands in Mathematica put the mesh on top of the underlying surface. To make it work with this manual grid, you need to increase the plotpoints in the angular direction. Then, the grid needs to be drawn by lines as well and the selection of the "T" needs to be adjusted. I'm appending it to my answer. $\endgroup$
    – halirutan
    Commented Sep 25, 2017 at 9:53
4
$\begingroup$

As to the T shape, I think it's not a bad idea to make use of the drawing tools.

We first draw the grid line:

With[{i = 1/2, o = 3/2}, 
 ParametricPlot[{r Cos[t], r Sin[t]}, {t, 0, π/3}, {r, i, o}, Frame -> False, 
   Axes -> False, PlotRange -> All, PlotPoints -> 50]~Show~
  ParametricPlot[i {Cos[t], Sin[t]}, {t, 0, 2 π}]]

Then select the graphic, Ctrl+d or right click and press d to open the tool palette, press g to select the polygon tool and draw a T shape, and store the modified graphic to a variable e.g. p. The following is a screen record for the procedure:

enter image description here

Finally, transform p:

Show[Normal@p /. (h : Polygon | Line)[a_] :> h[({Re@#, Im@#} &[({1, I}.#)^2] & /@ a)], 
 PlotRange -> All]

Mathematica graphics

$\endgroup$
2
$\begingroup$
        Join[Join[
   Join[{Circle[]}, 
    Table[Circle[{0, 0}, i^2, {0, \[Pi]/3}], {i, 1, Sqrt[
      3], (Sqrt[3] - 1)/10}], 
    Table[Line[{{Cos[\[Theta]], Sin[\[Theta]]}, {3 Cos[\[Theta]], 
        3 Sin[\[Theta]]}}], {\[Theta], 
      0, \[Pi]/3, \[Pi]/21}]]], {Annulus[{0, 
     0}, {1, (1 + 3 (Sqrt[3] - 1)/10)^2}, {3 \[Pi]/21, 4 \[Pi]/21}], 
   Annulus[{0, 
     0}, {(1 + 2 (Sqrt[3] - 1)/10)^2, (1 + 
       3 (Sqrt[3] - 1)/10)^2}, {2 \[Pi]/21, 5 \[Pi]/21}]}] // Graphics

enter image description here

$\endgroup$
1
$\begingroup$

Thanks to helpful comments and answers in the following two questions:

How can I improve my code for visualizing a complex map?

Can I add different texts to these two pictures using the `If` function?

this is the best I can do so far:

enter image description here

F[z_] := z^2;
t1 = 0; t2 = Pi/3; dt = (t2 - t1)/10;
r1 = 1; r2 = 3; dr = (r2 - r1)/10;

GraphicsRow[
 With[{z = r Exp[I t], col = Black},
    Show[
     ParametricPlot[
      ReIm@#[z], {r, r1, r2}, {t, t1, t2},
      Mesh -> 9,
      MeshShading -> ArrayPad[
        {{None, col}, {col, col}, {None, col}}, {{5, 2}, {4, 4}}, None
        ],
      PlotPoints -> 200,
      Frame -> False,
      AxesOrigin -> {0, 0},
      PlotRange -> {{-6, 13}, {-1.1, 10}},
      ImageSize -> Large,
      AxesStyle -> Opacity[0]],
     Graphics[{
       {Blue, 
        Circle[], {FontSize -> 12, 
         Text[If[# === Identity, "\[Theta]", 
           "2\[Theta]"], {.44, .25}]}},
       {Blue, {FontSize -> 18, 
         Text[If[# === Identity, "\[Infinity]", ""], {10.5, 0}]}},
       {Blue, {FontSize -> 18, 
         Text[If[# === Identity, "\[Infinity]", ""], 
          10.5 ReIm@#[ Exp[I Pi/3]]]}},
       {Blue, {FontSize -> 12, Text["1", {1.3, -0.5}]}},
       {Blue, Arrow[{{0, 0}, {10, 0}}]},
       {Blue, Arrow[If[# === Identity, {{6, 4}, {8, 4}}, {}]]},
       {Blue, {FontSize -> 18, 
         Text[If[# === Identity, 
           "\!\(\*SuperscriptBox[\(z\), \(2\)]\)", ""], {7, 5}]}},
       {Blue, Arrow[{{0, 0}, 10 ReIm@#[ Exp[I Pi/3]]}]}
       }]
     ]
    ] & /@ {Identity, F}]
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.