Мой вопрос: как найти координаты вершин правильных тетраэдра и додекаэдра? Я пытался найти координаты вершин правильного тетраэдра как решения некоторой полиномиальной системы в $8$ переменных, обозначив вершины тетраэдра $S(0,0,1)$, $A(0,yA,zA)$, $B(xB,yB,zB)$ и $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]
Однако этот код крутится часами без какого-либо результата. Требуется новая идея.
P.S. 12.12.13. Ответ, сделанный с помощью Maple, можно посмотреть на http://mapleprimes.com/questions/200438-Around-Plato-And-Kepler-Again. Поскольку не используется ничего, кроме тригонометрии, я уверен, что все это возможно в Mathematica.
Геометрическая конструкция
Альтернативные вершины куба - это вершины правильного тетраэдра. Поверните их вокруг соответствующей оси (объяснение математики см., например, Euclid, Prop. XIII.17 или this demonstration) пять раз на 1/5 оборота, и вы получите вершины правильного додекаэдра. В приведенной ниже конструкции можно выбрать любые три взаимно перпендикулярных вектора одинаковой длины e1
, e2
, e3
для определения граней куба. Куб будет центрирован в начале координат с гранями, длина которых вдвое больше длины e1
. Различные варианты дают разные ориентации и размеры.
{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];
Тетраэдр
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}]]
}]
]
Додекаэдр
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 может прекрасно решать поставленную систему квадратиков напрямую...
Это должно быть эквивалентно формулировке, заданной в вопросе:
$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]
Я заметил, что если я укажу область Reals для решения, это не вернет решение немедленно, но если оставить область, это быстро вернет 4 комплексных результата и 4 вещественных.
То же самое происходит и с Reduce, отмечая, что система уравнений на самом деле имеет 4 (я думаю) реальных решения в силу симметрии (tet может быть перевернута / зеркально отображена...). Reduce возвращает несколько беспорядочное выражение, охватывающее все возможности.
EDIT:
Только что заметил, что система допускает вырожденное решение всех совпадающих точек. Это добавляет еще одно уравнение, чтобы исключить вырожденный случай.
$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[_, _]]]
Это должно вытащить настоящие решения:
soln = Select[ soln , Length[Union@Flatten[Simplify[Im[pts] /. #]]] == 1 &]
К сожалению, это работает только для n=4, но не для 6, 8, 12 или 20...
Edit 2 -- ну и дурак же я... уравнения задают все точки равноудаленными друг от друга, что справедливо только для тетраэдра. Я не уверен, как даже поставить задачу для додекаэдра (то есть как систему уравнений без какого-либо другого знания решения).
Не будет ли обманом использовать PolyhedronData["Dodecahedron", "EdgeIndices"]
?
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}}
Поскольку вы хотите получить точный результат, а не числовой, вы можете использовать LinearProgramming. Эта функция возвращает рациональный вывод для рационального ввода. Вам просто нужна параметризация граней/граней, которые определяют ваш тетраэдр, и правильные объективные функции, по одной на узел. Теперь вы можете сделать то же самое для примера с додекаэдром, или для любого политопа, если на то пошло - включая обычные тетраэдры, симплисы, платоновы твердые тела или что-то еще.