Message Boards Message Boards

Platonic (Stereographic projections of the Platonic solids)

Stereographic tetrahedron

Stereographic cube

Stereographic octahedron

Stereographic dodecahedron

Stereographic icosahedron

Platonic

For 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}]]}]

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

POSTED BY: EDITORIAL BOARD
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