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}]]
}]
]
Dodecahedron:
Graphics3D[GraphicsComplex[vDodeca2,
{Darker@Green, Thick, PointSize[Large],
Point[Range@20],
Line[edgeIndices2]
}]
]
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]
}]
]
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"]
?