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

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

tetrahedron

Dodecahedron:

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

dodecahedron


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

Mathematica graphics

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

Mathematica graphics


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"] ?