How to find the vertices of a regular tetrahedron? a dodecahedron?

Question

My question is: how to find the coordinates of the vertices of regular tetrahedron and dodecahedron? I tried to find the coordinates of the vertices of a regular tetrahedron as the solutions of a certain polynomial system in $8$ variables, notating the vertices of a tetrahedron $S(0,0,1)$, $A(0,yA,zA)$, $B(xB,yB,zB)$, and $C(xC,yC,zC)$:

Reduce[
yA^2 + zA^2 == 1 &&
xB^2 + yB^2 + zB^2 == 1 && 
xC^2 + yC^2 + zC^2 == 1 && 
yA^2 + (zA - 1)^2 == xB^2 + yB^2 + (zB - 1)^2 && 
yA^2 + (zA - 1)^2 == xC^2 + yC^2 + (zC - 1)^2 && 
xB^2 + (yB - yA)^2 + (zB - zA)^2 ==
                 xC^2 + (yC - yA)^2 + (zC - zA)^2 && 
xB^2 + (yB - yA)^2 + (zB - zA)^2 ==
                 (xC - xB)^2 + (yC -yB)^2 + (zC - zB)^2 && 
xB^2 + (yB - yA)^2 + (zB - zA)^2 == 
                 yA^2 + (zA - 1)^2,
        {xB, xC, yA, yB, yC, zA, zB, zC}, Reals]

However, that code is spinning for hours without any output. A new idea is required.

P.S. 12.12.13. The answer done with Maple can be seen at http://mapleprimes.com/questions/200438-Around-Plato-And-Kepler-Again. Because nothing but trigonometry is used, I am pretty sure all that is possible in Mathematica.

Answer 1

Invariant theory construction

We can use Klein's invariants ($\Phi'$ on page 55, $H$ on page 61, Lectures on the Icosahedron) and project the complex roots onto the Riemann sphere, borrowing ubpdqn's projection code:

tetraPoly = -z1^4 - 2 Sqrt[3] z1^2 z2^2 + z2^4;
dodecaPoly = z1^20 + z2^20 - 228 (z1^15 z2^5 - z1^5 z2^15) + 494 z1^10 z2^10;

 (* project onto the Riemann sphere *)
sph[z_?NumericQ] := 
  Module[{den}, den = 1 + Re[z]^2 + Im[z]^2; {2 Re[z]/den, 2 Im[z]/den, (den - 2)/den}];

vTetra2 = sph[z1] /. Solve[(tetraPoly /. z2 -> 1) == 0, z1];

vDodeca2 = sph[z1] /. Solve[(dodecaPoly /. z2 -> 1) == 0, z1];
nf = Nearest[N@vDodeca2 -> Automatic];
edgeIndices2 = 
  Flatten[Cases[nf[vDodeca2[[#]], 4], n_ /; n > # :> {#, n}] & /@ Range[1, 19], 1];

Tetrahedron:

Graphics3D[GraphicsComplex[vTetra2,
  {Darker@Green, Thick, PointSize[Large],
   Point[Range@4],
   Line[Subsets[Range@4, {2}]]
   }]
 ]

Dodecahedron:

Graphics3D[GraphicsComplex[vDodeca2,
  {Darker@Green, Thick, PointSize[Large],
   Point[Range@20],
   Line[edgeIndices2]
   }]
 ]

Answer 2

A geometric construction

The alternate vertices of a cube are the vertices of a regular tetrahedron. Rotate these about an appropriate axis (for an explanation of the mathematics, see, for example, Euclid, Prop. XIII.17 or this demonstration) five times through a 1/5 turn and you get the vertices of a regular dodecahedron. In the construction below, one can choose any three mutually perpendicular vectors of the same length for e1, e2, e3 to define the edges of the cube. The cube will be centered at the origin with edges of twice the length of e1. Different choices yield different orientations and sizes.

{e1, e2, e3} = IdentityMatrix[3];
n0 = e1 + GoldenRatio e3; (* axis of rotation *)
vTetra = {{1, 1, 1}, {-1, -1, 1}, {1, -1, -1}, {-1, 1, -1}}.{e1, e2, e3};
vDodeca = Flatten[NestList[#.RotationMatrix[2 Pi/5, n0] &, vTetra, 4], 1];
nf = Nearest[N@vDodeca -> Automatic];
edgeIndices = 
  Flatten[Cases[nf[vDodeca[[#]], 4], n_ /; n > # :> {#, n}] & /@ Range[1, 19], 1];

Tetrahedron

vTetra
(* {{1, 1, 1}, {-1, -1, 1}, {1, -1, -1}, {-1, 1, -1}} *)

Graphics3D[GraphicsComplex[vTetra,
  {Red, Thick, PointSize[Large],
   Point[Range@4],
   Line[Subsets[Range@4, {2}]]
   }]
 ]

Dodecahedron

vDodeca /. GoldenRatio -> (1 + Sqrt[5])/2 // Simplify

(* {{1, 1, 1}, {-1, -1, 1}, {1, -1, -1}, {-1, 1, -1},
    {1/2 (1 + Sqrt[5]), 0, 1/2 (-1 + Sqrt[5])}, {-1, 1, 1},
    {1/2 (1 - Sqrt[5]), 1/2 (-1 - Sqrt[5]), 0}, {0, 1/2 (-1 + Sqrt[5]), 1/2 (-1 - Sqrt[5])},
    {1, -1, 1}, {1/2 (-1 + Sqrt[5]), 1/2 (1 + Sqrt[5]), 0},
    {1/2 (-1 - Sqrt[5]), 0,  1/2 (-1 + Sqrt[5])}, {0, 1/2 (1 - Sqrt[5]), 1/2 (-1 - Sqrt[5])},
    {0, 1/2 (1 - Sqrt[5]), 1/2 (1 + Sqrt[5])}, {1/2 (1 + Sqrt[5]), 0, 1/2 (1 - Sqrt[5])},
    {1/2 (1 - Sqrt[5]), 1/2 (1 + Sqrt[5]), 0}, {-1, -1, -1},
    {0, 1/2 (-1 + Sqrt[5]), 1/2 (1 + Sqrt[5])}, {1/2 (-1 + Sqrt[5]), 1/2 (-1 - Sqrt[5]), 0},
    {1, 1, -1}, {1/2 (-1 - Sqrt[5]), 0, 1/2 (1 - Sqrt[5])}} *)

Graphics3D[GraphicsComplex[vDodeca,
  {Red, Thick, PointSize[Large],
   Point[Range@20],
   Line[edgeIndices]
   }]
 ]

Answer 3

Actually It turns out mathematica can nicely directly solve the posed system of quadratics...

This should be equivalent to the formulation posed in the question:

$Assumptions = {Element[x[i_, j_], Reals]}
pts = Table[ x[i, j] , {i, 4}, {j, 3}] 
pts[[1]] = {0, 0, 1}
pts[[2, 1]] = 0
soln = Solve[Simplify[(Norm[#]^2 == 1 & /@ pts)~Append~
    (Equal @@ 
      Simplify[
         Norm[pts[[#[[1]]]] - pts[[#[[2]]]]]^2 & /@  
         Subsets[Range[4], {2}]])], Cases[Flatten@pts, x[_, _]]];

Last@soln  (*just by observation the last solution is real *)


(*
   {x[2, 2] -> -((2 Sqrt[2])/3), x[2, 3] -> -(1/3), x[3, 1] -> Sqrt[2/3],
    x[3, 2] -> Sqrt[2]/3, x[3, 3] -> -(1/3), x[4, 1] -> -Sqrt[(2/3)], 
    x[4, 2] -> Sqrt[2]/3, x[4, 3] -> -(1/3)}
*)

Graphics3D[
  Line[{pts[[#[[1]]]], pts[[#[[2]]]]}] & /@ Subsets[Range[4], {2}] /. 
  Last@soln, Boxed -> False]

I note that If I specify the Reals domain to solve it does not immediately return a solution, but by leaving out the domain it quickly returns 4 complex results and 4 real..

This works the same with Reduce noting the system of equations actually has 4 (I think) real solutions by symmetry (the tet can be upsidedown / mirrored..). Reduce returns a somewhat messy expression encompassing all the possibilities.

EDIT:

Just noticed the posed system admits the degenerate solution of all coincident points. This adds one more equation to exclude the degenerate case.

$Assumptions = {Element[x[i_, j_], Reals]};
n = 4;
pts = Table[ x[i, j] , {i, n}, {j, 3}] ;
pts[[1]] = {0, 0, 1};
pts[[2, 1]] = 0;
soln = Solve[Simplify[(Norm[#]^2 == 1 & /@ pts)~Append~
   (Equal @@ 
       Simplify[
           Norm[pts[[#[[1]]]] - pts[[#[[2]]]]]^2 & /@  
                Subsets[Range[n], {2}]])~Append~(pts[[2]] != pts[[1]])], 
                             Cases[Flatten@pts, x[_, _]]]

This should pull out the real solutions:

soln = Select[ soln  ,   Length[Union@Flatten[Simplify[Im[pts] /. #]]] == 1 &]

Unfortuately it only seems to work for n=4, not for 6,8,12 or 20..

Edit 2 -- well duh on me..the equations specify all points equidistant from each other, which is only the case for the tetrahedron. I'm not sure how to even pose the problem for a dodecahedron (That is as a sysem of equations w/o some other knowledge of the solution) Would it be cheating to use PolyhedronData["Dodecahedron", "EdgeIndices"] ?

Answer 4

Reflection group approach

Yet another approach in which Mathematica does most of the work. The starting point is to observe that if a face of a dodecahedron is subdivided into ten congruent right triangles, the group of symmetries of a dodecahedron is generated by reflections in planes that form a spherical triangle of angles $\pi/2$, $\pi/3$, and $\pi/5$ (triangle group (2, 3, 5)). The vertices of the dodecahedron are the orbit of the vertex v0 of the triangle where the angle is $\pi/3$. One starts with two planes at right angles to each other, and Mathematica solves for the third plane of reflection so that, given it is constructed so that it is inclined at an angle of $\pi/3$ to one initial plane, the plane of reflection is inclined at an angle of $\pi/5$ to the other initial plane.

refl[1] = ReflectionTransform[{1, 0, 0}];
refl[2] = ReflectionTransform[{0, 0, 1}];
refl[3] = 
  ReflectionTransform[{Sin[Pi/3] Cos[theta], Sin[Pi/3] Sin[theta], Cos[Pi/3]} /. 
    Last @ Quiet @
      Solve[VectorAngle[{1, 0, 0}, {Sin[Pi/3] Cos[theta], 
          Sin[Pi/3] Sin[theta], Cos[Pi/3]}] == Pi/5, theta]];
 (* basic rotational symmetries *)
rot[2] = Composition[refl[1], refl[2]];
rot[3] = Composition[refl[2], refl[3]];
rot[5] = Composition[refl[1], refl[3]];
 (* a convenient symmetry *)
rot[0] = Composition[rot[3], rot[5]];

 (* initial vertex *)
v0 = {Sin[Pi/2] Cos[theta - Pi/2], Sin[Pi/2] Sin[theta - Pi/2], Cos[Pi/2]} /. 
   Last @ Quiet @
     Solve[VectorAngle[{1, 0, 0}, {Sin[Pi/3] Cos[theta], 
         Sin[Pi/3] Sin[theta], Cos[Pi/3]}] == Pi/5, theta];
 (* 20 symmetries for transforming the initial vertex *)
rotDodeca = 
  NestList[Simplify @ Composition[rot[5], #] &, #, 4] & /@ 
    Simplify @ FoldList[Dot, 
      TransformationFunction@IdentityMatrix[4], {rot[0], rot[5], rot[0]}] // Flatten;

vDodeca3 = #[v0] & /@ rotDodeca; (* 20 vertices *)
nf = Nearest[N@vDodeca3 -> Automatic];
edgeIndices3 =  (* edges *)
  Flatten[Cases[nf[vDodeca3[[#]], 4], n_ /; n > # :> {#, n}] & /@ Range[1, 19], 1];

Dodecahedron:

Graphics3D[GraphicsComplex[vDodeca3,
  {Blue, Thick, PointSize[Large],
   Point[Range@20],
   Line[edgeIndices3]
   }]
 ]

[Coordinates, which may vary with orientation, and tetrahedron omitted.]

Answer 5

Here is something that seems to work for the tetrahedron. I expect the dodecahedron would work the same way with more code-typing or a list trick (anyone knows how to do that?).

p1 := {x1, y1, z1};
p2 := {x2, y2, z2};
p3 := {x3, y3, z3};
p4 := {x4, y4, z4};
Solve[
    EuclideanDistance[p1, p2] == 1 &&
     EuclideanDistance[p1, p3] == 1 &&
     EuclideanDistance[p1, p4] == 1 &&
     EuclideanDistance[p2, p3] == 1 &&
     EuclideanDistance[p2, p4] == 1 &&
     EuclideanDistance[p3, p4] == 1 &&
     x1 == 0 && y1 == 0 && z1 == 0 &&
     x2 == 0 && y2 == 0 && z2 == 1 &&
     x3 == 0,
    {x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4}, Reals] // Last;
tetra = Partition[{x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, 
    z4} /. %, 3]

Output :

{{0, 0, 0}, {0, 0, 1}, {0, Sqrt[3]/2, 1/2}, {Sqrt[2/3], 1/(2 Sqrt[3]),
   1/2}}

Answer 6

LinearProgramming[#,
{{1,1,1},{1,0,0},{0,1,0},{0,0,1}},
{{1,-1},{1,-1},{1,-1},{1,-1}},{0,0,0}]&/@{{-1,0,0},{0,-1,0},{0,0,-1},{1,1,1}}

As you want exact output, and not numeric output, you could use LinearProgramming. This function returns rational output for rational input. You just need the parametrization of the faces/facets that define your tetrahedron and the correct objective functions, one per node. You could now do the same for your dodecahedron example, or any polytope, for that matter -- including regular tetrahedra, simplices, and platonic solids or whatever else.