Unistable Polyhedron

Author

Eric W. Weisstein
November 1, 2023

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

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

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

Graphic

<<MathWorld`Polyhedra`

unistable=SortBy[PolyhedronData["Unistable"],PolyhedronData[#,"F"]&]

TextGrid[{PolyhedronData[#,"F"],#}&/@unistable,Dividers->All]

GraphicsGrid[
Partition[
Graphics3D[
{
{Opacity[.6],PolyhedronData[#,"UnstableFaces"]},
{Red,PolyhedronData[#,"StableFaces"]}
},
Boxed->False,BoxRatios->1,PlotLabel->Style[PolyhedronData[#,"Name"],14,Black,Italic,FontFamily->"Times"]]&/@unistable,
UpTo[3]],
Dividers->All,ImageSize->700,Alignment->Top]

Properties: "ReshetovPolyhedron14"

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="ReshetovPolyhedron14","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

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

(sphere=MyCircumsphere[p])//Timing

Graphics3D[{{Opacity[.2],Yellow,sphere},p},Boxed->False]

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[%,RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

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

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"]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

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

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/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)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxy]

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

ByteCount[rxycollect=Collect[TrigToExp[rxylog],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,zmin,zmax}])//Timing

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

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

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

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

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)) Integrate[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}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

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

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

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

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

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[N[p,50]]

Net

PolyhedronData[pname,"Net"]

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//ToAlgebraicRoot//Timing

PolyhedronData[pname,"SurfaceArea"]

poly3d=PolyhedronData[pname,"Net","Polygons"]/.Polygon[v_]:>Polygon[Append[#,0]&/@v]

Total[Area/@Flatten[poly3d]]//RootReduce//FullSimplify

Graphics3D[{FaceForm[Green,Red],poly3d},Axes->True,AxesLabel->{"x","y","z"}]

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[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]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

StableFaces

PolyhedronData[pname,"StableFaces","List"]

PolyhedronData[pname,"StableFaces","Count"]

Graphics3D[Transpose[{{Red,Opacity[.2]},PolyhedronData[pname,{"StableFaces","UnstableFaces"}]}],Boxed->False,BoxRatios->1]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

SurfaceArea[p]//FullSimplify//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

Unistable

PolyhedronData[pname,"Unistable"]

UnstableFaces

PolyhedronData[pname,"UnstableFaces","List"]

PolyhedronData[pname,"UnstableFaces","Count"]

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: "ReshetovPolyhedron15"

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="ReshetovPolyhedron15","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

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[%,RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

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

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"]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

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/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)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxy]

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

ByteCount[rxycollect=Collect[TrigToExp[rxylog],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,zmin,zmax}])//Timing

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

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

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

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

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)) Integrate[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}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

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

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

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

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

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[N[p,50]]

Net

PolyhedronData[pname,"Net"]

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//ToAlgebraicRoot//Timing

PolyhedronData[pname,"SurfaceArea"]

poly3d=PolyhedronData[pname,"Net","Polygons"]/.Polygon[v_]:>Polygon[Append[#,0]&/@v]

Total[Area/@Flatten[poly3d]]//RootReduce//FullSimplify

Graphics3D[{FaceForm[Green,Red],poly3d},Axes->True,AxesLabel->{"x","y","z"}]

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[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]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//FullSimplify//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

Unistable

PolyhedronData[pname,"Unistable"]

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]

PolyhedronVolume[p]

Volume[PolyhedronData[pname,"Region"]]

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Properties: "ReshetovPolyhedron16"

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="ReshetovPolyhedron16","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

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[%,RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

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

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"]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

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/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)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxy]

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

ByteCount[rxycollect=Collect[TrigToExp[rxylog],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,zmin,zmax}])//Timing

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

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

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

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

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)) Integrate[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}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

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

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

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

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

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[N[p,50]]

Net

PolyhedronData[pname,"Net"]

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//ToAlgebraicRoot//Timing

PolyhedronData[pname,"SurfaceArea"]

poly3d=PolyhedronData[pname,"Net","Polygons"]/.Polygon[v_]:>Polygon[Append[#,0]&/@v]

Total[Area/@Flatten[poly3d]]//RootReduce//FullSimplify

Graphics3D[{FaceForm[Green,Red],poly3d},Axes->True,AxesLabel->{"x","y","z"}]

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[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]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

(13527594591111054183394/9177950325404829375)+((230394600914202610739428367326 (Sqrt[(2/5)]))/14094968889785404945373335)+((15336991509849789530947 (Sqrt[(53/57)]))/1685356187875868750)+((2132431606552441935377855204 (Sqrt[(994/5)]))/5741679791496821919157125)+((15819223162780992306782953270153 (Sqrt[557]))/16565356986781689977198343750)+((20052221437891917792942095896 (Sqrt[3338]))/186777914745794466106299375)+(3104398536904656864608324288/(11463955196982490912125 (Sqrt[3685])))+((706604696335901864873754625301632 (Sqrt[4013]))/7357900885618026949196629941875)+((350957845918903964994456 (Sqrt[4174]))/8896777380918520039375)+((2021295512510578242306746 (Sqrt[4709]))/77633981063008342025625)+((2005462330954410342822976 (Sqrt[5186]))/42926152742582337979025)+((249941241939851468421095453094 (Sqrt[5714]))/7305052286340927525454994375)+((78363567206034597007962 (Sqrt[6434]))/8316518247550286613125)+((32386340889839653797450299642983861528 (Sqrt[6574]))/225609660273779402424469348289416875)+((7061059597683227198262888284168896389308644 (Sqrt[7673]))/46503556945641621062027597985603543421875)+((3197519856499383493818071815391442503360311979956 (Sqrt[9429]))/21463422027317312646361889044168555407969915625)//FullSimplify//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

Unistable

PolyhedronData[pname,"Unistable"]

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: "ReshetovPolyhedron17"

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="ReshetovPolyhedron17","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

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[%,RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

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

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"]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

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/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)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxy]

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

ByteCount[rxycollect=Collect[TrigToExp[rxylog],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,zmin,zmax}])//Timing

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

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

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

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

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)) Integrate[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}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

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

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

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

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

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[N[p,50]]

Net

PolyhedronData[pname,"Net"]

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//ToAlgebraicRoot//Timing

PolyhedronData[pname,"SurfaceArea"]

poly3d=PolyhedronData[pname,"Net","Polygons"]/.Polygon[v_]:>Polygon[Append[#,0]&/@v]

Total[Area/@Flatten[poly3d]]//RootReduce//FullSimplify

Graphics3D[{FaceForm[Green,Red],poly3d},Axes->True,AxesLabel->{"x","y","z"}]

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[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]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

((401270197635276555969647960103429940424978547589657 (Sqrt[(13/785)]))/64531875939232988961149236237020864740490705552)+((1839472159480712786091969640601189852944824969 (Sqrt[(39/23)]))/3203506686615502785211745486385412023961280)+(127322725661110645627096195203/(609217184220017405105881075 (Sqrt[2])))+((1039403674906858679893130180585 (Sqrt[(97/2)]))/5350930973340203983129708779)+((12389415917155542572337127168423191486543 (Sqrt[(397/2)]))/464394175365956984342760358591611075040)+((35014044314392050962947806120961 (Sqrt[(1717/5)]))/1347747691490992269269020475722)+((549969535077971600899967 (Sqrt[(1961/2)]))/38443478087471593878928)+((369336444689093852680512075 (Sqrt[1105]))/37213286788672502874802304)+((388177395118308239934470409 (Sqrt[(4521/2)]))/813303785011364665745750305)+((72864778771189912084164733578163646863897 (Sqrt[(4849/2)]))/4771820343137664960005915938175438450400)+((1538439445157886546057928821 (Sqrt[4909]))/731938104900310264425028736)+((106645425573287725120256826622771 (Sqrt[5161]))/51855552756111766038071108803592)+((4552973752612239692133888331411 (Sqrt[5483]))/977916773533443623323387547688)+((809030147847190277653939017547681 (Sqrt[5651]))/640549877256732902030990680110380)+((6770214639223581304457820693 (Sqrt[6353]))/13137006679766316738936189820)+((17060339244506949919986337229077871 (Sqrt[6677]))/6195451696143691904183334855700800)+((213708096116012784620491193289786247 (Sqrt[8363]))/250271392236154730619096182188276800)//FullSimplify//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

Unistable

PolyhedronData[pname,"Unistable"]

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"]

Construction

Code from Reshetov

Polyhedra also given in https://demonstrations.wolfram.com/ReshetovsUnistablePolyhedraWith141516And17Faces/

Alexander Reshetov
A unistable polyhedron with 14 faces
March 2014
International Journal of Computational Geometry & Applications 24(01):39-59

https://research.nvidia.com/sites/default/files/pubs/2014-03_A-unistable-polyhedron/polytop-ijcga-rev2.pdf

https://www.researchgate.net/publication/280172577_A_unistable_polyhedron_with_14_faces

Vertices[v_List,n_List]:=Module[{x,y,z,p},
p={x,y,z};
(p/.First[Solve[Thread[Dot[p−#,#]&/@n[[#]]==0],p]])&/@v
]

ReshetovPolyhedron[f_,v_,n_]:=Polyhedron[Vertices[v,n],Reverse/@f]

"ReshetovPolyhedron14"

f={{16,10,14,1,7,17},{13,1,14},{23,5,3,19,18,9,8,24},{12,7,1,13},{21,19,3,2,6,22},{6,2,4},{4,2,3,5},{22,6,4,5,23},{17,7,12,11,9,18},{24,8,15,20},{15,8,9,11,10,16},{10,11,12,13,14},{20,15,16,17,18,19,21},{20,21,22,23,24}};
v={{1,2,4},{5,6,7},{3,5,7},{6,7,8},{3,7,8},{5,6,8},{1,4,9},{3,10,11},{3,9,11},{1,11,12},{9,11,12},{4,9,12} ,{2,4,12},{1,2,12} ,{10,11,13}, {1,11,13} ,{1,9,13}, {3,9,13},{3,5,13},{10,13,14},{5,13,14},{5,8,14},{3,8,14},{3,10,14}};
n={{19,70,-410},{0,289,-186},{-26,-389,-2},{-6,207,-331},{13,-329,101},{1,-167,233},{-5,-263,181},{0,-73,253},{-27,-85,-443} ,{0,107,201} ,{0,181,103},{0,287,-27},{32,-394,-134},{0,18,244}};

points=Vertex[#,v,n]&/@Range[Length[v]]

Graphics3D[p14=ReshetovPolyhedron[f,v,n],Boxed->False]

Graphics3D[{FaceForm[Green,Red],p14},Boxed->False,BoxRatios->1]

stable=StableFaces[PolyhedronData["ReshetovPolyhedron14","Polyhedron"]]

Graphics3D[{{FaceForm[Red,Red],poly[[stable]]},{Opacity[.8],Delete[poly,{stable}]}},Boxed->False,BoxRatios->1]

"ReshetovPolyhedron15"

f15={{3,2,1,4},{25,16,15,26},{5,4,1,6},{23,8,9,14,17,24},{11,6,1,2,12},{12,2,3,13},{22,13,3,4,5,7,8,23},{10,7,5,6,11},{9,8,7,10},{24,17,16,25},{26,15,18,19},{21,14,9,10,11,12,13,22},{20,18,15,16,17,14,21},{19,18,20},{19,20,21,22,23,24,25,26}};v15={{1,3,5},{1,5,6},{1,6,7},{1,3,7},{3,7,8},{3,5,8},{7,8,9},{4,7,9},{4,9,12},{8,9,12},{5,8,12},{5,6,12},{6,7,12},{4,12,13},{2,11,13},{2,10,13},{4,10,13},{11,13,14},{11,14,15},{13,14,15},{12,13,15},{7,12,15},{4,7,15},{4,10,15},{2,10,15},{2,11,15}};n15={{-64,0,-37},{80,0,0},{-46,0,-52},{29,0,-47},{-74,-2,-18},{-84,0,6},{-90,7,40},{-23,0,-61},{2,0,-61},{63,0,-30},{80,-1,35},{-75,-7,50},{40,-6,87},{66,-2,67},{24,8,107}};

Graphics3D[p15=ReshetovPolyhedron[f15,v15,n15],Boxed->False]

Graphics3D[{FaceForm[Green,Red],p15},Boxed->False,BoxRatios->1]

stable=StableFaces[PolyhedronData["ReshetovPolyhedron15","Polyhedron"]]

Graphics3D[{{FaceForm[Red,Red],poly[[stable]]},{Opacity[.8],Delete[poly,{stable}]}},Boxed->False,BoxRatios->1]

"ReshetovPolyhedron16"

f16={{25,13,9,5,26},{26,5,4,1,27},{20,1,4,3,8,14},{18,6,12,11,7,8,3,2,19},{17,6,18},{27,1,20,19,2,28},{28,2,3,4,5,9,23,22,24},{16,10,12,6,17},{15,7,11,10,16},{14,8,7,15},{23,9,13,21},{10,11,12},{24,22,21,13,25},{14,15,16,17,18,19,20},{21,22,23},{24,25,26,27,28}};
v16={{2,3,6},{4,6,7},{3,4,7},{2,3,7},{1,2,7},{4,5,8},{4,9,10},{3,4,10},{1,7,11},{8,9,12},{4,9,12},{4,8,12},{1,11,13},{3,10,14},{9,10,14},{8,9,14},{5,8,14},{4,5,14},{4,6,14},{3,6,14},{11,13,15},{7,13,15},{7,11,15},{7,13,16},{1,13,16},{1,2,16},{2,6,16},{6,7,16}};n16={{6,-7,-60},{8,-29,-46},{8,-42,-20},{-23,34,88},{-5,3,80},{-3,79,0},{-18,82,-25},{-1,-23,72},{6,-56,29},{8,-57,5},{3,14,-63},{1,-44,57},{0,47,-50},{-3,33,74},{0,32,-60},{-1,60,-37}};

Graphics3D[p16=ReshetovPolyhedron[f16,v16,n16],Boxed->False]

Graphics3D[{FaceForm[Green,Red],p},Boxed->False,BoxRatios->1]

stable=StableFaces[PolyhedronData["ReshetovPolyhedron16","Polyhedron"]]

Graphics3D[{{FaceForm[Red,Red],poly[[stable]]},{Opacity[.8],Delete[poly,{stable}]}},Boxed->False,BoxRatios->1]

"ReshetovPolyhedron17"

f17={{21,11,10,2,4,22},{12,2,10,9,13},{25,1,26},{24,3,5,1,25},{14,8,7,15},{28,26,1,5,29},{15,7,6,16},{18,16,6,19},{13,9,8,14},{30,4,2,12,20,27},{23,3,24},{29,5,3,23,22,4,30},{19,6,7,8,9,10,11,17},{20,12,13,14,15,16,18,17,11,21},{17,18,19},{27,20,21,22,23,24,25,26,28},{27,28,29,30}};v17={{3,4,6},{1,2,10},{4,11,12},{1,10,12},{4,6,12},{7,8,13},{5,7,13},{5,9,13},{2,9,13},{1,2,13},{1,13,14},{2,10,14},{2,9,14},{5,9,14},{5,7,14},{7,8,14},{13,14,15},{8,14,15},{8,13,15},{10,14,16},{1,14,16},{1,12,16},{11,12,16},{4,11,16},{3,4,16},{3,6,16},{10,16,17},{6,16,17},{6,12,17},{10,12,17}};n17={{0,-11,92},{49,0,-39},{-79,4,-41},{-89,1,-21},{70,0,3},{-52,2,-63},{69,0,20},{63,-1,41},{64,0,-18},{20,0,-52},{-95,1,4},{-91,-11,36},{29,-8,79},{28,8,85},{50,-3,62},{-94,12,35},{-21,1,-71}};

Graphics3D[p17=ReshetovPolyhedron[f17,v17,n17],Boxed->False]

Graphics3D[{FaceForm[Green,Red],p},Boxed->False,BoxRatios->1]

poly=PolyhedronData["ReshetovPolyhedron17","Polygons"];

zbar=PolyhedronData["ReshetovPolyhedron17","Centroid"];

stable=Flatten@Position[StableFaceQ[#,zbar]&/@poly,True]

Graphics3D[{{FaceForm[Red,Red],poly[[stable]]},{Opacity[.8],Delete[poly,{stable}]}},Boxed->False,BoxRatios->1]

"BezdekPolyhedron" on 18 faces

Reshetov 2014

Minich 2012

https://citeseerx.ist.psu.edu/document?repid=rep1&type=pdf&doi=19725f39dffa49c6c25958c366f0c0eba179a3b4

Code stripped down from:

https://demonstrations.wolfram.com/BezdeksUnistablePolyhedronWith18Faces/

<<MathWorld`Polyhedra`

solid2[m_,ep_,z0_]:=Module[
{k,fi,delta,r1,r2,zac,cikli,kor1,del=(Pi-2(Pi/m+ep))/(m-2),cikli2},
fi=Join[{0},Table[Pi/m+ep+i del,{i,0,m-2}],{Pi}];
delta=Join[{0,Pi/m+ep},Table[del,{m-2}],{Pi/m+ep}];
r1[1]=3;
r1[n_]:=r1[n-1]/Cos[delta[[n]]];
r2=Table[r1[n],{n,m+1}];
zac=Table[{n,If[n==2m-1,1,n+1],If[n==2m-1,1,n+1]+2m-1,n+2m-1},{n,2m-1}];
cikli=Join[zac,{Reverse[Range[2m-1]]},{Range[2m,4m-2]}];
kor1=Join[Table[{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],0},{n,2,m+1}],Reverse[Table[{Re[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],0},{n,2,m}]],Table[{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],0},{n,2,m+1}],Reverse[Table[{Re[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],0},{n,2,m}]]];{{cikli,kor1},r2[[m+1]],{Join[Table[{i,If[i==2m-1,1,i+1],2m},{i,2m-1}],{Reverse[Range[2m-1]]}],Join[Take[kor1,2m-1],{{0,-3,z0}}]}}]

BezdekPolyhedron[m_,ep_,z_]:=Module[{f,v},
{f,v}=solid2[m,ep,z][[3]];
Polyhedron[v,f]
]

BezdekPolyhedron[9, 0.26, 86.9]

p=BezdekPolyhedron[9,.26,86.9]

Graphics3D[p,AxesLabel->{"x","y","z"},Axes->True]

StableFaceIndices[p]

StableFaceIndices[N[p]]

StableFaceIndices[N[p,20]]

zbar=PolyhedronCentroid[p]

v=p[[1]];
f=p[[2]];

plane=InfinitePlane[Take[v[[f[[18]]]],3]]

nearestpt=RegionNearest[plane,zbar]

RegionMember[p,nearestpt]

Somehow, switching to exact destroys unistable property?!:

Graphics3D[p=BezdekPolyhedron[9,26/100,869/10]]

StableFaceIndices[p]//Quiet//Timing

StableFaceIndices[N[p]]

StableFaceIndices[N[p,20]]

Graphics3D/@{BezdekPolyhedron[9,.26,86.9],BezdekPolyhedron[9,26/100,869/10]}

BezdekPolyhedron[9,.26,86.9]==N[BezdekPolyhedron[9,26/100,869/10]]

BezdekPolyhedron[9, 26/100, 869/10]

Solve[.26==Pi/n,n]

Pi/12.

p=BezdekPolyhedron[9,Pi/12,869/10];

Graphics3D[p]

p//InputForm

StableFaceIndices[p]//Quiet//Timing

StableFaceIndices[N[p]]

StableFaceIndices[N[p,20]]

BezdekPolyhedron[9, 26/100, 869/10]

p=BezdekPolyhedron[9,26/100,869/10];

zbar=PolyhedronCentroid[p];

v=p[[1]];
f=p[[2]];

plane=InfinitePlane[Take[v[[f[[18]]]],3]]

nearestpt=RegionNearest[plane,zbar]

RegionMember[p,nearestpt]

nearestpt=RegionNearest[N[plane,20],N[zbar,20]]

RegionMember[N[p],nearestpt]

BezdekPolyhedronX[m_,ep_,z_]:=Module[{f,v},
{f,v}=solid2[m,ep,z][[3]];
Polyhedron[{#3,#1,#2}&@@@v,f]
]

Somehow, switching orientation destroys unistable property?!:

Graphics3D[p=BezdekPolyhedronX[9,26/100,869/10],AxesLabel->{"x","y","z"},Axes->True]

StableFaceIndices[N[p,20]]

StableFaceIndices[N[p,50]]

data={#,#2,StableFaceIndices[N[#2,20]]}&@@@Flatten[Table[{{i,j},BezdekPolyhedronX[9,i,j]},{i,1/10.,3/10,2/100},{j,20}],1];//Timing

Select[data,Length[#[[3]]]==1&]

data/.p_Polyhedron:>Graphics3D[p]

Somehow, switching to exact destroys unistable property?!:

data={#,#2,StableFaceIndices[N[#2,20]]}&@@@Flatten[Table[{{i,j},BezdekPolyhedronX[9,i,j]},{i,1/10,3/10,2/100},{j,20}],1];//Timing

Select[data,Length[#[[3]]]==1&]

"ConwayGuyPolyhedron" on 19 faces

PolyhedronData

<<MathWorld`Polyhedra`

PolyhedronDataString

file=OpenWrite["~/unistable.m"]

WriteString[file,PolyhedronDataString[
p,
"StandardName"->"ConwayGuyPolyhedron",
"Name"->"Conway\[Hyphen]Guy polyhedron",
"Classes"->{"Unistable"},
"Information"->"Conway-GuyPolyhedron"
]]

Close[file]

MapIndexed[
WriteString[file,PolyhedronDataString[
#,
"StandardName"->"ReshetovPolyhedron"<>(13+ToString[#2[[1]]]),
"Name"->"Reshetov polyhedron "<>ToString[#2[[1]]+13],
"Classes"->{"Unistable"},
"Information"->"UnistablePolyhedron",
TimeConstraint->5
]]&,
{p14,p15,p16,p17}]

Close[file]