Tetrahedral Ring

Author

Eric W. Weisstein
October 16, 2023

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

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

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

Figure

GraphicsRow[Table[Graphics3D[TetrahedralRing[n],ViewPoint->{0,-2,.8},Boxed->False],{n,5}],Dividers->All]

5-ring ("Aristotle") gap

Mysteries in Packing Regular Tetrahedra
Jeffrey C. Lagarias and Chuanming Zong
1540–1549
Notices of the AMS Volume 59, Number 11
DOI: http://dx.doi.org/10.1090/noti918

Aristotle’s Error
In the history of mathematics, one of the earliest recorded mistakes was made by Aristotle. More than 2,300 years ago, Aristotle (384–322 BCE) taught that the regular tetrahedra fill space. In De Caelo (On the Heavens) Book III.8 he says (in translation): “Among surfaces it is agreed that there are three figures which fill the place that contain them—the triangle, the square and the hexagon: among solids only two, the pyramid and the cube” [3, 306b, p. 319]. Here “pyramid” refers to the regular tetrahedron, a Platonic solid. Thus Aristotle’s assertion can be taken to mean: space can be tiled by congruent regular tetrahedra.

Such a tiling is impossible. Let T denote a regular tetrahedron with unit edges and let α denote one of its dihedral angles. By a routine computation one can deduce that
α = arccos(1/3) ≈ 70◦32′.
If five tetrahedra are fitted around an edge (see Figure 1), then there is a small gap whose angular measure θ satisfies
0<θ=2π−5α≈7◦21′ <α,
and we conclude that regular tetrahedra cannot fill the space when arranged face-to-face

c=Mean[vnew[[{3,4}]]]

VectorAngle[vnew[[7]]-c,vnew[[8]]-c]//FullSimplify

N[%]

2π-5ArcCos[(1/3)]//N

N[ArcCos[(241/243)]/Degree,10]

FullSimplify[Subtract@@{2π-5ArcCos[(1/3)],ArcCos[(241/243)]}]

N[Subtract@@{2π-5ArcCos[(1/3)],ArcCos[(241/243)]},10^5]

Properties: {"TetrahedralRing", 3}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedralRing",3},"Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

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]//FullSimplify//Quiet

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[N[p,50]]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

convexhullname=PolyhedronData[pname,"ConvexHull","Name"]

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

Graphics3D[convexhullreg=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Sort[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

ConvexHullOf

hullof=DeleteCases[Select[PolyhedronData[All],PolyhedronData[#,"ConvexHullName"]===pname&],pname]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

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

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

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->RootReduce]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

PolyhedronData[pname,"Lines"]/.Line[l_]:>EuclideanDistance@@l//FullSimplify//Union//Quiet

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=p[[1]];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Hull

hullname=PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[hullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

PolyhedronData[pname,"Hull"]

Max[Norm/@PolyhedronData[pname,"Hull","Polyhedron"][[1]]]

Max[Norm/@p[[1]]]

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===hullname&]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

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

ClosestMeanCylindricalRadius[%]

Integrate over polyhedron [unevaluated]

$Version

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

Divergence theorem

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

N[rxy]

LogSimplify[rxy]//FullSimplify//Expand

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]

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

N[rxy]

LogSimplify[rxy]

(139/612)+((125 )/(272 (Sqrt[34])))(ArcSinh[(3/5)]+ArcSinh[(5/3)])-((ArcSinh[1])/(12 (Sqrt[2])))//N

TrigToExp[(ArcSinh[(3/5)]+ArcSinh[(5/3)])]//FullSimplify

LogPowers[49+8 (Sqrt[34]),(Sqrt[34]),20]

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->False])//Timing

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/4

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

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

cad=CylindricalDecompositionFunction[][x,y,z]

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

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

MaxMemoryUsed[]/10^9."GB"

N[rxyz,20]

rxysimp1=LogSimplify[rxy]//FullSimplify

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

Integrate over polyhedron

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

N[rxyz2]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p])//Timing

(sphere=Midsphere[p,Method->"PointLineDistance"])//Timing

Net

PolyhedronData[pname,"Net"]

NotationRules

PolyhedronData[pname,"NotationRules"]

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[{FaceForm[Green,Red],polyhedra}]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

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

Construction

v=p[[1]];

hulls=VertexSubsetHulls[p,"Platonic"]

Factor[(3/(Sqrt[2]))+2 (Sqrt[2]) x+3 (Sqrt[2]) y+z]

ineq=FullSimplify@Factor[Or@@(PolyhedronInequalities[ConvexHullRegion[v[[#]]],{x,y,z}]&/@Lookup[hulls,"Tetrahedron"])]

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

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

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

gn=PolyhedronData[pname,"Skeleton","Name"]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Cases[Union[emb,{pname}],Alternatives@@PolyhedronData[All]]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

RenameGraphFiles[]

GraphData[gn,"Graph",{"3D","All"}]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

Rule[#,Graphics3D[{{Opacity[.3],{Green,p}},Blue,ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Flatten[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]//Union

%===Range@Length@v

PolyhedronData[pname,"ConvexHull","Name"]

Platonic

(h=VertexSubsetHulls[p,"Platonic","Skip"->{}])//Timing

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Properties: {"TetrahedralRing", 4}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedralRing",4},"Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

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]//FullSimplify//Quiet

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[N[p,50]]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

convexhullname=PolyhedronData[pname,"ConvexHull","Name"]

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

Graphics3D[convexhullreg=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Sort[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

Conventual

hullof=DeleteCases[Select[PolyhedronData[All],PolyhedronData[#,"ConvexHullName"]===pname&],pname]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

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

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

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->RootReduce]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

PolyhedronData[pname,"Lines"]/.Line[l_]:>EuclideanDistance@@l//FullSimplify//Union//Quiet

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=p[[1]];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Hull

hullname=PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[hullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

PolyhedronData[pname,"Hull"]

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===hullname&]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

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 [wrong integral]

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

N[rxy]

LogSimplify[rxy]//FullSimplify//Expand

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]

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

N[rxy]

SetSystemOptions[]

rxysimp=LogSimplify[rxy,"ZeroTestNumericalPrecision"->1000]//FullSimplify

N[rxysimp-rxy,10^4]

TrigToExp[rxysimp]//FullSimplify

LogSimplify[%39]

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->False])//Timing

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/4

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

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

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

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

N[rxyz,20]

rxysimp1=LogSimplify[rxy]//FullSimplify

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

Integrate over polyhedron

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

N[rxyz2]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

sphere=Midsphere[p]

sphere=Midsphere[p,Method->"PointLineDistance"]

Net

PolyhedronData[pname,"Net"]

NotationRules

PolyhedronData[pname,"NotationRules"]

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[{FaceForm[Green,Red],polyhedra}]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

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

Construction

v=p[[1]];

hulls=VertexSubsetHulls[p,"Platonic"]

ineq=FullSimplify@Factor[Or@@(PolyhedronInequalities[ConvexHullRegion[v[[#]]],{x,y,z}]&/@Lookup[hulls,"Tetrahedron"])]

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

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

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

gn=PolyhedronData[pname,"Skeleton","Name"]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Cases[Union[emb,{pname}],Alternatives@@PolyhedronData[All]]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

RenameGraphFiles[]

GraphData[gn,"Graph",{"3D","All"}]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

Rule[#,Graphics3D[{{Opacity[.3],{Green,p}},Blue,ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Flatten[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]//Union

%===Range@Length@v

PolyhedronData[pname,"ConvexHull","Name"]

Platonic

(h=VertexSubsetHulls[p,"Platonic","Skip"->{}])//Timing

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Properties: {"TetrahedralRing", 5}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedralRing",5},"Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

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]//FullSimplify//Quiet

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[N[p,50]]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

convexhullname=PolyhedronData[pname,"ConvexHull","Name"]

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

Graphics3D[convexhullreg=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Sort[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

ConvexHull of

hullof=DeleteCases[Select[PolyhedronData[All],PolyhedronData[#,"ConvexHullName"]===pname&],pname]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

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

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

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->RootReduce]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

PolyhedronData[pname,"Lines"]/.Line[l_]:>EuclideanDistance@@l//FullSimplify//Union//Quiet

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=p[[1]];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Hull

hullname=PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

PolyhedronData[pname,"Hull"]

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===hullname&]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

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//Expand

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]

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

N[rxy]

rxysimp=LogSimplify[rxy,"ZeroTestNumericalPrecision"->1000]//FullSimplify

N[(53339/250920)-(9/(22960 (Sqrt[82])))( ArcCsch[9]+ArcSinh[9])+(375/(952 (Sqrt[34])))( ArcSinh[(3/5)]+ArcSinh[(5/3)])-((ArcSinh[1])/(20 (Sqrt[2])))]

N[rxysimp-rxy,10^4]

TrigToExp[rxysimp]//FullSimplify

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]

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/4

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

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

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

70+ GB

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

N[rxyz,20]

rxysimp1=LogSimplify[rxy]//FullSimplify

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

Integrate over polyhedron

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

N[rxyz2]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

sphere=Midsphere[p]

sphere=Midsphere[p,Method->"PointLineDistance"]

Net

PolyhedronData[pname,"Net"]

NotationRules

PolyhedronData[pname,"NotationRules"]

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[{FaceForm[Green,Red],polyhedra}]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

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

Construction

v=p[[1]];

hulls=VertexSubsetHulls[p,"Platonic"]

ineq=FullSimplify@Factor[Or@@(PolyhedronInequalities[ConvexHullRegion[v[[#]]],{x,y,z}]&/@Lookup[hulls,"Tetrahedron"])]

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

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

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

gn=PolyhedronData[pname,"Skeleton","Name"]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Cases[Union[emb,{pname}],Alternatives@@PolyhedronData[All]]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

RenameGraphFiles[]

GraphData[gn,"Graph",{"3D","All"}]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

Rule[#,Graphics3D[{{Opacity[.3],{Green,p}},Blue,ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Flatten[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]//Union

%===Range@Length@v

PolyhedronData[pname,"ConvexHull","Name"]

Platonic

(h=VertexSubsetHulls[p,"Platonic","Skip"->{}])//Timing

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Net construction

3

TetrahedralRing[3]

Table[{poly=UnfoldPolyhedron[TetrahedralRing[3],WorkingPrecision->1000],Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly}]},100]

{Polygon[],},

net=Polygon[];

Graphics[{FaceForm[LightYellow],EdgeForm[Black],net,MapIndexed[Text[#2[[1]],#,Background->White]&,v=net[[1]]]}]

rot=RotationMatrix[{v[[18]]-v[[1]],{1,0}}];

v2=(rot.(#-v[[1]]))&/@v;

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v2,net[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,v2]}]

vexact=Map[ToAlgebraicRoot,v2,{2}]

net[[2]]//Sort

4

TetrahedralRing[4]

Table[{poly=UnfoldPolyhedron[TetrahedralRing[4],WorkingPrecision->1000],Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly}]},100]

{Polygon[],},

net=Polygon[];

Graphics[{FaceForm[LightYellow],EdgeForm[Black],net,MapIndexed[Text[#2[[1]],#,Background->White]&,v=net[[1]]]}]

rot=RotationMatrix[{v[[18]]-v[[1]],{1,0}}];

v2=(rot.(#-v[[1]]))&/@v;

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v2,net[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,v2]}]

vexact=Map[ToAlgebraicRoot,v2,{2}]

net[[2]]//Sort

5

TetrahedralRing[5]

PolyhedronFaceCount[%49]

Table[{poly=UnfoldPolyhedron[TetrahedralRing[5],WorkingPrecision->1000],Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly}]},100]

{Polygon[],},

net=Polygon[];

Graphics[{FaceForm[LightYellow],EdgeForm[Black],net,MapIndexed[Text[#2[[1]],#,Background->White]&,v=net[[1]]]}]

rot=RotationMatrix[{v[[18]]-v[[1]],{1,0}}];

v2=(rot.(#-v[[1]]))&/@v;

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v2,net[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,v2]}]

vexact=Map[ToAlgebraicRoot,v2,{2}]

net[[2]]//Sort

PolyhedronData

<<MathWorld`Polyhedra`

PolyhedronData

file="~/tetrahedral_ring.m"

Do[
WriteString[file,PolyhedronDataString[
TetrahedralRing[n],
"StandardName"->{"TetrahedralRing",n},
"Name"->ToString[n]<>"-tetrahedral ring",
"Classes"->{"Deltahedron"},
TimeConstraint->10,
"Skip"->{"MeanCylindricalRadius"}
]],{n,3,5}]

Close[file]