Heronian Tetrahedron

Author

Eric W. Weisstein
July 28, 2003

This notebook downloaded from http://mathworld.wolfram.com/notebooks/DiophantineEquations/HeronianTetrahedron.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/HeronianTetrahedron.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Initialization

<<LinearAlgebra`MatrixManipulation`
<<DiscreteMath`Combinatorica`

Code

Faces[e_]:=KSubsets[e,3][[Flatten[Position[Area/@KSubsets[e,3],_Integer,1]]]]

CayleyMenger[n_,d_]:=Module[{
u=UpperDiagonalMatrix[d,n+1]^2/.d[i_,i_]:>0,
z=Prepend[Table[1,{n+1}],0]
},
AppendRows[List/@z,AppendColumns[{Rest[z]},u+Transpose[u]]]
]

Distance2[{v1_,v2_}]:=#.#&[v1-v2]

TetrahedronVertices[e_List?VectorQ]:=Module[{z,vars,soln,p=Range[6]},
z[1]={0,0,0};
z[2]={x1,0,0};
z[3]={x2,y2,0};
z[4]={x3,y3,z3};
vars=DeleteCases[Union[Flatten[z/@Range[4]]],0];
While[(soln=Reduce[And@@Thread[e[[p]]^2==Distance2/@KSubsets[Array[z,4],2]],vars,Reals,Backsubstitution->True])===False,
p=NextPermutation[p]
];
Array[z,4]/.ToRules[soln[[1]]]
]

Volume[e_List]:=Module[{d,ij=KSubsets[Range[4],2]},
orderede=Sqrt[Distance2/@KSubsets[TetrahedronVertices[e],2]];
Sqrt[Abs[Det[CayleyMenger[3,d]/.Thread[d@@@ij->orderede]]/288]]
]

TetrahedronFromEdges[e_List?VectorQ]:=Module[{v},
v=TetrahedronVertices[e];
{Polygon/@KSubsets[v,3],
Text[Sqrt[Distance2[#]],Plus@@#/2]&/@KSubsets[v,2]
}
]

Examples

Heronian tetrahedron with smallest maximum side length (and only one less than 156)

e1={117,80,84,53,51,52};

TetrahedronVertices[e1]

Faces[e1]

{Plus@@#,#}&[Area/@Faces[e1]]

Volume[e1]

With[{e=e1},
Show[GraphicsArray[
Block[{$DisplayFunction=Identity},
{
Show[Graphics3D[{TetrahedronFromEdges[e]},
BoxRatios->{1,1,1},ViewPoint->{1.3,-2.4,2},Boxed->False]],
Show[Graphics[HiddenWireframe[TetrahedronFromEdges[e]]],AspectRatio->Automatic]
}]
]]
]

Smallest Volume and Area

e2={160,153,120,56,39,25};

TetrahedronVertices[e2]

Faces[e2]

{Plus@@#,#}&[Area/@Faces[e2]]

Volume[e2]

With[{e=e2},
Show[GraphicsArray[
Block[{$DisplayFunction=Identity},
{
Show[Graphics3D[{TetrahedronFromEdges[e]},
BoxRatios->{1,1,1},ViewPoint->{1.3,-2.4,2},Boxed->False]],
Show[Graphics[HiddenWireframe[TetrahedronFromEdges[e]]],AspectRatio->Automatic]
}]
]]]

Smallest Pair with same surface area

Map[{Plus@@Area/@Faces[#],Volume[#]}&,
es={{595,429,208,116,276,325},
{595,507,116,208,276,325}},
{1}]

Show[GraphicsArray[
Block[{$DisplayFunction=Identity},
{
Show[Graphics3D[{TetrahedronFromEdges[#]},
BoxRatios->{1,1,1},ViewPoint->{1.3,-2.4,2},Boxed->False]],
Show[Graphics[HiddenWireframe[TetrahedronFromEdges[#]]],AspectRatio->Automatic]
}]&/@es
]]

Opposite Edges

This needs special treatment to make sure equal edges are placed opposite one another instead of adjacent

opp=Join[#,#]&/@{{148,195,203},{533,875,888},{1183,1479,1804},{2175,2296,2431},{1825,2748,2873},
{2180,2639,3111},{1887,5215,5512},{6409,6625,8484},{8619,10136,11275}};

TetrahedronVertices[opp[[1]]]

Show[Graphics3D[{TetrahedronFromEdges[opp[[1]]]},
BoxRatios->{1,1,1},ViewPoint->{1.3,-2.4,2},Boxed->False]]