Message Boards Message Boards

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

MODERATOR NOTE: a submission to computations art contest, see more: https://wolfr.am/CompArt-22


Conformally transformed hexagonal circle packing

Part of the Journey

This 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 Pi/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 Pi, 2 Pi/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

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.

Posted 7 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 BY: J. M.

enter image description here - Congratulations! This post is now a Staff Pick as distinguished on your profile! Thank you, keep it coming!

POSTED BY: EDITORIAL BOARD

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).

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract