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.