8
$\begingroup$

I am trying to create coordinates of all vertices of a tetrahedron is known by the lengths of its six edges Integer tetrahedron . I tried

SSSTriangle[51, 52, 53]

Triangle[{{0, 0}, {53, 0}, {1456/53, 2340/53}}]

ptO = {0, 0, 0}; ptA = {53, 0, 0}; ptB = {1456/53, 2340/53, 0}; ptC = {x, y, z}; {x, y, z} /. Solve[{EuclideanDistance[ptO, ptC] == 80, EuclideanDistance[ptA, ptC] == 84, EuclideanDistance[ptB, ptC] == 117}, {x, y, z}]

{{2153/106, -(1779337/27560), -((7 Sqrt[10038791])/520)}, {2153/ 106, -(1779337/27560), (7 Sqrt[10038791])/520}}

How to create a SSSSSSTetrahedron command in Mathematica to get all coordinates of vertices of the tetrahedron as SSSSSSTetrahedron[51, 52, 53, 80, 84, 117]?

Improve this question
$\endgroup$

1 Answer 1

Reset to default
10
$\begingroup$

I think you have got an almost complete answer already. How about packaging it like this?

Clear["Global`*"]; SSSSSSTetrahedron[s1_, s2_, s3_, s4_, s5_, s6_] := Module[{ptO, ptA, ptB, ptC, cand, tri, x, y, z}, tri = SSSTriangle[s1, s2, s3]; {ptO, ptA, ptB} = Append[#, 0] & /@ tri[[1]]; ptC = {x, y, z}; cand = ptC /. Solve[{ EuclideanDistance[ptO, ptC] == s4, EuclideanDistance[ptA, ptC] == s5, EuclideanDistance[ptB, ptC] == s6}, ptC]; (* choose one of two possible orientation *) ptC = SelectFirst[cand, Det[{ptA, ptB, #}] > 0 &]; {ptO, ptA, ptB, ptC}] tet = SSSSSSTetrahedron[51, 52, 53, 80, 84, 117]

coordinates

Graphics3D[{ {Opacity[.5], Simplex[tet]}, MapThread[Text[Style[#1, 20, Bold], #2]&, {{"O", "A", "B", "C"}, tet}]}]

tetrahedron

Appendix

In response to OP's request, I added a code which determines whether the input data is valid or not.

Clear["Global`*"]; validDataQ[{s1_, s2_, s3_, s4_, s5_, s6_}] := Module[{edgelen, faces, result, triangleineq, report}, faces = Subsets[{"A", "B", "C", "O"}, {3}]; edgelen = {{"A", "B"} -> s1, {"B", "O"} -> s2, {"A", "O"} -> s3, {"C", "O"} -> s4, {"A", "C"} -> s5, {"B", "C"} -> s6}; triangleineq[{a_, b_, c_}] := a + b > c && b + c > a && c + a > b; result = triangleineq[Subsets[#, {2}] /. edgelen] & /@ faces; If[And @@ result, Return[True]]; report = Table[ {StringJoin @@ tri, StringJoin[#] <> "=" <> ToString[# /. edgelen] & /@ Subsets[tri, {2}]}, {tri, Pick[faces, result, False]}]; Echo[#, "Invalid triangle :"] & /@ report; False]; SSSSSSTetrahedron[s1_, s2_, s3_, s4_, s5_, s6_] := Module[{ptO, ptA, ptB, ptC, cand, tri, x, y, z}, If[Not[validDataQ[{s1, s2, s3, s4, s5, s6}]], Return[{}]]; tri = SSSTriangle[s1, s2, s3]; {ptO, ptA, ptB} = Append[#, 0] & /@ tri[[1]]; ptC = {x, y, z}; cand = ptC /. Solve[{EuclideanDistance[ptO, ptC] == s4, EuclideanDistance[ptA, ptC] == s5, EuclideanDistance[ptB, ptC] == s6}, ptC]; (*choose one of two possible orientation*) ptC = SelectFirst[cand, Det[{ptA, ptB, #}] > 0 &]; {ptO, ptA, ptB, ptC}];

Sample run:

SSSSSSTetrahedron[8, 4, 6, 5, 6, 4]

5

SSSSSSTetrahedron[7, 2, 10, 9, 7, 1]

error1 error2

ans

Improve this answer
$\endgroup$
10
  • $\begingroup$ I see here. It seems containing some conditions of edgs. $\endgroup$ Commented Nov 3, 2024 at 11:29
  • $\begingroup$ @minhthien_2016 You are right. For example SSSSSSTetrahedron[1, 2, 3, 4, 5, 6] fails as it should. Do you want to include the code for checking edge lengths, so that triangle inequalities hold for all faces? $\endgroup$ Commented Nov 4, 2024 at 2:05
  • $\begingroup$ Yes, I want the code like that. $\endgroup$ Commented Nov 4, 2024 at 6:01
  • $\begingroup$ @minhthien_2016 I edited my answer. Hopefully the code in the appendix would answer your new request. $\endgroup$ Commented Nov 5, 2024 at 2:48
  • 1
    $\begingroup$ @IanFord Thank you for your recommendation. I'm wondering if the current form of my code is useful enough as a resource function. The order of the arguments really matters. For example, SSSSSSTetrahedron[9,6,10,10,8,2] fails but SSSSSSTetrahedron[9,6,10,10,2,8] succeeds. Are general users happy with that? One possible solution would be to provide two forms : SSSSSSTetrahedron[s1,...,s6] cares the order, but SSSSSSTetrahedron[{s1,...,s6}] does not. Any suggestion? $\endgroup$ Commented Nov 6, 2024 at 1:19

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.