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

Posted 3 years ago
4460 Views
|
3 Replies
|
11 Total Likes
|
 Pack It InConsider 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}] ] 
3 Replies
Sort By:
Posted 3 years ago
 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: 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. 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[].
 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.