Message Boards Message Boards

[GIF] Modular (Point orbit under the action of the modular group)

GROUPS:

Point orbit under the action of the modular group

Modular

In the two-part talk she gave at the ICERM Workshop on Illustrating Mathematics, Katherine Stange talked about Kleinian groups – which are discrete subgroup of $PSL(2,\mathbb{C})$ – and the various beautiful pictures that come up when studying them. She mostly focused on Schmidt arrangements, which are the images of the real line under the action of a Bianchi group, which is a special type of Kleinian group.

With that somehow in the back of my head, I set out to show the orbit of a point under the action of the modular group, otherwise known as $PSL(2,\mathbb{Z})$, on the hyperbolic plane. $PSL(2,\mathbb{Z})$ naturally acts on the half-plane model of the hyperbolic plane by fractional linear transformations, so that the matrix $\left(\begin{array} aa & b \\ c & d \end{array}\right)$ sends $z$ to $\frac{az+b}{cz+d}$. This is a discrete subgroup of the isometry group of the hyperbolic plane, which is just $PSL(2,\mathbb{R})$ acting by fractional linear transformations.

Now, as you can see from the animation, I'm not using the upper half-plane model, I'm using the Poincaré disk model, not the upper half-plane model, so we need to translate appropriately.

Since the Möbius transformation $f(z)=\frac{z-i}{z+i}$ sends the upper half-plane to the unit disk, we can conjugate the fractional linear transformation $z \mapsto \frac{az+b}{cz+d}$ by $f$ to see that the corresponding action on the Poincaré disk model is $z \mapsto \frac{\alpha z + \beta}{\bar{\beta}z+\bar{\alpha}}$ for any complex numbers $\alpha$ and $\beta$ with $|\alpha|> |\beta|$ (more precisely, $\alpha = a+d+i(b-c)$ and $\beta=a-d-i(b+c)$). Hence the following definition:

PoincareMobius[{α_,β_}]:=(ReIm[(α #1+β)/(Conjugate[β] #1+Conjugate[α])]&)[Complex@@#1]&

All of this just goes to show that you get a modular group element that acts on the Poincaré disk by choosing pairs $(\alpha, \beta)$ of Gaussian integers with $|\alpha| > |\beta|$.

So that's how I'm getting the animation, though I'm doing it in a kind of stupid way: I'm iterating over the $L^\infty$ norm of $(\alpha, \beta)$, thought of as a point in $\mathbb{R}^4$, applying them to the point $(0,0)$, and (hopefully) throwing away duplicates. Of course, I could have also picked just a few generators and applied them recursively to the point, and maybe I will in the future.

Here's the code which produces the still image shown below, which is the seventh frame from the animation with some slightly different coloring (to generate the frames in the animation, which have consistent coloring, I replaced #[[2]]/(4 n - 1) in the second argument of Blend with #[[2]]/51):

Module[
 {n = 6,
  cols = RGBColor /@ {"#EAEAEA", "#FF2E63", "#08D9D6", "#252A34"},
  newindices,
  indices = {},
  newpts,
  cleanedpts = {{{0, 0}, 0}}},
 Do[
  newindices = 
   DeleteCases[
    DeleteDuplicates[
     Sort[Complement[Tuples[Range[-depth, depth], {4}], indices], 
      Norm[#1, 1] > Norm[#2, 1] &]], {a_, b_, 0, 0} | {a_, b_, c_, 
       d_} /; Norm[{c, d}] >= Norm[{a, b}]];
  indices = Join[indices, newindices];
  newpts = 
   Table[{PoincareMobius[{a[[1]] + a[[2]] I, a[[3]] + a[[4]] I}][{0, 
       0}], Norm[a, 1]}, {a, newindices}];
  cleanedpts = 
   Join[cleanedpts, 
    DeleteDuplicates[
     Sort[newpts, #1[[2]] < #2[[2]] &], #1[[1]] == #2[[1]] &]];
  , {depth, 0, n}];
 Graphics[
  {
   {PointSize[.03/If[#[[2]] == 0, 1, #[[2]]]],
      Blend[cols[[2 ;; -2]], #[[2]]/(4 n - 1)],
      Point[#[[1]]]} & /@ Reverse[cleanedpts],
   cols[[1]], Thickness[.003], Circle[]
   },
  ImageSize -> 1080, PlotRange -> Sqrt[2], Background -> cols[[-1]]
  ]
 ]

This takes about 20 seconds to run on my 5 year old MacBook Air, so it's definitely not fast, but that's surely due to horribly inefficient programming.

Still version

POSTED BY: Clayton Shonkwiler
Answer
10 months ago

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the top of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

POSTED BY: Moderation Team
Answer
10 months ago

Very nice visualisation!

On two occassions:

Sort[...,  Norm[#1, 1] > Norm[#2, 1] &]

Could be sped up by:

SortBy[..., Norm[#, 1]&]

25% improved on my laptop...

In addition:

DeleteDuplicatesBy[SortBy[newpts, #[[2]] &], First]

Speeds it up another 10x times, 13x total or so...

Moral of the story: if you compare two the same things in Sort, DeleteDuplicates, Gather et cetera use SortBy, DeleteDuplicatesBy, GatherBy, et cetera. those are a lot faster because it evaluates the criterion only once on all the elements, sorts those (very fast) and reorders the original. While e.g Sort compares each PAIR again and again, reevaluating the criterion. Because in theory you could have an 'asymmetrical' comparison: e.g. SortBy[list,First[#1]>Last[#2]&] (quite uncommon but it happens sometimes!).

POSTED BY: Sander Huisman
Answer
10 months ago

Oh wow, thank you! I didn't even know about SortBy and DeleteDuplicatesBy, but that's obviously the way to go.

POSTED BY: Clayton Shonkwiler
Answer
10 months ago

Group Abstract Group Abstract