# [GIF] Part of the Journey (Conformally transformed hex circle packing)

Posted 4 years ago
7002 Views
|
4 Replies
|
13 Total Likes
|
 Part of the JourneyThis has a simple starting point: the hexagonal lattice packing of the plane by circles. Then we animate by translating: thinking of the plane as the complex numbers, that just means applying the tranformation $z \mapsto z+t$. This tranformation is 1-periodic, which will make the animation loop. Finally, then, the visually interesting part comes from applying a conformal transformation, which we can realize as a fractional linear transformation $z \mapsto \frac{az + b}{cz + d}$, corresponding to the matrix $\begin{pmatrix}a & b \\ c & d \end{pmatrix}$. Following Wikipedia, the transformation with fixed points at $\gamma_1$ and $\gamma_2$, pole at $z_\infty$ (meaning the point sent to infinity by the transformation) and inverse pole $Z_\infty = \gamma_1 + \gamma_2 - z_\infty$ (meaning the point that infinity maps to) is given by $\begin{pmatrix}a & b \\ c & d \end{pmatrix} = \begin{pmatrix}Z_\infty & -\gamma_1 \gamma_2 \\ 1 & -z_\infty \end{pmatrix}$After some playing around, I found that $\gamma_1 = 2$, $\gamma_2 = 2i$, and $z_\infty = \frac{17}{2} e^{i \pi/3}$ looked cool. Composing with $z \mapsto z+t$ then gives the animation.I assume @J. M. or @Kuba Podkalicki will pop up later in the thread and show 7 different ways to get dramatic speed-ups in the code, but I couldn't find a way to make this fast enough for a Manipulate[]. So instead, here's a list of frames: dots = With[{?1 = 2, ?2 = 2 I, z? = 8.5 E^(I ?/3.), cols = RGBColor /@ {{243, 229, 81}/255, {173, 216, 93}/ 255, {101, 188, 183}/255, {93, 140, 210}/255, {195, 116, 175}/ 255, {226, 87, 77}/255, {226, 118, 47}/255, "#0D2C54"}}, ParallelTable[ Graphics[ Table[{cols[[Mod[b, 7, 1]]], Polygon[ Table[ReIm[((?1 + ?2 - z?) # - ?1 ?2)/(# - z?) &[t + Complex @@ (a {1, 0} + b {1/2, Sqrt[3]/2} + 1/2 {Cos[?], Sin[?]})]], {?, 0., 2 ?, 2 ?/100}]]}, {a, -35, 13}, {b, If[a == 0 || a == -1, DeleteCases[Range[-30, 18], c_ /; c == 7 || c == 8 || c == 9], Range[-30, 18]]}], PlotRange -> 4, ImageSize -> 540, Background -> cols[[-1]]], {t, 0., 1 - #, #}] &[1/50] ]; ...which can be exported to a GIF: Export[NotebookDirectory[] <> "dots.gif", dots, "DisplayDurations" -> 1/50, "AnimationRepetitions" -> Infinity] 
4 Replies
Sort By:
Posted 4 years ago
 It feels slightly weird to be name-checked by Clayton at the outset. :) I will try hard at this.First, a preliminary subroutine (whose derivation was slightly unwieldy even with Mathematica at hand): moebiusDisk[{{a_, b_}, {c_, d_}}, {z0_, r_}] := With[{den = Abs[c z0 + d]^2 - Abs[r c]^2}, Disk[ReIm[((a z0 + b) Conjugate[c z0 + d] - a Conjugate[c] r^2)/den], r Abs[b c - a d]/den]] which, as might be ascertained, will generate a new Disk[] object corresponding to the Möbius transformation of Disk[ReIm[z0], r].With this, we can now write a Manipulate[] version: With[{?1 = 2., ?2 = 2. I, z? = 8.5 Exp[I ?/3], h = 1/50, cols = RGBColor /@ {"#f3e551", "#add85d", "#65bcb7", "#5d8cd2", "#c374af", "#e2574d", "#e2762f", "#0D2C54"}}, Manipulate[Graphics[ Table[If[! (MatchQ[a, -1 | 0] && MatchQ[b, 7 | 8 | 9]), {cols[[Mod[b, 7, 1]]], moebiusDisk[{{?1 + ?2 - z?, -?1 ?2}, {1., -z?}}, {t + a + b Exp[? I/3.], 0.5}]}, Nothing], {a, -35, 13}, {b, -30, 18}], PlotRange -> 4, ImageSize -> 540, Background -> cols[[-1]]], {t, 0, 1 - h, h}, SaveDefinitions -> True]] 
Posted 4 years ago
 Oh, nice! I'm glad you did what I was too lazy to do.Also, the little If[condition, output, Nothing] trick is a good one that I'll have to remember.
 I should point out that this business: If[a == 0 || a == -1, DeleteCases[Range[-30, 18], c_ /; c == 7 || c == 8 || c == 9], Range[-30, 18]] is to delete the disks which have a point in their interior get mapped to infinity (which should turn the disk inside-out, but Polygon[] doesn't work that way, and you just get a giant solid blob covering everything else).