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

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

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

POSTED BY: Moderation Team
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