Tetrahedron Center Functions

Ed Pegg Jr
Wolfram Demonstrations Project

(RowDefault[, (Spacer1), , (Spacer1), ])  #WolframTechConf

ABSTRACT

Many triangle and tetrahedron related items have been added to the Wolfram Functions Repository and Wolfram Demonstrations Project. The talk will discuss and show many of them, especially those that work in 2D and 3D.

For example, these built-in functions work in both 2D and 3D:

Insphere

Circumsphere

Wolfram Functions Repository

Some of the functions that work in 2D and 3D:

KimberlingCenter and TetrahedronCenter

SubTriangle and SubTetrahedron

IsogonalConjugate and IsotomicConjugate

TriangleEdgeAngles and TetrahedronEdgeAngles

Exspheres. ReflectPoints. Cevians.

FindExtraordinaryLines

Areal or BarycentricCoordinates

LineIntersection, PlaneLineIntersection and HessianPlane

SimplexVolume and PolygonArea3D

Demonstrations

191 Tetrahedron Demonstrations

1308 Triangle Demonstrations

1. Incenter (I) = Incentral Triangle, Contact Triangle

Incenter I, where the angle bisectors intersect.  The center of the incircle.
The Incentral triangle (in green) gives the cevians of the incenter.
The contact triangle (in red) gives the tangency points of the incircle.

initial={{0,0},{1,2},{3,0}};
ii =Insphere[initial];
incentral=ResourceFunction["SubTriangle"][initial,"Incentral"];
contact=ResourceFunction["SubTriangle"][initial,"Contact"];
gergonne =N[ResourceFunction["KimberlingCenter"][initial,7]];
gercevians=ResourceFunction["Cevians"][initial, symmedian];
Graphics[{Gray,EdgeForm[Black],Triangle[initial],LightOrange,Disk@@ii, Black,InfiniteLine[{ii[[1]],#}]&/@initial,
InfiniteLine[{gergonne,#}]&/@gercevians,White,
Opacity[.5],EdgeForm[Red], contact,EdgeForm[Green], incentral}]

Center of the insphere, which is tangent to the four faces.
Incentral Tetrahedron, Contact Tetrahedron.

Intersection point of the dihedral angle bisectors.

initial = {{0,0,0},{0,0,6},{0,8,6},{6,2,9}};
ii =Insphere[initial];
incentral=ResourceFunction["SubTetrahedron"][initial,"Incentral"];
contact=ResourceFunction["SubTetrahedron"][initial,"Contact"];
Graphics3D[{Opacity[.4],EdgeForm[{Black, Thick}],Tetrahedron[initial],LightOrange,ii, Black,InfiniteLine[{ii[[1]],#}]&/@initial,White,
EdgeForm[Red], Tetrahedron@contact,EdgeForm[Green], Tetrahedron@incentral,
Opacity[1],Blue, Sphere[ii[[1]],.2]}, Boxed->False, SphericalRegion-> True ]

2. Centroid (G) = Medial Triangle, Anticomplementary Triangle

Centroid G, where the medians intersect.
The Medial Triangle (Red) connects the line centroids (midpoints).
The Anticomplementary Triangle (Green) is the reverse.

initial={{0,0},{0,2},{3,0}};
gg =Mean[initial];
medial=ResourceFunction["SubTriangle"][initial,"Medial"];
anti=ResourceFunction["SubTriangle"][initial,"Anticomplementary"];
Graphics[{Gray,EdgeForm[Black],Triangle[initial], Black,InfiniteLine[{gg,#}]&/@initial,
{Yellow,Disk[gg,.1]},White,Opacity[.5],EdgeForm[Red], medial,EdgeForm[Green],anti}]

Concurrence of the centroids.
The Medial Tetrahedron (Red) connects the face centroids.
The Anticomplementary Tetrahedron (Green) is the reverse.

initial={{0,0,0},{1,2,0},{3,0,0}, {1,1,2}};
gg =Mean[initial];
medial=ResourceFunction["SubTetrahedron"][initial,"Medial"];
anti=ResourceFunction["SubTetrahedron"][initial,"Anticomplementary"];
Graphics3D[{Opacity[.5],EdgeForm[{Black, Thick}],Tetrahedron[initial], Black,InfiniteLine[{gg,#}]&/@initial,{Yellow,Sphere[gg,.1]},White,
EdgeForm[Red], Tetrahedron@medial,Opacity[.3],EdgeForm[Green], Tetrahedron@anti}, Boxed->False, SphericalRegion-> True ]

3. Circumcenter (O) = Tangential

Circumcenter O, the center of the circumcircle. Intersection of perpendicular bisectors. 
The tangential triangle is tangent to the vertex points of the circumcircle.

initial={{0,0},{1,2},{3,0}};
oo =Circumsphere[initial];
tan =ResourceFunction["SubTriangle"][initial,"Tangential"];
Graphics[{LightOrange,Disk@@oo,Gray,Triangle[initial], Green,InfiniteLine[{Mean[initial],#}]&/@initial,White,
Opacity[.5],EdgeForm[Red], tan}]

Center of the circumsphere, which goes through the four vertices. Intersection of edge ⊥ bisecting planes.

The tangential tetrahedron is tangent to the vertex points of the circumsphere.

initial={{0,0,0},{1,2,0},{3,0,0}, {1,1,2}};
gg =Mean[initial];
oo =Circumsphere[initial];
tan=ResourceFunction["SubTetrahedron"][initial,"Tangential"];
Graphics3D[{Opacity[.5],EdgeForm[{Black, Thick}],Tetrahedron[initial], Black,InfiniteLine[{gg,#}]&/@initial,White,
EdgeForm[Red], Tetrahedron@tan(*,EdgeForm[Green], Tetrahedron@incentral*),oo}, Boxed->False, SphericalRegion-> True ]

4. Orthocenter (H) = Orthic or Altitude Triangle

Orthocenter H, where the altitudes intersect.

initial={{0,0},{1,2},{3,0}};
hh =ResourceFunction["Orthocenter"][initial];
orthic =ResourceFunction["Cevians"][initial,hh];
Graphics[{Gray,Triangle[initial], Black,InfiniteLine[{hh,#}]&/@initial,
Opacity[.5],EdgeForm[Red],Triangle@orthic}]

No corresponding center in 3D. 
When altitudes are concurrent, same as Monge point.
The midplanes are perpendicular to and edge and concurrent with the opposing midpoint. The Monge point is the intersection:

Manipulate[Graphics3D[{{Tube[#],Gray, Sphere[Mean[#],.05]}&/@Subsets[initial2,{2}],Green,Sphere[monge2[[1]],.1],Opacity[.6],Red,Polygon/@Subsets[initial2,{3}],Yellow,Opacity[.2],monge2[[2]][[k]]}, SphericalRegion->True, Boxed-> False],
{k,1,6,1}, Initialization:>(
initial2={{0,0,0},{2,3,0},{3,0,0}, {1,1,2}};monge2 = ResourceFunction["Monge"][initial2];)]

Let the opposite side lengths of a tetrahedron T be a and e, b and f and c and d. Then T is orthocentric if and only if (a^2)+(e^2)=(b^2)+(f^2)=(c^2)+(d^2).
A bimedian of a tetrahedron is a line segment that joins the midpoints of a pair of opposite edges. A tetrahedron is orthocentric if and only if the three bimedians have equal length. The altitudes pass through the Monge point.

Manipulate[
SeedRandom[177];Module[{tetrahedron,mids,mreza1,f,e,sq2,n123,n134,n234,n124,AA1,BB1,CC1,DD1,vert},sq2=d^2+c^2;f=Sqrt[sq2-b^2];e=Sqrt[sq2-a^2];If[!(triangleQ[{a,d,b}]&&triangleQ[{b,e,c}]&&triangleQ[{a,f,c}]&&triangleQ[{e,d,f}]),a=1;b=1;c=1;e=1;f=1];vert=RisiTet[{a,b,c,d,e,f}][{-0.5,-0.5,-0.5},{1,0,0},{0,1,0}];tetrahedron={{{4,1,2},{4,2,3},{4,3,1},{1,3,2}},vert};
mids={(vert[[1]]+vert[[4]])/2,(vert[[2]]+vert[[4]])/2,(vert[[3]]+vert[[4]])/2,(vert[[1]]+vert[[2]])/2,(vert[[2]]+vert[[3]])/2,(vert[[1]]+vert[[3]])/2};
n123=Normalize[Cross[vert[[2]]-vert[[1]],vert[[3]]-vert[[1]]]];
n134=Normalize[Cross[vert[[3]]-vert[[1]],vert[[4]]-vert[[1]]]];
n124=Normalize[Cross[vert[[4]]-vert[[1]],vert[[2]]-vert[[1]]]];
n234=Normalize[Cross[vert[[4]]-vert[[2]],vert[[3]]-vert[[2]]]];
AA1=vert[[1]]+((vert[[4]]-vert[[1]]).n234)n234;
BB1=vert[[2]]+((vert[[4]]-vert[[2]]).n134)n134;CC1=vert[[3]]+((vert[[4]]-vert[[3]]).n124)n124;DD1=vert[[4]]+((vert[[1]]-vert[[4]]).n123)n123;
mreza1=MrezaConcav[tetrahedron];If[dim==1,Graphics[Map[Line,mreza1[[1,1]]],ImageSize->1.125{400,400}],Column[{Graphics3D[Translate[{Sphere[vert,.01],Sphere[{AA1,BB1,CC1,DD1},.01],Line[{vert[[1]],AA1}],Line[{vert[[2]],BB1}],Line[{vert[[3]],CC1}],Line[{vert[[4]],DD1}],{Opacity[0.2],Polygon[Map[tetrahedron[[2,#]]&,tetrahedron[[1]]]]},If[shb,{Red,Line[{mids[[1]],mids[[5]]}],Line[{mids[[3]],mids[[4]]}],Line[{mids[[2]],mids[[6]]}]}],If[sh,{Table[Text[vertlabels[[i]],vert[[i]],{-1,-1}],{i,1,4}],Table[Text[edlabels[[i]],mids[[i]],{-1,-1}],{i,1,6}]}]},-(vert[[1]]+vert[[2]]+vert[[3]])/4],ImageSize->1.125{400,400},Boxed->False,SphericalRegion->True,PlotRange->1.5,ViewAngle->10 Degree]}]]],
{{a,1.2,Style["a",Italic]},.9,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},
{{b,1,Style["b",Italic]},.9,1.1,0.01,ImageSize->Tiny,Appearance->"Labeled"},
{{c,1,Style["c",Italic]},.9,1.,0.01,ImageSize->Tiny,Appearance->"Labeled"},
{{d,1.2,Style["d",Italic]},1,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},"","2D/3D",
{{dim,2,""},{1->"net",2->"polyhedron"}},"",
"show labels",{{sh,True,""},{True,False},Enabled->dim==2},"",
"show bimedians",{{shb,False,""},{True,False},Enabled->dim==2},ControlPlacement->Left,Initialization:>(Volumen[{a1_,a2_,a3_,a4_,a5_,a6_}]:=Sqrt[a1^2a5^2(a2^2+a3^2+a4^2+a6^2-a1^2-a5^2)+
			a2^2a6^2(a1^2+a3^2+a4^2+a5^2-a2^2-a6^2)+a3^2a4^2(a1^2+a2^2+a5^2+a6^2-a3^2-a4^2)-a1^2a2^2a4^2-a2^2a3^2a5^2-a1^2a3^2a6^2-a4^2a5^2a6^2]/12;
(*projekcija b na c v trikotniku*)
projek[{a_,b_,c_}]:=b (b^2+c^2-a^2)/(2 b c);
polobs[{a_,b_,c_}]:=(a+b+c)/2;
plosc[{a_,b_,c_}]:=Block[{p=polobs[{a,b,c}]},Sqrt[p(p-a)(p-b)(p-c)]];
visina[tet_,trik_]:=3Volumen[tet]/plosc[trik];
vistrik[trik_,d_]:=2plosc[trik]/d;
projekvisine[{a_,b_,c_,d_,e_,f_}]:=Sqrt[vistrik[{d,b,a},d]^2-visina[{a,b,c,d,e,f},{d,e,f}]^2];
Smer[{x_,y_,z_}]:={x,y,z}/Sqrt[x^2+y^2+z^2];
Velikost[{a_,b_,c_}]:=Sqrt[a^2+b^2+c^2];
RisiTet[{a_,b_,c_,d_,e_,f_}][{Ax_,Ay_,Az_},{ex_,ey_,ez_},{fx_,fy_,fz_}]:=Block[{projanad,vd,v,provis},
projanad=projek[{b,a,d}];
		vd=vistrik[{d,b,a},d];
		v=visina[{a,b,c,d,e,f},{d,e,f}];
		provis=projekvisine[{a,b,c,d,e,f}];		
{{Ax,Ay,Az},{Ax,Ay,Az}+d Smer[{ex,ey,ez}],{Ax,Ay,Az}+projek[{e,f,d}]Smer[{ex,ey,ez}]+
	Smer[Cross[Cross[{ex,ey,ez},{fx,fy,fz}],{ex,ey,ez}]]vistrik[{d,e,f},d],
			{Ax,Ay,Az}+Smer[{ex,ey,ez}]projanad+Smer[Cross[Cross[{ex,ey,ez},{fx,fy,fz}],{ex,ey,ez}]]provis+Smer[Cross[{ex,ey,ez},{fx,fy,fz}]]v}];	
edlabels={Style["a",Italic,16],Style["b",Italic,16],Style["c",Italic,16],Style["d",Italic,16],Style["e",Italic,16],Style["f",Italic,16]};
vertlabels={Style["A",16],Style["B",16],Style["C",16],Style["D",16]};
ChangeOrientation[pari_][lica_] := 
  Module[{nnov, nprej, n, len = Length[lica], ai, zi, indlicap, indlican, 
    licep, licen, presek, p1, p2, q1, q2, a1, ainov, r1, r2, aiprej, 
    aikompl, aizaceten, qq1, uni1, uni2, newfaces = lica, avindex, edges, 
    q1n, q2n}, Do[indlicap = pari[[m]][[1]]; indlican = pari[[m]][[2]]; 
      nnov = Length[lica[[indlican]]]; nprej = Length[lica[[indlicap]]]; 
      licep = newfaces[[indlicap]]; licen = newfaces[[indlican]]; 
      presek = Intersection[licep, licen]; 
      {{p1}} = Position[licep, presek[[1]]]; 
      {{p2}} = Position[licep, presek[[2]]]; 
      {{q1}} = Position[licen, presek[[1]]]; 
      {{q2}} = Position[licen, presek[[2]]]; q1n = q1; q2n = q2; 
      If[PrejQHI[nprej][p1, p2] && PrejQHI[nnov][q1, q2] || 
        PrejQHI[nprej][p2, p1] && PrejQHI[nnov][q2, q1], 
       newfaces = ReplacePart[newfaces, Reverse[licen], indlican]; 
        q1n = nnov - q1; q2n = nnov - q2]; 
      newfaces = 
       ReplacePart[newfaces, If[PrejQHI[nnov][q1n, q2n], 
         RotateLeft[newfaces[[indlican]], q1n - 1], 
         RotateLeft[newfaces[[indlican]], q2n - 1]], indlican], 
     {m, 1, len - 1}]; newfaces];
 PrejQHI[n_][p_, q_] := q == p + 1 || p == n && q == 1;
 NetOfConvex[afaces_, facetree_, vertis_][{a_, b_}] := 
  Module[{linijaset, linija, poin1, poin2, d1, d2, len, p1, p2, indn, indp, 
    indlica, novatocka, len1, maksi}, 
   linijaset = Table[{}, {Length[afaces]}]; 
    maksi = Table[0, {Length[afaces]}]; linija = {}; poin1 = {a, b}; 
    indlica = facetree[[1,1]]; maksi = 
     ReplacePart[maksi, Max[afaces[[indlica]]], indlica]; 
    linija = Append[linija, poin1]; 
    d1=DistanceHI[vertis[[afaces[[indlica,1]]]], 
      vertis[[afaces[[indlica,2]]]]]; poin2 = {poin1[[1]] + d1, poin1[[2]]}; 
    linija=Append[linija, poin2]; len = Length[afaces[[indlica]]]; 
    Do[d1=DistanceHI[vertis[[afaces[[indlica,1]]]], 
        vertis[[afaces[[indlica,i]]]]]; 
      d2 = DistanceHI[vertis[[afaces[[indlica,2]]]], 
        vertis[[afaces[[indlica,i]]]]]; 
      novatocka = TwoCirclesIntersectionNewHI[poin1, poin2, {d1, d2}]; 
      linija = Append[linija, novatocka], {i, 3, len}]; 
    linija = Append[linija, poin1]; 
    linijaset = ReplacePart[linijaset, linija, indlica]; 
    len1 = Length[facetree]; linija = {}; 
    Do[indn = facetree[[i,2]]; indp = facetree[[i,1]]; 
      maksi = ReplacePart[maksi, Max[afaces[[indn]]], indn]; 
      {{p1}} = Position[afaces[[indp]], afaces[[indn,1]]]; 
      {{p2}} = Position[afaces[[indp]], afaces[[indn,2]]]; linija = {}; 
      poin1 = linijaset[[indp,p1]]; poin2 = linijaset[[indp,p2]]; 
      linija = Append[linija, poin1]; linija = Append[linija, poin2]; 
      len = Length[afaces[[indn]]]; 
      Do[d1 = DistanceHI[vertis[[afaces[[indn,1]]]], 
          vertis[[afaces[[indn,k]]]]]; 
        d2 = DistanceHI[vertis[[afaces[[indn,2]]]], 
          vertis[[afaces[[indn,k]]]]]; 
        novatocka = TwoCirclesIntersectionNewHI[poin1, poin2, {d1, d2}]; 
        linija = Append[linija, novatocka], {k, 3, len}]; 
      linija = Append[linija, linijaset[[indp,p1]]]; 
      linijaset = ReplacePart[linijaset, linija, indn], {i, 1, len1}]; 
    {linijaset, maksi}];
 DistanceHI[{a_, b_, c_}, {x_, y_, z_}] := 
  N[Sqrt[(a - x)^2 + (b - y)^2 + (c - z)^2]];
 TwoCirclesIntersectionNewHI[{x1_, y1_}, {x2_, y2_}, {r1_, r2_}] := 
  Module[{c, a, b, e}, c = Sqrt[(x2 - x1)^2 + (y2 - y1)^2]; a = r2; b = r1; 
    e = ({x2, y2} - {x1, y1})/c; ConstructTriangleHI[{x1, y1}, e][a, b, c]];
 ConstructTriangleHI[{x1_, y1_}, e_][a_, b_, c_] := 
  Module[{p, hc, cosa, AB, x2, y2, x3, y3}, 
   p = (a + b + c)/2; hc = 2*Sqrt[p*(p - a)*(p - b)*(p - c)]/c; 
    cosa = (b^2 + c^2 - a^2)/(2*b*c); AB = c*e; {x2, y2} = {x1, y1} + AB; 
    {x3, y3} = {x1, y1} + b*cosa*e + OrtAB[AB]*hc; {x3, y3}];
 OrtAB[{x_, y_}] := {-y, x}/Sqrt[x^2 + y^2];
TreeHI[pove_][n_][m_] := Module[{tr = {pove[[n]]}}, 
     While[ !MaksiTreeHIQ[tr, m], Do[If[DodajHIQ[tr, pove[[k]]], 
         tr = Append[tr, pove[[k]]]; Break[]], {k, 1, Length[pove]}]]; tr];
 MaksiTreeHIQ[tr_, n_] := Module[{flag = True}, 
     Do[If[NiNode[i][tr], flag = False; Break[]], {i, 1, n}]; flag];
 NiNode[a_][seznam_] := Module[{flag = True}, 
     Do[If[a == seznam[[i]][[1]] || a == seznam[[i]][[2]], 
        flag = False; Break[]], {i, 1, Length[seznam]}]; flag];
 DodajHIQ[tr_, {a_, b_}] := JeNode[a][tr] && NiNode[b][tr] || 
     JeNode[b][tr] && NiNode[a][tr];
 JeNode[a_][seznam_] := MemberQ[seznam, {a, x_}] || MemberQ[seznam, {y_, a}];
 UrediTree2HI[drevo_] := Module[{drev = drevo, len = Length[drevo]}, 
     Do[Do[If[drev[[k]][[2]] == drev[[i]][[2]], 
         drev = ReplacePart[drev, {drev[[k]][[2]], drev[[k]][[1]]}, k]], 
        {i, 1, k - 1}], {k, 2, len}]; drev];
 PrejQHI[n_][p_, q_] :=q ==p + 1 || p == n && q==1;
 EdgesOnFaces[cic_] := Block[{edgs={}, n=Length[cic], ed, i}, 
     Do[ed = EdgesOnFace[cic[[i]]]; edgs = Union[edgs, ed], {i, 1, n}]; 
      edgs = Union[Map[Sort, edgs, 1]]];
 EdgesOnFace[lice_]:= Module[{i,rez},rez= Table[{lice[[i]], lice[[i + 1]]}, 
       {i, 1, Length[lice] - 1}];Append[rez, {Last[lice], First[lice]}]];
FacesOfEdge[{a_, b_}, c1_] := Module[{f, v, e}, f = Length[c1]; 
      v = Length[Union[Flatten[c1]]]; e = f + v - 2; 
      Select[Range[f],Length[Intersection[c1[[#1]], {a, b}]] == 2 & ]];
 DistanceHI[{a_, b_, c_}, {x_, y_, z_}] := 
    N[Sqrt[(a - x)^2 + (b - y)^2 + (c - z)^2]];
ToAdjacencyListsHI[pove_]:=With[{n=Length[Union[Flatten[pove]]]},Table[Complement[Flatten[Select[pove,MemberQ[#,i]&]],{i}],{i,1,n}]];
TreeFromPairs2[pove_,selectFirst_,SelectPred_,SelectSucc_]:=
Block[{e,bfi,selectfrom1,selectfrom2,selectfrom3,b,edges={},cnt=1,n=Length[Union[Flatten[pove]]],len,a},
 len=Length[Union[Flatten[pove]]];
    bfi=Table[0,{n}];
    e=ToAdjacencyListsHI[pove];(*Print["e",e];*)
    selectfrom1=Range[n];
    a=selectFirst[selectfrom1];
    bfi[[a]]=cnt;
    e=Map[Complement[#,{a}] &,e];
    selectfrom2=Cases[Range[n],x_/;e[[x]]!={} && bfi[[x]]>0];
    While[cnt<len,  
       selectfrom3=e[[a]];
     (* Print["selectfrom2",selectfrom2,"selectfrom3",selectfrom3];*)
       b=SelectSucc[selectfrom3];
       cnt=cnt+1;
       bfi[[b]]=cnt;
       edges=Append[edges,{a,b}];
       e=Map[Complement[#,{b}] &,e];
       selectfrom2=Cases[Range[n],x_/;e[[x]]!={} && bfi[[x]]>0];
       If[selectfrom2!={},a=SelectPred[selectfrom2]]];
  {edges,bfi}] ;
  SelectFr2[list_]:=list[[RandomInteger[{1,Length[list]}]]];
SelectPr2[list_]:=list[[RandomInteger[{1,Length[list]}]]];
SelectSu2[list_]:=list[[RandomInteger[{1,Length[list]}]]];
AdjacentHI[lis_][a_,b_]:=Length[Intersection[lis[[a]],lis[[b]]]]==2;
AdjacencyPairsHI[lis_]:=Cases[Apply[Union,Table[{a,b},{a,1,Length[lis]-1},{b,a+1,Length[lis]}]],{x_,y_}/;AdjacentHI[lis][x,y]];
DodajQ[tr_,{a_,b_}]:=(MemberQ[tr,{a,x_}] && !MemberQ[tr,{y_,b}])|| (MemberQ[tr,{x_,a}] && !MemberQ[tr,{y_,b}]);
AllHI[q_][seznam_]:=Module[{flag=True},Do[If[!q[seznam[[i]]],(flag=False;Break[])],{i,1,Length[seznam]}];flag];
ExistsHI[q_][seznam_]:=Module[{flag=False},Do[If[q[seznam[[i]]],(flag=True;Break[])],{i,1,Length[seznam]}];flag];
MaksiTreeHIQ[tr_,n_]:=Module[{flag=True},Do[If[NiNode[i][tr],(flag=False;Break[])],{i,1,n}];flag];
TreeHI[pove_][n_][m_]:=Module[{tr={pove[[n]]}},While[!MaksiTreeHIQ[tr,m],Do[If[DodajHIQ[tr,pove[[k]]],(tr=Append[tr,pove[[k]]];Break[])],{k,1,Length[pove]}]];tr];
UrediTreeHI[drevo_]:=Module[{drev=drevo,len=Length[drevo]},Do[Do[If[drevo[[k]][[2]]==drevo[[i]][[2]],drev=ReplacePart[drev,{drevo[[k]][[2]],drevo[[k]][[1]]},k]],{i,1,k-1}],{k,2,len}];drev];
MrezaConcav[p1_]:=Module[{stran,lica,ogli,pove1,m,vertcoor2,drevo,tr2,lica3,net},
stran=p1[[1]];
vertcoor2=p1[[2]];
pove1=AdjacencyPairsHI[stran];
m=Length[stran];
drevo=First[TreeFromPairs2[pove1,SelectFr2,SelectPr2,SelectSu2]];
tr2=UrediTree2HI[drevo];
lica3=ChangeOrientation[tr2][stran];
net=NetOfConvex[lica3,tr2,vertcoor2][{0.,0.}];{net,tr2,lica3}];
adj[solid_][x_,y_]:=Length[Intersection[solid[[1,x]],solid[[1,y]]]]==2;
povprecje[vec_]:=Apply[Plus,Drop[vec,-1 ]]/(Length[vec]-1);
povprecje2[vec_]:=Apply[Plus,vec]/(Length[vec]);triangleQ[{a_,b_,c_}]:=Sort[Sign[{(a+b)-c,(a+c)-b,(b+c)-a}]]=={1,1,1};
)]

Most of the time, the altitudes do not intersect. The feet form the altitude tetrahedron.

initial={{0,0,0},{2,3,0},{3,0,0}, {1,1,2}};
monge = ResourceFunction["Monge"][initial];
alt=ResourceFunction["SubTetrahedron"][initial,"Altitude"];
Graphics3D[{Opacity[.5],Tetrahedron[initial],Opacity[.8], Black,Thick,Tube[#]&/@Transpose[{initial,alt}], Red,{Opacity[1], Sphere[monge[[1]],.05]},Green,
EdgeForm[Red], Tetrahedron@alt}, Boxed-> False, SphericalRegion->True]

5. 9-point (T) = {“Euler”, “EulerProjected”, “Medial”}

2D. 9-point T, the center of the nine-point circle.
Goes through the midpoints, the feet, and the midpoints between H and the vertices. Tangent to the excircles.

initial={{0,0},{1,2},{3,0}};
mids=Mean/@Subsets[initial,{2}];
tt =Circumsphere[mids];
hh =ResourceFunction["Orthocenter"][initial];
mids2 = Mean[{hh,#}]&/@initial;
feet =Table[{initial[[k]],ResourceFunction["PointLineDistance"][ initial[[k]],Drop[initial,{k}]][[2]]},{k,1,3}];
Graphics[{EdgeForm[Black],Opacity[.6],{Cyan,InfiniteLine/@Subsets[initial,{2}]},Gray,Triangle[initial],LightOrange,Disk@@tt, Black,Line/@feet, Disk[#,.02]&/@mids,Disk[#,.02]&/@mids2, 
Disk[Last[#],.02]&/@feet,
ResourceFunction["Exspheres"][initial], White,EdgeForm[Red], Triangle[mids],EdgeForm[Green], Triangle[Last/@feet], EdgeForm[Yellow], Triangle[mids2]}, PlotRange-> {{-1,4.5},{-1,3}}]

3D. The 12-Point sphere:
1. medial points of each triangle.
2. 1/3rd distance points between Monge and vertices.
3.  The feet of the Euler points.

initial={{0,0,0},{1,3,0},{3,0,0}, {1,1,2}};
tpc=ResourceFunction["TetrahedronCenter"][initial,"12Point"];
tetras=ResourceFunction["SubTetrahedron"][initial,#]&/@{"Euler", "EulerProjected", "Medial"};
Graphics3D[{Sphere[tpc,.05],Opacity[.3],Thick,Tetrahedron[initial],
Circumsphere[tetras[[1]]],Tetrahedron/@tetras, ResourceFunction["Exspheres"][initial]}, ]

6. Symmedian Point (K)

2D. Symmedian K, reflections of the medians in the angle bisectors. Minimizes the sum of the distances squared to edges. Isogonal conjugate of centroid.

initial={{0,0},{2,3},{5,0}};
gg=Mean[initial];
kk =ResourceFunction["IsogonalConjugate"][initial,gg];
ii =Insphere[initial];
Graphics[{EdgeForm[Black],Opacity[.6],Gray,Triangle[initial],Red, InfiniteLine[{ii[[1]],#}]&/@initial,Green, InfiniteLine[{gg,#}]&/@initial,Disk[gg,.1],Pink, InfiniteLine[{kk,#}]&/@initial, Disk[kk,.1], Black,Text["G", gg], Text["K", kk]}]

3D. Reflections of the median planes in the dihedral angle bisectors. Also the least-squares point, which is the point with minimal total distance squared to the four faces.

initial={{0,0,0},{1,3,0},{3,0,0}, {1,1,2}};

gg=Mean[initial];
kk =ResourceFunction["IsogonalConjugate"][initial,gg]

ResourceFunction["TetrahedronCenter"][initial,"Symmedian"]

symmedial=ResourceFunction["SubTetrahedron"][initial,"Symmedial"]

ResourceFunction["Cevians"][initial,kk]

ii =Insphere[initial];
Graphics3D[{EdgeForm[Black],Opacity[.6],Gray,Tetrahedron[initial],Red, Thick,InfiniteLine[{ii[[1]],#}]&/@initial,Green, InfiniteLine[{gg,#}]&/@initial,Sphere[gg,.1],Pink, InfiniteLine[{kk,#}]&/@initial, Sphere[kk,.1], Black,Text["G", gg], Text["K", kk], 
Red,Tetrahedron@symmedial},Boxed-> False, SphericalRegion-> True]

Excircles and Exspheres, Excentral, Extouch, Extangent

Excentral = centers of excircles. 
Extouch = tangency points of excircles.

initial={{0,0},{2,3},{5,0}};
ee =ResourceFunction["Exspheres"][initial];
excentral =ResourceFunction["SubTriangle"][initial,"Excentral"];
extouch =ResourceFunction["SubTriangle"][initial,"Extouch1"];
Graphics[{EdgeForm[Black],Opacity[.6],Gray,Triangle[initial],Red, InfiniteLine[#]&/@Subsets[initial,{2}], ee,
Gray,excentral, Green,extouch }]

Exspheres

Excentral = centers of exspheres. 
Extouch = tangency points of exspheres.

initial={{0,0,0},{1,3,0},{3,0,0}, {1,1,2}};
ee =ResourceFunction["Exspheres"][initial];
excentral =ResourceFunction["SubTetrahedron"][initial,"Excentral"];
extouch =ResourceFunction["SubTetrahedron"][initial,"Extouch"];
Graphics3D[{EdgeForm[Black],Opacity[.3],Red,Tetrahedron[initial],Red, Thick,InfiniteLine[#]&/@Subsets[initial,{2}],Green, 
ee,Gray,Tetrahedron@excentral, Green,Opacity[.8],Blue,Tetrahedron@extouch},Boxed-> False, SphericalRegion-> True]

Extangent = externally tangent to the exspheres

tet={{0,0,0},{1,3,0},{3,0,0}, {1,1,2}};
extangents= ResourceFunction["SubTetrahedron"][tet,"Extangents"];Graphics3D[{Tube[#]&/@Transpose[{tet,extangents}],Opacity[.3],Blue,Tetrahedron[tet],Red,Tetrahedron[extangents],Green, ResourceFunction["Exspheres"][tet]}, Boxed->False,ImageSize->Medium,SphericalRegion->True]

Parallelians point

tet={{0,0,0},{1,3,0},{3,0,0}, {1,1,2}};
para=N[ResourceFunction["TetrahedronCenter"][tet,"Parallelians"]]

Move the tetrahedron and calculate the area of the parallel triangles through the point:

new = #-para &/@tet;
planes = Take[#,3]&/@(N[ResourceFunction["HessianPlane"][#]]&/@Reverse[Subsets[new,{3}]]);
triangles=Table[RegionIntersection[Hyperplane[planes[[k]],{0,0,0}],Tetrahedron[N[new]]],{k,1,4}];
Area/@triangles

Show the parallelians point and the equal area parallel triangles:

Graphics3D[{{Opacity[.5],Tetrahedron[new], Gray, triangles}, Red,Sphere[{0,0,0},.1]}, Boxed-> False, SphericalRegion-> True]

Dihedral Angle Constant

For opposite edges, p⊗q = (p^2)+(q^2)+2p q cot p' cot q' is a constant, where p' is the dihedral angle at p and q' is the dihedral angle at q.

Manipulate[
SeedRandom[177];Module[{tetrahedron,mids,mreza1,sq2,n123,n134,n234,n124,AA1,BB1,CC1,DD1,vert,dirae,dirbf,dircd,ap,bp,cp,dp,ep,fp,diha,dihb,dihc,dihd,dihe,dihf},If[!(triangleQ[{a,d,b}]&&triangleQ[{b,e,c}]&&triangleQ[{a,f,c}]&&triangleQ[{e,d,f}]),a=1;b=1;c=1;e=1;f=1];vert=RisiTet[{a,b,c,d,e,f}][{-0.5,-0.5,-0.5},{1,0,0},{0,1,0}];tetrahedron={{{4,1,2},{4,2,3},{4,3,1},{1,3,2}},vert};
mids={(vert[[1]]+vert[[4]])/2,(vert[[2]]+vert[[4]])/2,(vert[[3]]+vert[[4]])/2,(vert[[1]]+vert[[2]])/2,(vert[[2]]+vert[[3]])/2,(vert[[1]]+vert[[3]])/2};
n123=Normalize[Cross[vert[[2]]-vert[[1]],vert[[3]]-vert[[1]]]];
n134=Normalize[Cross[vert[[3]]-vert[[1]],vert[[4]]-vert[[1]]]];
n124=Normalize[Cross[vert[[4]]-vert[[1]],vert[[2]]-vert[[1]]]];
n234=Normalize[Cross[vert[[4]]-vert[[2]],vert[[3]]-vert[[2]]]];
AA1=vert[[1]]+((vert[[4]]-vert[[1]]).n234)n234;
BB1=vert[[2]]+((vert[[4]]-vert[[2]]).n134)n134;CC1=vert[[3]]+((vert[[4]]-vert[[3]]).n124)n124;DD1=vert[[4]]+((vert[[1]]-vert[[4]]).n123)n123;
dirae=Normalize[Cross[vert[[4]]-vert[[1]],vert[[3]]-vert[[2]]]];
dircd=Normalize[Cross[vert[[4]]-vert[[3]],vert[[1]]-vert[[2]]]];
dirbf=Normalize[Cross[vert[[4]]-vert[[2]],vert[[1]]-vert[[3]]]];
ap=intersectionLinePlane[vert[[1]],vert[[4]]-vert[[1]],vert[[2]],Cross[dirae,vert[[3]]-vert[[2]]]];
ep=intersectionLinePlane[vert[[2]],vert[[3]]-vert[[2]],vert[[1]],Cross[dirae,vert[[1]]-vert[[4]]]];
cp=intersectionLinePlane[vert[[3]],vert[[4]]-vert[[3]],vert[[2]],Cross[dircd,vert[[1]]-vert[[2]]]];
dp=intersectionLinePlane[vert[[1]],vert[[1]]-vert[[2]],vert[[3]],Cross[dircd,vert[[3]]-vert[[4]]]];
bp=intersectionLinePlane[vert[[2]],vert[[4]]-vert[[2]],vert[[1]],Cross[dirbf,vert[[1]]-vert[[3]]]];
fp=intersectionLinePlane[vert[[1]],vert[[1]]-vert[[3]],vert[[2]],Cross[dirbf,vert[[2]]-vert[[4]]]];
diha=ArcCos[n124.n134];
dihb=ArcCos[n124.n234];
dihc=ArcCos[n234.n134];
dihd=ArcCos[n124.n123];
dihe=ArcCos[n123.n234];dihf=ArcCos[n123.n134];
Column[{Graphics3D[Translate[{Thickness[0.006],Sphere[vert,.015],{Opacity[0.2],Polygon[Map[tetrahedron[[2,#]]&,tetrahedron[[1]]]]},If[sh,{Table[Text[Style[vden[[i]],16],vert[[i]],-{-1,-1}],{i,1,4}],Table[Text[edlabels[[i]],mids[[i]],-{-1,-1}],{i,1,6}]}]},-(vert[[1]]+vert[[2]]+vert[[3]])/4],ImageSize->{400,300},Boxed->False,SphericalRegion->True,PlotRange->1.5,ViewAngle->8 Degree],Text@Grid[{{Row[{Style["a",Italic]," ⊗ ",Style["e",Italic]}],Row[{Style["b",Italic]," ⊗ ",Style["f",Italic]}],Row[{Style["c",Italic]," ⊗ ",Style["d",Italic]}]},{fun[vert[[1]]-vert[[4]],vert[[2]]-vert[[3]],diha,dihe],fun[vert[[2]]-vert[[4]],vert[[1]]-vert[[3]],dihb,dihf],fun[vert[[3]]-vert[[4]],vert[[1]]-vert[[2]],dihc,dihd]}},Frame->All,ItemSize->5],
Text@Grid[{{"edge","length","angle","angle (radians)"},{Style["a",Italic],Norm[vert[[4]]-vert[[1]]],"α",diha},{Style["b",Italic],Norm[vert[[4]]-vert[[2]]],"β",dihb},{Style["c",Italic],Norm[vert[[4]]-vert[[3]]],"γ",diha},{Style["d",Italic],Norm[vert[[2]]-vert[[1]]],"δ",dihd},{Style["e",Italic],Norm[vert[[2]]-vert[[3]]],"ϵ",dihe},{Style["f",Italic],Norm[vert[[3]]-vert[[1]]],"ϕ",dihf}},Frame->All]}, Alignment-> Center]],{{a,1.2,Style["a",Italic]},.9,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},{{b,1,Style["b",Italic]},.9,1.1,0.01,ImageSize->Tiny,Appearance->"Labeled"},{{c,1,Style["c",Italic]},.9,1.,0.01,ImageSize->Tiny,Appearance->"Labeled"},{{d,1.2,Style["d",Italic]},1,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},
{{e,1.2,Style["e",Italic]},1,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},{{f,1.2,Style["f",Italic]},1,1.2,0.01,ImageSize->Tiny,Appearance->"Labeled"},"","show labels",{{sh,True,""},{True,False}},
ControlPlacement->Left,Initialization:>(Volumen[{a1_,a2_,a3_,a4_,a5_,a6_}]:=Sqrt[a1^2a5^2(a2^2+a3^2+a4^2+a6^2-a1^2-a5^2)+
			a2^2a6^2(a1^2+a3^2+a4^2+a5^2-a2^2-a6^2)+a3^2a4^2(a1^2+a2^2+a5^2+a6^2-a3^2-a4^2)-a1^2a2^2a4^2-a2^2a3^2a5^2-a1^2a3^2a6^2-a4^2a5^2a6^2]/12;
(*projekcija b na c v trikotniku*)
projek[{a_,b_,c_}]:=b (b^2+c^2-a^2)/(2 b c);
polobs[{a_,b_,c_}]:=(a+b+c)/2;
plosc[{a_,b_,c_}]:=Block[{p=polobs[{a,b,c}]},Sqrt[p(p-a)(p-b)(p-c)]];
visina[tet_,trik_]:=3Volumen[tet]/plosc[trik];
vistrik[trik_,d_]:=2plosc[trik]/d;
projekvisine[{a_,b_,c_,d_,e_,f_}]:=Sqrt[vistrik[{d,b,a},d]^2-visina[{a,b,c,d,e,f},{d,e,f}]^2];
Smer[{x_,y_,z_}]:={x,y,z}/Sqrt[x^2+y^2+z^2];
Velikost[{a_,b_,c_}]:=Sqrt[a^2+b^2+c^2];
RisiTet[{a_,b_,c_,d_,e_,f_}][{Ax_,Ay_,Az_},{ex_,ey_,ez_},{fx_,fy_,fz_}]:=Block[{projanad,vd,v,provis},
projanad=projek[{b,a,d}];
		vd=vistrik[{d,b,a},d];
		v=visina[{a,b,c,d,e,f},{d,e,f}];
		provis=projekvisine[{a,b,c,d,e,f}];		
{{Ax,Ay,Az},{Ax,Ay,Az}+d Smer[{ex,ey,ez}],{Ax,Ay,Az}+projek[{e,f,d}]Smer[{ex,ey,ez}]+
	Smer[Cross[Cross[{ex,ey,ez},{fx,fy,fz}],{ex,ey,ez}]]vistrik[{d,e,f},d],
			{Ax,Ay,Az}+Smer[{ex,ey,ez}]projanad+Smer[Cross[Cross[{ex,ey,ez},{fx,fy,fz}],{ex,ey,ez}]]provis+Smer[Cross[{ex,ey,ez},{fx,fy,fz}]]v}];	
edlabels={Style["a",Italic,16],Style["b",Italic,16],Style["c",Italic,16],Style["d",Italic,16],Style["e",Italic,16],Style["f",Italic,16]};
adj[solid_][x_,y_]:=Length[Intersection[solid[[1,x]],solid[[1,y]]]]==2;
povprecje[vec_]:=Apply[Plus,Drop[vec,-1 ]]/(Length[vec]-1);
povprecje2[vec_]:=Apply[Plus,vec]/(Length[vec]);triangleQ[{a_,b_,c_}]:=Sort[Sign[{(a+b)-c,(a+c)-b,(b+c)-a}]]=={1,1,1};intersectionLinePlane[r2_,e_,r1_,n_]:=r2+((r1-r2).n/(e.n))e;
ort3D[x_]:=x/Sqrt[x[[1]]^2+x[[2]]^2+x[[3]]^2];vden={Style["A",16],Style["B",16],Style["C",16],Style["D",16]};fun[a_,b_,al_,be_]:=Norm[a]^2+Norm[b]^2+2Norm[a]Norm[b]Cot[al]Cot[be];
)]

(p^2)+(q^2)+2p q cot p' cot q'

DihedralAngleConstant[tetra_]:= Module[{edges, angles},
edges= EuclideanDistance@@#&/@Subsets[tetra,{2}]; 
angles = ResourceFunction["TetrahedronEdgeAngles"][edges];
edges[[#[[1]]]]^2 + edges[[#[[2]]]]^2 + 2 edges[[#[[1]]]]edges[[#[[2]]]]Cot[angles[[#[[1]]]]] Cot[angles[[#[[2]]]]]&/@ {{1,6},{2,5},{3,4}}
]

DihedralAngleConstant[{{0,0,0},{0,0,6},{0,8,6},{6,2,9}}/13]

DihedralAngleConstant[{{-14,-6,-(Sqrt[22])},{10,-6,-(Sqrt[22])},{4,12,-(Sqrt[22])},{0,0,3 (Sqrt[22])}}]

DihedralAngleConstant[{{-22,-25,4},{-12,15,-6},{8,5,-6},{18,-15,24}}]

DihedralAngleConstant[{{2,2,2},{0,-2,2},{-4,2,2},{0,0,-2}}]

DihedralAngleConstant[{{33,-33,33},{-11,-22,33},{-33,0,33},{-15,3,21}}]

Orthoschemes and other Spacefilling Tetrahedra

A few tetrahedra, known as orthoschemes, can be divided into eight similar copies of themselves.

ortho1=IntegerDigits[#,10,3]&/@#&/@{{020,111,121,022},{022,111,112,222},{022,111,121,222},{022,113,112,222},{022,113,123,024},{022,113,123,222},{111,202,212,113},{111,222,212,113}};

ortho2=IntegerDigits[#,10,3]&/@#&/@{{002,022,111,113},{022,042,131,133},{022,222,111,113},{022,222,111,131},{022,222,113,133},{022,222,131,133},{111,131,220,222},{113,133,222,224}};

Graphics3D[{Opacity[.6], Tetrahedron/@ortho1}, Boxed-> False, SphericalRegion->True]

Graphics3D[{Opacity[.6], Tetrahedron/@ortho2}, Boxed-> False, SphericalRegion->True]

Here are all five space-filling tetrahedra:

tetrahedralcells ={
{{{0,0,1},{0,2,1},{1,1,0},{1,1,2}},{{0,2,1},{1,1,0},{1,1,2},{2,2,1}},{{0,2,1},{1,1,2},{1,3,2},{2,2,1}}},

{{{0,0,1},{0,1,1},{1,0,0},{1,0,2}},{{0,1,1},{1,0,0},{1,0,1},{2,1,1}},{{0,1,1},{1,0,0},{1,1,0},{2,1,1}},{{0,1,1},{1,0,1},{1,0,2},{2,1,1}},{{0,1,1},{1,0,2},{1,1,2},{2,1,1}},{{1,0,0},{1,0,2},{2,0,1},{2,1,1}}},

{{{0,0,0},{0,0,2},{0,2,2},{1,1,1}},{{0,0,0},{0,0,2},{1,1,1},{2,0,0}},{{0,0,0},{0,2,0},{0,2,2},{1,1,1}},{{0,0,0},{0,2,0},{1,1,1},{2,2,0}},{{0,0,0},{1,1,1},{2,0,0},{2,2,0}},{{0,0,2},{0,2,2},{1,1,1},{2,2,2}},{{0,0,2},{1,1,1},{2,0,0},{2,0,2}},{{0,0,2},{1,1,1},{2,0,2},{2,2,2}},{{0,2,0},{0,2,2},{1,1,1},{2,2,0}},{{0,2,2},{1,1,1},{2,2,0},{2,2,2}},{{1,1,1},{2,0,0},{2,0,2},{2,2,2}},{{1,1,1},{2,0,0},{2,2,0},{2,2,2}}},

{{{0,0,2},{0,4,2},{1,2,2},{2,2,0}},{{0,0,2},{0,4,2},{1,2,2},{2,2,4}},{{0,0,2},{1,2,2},{2,2,0},{2,2,4}},{{0,4,2},{1,2,2},{2,2,0},{2,2,4}},{{0,4,2},{2,2,0},{2,2,4},{2,3,2}},{{0,4,2},{2,2,0},{2,3,2},{4,4,2}},{{0,4,2},{2,2,4},{2,3,2},{4,4,2}},{{0,4,2},{2,2,4},{2,4,3},{2,6,4}},{{0,4,2},{2,2,4},{2,4,3},{4,4,2}},{{0,4,2},{2,4,3},{2,6,4},{4,4,2}},{{2,2,0},{2,2,4},{2,3,2},{4,4,2}},{{2,2,4},{2,4,3},{2,6,4},{4,4,2}}},

{{{0,3,3},{1,4,2},{3,2,4},{1,0,2}},{{2,1,1},{1,0,2},{3,2,4},{1,4,2}},{{4,3,3},{5,4,2},{3,2,0},{1,4,2}},{{2,5,1},{1,4,2},{3,2,0},{5,4,2}},{{4,3,3},{3,2,4},{1,4,2},{3,2,0}},{{2,1,1},{3,2,0},{1,4,2},{3,2,4}}}};
tetrahedralnames = {
{"Sommerville 1", "Baumgartner T", "Hill, 1-60"},
{"Sommerville 2", "Baumgartner (Subscript[T, 1])", "Hill, special"},
{"Sommerville 3", "Hill, 2-45", "(not in Baumgartner)"},
{"Sommerville 4", "Baumgartner (Subscript[T, 4])", "(not in Hill)"},
{"Baumgartner (Subscript[T, 3])", "Hill, 2-60", "(not in Sommerville)"}};
Manipulate[
Column[{
Text@Column[tetrahedralnames[[n]], Alignment-> Center],
Graphics3D[{Opacity[.8],
Polygon/@Subsets[#,{3}]&/@ tetrahedralcells[[n]]},
SphericalRegion-> True, Boxed-> False, ImageSize-> 400]},
Alignment-> Center],
{n,Range[5], ControlType->Setter},
SaveDefinitions -> True]

The 59 Sporadic Rational Tetrahedra

The following tetrahedron has integer vertices and integer side lengths:

tet={{0,0,6},{0,0,0},{6,2,9},{0,8,6}};
EuclideanDistance@@#&/@Subsets[tet,{2}]

Conway question: What tetrahedra can be cut into a cube?

Space vectors forming rational angles (2020).  There are 59 sporadic tetrahedra where all dihedral angles are rational fractions of π. Of these, 56 can be derived from the Icosidodecahedron or the 3×3×3 cubic lattice.  The last three have angles (π/7, 3π/7, π/3, π/3, 4π/7, 4π/7).

Row[{PolyhedronData["Icosidodecahedron"], Graphics3D[Point[Tuples[{0,1,2},{3}]]]}]

Here are all of them, with 2Σ d-Σ s=4 .

sporadic={};
Manipulate[Module[{tet,mids},
tet=sporadic[[k]];
mids= Mean/@Subsets[tet[[3]],{2}] ;
Graphics3D[{Tetrahedron[tet[[3]]], Table[Style[Text[tet[[1,k]], mids[[k]]],18],{k,1,6}],Table[Style[Text[tet[[2,k]], tet[[3,k]]],{Bold,20, Blue}],{k,1,4}]},Boxed-> False, SphericalRegion->True]],{{k, 1, "choose"},1,59,1, Appearance-> "Labeled"}, SaveDefinitions->True, SynchronousInitialization->False]

Exact coordinates

spor={{0,0,0},{0,0,1},{0,(NumericalApproximation[Root, (RowDefault["2.83", FEExpressionsNumericalApproximationElider]), Root[256-384 ((#1)^2)-1744 ((#1)^4)+216 ((#1)^6)+((#1)^8)&,4], ]),(NumericalApproximation[Root, (RowDefault["-0.924", FEExpressionsNumericalApproximationElider]), Root[16-16 #1-24 ((#1)^2)+14 ((#1)^3)+((#1)^4)&,2], ])},{(NumericalApproximation[Root, (RowDefault["2.32", FEExpressionsNumericalApproximationElider]), Root[1-13 ((#1)^2)-16 ((#1)^4)-2 ((#1)^6)+((#1)^8)&,4], ]),(NumericalApproximation[Root, (RowDefault["0.244", FEExpressionsNumericalApproximationElider]), Root[1-19 ((#1)^2)+36 ((#1)^4)+26 ((#1)^6)+((#1)^8)&,3], ]),(NumericalApproximation[Root, (RowDefault["-0.0799", FEExpressionsNumericalApproximationElider]), Root[1+11 #1-19 ((#1)^2)+((#1)^3)+((#1)^4)&,2], ])}};
len=RootReduce[EuclideanDistance@@#]&/@Subsets[spor,{2}];
RootApproximant[N[RootReduce[ResourceFunction["TetrahedronEdgeAngles"][len]]/Pi,50]]

Graphics3D[{Tetrahedron[spor]}]

Face reflection

Graphics3D[FoldList[ResourceFunction["PolyhedronFaceReflect"],Tetrahedron[N[spor]],{1,4,1,4,1,4,1,4,1,4,1,4,1}],Boxed->False]

Another with exact coordinates

seventh={{-(1/2),0,0},{(1/2),0,0},{(NumericalApproximation[Root, (RowDefault["-0.0678", FEExpressionsNumericalApproximationElider]), Root[1-14 #1-420 ((#1)^2)+56 ((#1)^3)&,1], ]),(NumericalApproximation[Root, (RowDefault["0.552", FEExpressionsNumericalApproximationElider]), Root[1-21 ((#1)^2)+56 ((#1)^4)+7 ((#1)^6)&,4], ]),(NumericalApproximation[Root, (RowDefault["-0.126", FEExpressionsNumericalApproximationElider]), Root[1-91 ((#1)^2)+1764 ((#1)^4)+49 ((#1)^6)&,2], ])},{(NumericalApproximation[Root, (RowDefault["0.0678", FEExpressionsNumericalApproximationElider]), Root[-1-14 #1+420 ((#1)^2)+56 ((#1)^3)&,3], ]),(NumericalApproximation[Root, (RowDefault["0.552", FEExpressionsNumericalApproximationElider]), Root[1-21 ((#1)^2)+56 ((#1)^4)+7 ((#1)^6)&,4], ]),(NumericalApproximation[Root, (RowDefault["0.126", FEExpressionsNumericalApproximationElider]), Root[1-91 ((#1)^2)+1764 ((#1)^4)+49 ((#1)^6)&,3], ])}};

Graphics3D[FoldList[ResourceFunction["PolyhedronFaceReflect"],Tetrahedron[N[seventh]],{2,3,2,3,2,3,2,3,2,3,2,3,2,3}],Boxed->False]

Kimberling Centers (Currently 53769 centers)

Here are the first six:

(({{(Subscript[X, 1]), I, incenter}, {(Subscript[X, 2]), G, centroid}, {(Subscript[X, 3]), O, circumcenter}, {(Subscript[X, 4]), H, orthocenter}, {(Subscript[X, 5]), T, ninepoint}, {(Subscript[X, 6]), K, symmedian}}))

Encyclopedia of Triangle Centers.  https://faculty.evansville.edu/ck6/encyclopedia/etc.html .

Here’s an animation of a few hundred of the triangle centers.

ListAnimate[Graphics[#,ImageSize->{400,400}]&/@Import["https://www.mathpuzzle.com/KimberlingCenters.gif"]]

ListAnimate[Graphics[#,ImageSize->{900,900}]&/@Import["https://community.wolfram.com//c/portal/getImageAttachment?filename=EdPeggPost.gif&userId=20103"]]

https://community.wolfram.com//c/portal/getImageAttachment?filename=EdPeggPost.gif&userId=20103

Euler Line

The Euler line goes through O G T and H.
The incenter and symmedian are off the Euler line.
The isogonal conjugate of the Euler line is the Jerabek hyperbola.

tri={{-14,-6},{10,-6},{4,12}};
euler=ResourceFunction["EulerLinePoints"][tri];
mids=Mean/@Subsets[Reverse[tri],{2}];
jerabek=GroebnerBasis[{\[FormalX],\[FormalY]}==ResourceFunction["IsogonalConjugate"][tri,(1-\[FormalU]) euler[[1]]+\[FormalU] euler[[-1]]],{\[FormalX],\[FormalY]},\[FormalU]][[1]];
ii=Insphere[tri];
kk =ResourceFunction["IsogonalConjugate"][tri,Mean[tri]];
otherthree=Mean[{#,euler[[4]]}]&/@tri;
Legended[Graphics[{EdgeForm[Black],White,Thick,Triangle[tri],Blue,InfiniteLine[Take[euler,2]],Thin,
Red,InfiniteLine[{euler[[1]],#}]&/@mids,Circumsphere[tri],
Disk[euler[[1]],0.5],Style[Text["O", euler[[1]]], Black],Cyan,InfiniteLine/@Transpose[{tri,mids}],
Disk[euler[[2]],0.5],Style[Text["G", euler[[2]]], Black],Brown,Circle[euler[[3]],EuclideanDistance[euler[[3]],mids[[1]]]],
Disk[#,.1]&/@otherthree,
Disk[euler[[3]],0.5],Style[Text["T", euler[[3]]], Black],Green,InfiniteLine[{euler[[4]],#}]&/@tri,
Disk[euler[[4]],0.5],Style[Text["H", euler[[4]]], Black],Yellow,
Disk[ii[[1]],0.3],Style[Text["I", ii[[1]]], Black, 7],Magenta,
Disk[kk,0.3],Style[Text["K", kk], Black, 7],ContourPlot[jerabek==0//Evaluate,{\[FormalX],-15,13},{\[FormalY],-14,14}][[1]]}],PointLegend[{Red,Cyan,Brown,Green},{"circumcenter","centroid","nine-point center","orthocenter"},LegendMarkers->ConstantArray[Graphics[Disk[]],3]]]

Positions of O G T H on the Euler Line:

euler

The Euler Line for Tetrahedra

The Euler line goes through O G T and M.
The incenter and symmedian are off the Euler line.

initial={{-14,-6,-(Sqrt[22])},{10,-6,-(Sqrt[22])},{4,12,-(Sqrt[22])},{0,0,3 (Sqrt[22])}};
monge = ResourceFunction["Monge"][initial][[1]];
gg=Mean[initial];
oo=Circumsphere[initial];
medialpts=Mean[#]&/@Table[Drop[initial,{n}],{n,1,4}];
tt=Circumsphere[medialpts];
eulerpoints=(2 monge+#)/3&/@initial;
eulerpointfeet=Table[foot[Drop[initial,{k}], eulerpoints[[k]]],{k,1,4}];
feet =Table[foot[Drop[initial,{k}], initial[[k]]],{k,1,4}];
Graphics3D[{Opacity[.2],Thick,Tetrahedron[initial],Sphere@@tt,Cyan,Line[{monge,#}]&/@initial,Red,Line[{tt[[1]],#}]&/@medialpts,
AbsolutePointSize[10],
Point/@medialpts,Blue,Point/@eulerpoints,Green,Point/@eulerpointfeet,Yellow,Line/@Transpose[{eulerpoints}],
Opacity[1],
Style[Text["M", monge], Green, 20],
Style[Text["T", tt[[1]]], Brown, 20],
Style[Text["G", gg], Cyan, 20],
Style[Text["O", oo[[1]]], Red, 20],
Style[Text["I", Insphere[initial][[1]]], Yellow, 10],
Style[Text["K", ResourceFunction["IsogonalConjugate"][initial,Mean[initial]]], Magenta, 10],
Thick,Blue,InfiniteLine[{monge, oo[[1]]}], Brown, Line[Table[ResourceFunction["IsogonalConjugate"][N[initial],(1-\[FormalU]) oo[[1]]+\[FormalU] monge],{\[FormalU],-1.1,2.1,.1}]]
}, Boxed-> False, SphericalRegion-> True]

Many positions on the Euler Line:

initial={{-14,-6,-(Sqrt[22])},{10,-6,-(Sqrt[22])},{4,12,-(Sqrt[22])},{0,0,3 (Sqrt[22])}};
centers=SortBy[{#,RootApproximant[N[Chop[ResourceFunction["TetrahedronCenter"][N[initial,200],#]],40]]}&/@{"Incenter","Centroid","Circumcenter","Monge","12Point","Symmedian","Spieker","Fermat","Parallelians","Extangents","EulerMedial","EulerNegative","MedialEuler","NegativeEuler"}, {Abs[Last[Last[#]]],Last[#] }&]

Most of these are close to the Euler Line

Graphics3D[{Point[Last[#]]&/@centers,
{Red, Point[ResourceFunction["IsogonalConjugate"][N[initial], N[Last[#]]]]&/@centers}, 
{Blue, Point[ResourceFunction["IsotomicConjugate"][N[initial], N[Last[#]]]]&/@centers},{Cyan, Line[{{-2,0,0},{2,0,0}}]}, Opacity[.2], Tetrahedron[initial]},Boxed-> False, SphericalRegion-> True]

140618 Tetrahedron Centers

As shown in Mathematical Games: Tetrahedral Centers.

1. Use 10,000 triangle center functions.
2. Get this center on each triangle. That defines a tetrahedron.
3. Also get isogonal and isotomic conjugates.
4. That defines a lot of centers. But they don’t seem meaningful.

https://community.wolfram.com//c/portal/getImageAttachment?filename=EdPeggPost.gif&userId=20103

Thanks!  Ed Pegg Jr    edp@wolfram.com
Unsolved Questions

1. Virtually everything!  For example, what is the Tetrahedral Formula for the Fermat Point?
2.  For this talk, I generated hundreds of thousands of points. Which ones have easy formulas?  
3.  We can use simple formulas to generate points.  For example, for solid angles A B C D,  cos(A):cos(B):cos(C):cos(D).  Which of these correspond to useful points?
4.  What Tetrahedron Centers deserve LETTERS?   I = Incenter, G = Centroid, O = Circumcenter, M=Monge
5.  What triangles centers have tetrahedral equivalents, and which do not?  
6.  What are the equivalent SubTetrahedra corresponding to SubTriangles?

Possible project: 
1.  Pick a few scalene tetrahedron with nice properties.  Perhaps four reference tetrahedra.
2.  For each one, generate millions of points with a generation method.  Incenter of (Subscript[X, 777]) points would be generation method.  
3.  Generate thousands or millions of formulas.  
4.  See which formulas match up with points in all of the reference tetrahedra.