Regular Tetrahedron

Author

Eric W. Weisstein
January 4, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/RegularTetrahedron.nb.

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

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

Figure

GraphicsRow[{
Graphics3D[{Opacity[.5],PolyhedronData["Tetrahedron","Polyhedron"]},Method->{"ShrinkWrap"->True},Boxed->False,ViewPoint->{0,1.2,1}10],
Graphics3D[{PolyhedronData["Tetrahedron","Lines"]},Method->{"ShrinkWrap"->True},Boxed->False,ViewPoint->{0,1.2,1}10],
PolyhedronData["Tetrahedron","Net"]
},ImageSize->700,Alignment->Center,Spacings->50]

Polyhedron

Orientations

PolyhedronData["Tetrahedron","Orientations"]

PolyhedronData["Tetrahedron","DefaultOrientation"]

Show[PolyhedronData[{"Tetrahedron",#}],Boxed->True]&/@PolyhedronData["TruncatedTetrahedron","Orientations"]

Polyhedron

Graphics3D[{FaceForm[Green,Red],PolyhedronData["Tetrahedron","Polyhedron"]}]

Region

PolyhedronData["Tetrahedron","Region"]

Solid and dual

PolyhedronData["Tetrahedron",#]&/@{"Graphics3D","Dual","DualCompound"}

Graphics3D[{Opacity[.6],
Red,PolyhedronData["Tetrahedron","Polyhedron"],
Green,PolyhedronData["Tetrahedron","Dual","Polyhedron"],
Yellow,PolyhedronData["Tetrahedron","Midsphere"]},Boxed->False]

UniformPolyhedron

uniform=UniformPolyhedron[stdname="Tetrahedron"]

PolyhedronFaceTally[uniform]

UniformPolyhedron/@{
stdname,
UniformPolyhedronIndex[stdname,"Wenninger"],
{"Coxeter",UniformPolyhedronIndex[stdname,"Coxeter"]},
{"Kaleido",UniformPolyhedronIndex[stdname,"Kaleido"]},
{"Uniform",UniformPolyhedronIndex[stdname,"Maeder"]},
{"Wenninger",UniformPolyhedronIndex[stdname,"Wenninger"]}
}

SameQ@@%

Graphics3D/@(polys=Polygon[poly[[1]],#]&/@poly[[2]])

Graphics3D[#,Boxed->False]&/@{uniform,polys}

Bulatov

BulatovUniformName[UniformPolyhedronIndex[stdname,"Kaleido"]]

BulatovUniformGraphics3D[UniformPolyhedronIndex[stdname,"Kaleido"],Boxed->False]

bulatov=BulatovUniformPolyhedron[UniformPolyhedronIndex[stdname,"Kaleido"]]

PolyhedronFaceTally[bulatov]

Meader

MaederUniformName[UniformPolyhedronIndex[stdname,"Maeder"]]

MaederWythoffSymbol[UniformPolyhedronIndex[stdname,"Maeder"]

maeder=MaederUniformPolyhedron[UniformPolyhedronIndex[stdname,"Maeder"]

PolyhedronFaceTally[maeder]

Region

PolyhedronData["Tetrahedron","Region"]

Solid and Dual

GraphicsRow[PolyhedronData["Tetrahedron",#]&/@{"Graphics3D","Dual","DualCompound"}]

Net

PolyhedronData["Tetrahedron","Net"]

PolyhedronData["Tetrahedron","Net","Colored"]

NetPrintout[PolyhedronData["Tetrahedron","Polyhedron"],"Tetrahedron.pdf"]

Distinct Nets

PolyhedronData["Tetrahedron","NetCount"]

tri[x_]:=Line[x+#&/@{{0,0},{1,0},{1/2,Sqrt[3]/2},{0,0}}]
utri[x_]:=Line[x+#&/@{{0,0},{-1/2,Sqrt[3]/2},{1/2,Sqrt[3]/2},{0,0}}]

Show[GraphicsArray[Graphics[#,AspectRatio->Automatic,PlotRange->{{-.1,2.6},{-.1,1.8}}]&/@{
{tri/@{{0,0},{1,0},{1/2,Sqrt[3]/2}}},
{tri/@{{0,0},{1,0}},utri/@{{1,0},{2,0}}}
}]]

Symmetry axes

axes=Line[{-#,#}]&/@Permutations[{.8,0,0}];

Show[GraphicsArray[Graphics3D[{Polyhedron[Tetrahedron,#],{Red,Thickness[.02],axes}},PlotLabel->#,Boxed->False,ViewPoint->{5,1,0}]&/@{"C2","C3"}]]

Show[GraphicsArray[Graphics3D[{Polyhedron[Tetrahedron,#],{Red,Thickness[.02],axes}},PlotLabel->#,Boxed->False,ViewPoint->{0,0,5}]&/@{"C2","C3"}]]

Union[FullSimplify[Norm/@Subtract@@@KSubsets[Midpoint/@Map[PolyhedronVertices[Tetrahedron][[#]]&,PolyhedronEdges[Tetrahedron],{2}],2]]]

Max[%]

c2=FullSimplify[Select[KSubsets[Midpoint/@Map[PolyhedronVertices[Tetrahedron][[#]]&,PolyhedronEdges[Tetrahedron],{2}],2],Abs[Norm[Subtract@@#]-1/Sqrt[2]]<10^-10&]]

c3=FullSimplify[Select[KSubsets[Join[PolyhedronVertices[Tetrahedron],Centroid/@Map[PolyhedronVertices[Tetrahedron][[#]]&,PolyhedronFaces[Tetrahedron],{2}]],2],Abs[Norm[Subtract@@#]-Inradius[Tetrahedron]-Circumradius[Tetrahedron]]<10^-10&]]

Length/@{c2,c3}

Length[Join[c2,c3]]

v=FullSimplify[Subtract@@@Join[c2,c3]]

Properties: "Tetrahedron" == {"Tetrahedron", "C3"}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="Tetrahedron","Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]

PolyhedronCentroid[p,Method->"Direct"]//Quiet//FullSimplify

PolyhedronCentroid[p,Method->"GaussLaw"]//Quiet//FullSimplify

Circumsphere

PolyhedronData["Tetrahedron","Circumsphere"]

Circumsphere[PolyhedronData["Tetrahedron","Polyhedron"]]//RootReduce//Timing

MyCircumsphere[PolyhedronData["Tetrahedron","Polyhedron"]]//RootReduce//Timing

Dual

pname

dname=PolyhedronData[pname,"Dual","Name"]

PolyhedronData[pname,"Dual","Scale"]

midrs={PolyhedronData[pname,"Midradius"],PolyhedronData[dname,"Midradius"]}

Divide@@midrs//FullSimplify

GraphicsRow[With[{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
style=Directive[Black,Italic,FontFamily->"Times",14]
},
{
Graphics3D[{s,Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},Boxed->False,PlotLabel->Style[PolyhedronData[pname,"Name"],style]],
Graphics3D[{s,Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},Boxed->False,PlotLabel->Style["dual tetrahedron",style]],
Graphics3D[{
{Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},
{Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},
s
},Boxed->False,PlotLabel->Style["compound with midsphere",style]],
Graphics3D[{
PolyhedronData[pname,"Polyhedron"],
PolyhedronData[pname,"Dual","Polyhedron"]
},Boxed->False,PlotLabel->Style["compound",style]]
}],Alignment->Top,ImageSize->800]

EdgeLengths

PolyhedronData["Tetrahedron","EdgeLengths"]

PolyhedronEdgeLengths[p]//Union

Inequalities

FullSimplify[PolyhedronData["Tetrahedron","RegionFunction"][x,y,z]/.{x->x/a,y->y/a,z->z/a},a>0]

ineq=(Sqrt[2])+4 (Sqrt[3]) z≥0&&4 (Sqrt[3]) z≤3 (Sqrt[2])+8 (Sqrt[6]) x&&4 (Sqrt[3]) ((Sqrt[2]) x+z)≤3 (Sqrt[2]) (1+4 y)&&4 ((Sqrt[6]) x+3 (Sqrt[2]) y+(Sqrt[3]) z)≤3 (Sqrt[2]);

RegionPlot3D[in,{x,-.5,.6},{y,-.5,.5},{z,-.3,.7}]

Insphere

PolyhedronData["Tetrahedron","Inradius"]

Insphere[PolyhedronData["Tetrahedron","Polyhedron"]]//RootReduce//Timing

MyInsphere[PolyhedronData["Tetrahedron","Polyhedron"]]//RootReduce//Timing

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p,{0,0,0}])/vol)

PolyhedronInertiaTensor[p]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)//Quiet

Integrate over polyhedron [wrong]

bug(439621): Integrate[Sqrt[x^2 + y^2], {x, y, z} ∈ tetrahedron] gives wrong complex result

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol))//Timing

N[rxy]

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p,GenerateConditions->True])/vol))//Timing

Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p,GenerateConditions->True]//Head//Timing

Integrate over region [wrong]

reg=PolyhedronData[pname,"Region"];

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈reg])/vol)//Quiet

bug(439621): Integrate[Sqrt[x^2 + y^2], {x, y, z} ∈ tetrahedron] gives wrong complex result

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈reg])/vol))//Timing

Boole

reg=PolyhedronData[pname,"RegionFunction"][x,y,z]

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)])Boole[reg],{x,y,z}∈FullRegion[3]])/vol))//Timing

ResourceFunction["LogSimplify"][rxy]

CAD

reg=PolyhedronData[pname,"RegionFunction"][x,y,z]

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

ResourceFunction["LogSimplify"][rxy]

CAD over  1/6

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/3]x]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

6((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=6((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxy]

LogSimplify[rxy]

TrigToExp[%]

DivergenceTheorem

(rxy=MeanCylindricalRadius[p,Debug->True])//Timing

ResourceFunction["LogSimplify"][rxy]

FullSimplify[%]

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

A366019/Sqrt[2]

N[lbar,20]

Dominik Beck.  "Mean distance in polyhedra."  https://arxiv.org/abs/2309.13177

Solve[(1/(6 (Sqrt[2])))(a^3)==1,a,PositiveReals]//FullSimplify

(1/((Sqrt[2]) (3^(1/3))))(3^(1/3))(((Sqrt[2])/7)-((37 π)/315)+((4 ArcTan[(Sqrt[2])])/15)+((113 Log[3])/(210 (Sqrt[2]))))//Expand

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax},
Method->{"GlobalAdaptive","MaxErrorIncreases"->1*^4}]//Timing

Integration using CAD using PolyhedronData's default orientation

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

cad=CylindricalDecomposition[ineq[x1,y1,z1]&&ineq[x2,y2,z2],{x1,y1,z1,x2,y2,z2},"Function"]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[cad],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

Integration using CAD using embedding in a cube

Monte Carlo using PolyhedronData's default orientation

ineq=PolyhedronData[pname,"RegionFunction"]

reg=ImplicitRegion[ineq[x,y,z],{x,y,z}];

Length[lines=Partition[RandomPoint[N@reg,10^7],2]]//Timing

Graphics3D[{{Opacity[.03],EdgeForm[],DiscretizeRegion[reg]},Red,Line/@Take[lines,UpTo@1000]},AspectRatio->Automatic]

Length[lengths=EuclideanDistance@@@lines]

Histogram[lengths,{.01}]

Mean[lengths]

Monte Carlo using embedding in a cube

ineq[x_,y_,z_]:=And@@{x+y+z≤2 ,x-y-z≤0,-x+y-z≤0,-x-y+z≤0};

reg=ImplicitRegion[ineq[x,y,z],{x,y,z}];

Volume[reg]

Length[lines=Partition[RandomPoint[N@reg,10^7],2]]//Timing

Graphics3D[{{Opacity[.03],EdgeForm[],DiscretizeRegion[reg]},Red,Line/@Take[lines,UpTo@1000]},AspectRatio->Automatic]

Length[lengths=EuclideanDistance@@@lines]

Histogram[lengths/(Sqrt[2]),{.01}]

Mean[lengths]/(Sqrt[2])

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

((Integrate[(x^2)+(y^2),{x,y,z}∈PolyhedronData[{pname,#},"Polyhedron"]])/vol)&/@PolyhedronData["Tetrahedron","Orientations"]

MeanSquareCylindricalRadius[p]//FullSimplify

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol)//Quiet

Integrate over polygon [unevaluated]

((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol)//Timing

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxyz,20]

rxysimp1=ResourceFunction["LogSimplify"][rxy]//FullSimplify

CAD over  1/6 [unevaluated]

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/3]x]

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

6((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=6((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxyz,20]

rxysimp1=LogSimplify[rxy]//FullSimplify

CAD over 1/4

v=PolyhedronData["Tetrahedron","VertexCoordinates"]

NestList[RotateRight,Range[4],4]

vc={Complement[Range[4],#][[1]],#}&/@Subsets[Range[4],{3}]

tips=Prepend[#,{0,0,0}]&/@{
Join[Mean[{v[[4]],v[[#]]}]&/@{1,2,3},{v[[4]]},Mean[{v[[4]],Sequence@@v[[#]]}]&/@Subsets[{1,2,3},{2}]],
Join[Mean[{v[[3]],v[[#]]}]&/@{1,2,4},{v[[3]]},Mean[{v[[3]],Sequence@@v[[#]]}]&/@Subsets[{1,2,4},{2}]],
Join[Mean[{v[[2]],v[[#]]}]&/@{1,3,4},{v[[2]]},Mean[{v[[2]],Sequence@@v[[#]]}]&/@Subsets[{1,3,4},{2}]],
Join[Mean[{v[[1]],v[[#]]}]&/@{2,3,4},{v[[1]]},Mean[{v[[1]],Sequence@@v[[#]]}]&/@Subsets[{2,3,4},{2}]]
}

midpts=Mean/@Subsets[v,{2}]

Graphics3D[{Opacity[.5],PolyhedronData["Tetrahedron","Polyhedron"],
AbsolutePointSize[10],Point[v],{Blue,Point[{0,0,0}]},{Red,Point[midpts]},ConvexHullRegion/@tips}]

reg=FullSimplify[PolyhedronInequalities[ConvexHullRegion[tips[[1]]],{x,y,z}]]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

4((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

CAD over 1/8 [unevaluated]

reg=FullSimplify[PolyhedronInequalities[ConvexHullRegion[tips[[1]]],{x,y,z}]&&y>0]

reg=y>0&&(Sqrt[2])+4 (Sqrt[3]) z≥0&&y≤(Sqrt[3]) x&&2 z≤(Sqrt[2]) x&&4 ((Sqrt[6]) x+3 (Sqrt[2]) y+(Sqrt[3]) z)≤3 (Sqrt[2])

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

8((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=8((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxyz]

CAD over 1/24 [unevaluated]

Graphics3D[{Opacity[.5],PolyhedronData["Tetrahedron","Polyhedron"],
AbsolutePointSize[10],Point[v],{Blue,Point[{0,0,0}]},{Red,Point[midpts]},ConvexHullRegion@tips[[1]]}]

tip=ConvexHullRegion@tips[[1]]

Graphics3D[LabelPolyhedron@tip]

Picking a different third cab give 26 instead of 27 CAD cells

Graphics3D[{{Opacity[.2],tip},ConvexHullRegion[tip[[1]][[{5,3,8,1}]]]}]

reg=FullSimplify[PolyhedronInequalities[ConvexHullRegion[tip[[1]][[{5,8,1,3}]]],{x,y,z}]]

reg=(Sqrt[2])+4 (Sqrt[3]) z≥0&&y≤0&&(Sqrt[3]) x+y≥0&&(Sqrt[6]) x+4 (Sqrt[3]) z≤3 (Sqrt[2]) y

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

24((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=24((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxyz]

Divergence theorem [hangs]

MeanSphericalRadius[p,"Simplification"->FullSimplify,Debug->True]//FullSimplify//Timing

...hung here for ~1.5 days...

Boole over region

6(Sqrt[2])Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[ineq],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]//Timing

6(Sqrt[2])NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[ineq],{x,-.6,.7},{y,-.6,.6},{z,-.2,.8},Method->"QuasiMonteCarlo",MaxPoints->10^6]

Inequalities for a tetrahedron with nice vertices, edge length (Sqrt[2]), volume 1/3, and centroid (1/2, 1/2, 1/2)

ineqs0[x_,y_,z_]:=And@@{x+y+z≤2 ,x-y-z≤0,-x+y-z≤0,-x-y+z≤0}

ineqs0[x,y,z]

ineqs0@@@{{0,0,0},{1,1,0}}

Norm[{1,1,0}]

Integrate[Boole[x+y+z≤2&&x-y-z≤0&&-x+y-z≤0&&-x-y+z≤0],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]

RegionPlot3D[And@@{x+y+z≤2 ,x-y-z≤0,-x+y-z≤0,-x-y+z≤0},{x,0,1},{y,0,1},{z,0,1}]

Length[pts=Select[(3^(1/3))RandomReal[{0,1},{10^6,3}],ineqs0@@#&]]//Timing

Total[pts]/Length[pts]

Inequalities for a tetrahedron with nice vertices, edge length (Sqrt[2]), volume 1/3, and centroid (1/2, 1/2, 1/2)

x+y+z≤2&&x-y-z≤0&&-x+y-z≤0&&-x-y+z≤0/.{x->x+1/2,y->y+1/2,z->z+1/2}//FullSimplify

ineqs1[x_,y_,z_]:=x+y+z≤(1/2)&&x≤(1/2)+y+z&&(1/2)+x+z≥y&&(1/2)+x+y≥z

RegionPlot3D[x+y+z≤(1/2)&&x≤(1/2)+y+z&&(1/2)+x+z≥y&&(1/2)+x+y≥z,{x,-.5,.5},{y,-.5,.5},{z,-.5,.5}]

Length[pts1=Select[(3^(1/3))RandomReal[{-1/2,1/2},{10^6,3}],ineqs1@@#&]]//Timing

Total[pts1]/Length[pts1]

6(Sqrt[2])NIntegrate[((Sqrt[(x^2)+(y^2)+(z^2)]))Boole[ineq],{x,-.6,.7},{y,-.6,.6},{z,-.2,.8},Method->"QuasiMonteCarlo",MaxPoints->10^6]

3Integrate[(Sqrt[x^2+y^2+z^2])Boole[x+y+z≤(1/2)&&x≤(1/2)+y+z&&(1/2)+x+z≥y&&(1/2)+x+y≥z],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]/((Sqrt[2]))//Timing

3Integrate[(Sqrt[x^2+y^2+z^2])Boole[x+y+z≤(1/2)&&x≤(1/2)+y+z&&(1/2)+x+z≥y&&(1/2)+x+y≥z],{z,-∞,∞},{y,-∞,∞},{x,-∞,∞}]/((Sqrt[2]))//Timing

3Integrate[(Sqrt[x^2+y^2+z^2])Boole[x+y+z≤(1/2)&&x≤(1/2)+y+z&&(1/2)+x+z≥y&&(1/2)+x+y≥z],{y,-∞,∞},{x,-∞,∞},{z,-∞,∞}]/((Sqrt[2]))//Timing

{Mean[Norm[#-1/2]&/@pts]/(Sqrt[2]),3/40.}

{Mean[Norm[#]&/@pts1]/(Sqrt[2]),3/40.}

Integrate over y first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=MinMax/@Transpose[PolyhedronCoordinates[p]]

ineq=PolyhedronData[pname,"RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq](Sqrt[(x^2)+(y^2)+(z^2)]),{y,ymin,ymax}])//Timing

NIntegrate[(i1/vol),{z,zmin,zmax},{x,xmin,xmax}]

(ii1=FullSimplify[i1])//Timing

(i2=NIntegrate[((Boole[(Sqrt[6])+12 z≥0&&((4 ((Sqrt[2]) x+z)<(Sqrt[6])&&0≤x<(1/(Sqrt[3])))||((Sqrt[6])+8 (Sqrt[2]) x≥4 z&&x<0&&(Sqrt[3])+6 x>0))])/vol)((1/48) ((Sqrt[3])-4 x-2 (Sqrt[2]) z) (Sqrt[3+64 (x^2)-4 (Sqrt[6]) z+56 (z^2)-8 x ((Sqrt[3])-2 (Sqrt[2]) z)])+((x^2)+(z^2)) ArcCsch[((12 (Sqrt[2]) (Sqrt[(x^2)+(z^2)]))/(3 (Sqrt[2])-4 (Sqrt[6]) x-4 (Sqrt[3]) z))]),{z,zmin,zmax},{x,xmin,xmax}])

(i2=Integrate[((Boole[(Sqrt[6])+12 z≥0&&((4 ((Sqrt[2]) x+z)<(Sqrt[6])&&0≤x<(1/(Sqrt[3])))||((Sqrt[6])+8 (Sqrt[2]) x≥4 z&&x<0&&(Sqrt[3])+6 x>0))])/vol)((1/48) ((Sqrt[3])-4 x-2 (Sqrt[2]) z) (Sqrt[3+64 (x^2)-4 (Sqrt[6]) z+56 (z^2)-8 x ((Sqrt[3])-2 (Sqrt[2]) z)])+((x^2)+(z^2)) ArcCsch[((12 (Sqrt[2]) (Sqrt[(x^2)+(z^2)]))/(3 (Sqrt[2])-4 (Sqrt[6]) x-4 (Sqrt[3]) z))]),{z,zmin,zmax},{x,xmin,xmax}])//Timing

(i2=Integrate[(ii1/vol),{x,xmin,xmax}])//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

((Integrate[(x^2)+(y^2)+(z^2),{x,y,z}∈PolyhedronData[{pname,#},"Polyhedron"]])/vol)&/@PolyhedronData["Tetrahedron","Orientations"]

MeanSquareSphericalRadius[p]//FullSimplify

Midradius

PolyhedronData["Tetrahedron","Midradius"]

Midsphere[PolyhedronData["Tetrahedron","Polyhedron"]]//RootReduce//Timing

NotationRules

PolyhedronData[pname,"NotationRules"]

Region

reg=Tetrahedron[a{{0,0,Sqrt[2/3]-1/(2 Sqrt[6])},{-(1/(2 Sqrt[3])),-(1/2),-(1/(2 Sqrt[6]))},{-(1/(2 Sqrt[3])),1/2,-(1/(2 Sqrt[6]))},{1/Sqrt[3],0,-(1/(2 Sqrt[6]))}}];

assum=a>0;

SurfaceArea

PolyhedronData["Tetrahedron","SurfaceArea"]

SurfaceArea[PolyhedronData["Tetrahedron","Polyhedron"]]

Total[Area/@PolyhedronData["Tetrahedron","Polygons"]]//FullSimplify

Uniform

PolyhedronData[pname,"Uniform"]

With[{rules=PolyhedronData[pname,"NotationRules"]},{
UniformPolyhedron[Lookup[rules,"WenningerIndex"]],
UniformPolyhedron[{"Coxeter",Lookup[rules,"CoxeterIndex"]}],
UniformPolyhedron[{"Kaleido",Lookup[rules,"KaleidoIndex"]}],
UniformPolyhedron[{"Uniform",Lookup[rules,"MaederIndex"]}],
UniformPolyhedron[{"Wenninger",Lookup[rules,"WenningerIndex"]}]
}]

SameQ@@%

Volume

PolyhedronData[pname,"Volume"]

Volume[p]

PolyhedronVolume[p,Method->"Direct"]//FullSimplify

PolyhedronVolume[p,Method->"GaussLaw"]

Properties: {"Tetrahedron", "C2"}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"Tetrahedron","C2"},"Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

Graphics3D[{AbsolutePointSize[10],
Point[{0,0,0}],{Blue,Point[PolyhedronData[pname,"Centroid"]]},Opacity[.2],PolyhedronData[pname,"GraphicsComplex"]}]

RegionCentroid[p]

PolyhedronCentroid[p]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

(i=((MomentOfInertia[p,{0,0,0}])/vol))//Timing

PolyhedronInertiaTensor[p]//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)

ClosestMeanCylindricalRadius[%]

Integrate over polyhedron

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy]

Divergence theorem

(rxy=MeanCylindricalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

N[rxy]

LogSimplify[rxy]//FullSimplify

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

CAD over  1/4

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&x>0&&y>0]

Show[Graphics3D[{Opacity[.2],p}],RegionPlot3D[ImplicitRegion[reg,{x,y,z}],PlotPoints->50]]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)//FullSimplify

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

4((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=4((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

FullSimplify[rxy]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol)

ClosestMeanSphericalRadius[%]

Integrate over polyhedron

(rxyz=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol))//Timing

N[rxyz]

Divergence theorem

(rxyz=MeanSphericalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

N[rxyz]

LogSimplify[rxyz]//FullSimplify

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxyz,20]

rxysimp1=ResourceFunction["LogSimplify"][rxy]//FullSimplify

CAD over  1/XX

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/5]x]

Show[Graphics3D[{Opacity[.2],p}],RegionPlot3D[ImplicitRegion[reg,{x,y,z}],PlotPoints->50]]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)//FullSimplify

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

XX((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxyz=XX((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

ByteCount[rxyzlog=LogSimplify[rxyz,"ZeroTestNumericalPrecision"->10000,WorkingPrecision->10000,Debug->True]]//Timing

ByteCount[rxyzcollect=Collect[TrigToExp[rxyzlog],Log[_]]//RootReduce]//Timing

Boole Integrate doing z integral first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=CoordinateBounds[p]

ineq=PolyhedronData[pname,"RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq](Sqrt[(x^2)+(y^2)+(z^2)]),{z,zmin,zmax}])//Timing

NIntegrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}]

(i2=Integrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}])//Timing

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

((NIntegrate[(x^2)+(y^2),{x,y,z}∈p])/vol)

Integrate over Polyhedron

(rxy2=((Integrate[(x^2)+(y^2),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy2]

Divergence theorem

(rxy2=MeanSquareCylindricalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

((NIntegrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/vol)

Integrate over polyhedron

(rxy2=((Integrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy2]

Integrate over region

reg=PolyhedronData[pname,"RegionFunction"][x,y,z]

(rxy=((Integrate[((x^2)+(y^2)+(z^2))Boole[reg],{x,y,z}∈FullRegion[3]])/vol))

Divergence theorem

(rxy2=MeanSquareSphericalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

Boole Integrate doing z integral first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}==CoordinateBounds[p]

ineq=PolyhedronData[pname,"RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq]((x^2)+(y^2)+(z^2)),{z,zmin,zmax}])//Timing

NIntegrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}]

(i2=Integrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}])//Timing

Orientations

PolyhedronData[pname,"Orientations"]

PolyhedronData[pname,"DefaultOrientation"]

Show[PolyhedronData[{pname,#}],Boxed->False]&/@PolyhedronData[pname,"Orientations"]

Polygons

PolyhedronData[pname,"FaceCount"]

PolyhedronFaceTally[p]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

{RegionPlot3D[ImplicitRegion[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}]],
Graphics3D[p]}

Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[p,{x,y,z}]

ineq=FullSimplify[%]

ineq/.{x->#,y->#2,z->#3}

{Region@ImplicitRegion[ineq,{x,y,z}],Graphics3D[p]}

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

Total[Area/@PolyhedronData[pname,"Polygons"]]

SurfaceArea[PolyhedronData[pname,"Region"]]

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Volume[PolyhedronData[pname,"Region"]]//FullSimplify

Volume[ImplicitRegion[Evaluate@PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}]]//FullSimplify

Projections

PolyhedronProjectionGraph[PolyhedronData["Tetrahedron","Polyhedron"],#]&/@{{0,0,1},{0,1,0},{1,.0000001,0},{1,1,-1},{(Sqrt[2]),0,1}}

GraphData["TetrahedralGraph","Graph","Perspective"]

Construction

TetrahedronExact:=TetrahedronExact=Module[{v={{0,0,0},{0,1,1},{1,0,1},{1,1,0}}/Sqrt[2]},(*need this to put centroid at (0,0,0)*)Orient[Polygon/@{v[[{3,2,1}]],v[[{1,2,4}]],v[[{4,3,1}]],v[[{2,3,4}]]}]]

TetrahedronExactZ:=Orient[Polygon/@Partition[{{Sqrt[3]/3,0,0},{-Sqrt[3]/6,1/2,0},{-Sqrt[3]/6,-1/2,0},{0,0,Sqrt[6]/3}},3,1,1]]

(Subscript[C, 3])

Show[Graphics3D[Polyhedron[Tetrahedron]],ViewPoint->5{0,0,1}]

(Subscript[C, 2])

θ=ArcCos[FullSimplify[Divide@@Through[{Midradius,Circumradius}[Tetrahedron]]]]

Show[Graphics3D[poly=FullSimplify[Polyhedron[Tetrahedron]/.Polygon[x_]:>Polygon[RotationMatrixY[θ].#&/@x]]],ViewPoint->2{0,0,1}]

With[{p=Tetrahedron},FullSimplify[RootReduce[poly[[1,#[[1]],1,#[[2]]]]&/@(First[Position[PolyhedronFaces[p],#]]&/@Range[Length[PolyhedronVertices[p]]])]]]//InputForm

Inequalities

<<Graphics`InequalityGraphics`
<<Utilities`LiveGraphics3D`

WriteLiveForm["tetineq.m",
InequalityPlot3D[
 x+y+z<=2 &&
x-y-z<=0&&
-x+y-z<=0 &&
-x-y+z<=0,
 {x, -1, 1}, {y, -1, 1}, {z, -1, 1},Boxed->True,opts]
]

i=FullSimplify[PolyhedronInequalities[Polyhedron[Tetrahedron],{x,y,z}]][[1]]

Integrate[Boole[And@@PolyhedronInequalities[TetrahedronExact,{x,y,z}]],{x},{y},{z}]

FullSimplify[%]

Integrate[ Boole[x+y+z≤2&&x-y-z≤0&&-x+y-z≤0&&-x-y+z≤0],{x},{y},{z}]

1/12 Sqrt[2] Sqrt[2]^3

Table[{n,Integrate[# Boole[x+y+z≤2&&x-y-z≤0&&-x+y-z≤0&&-x-y+z≤0],{x},{y},{z}]&/@({x,y,z}^n)},{n,6}]//ColumnForm

Tetrahedron and cube

WriteLiveForm["tetcube.m",
	Show[Graphics3D[SplitLines[TetrahedronCube,1]],Boxed->False]]

Tetrahedron square

tetrahedron:=Module[
	{sq2=Sqrt[2],sq3=Sqrt[3],sq6=Sqrt[6],
	v1,v2,v3,v4},
	v1={0,0,sq3};
	v2={0,2/3 sq6,-sq3/3};
	v3={-sq2,-sq6/3,-sq3/3};
	v4={sq2,-sq6/3,-sq3/3};
 {Polygon[{v1,v2,v3}],Polygon[{v1,v2,v4}],Polygon[{v1,v3,v4}],
 Polygon[{v2,v3,v4}]}
]

square:=Module[
	{sq2=Sqrt[2],sq3=Sqrt[3],sq6=Sqrt[6],
	v1,v2,v3,v4},
	v1={0,0,sq3};
	v2={0,2/3 sq6,-sq3/3};
	v3={-sq2,-sq6/3,-sq3/3};
	v4={sq2,-sq6/3,-sq3/3};
	{(v1+v2)/2,(v1+v3)/2,(v3+v4)/2,(v2+v4)/2}
]

WriteLiveForm["tetsq1.m",
		Show[Graphics3D[SplitLines[{square,frame[tetrahedron]},2]],
		Boxed->False]]

WriteLiveForm["tetsq2.m",
Show[CenterAtCenterOfMass[PolyhedronPolygon[tetrahedron,square]],opts]]

Show[GraphicsArray[{
	Show[Graphics3D[{square,frame[tetrahedron]}],
		Boxed->False,DisplayFunction->Identity],
	Show[Graphics3D[{line[square[[1]]],tetrahedron[[1]]}],
		Boxed->False,DisplayFunction->Identity]}],
	DisplayFunction->$DisplayFunction]

Tetrahedron in a tetrahedron

v={{0, 0, 0}, {0,1, 1}, {1, 0, 1}, {1, 1, 0}};
tet={v[[{1,2,3}]],v[[{1,2,4}]],v[[{1,3,4}]],v[[{2,3,4}]]};
c=Apply[Plus,tet,1]/3;
tet2={c[[{1,2,3}]],c[[{1,2,4}]],c[[{1,3,4}]],c[[{2,3,4}]]};

Graphics3D[{Polygon/@tet2,FaceForm[],Polygon/@tet,{PointSize[.03],Point/@Union[Flatten[tet2,1]]}},ViewPoint->{-1.2,1.5,-1.3},Boxed->False]

Wireframe

TetrahedronWireframe[n_:20]:=Module[
{
t={{0,0,0},{0,1,1},{1,0,1},{1,1,0}},
r={{1,2},{2,3},{2,4}},
s={{4,3},{4,1},{1,3}},i,j
},
{Table[Line/@Table[{t[[r[[j,1]]]]+i/n (t[[r[[j,2]]]]-t[[r[[j,1]]]]),t[[s[[j,1]]]]+i/n (t[[s[[j,2]]]]-t[[s[[j,1]]]])},{i,0,n}],{j,Length[r]}],{Thickness[.01],Table[Line[t[[{i,j}]]],{i,4},{j,i+1,4}]}}]

Show[Graphics3D[TetrahedronWireframe[]],Boxed->False]

Bimedean Intersections

p={{0.592636,-0.528863,-0.75947},{-0.191352,0.00723416,0.498869},{-0.564707,0.986949,-0.260729},{0.757337,0.880725,0.222009}}

WriteLiveForm[tetbimed.m,Show[Graphics3D[{{Thickness[.01],TetrahedronEdges[p]},PointSize[.04],Point/@TetrahedronMidpoints[p],RGBColor[1,0,0],Point[LineLineIntersection3D@@(Take[Bimedians3D[p],{1,2}]/.Line:>Identity)],Bimedians3D[p]}],Boxed->False,ViewPoint->{-2.8520830088003395,-1.8098254223104622,-0.20038575715643192}]]

WriteLiveForm[tetmed.m,Show[Graphics3D[{{Thickness[.01],TetrahedronEdges[p]},PointSize[.04],Point[#[[1,2]]]&/@Medians3D[p],RGBColor[1,0,0],Medians3D[p],Point[LineLineIntersection3D@@(Take[Medians3D[p],{1,2}]/.Line:>Identity)]}],Boxed->False,ViewPoint->{-2.8520830088003395,-1.8098254223104622,-0.20038575715643192}]]

Stellation

FaceIntersections[poly_]:=Module[{pairs=KSubsets[Take[#,3]&/@First/@poly,2]},
DeleteCases[Intersection3D@@@Map[Plane,pairs,{2}],{}]
]

poly=Tetrahedron;
Show[Graphics3D[{Polyhedron[poly],{Red,lines=FaceIntersections[Polyhedron[poly]]},PointSize[.02],points=Intersection3D@@@KSubsets[lines,2]}]]