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

Posted 3 years ago
3870 Views
|
3 Replies
|
13 Total Likes
|
 ModularIn 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.
3 Replies
Sort By:
Posted 3 years ago
 Oh wow, thank you! I didn't even know about SortBy and DeleteDuplicatesBy, but that's obviously the way to go.
 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!).