Как найти вершины правильного тетраэдра? Додекаэдра?

Мой вопрос: как найти координаты вершин правильных тетраэдра и додекаэдра? Я пытался найти координаты вершин правильного тетраэдра как решения некоторой полиномиальной системы в $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.

J. M. will be back soon
Редактировал вопрос 18-го мая 2016 в 12:06
Вольфрам Mathematica
computational-geometry polyhedra
10-го декабря 2013 в 3:19
60 просмотров

Геометрическая конструкция

Альтернативные вершины куба - это вершины правильного тетраэдра. Поверните их вокруг соответствующей оси (объяснение математики см., например, 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]
   }]
 ]

Michael E2
Редактировал ответ 12-го декабря 2013 в 7:16
Комментарии (4)

На самом деле оказывается, что система 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"]?

george2079
Редактировал ответ 12-го декабря 2013 в 8:43
Комментарии (3)
 
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. Эта функция возвращает рациональный вывод для рационального ввода. Вам просто нужна параметризация граней/граней, которые определяют ваш тетраэдр, и правильные объективные функции, по одной на узел. Теперь вы можете сделать то же самое для примера с додекаэдром, или для любого политопа, если на то пошло - включая обычные тетраэдры, симплисы, платоновы твердые тела или что-то еще.

Комментарии (4)