# Platonic (Stereographic projections of the Platonic solids)

Posted 6 months ago
720 Views
|
1 Reply
|
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}]]}] 
Answer
Posted 6 months ago
 - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!
Answer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments