# Platonic (Stereographic projections of the Platonic solids)

Posted 9 months ago
990 Views
|
|
3 Total Likes
|
 PlatonicFor once, not a GIF, but instead a collection of still images. These show the stereographic projections of spherical circles centered at the vertices of each of the Platonic solids. For each of the five Platonic solids, the radius of the spherical circle is equal to $1/3$ of the angular distance between adjacent vertices, which of course means the circles centered at the vertices of the tetrahedron are much bigger than those centered at the vertices of the dodecahedron, but all the circles in a given image are the same size up in the sphere.This uses the ProjectedSphericalCircle[] function from Small Changes, but otherwise everything is contained in the following Manipulate[]. This is a little ugly because I'm rotating things so that each polyhedron has a face centered at the north pole and aligned nicely with the coordinate directions, and this required a slightly different rotation for each polyhedron, and also because each one requires a different zoom level. Anyway, here's the code: Manipulate[ Block[{θ, M, r, c, size = 540, v = Normalize /@ N[PolyhedronData[P, "VertexCoordinates"]], cols = RGBColor /@ {"#3dbd5d", "#de3d83", "#2677bb", "#ec6b2d", "#2f292b", "#f1f2f0"}}, θ = Min[DeleteCases[Flatten@Outer[VectorAngle, v, v, 1], 0.]]; {M, r, c} = Which[ P == "Tetrahedron", {RotationMatrix[-π/6, {0, 0, 1}].RotationMatrix[ArcCos[1/3], {{-(1/Sqrt[3]), 0, 1/(2 Sqrt[6])}, {0, 0, 1}}], 3.8, cols[[1]]}, P == "Cube", {IdentityMatrix[3], 3.5, cols[[2]]}, P == "Octahedron", {RotationMatrix[-π/12, {0, 0, 1}].RotationMatrix[ArcCos[1/Sqrt[3]], {{1, 1, 1}, {0, 0, 1}}], 5.3, cols[[3]]}, P == "Dodecahedron", {RotationMatrix[-π/10, {0, 0, 1}], 5.5, cols[[4]]}, P == "Icosahedron", {RotationMatrix[π/6, {0, 0, 1}].RotationMatrix[ArcCos[-(1/Sqrt[15 + 6 Sqrt[5]])], {{Sqrt[5/2 + 11/(2 Sqrt[5])], 0, -(1/Sqrt[10 - 2 Sqrt[5]])}, {0, 0, 1}}], 8.2, cols[[5]]}]; Blend[ {Graphics[ {c, Table[ ProjectedSphericalCircle[M.v[[i]], θ/3], {i, 1, Length[v]}]}, PlotRange -> r, ImageSize -> size, Background -> cols[[-1]]], RandomImage[1, {size, size}]}, .07] ], {P, PolyhedronData["Platonic"][[{-1, 1, 4, 2, 3}]]}]