[GIF] Pack It In (Stereographic projection of circles)

[claytonshonkwiler]

Pack It In

Consider the eight vertices of the cube as points on the unit sphere, then make (spherical) circles centered on those points with radii chosen so that the circles are just tangent. Then this gives a packing of the sphere by 8 circles of (spherical) radius \frac{1}{2} \arccos \left(\frac{1}{3}\right) \approx 0.61548. (Of course, this is not the optimal packing by 8 circles; that is given by circles centered on the vertices of the square antiprism.)

Now, rotate the sphere and the eight circles around the x-axis and stereographically project down to the plane. After adding some color, the result is this animation.

Here’s the code:

Stereo[{x_, y_, z_}] := 1/(1 - z) {x, y};

DynamicModule[{p, b, 
  verts = Normalize /@ PolyhedronData["Cube", "VertexCoordinates"], 
  t = 1/2 ArcCos[1/3], 
  cols = RGBColor /@ {"#EF6C35", "#2BB3C0", "#161C2E"}},
 Manipulate[
  p = RotationMatrix[?, {1, 0, 0}].# & /@ verts;
  b = Orthogonalize[NullSpace[{#}]] & /@ p;
  Graphics[{EdgeForm[None],
    Table[{cols[[Floor[(i - 1)/4] + 1]],
      Polygon[Table[Stereo[Cos[t] p[[i]] + Sin[t] (Cos[s] b[[i, 1]] + Sin[s] b[[i, 2]])], {s, 0, 2 ?, 2 ?/200}]]},
     {i, 1, Length[verts]}]}, PlotRange -> Sqrt[6], 
   Background -> cols[[-1]], ImageSize -> 540],
  {?, 0, ?/2}]
 ]

[pleasureoffiguring (J. M.)]

Here is a slight shortening of Clayton’s code:

DynamicModule[{p, b, verts = Normalize /@ N[PolyhedronData["Cube", "VertexCoordinates"]],
               t = ArcCos[1/3]/2, cols = RGBColor /@ {"#EF6C35", "#2BB3C0", "#161C2E"}}, 
              Manipulate[p = verts.RotationMatrix[-?, {1, 0, 0}]; b = NullSpace[{#}] & /@ p;
                         Graphics[{EdgeForm[], Table[{cols[[Quotient[i, 4, -3]]], 
                                   Polygon[Table[Most[#]/(1 - Last[#]) &[
                                                 Cos[t] p[[i]] + Sin[t] ({Cos[s], Sin[s]}.b[[i]])],
                                                 {s, 0, 2 ?, 2 ?/200}]]}, {i, Length[verts]}]}, 
                                  PlotRange -> Sqrt[6], Background -> cols[[-1]], ImageSize -> 540],
                         {?, 0, ?/2}]]

---

Notes:

1. Dot products are very efficient in Mathematica, thus the new direct expression for p (accounting for the need to transpose) is much faster than mapping a dot product all over a list.
2. Using inexact coordinates in this case, apart from the easier internal handling, allows NullSpace[] to use the singular value decomposition (SVD) internally, thus obviating the need for an extra Orthogonalize[].

[claytonshonkwiler]

I need to carve “Did you remember to use N[]?” into my wall or something. Exact calculations have caused me so many problems over the years, but I still forget all the time.

[wolframcommunity (EDITORIAL BOARD)]

• Congratulations! This post is now a Staff Pick as distinguished on your profile! Thank you, keep it coming!