Cube 10-Compound

Author

Eric W. Weisstein
October 11, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Cube10-Compound.nb.

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

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

Variants

variants=PolyhedronData["CubeTenCompound*"]

PolyhedronData[#,"FaceCount"]&/@variants

Length[PolyhedronData[#,"Polyhedra"]]&/@variants

Polyhedra

GraphicsGrid[Transpose[{
Graphics3D[{PolyhedronData[#,"Polyhedron"]},Boxed->False],
With[{poly=PolyhedronData[#,"Polyhedra"]},Graphics3D[Table[{Hue[(i/(Length[poly]))],poly[[i]]},{i,Length[poly]}],Boxed->False]]
}&/@variants],Dividers->All,ImageSize->700]

Solids and duals

GraphicsGrid[
Table[
With[
{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
dname=PolyhedronData[pname,"Dual","Name"],
style=Directive[Black,Italic,FontFamily->"Times",14]
},
{
Graphics3D[{s,Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},Boxed->False,PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center]],

Graphics3D[{s,Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},Boxed->False,PlotLabel->Style[PolyhedronData[dname,"Name"],style]],

Graphics3D[{
{Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},
{Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},
s
},Boxed->False,PlotLabel->Style["compound with midsphere",style]],

Graphics3D[{
PolyhedronData[pname,"Polyhedron"],
PolyhedronData[pname,"Dual","Polyhedron"]
},Boxed->False,PlotLabel->Style["compound",style]]
}],
{pname,variants}
],
Dividers->All,ImageSize->800,Alignment->Top
]

Interior and convex hull

GraphicsGrid[
With[{style=Directive[Black,Italic,FontFamily->"Times",16]},
Table[{
Graphics3D[PolyhedronData[pname,"Polyhedron"],PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center],Boxed->False],
Graphics3D[{AbsoluteThickness[.5],PolyhedronData[pname,"Lines"],Opacity[.8],PolyhedronData[pname,"CompoundInterior","Polyhedron"]},PlotLabel->Style["interior",style],Boxed->False],
Graphics3D[{
{EdgeForm[None],PolyhedronData[pname,"Polyhedron"]},
{Opacity[.7],EdgeForm[Thickness[.002]],PolyhedronData[pname,"ConvexHull","Polyhedron"]}},PlotLabel->Style["convex hull",style],Boxed->False]
},
{pname,variants}]
],
Dividers->All,ImageSize->700]

Polyhedron: {"CubeTenCompound", 1}

Orientations

PolyhedronData[{"CubeTenCompound",1},"Orientations"]

PolyhedronData[{"CubeTenCompound",1}]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"CubeTenCompound",1},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"CubeTenCompound",1},"Region"]

Solid and dual

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

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

Polyhedron: {"CubeTenCompound", 2}

Orientations

PolyhedronData[{"CubeTenCompound",2},"Orientations"]

PolyhedronData[{"CubeTenCompound",2}]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"CubeTenCompound",2},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"CubeTenCompound",2},"Region"]

Solid and dual

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

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

Polyhedron: {"CubeTenCompound", 3}

Orientations

PolyhedronData[{"CubeTenCompound",3},"Orientations"]

PolyhedronData[{"CubeTenCompound",3}]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"CubeTenCompound",3},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"CubeTenCompound",3},"Region"]

Solid and dual

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

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

Properties: {"CubeTenCompound", 1}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"CubeTenCompound",1},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

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

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

CompoundInterior

intname=PolyhedronData[pname,"CompoundInterior","Name"]

PolyhedronData[pname,"CompoundInterior","Scale"]

PolyhedronData[pname,"CompoundInterior","RotationMatrix"]

PolyhedronData[pname,"CompoundInterior"]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

Graphics3D[{{Opacity[0],p},Red,interior},Boxed->False]

MyCircumsphere[interior]//Quiet

Insphere[interior]//Quiet

Midsphere[interior]

Construction

int=RegionIntersection[Sequence@@PolyhedronData[pname,"Polyhedra"],PerformanceGoal->"Quality"]

Graphics3D[int]

Graphics3D[{{Opacity[.3],p},Red,int},Boxed->False]

Union[Chop@int[[1]]]//Length

Exactify

vexact=DeleteDuplicates[RootApproximant[Chop[int[[1]]],4]]

Length[vexact]

vexact=DeleteDuplicates[Map[ToAlgebraicRoot[SetPrecision[#,14],"MaxDegree"->4]&,Chop[int[[1]]],{2}]]

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=Sort[inthull[[2]]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[inthull]]//Counts//Quiet

lengths=Keys[%]

(lengths/(Min[lengths]))//FullSimplify

N[%]

PolyhedronData["PentakisDodecahedron","EdgeLengths"]

RootReduce[PolyhedronEdgeLengths[PolyhedronData["PentakisDodecahedron","Polyhedron"]]]//Counts

N[Keys[%]]

Numerically group

Union[Chop@int[[1]]]//Length

Length[grouped=SplitBy[SortBy[{#,Round[1*^12#]}&/@Chop[int[[1]]],Last],Last][[All,All,1]]]

Max[EuclideanDistance@@@Flatten[Subsets[#,{2}]&/@grouped,1]]

grouped//Column

rules=Flatten[Function[l,Rule[#,Mean[l]]&/@l]/@grouped,1];

newi=ConvexHullRegion[DeleteDuplicates[Chop[int[[1]]]/.rules]]

Graphics3D[LabelPolyhedron@newi]

Midsphere[newi]

lengths=PolyhedronEdgeLengths[newi]

Divide@@MinMax[%lengths]

lengths=Round[10^12lengths]/10^12.//Counts

Divide@@Keys[lengths]

RecognizeGraph@PolyhedronGraph@newi

PolyhedronData["PentakisDodecahedron","EdgeLengths"]

N[%]

newi[[1]]

newi[[2]]

Graphics3D[{
AbsoluteThickness[.1],PolyhedronData[pname,"Lines"],
Opacity[.8],newi},Boxed->False]

Find scale

intname=XXX;

PolyhedronData/@{pname,intname}

xyratio=((Max[Norm/@vexact[[All,;;2]]])/(Max[Norm/@PolyhedronData[intname,"VertexCoordinates"][[All,;;2]]]))//RootReduce//FullSimplify//Quiet

zratio=((Max[vexact[[All,3]]])/(Max[PolyhedronData[intname,"VertexCoordinates"][[All,3]]]))//RootReduce//FullSimplify

{xyratio,xyratio,zratio}

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[intname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

Graphics3D[{{Opacity[.5],LabelPolyhedron[p,Background->LightGreen]},
LabelPolyhedron@Polyhedron[newv=s rot.#&/@basesolid[[1]],basesolid[[2]]]},Boxed->False]

rot=RotationMatrix[{basev[[4]],Mean@p[[1]][[{3,7}]]}]//FullSimplify

rot2=RotationMatrix[θ,Subtract@@newv[[{4,3}]]]

newv2=rot2.#&/@newv;

p1[[1]][{3,6,7}]

Solve[RegionDistance[InfinitePlane[p1[[1]][[{3,6,7}]]],newv2[[5]]]==0&&0<θ<π,θ]//FullSimplify

rottotal=FullSimplify[rot2/.θ->((5 π)/12)].rot//FullSimplify

Graphics3D[{{Opacity[.5],LabelPolyhedron[p1,Background->LightGreen]},
LabelPolyhedron@Polyhedron[newv2=s rottotal.#&/@basesolid[[1]],basesolid[[2]]]},Boxed->False]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

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

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

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

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

RecognizeGraph@PolyhedronGraph@convexhull

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

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhullreg]]//Tally//FullSimplify

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[convexhullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ConvexHullOf

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

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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

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

Divide@@midrs//FullSimplify

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

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.7],p},{Red,sphere}},Boxed->False]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p]//RootReduce)//Timing

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

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

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[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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: {"CubeTenCompound", 2}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"CubeTenCompound",2},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

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

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

CompoundInterior

Interior

intname=PolyhedronData[pname,"CompoundInterior","Name"]

PolyhedronData[pname,"CompoundInterior","Scale"]

PolyhedronData[pname,"CompoundInterior","RotationMatrix"]

PolyhedronData[pname,"CompoundInterior"]

Graphics3D[{
AbsoluteThickness[.1],PolyhedronData[pname,"Lines"],
Opacity[.8],interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

Style[Graphics3D[{{Opacity[.1],p},Red,interior},Boxed->False],RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

MyCircumsphere[interior]//Quiet

Insphere[interior]//Quiet

Midsphere[interior]

Volume

PolyhedronData[pname,"CompoundInterior","Volume"]

N[%,30]

Volume compute

vol=Volume[PolyhedronData[pname,"CompoundInterior","Polyhedron"]]

N[vol,30]

vol2=Expand@Total@RootReduce[List@@Numerator[vol]]/Denominator[vol]

N[vol2,30]

Block[{$MaxRootDegree=1080},vol3=RootReduce[960vol2]]//Timing

N[(NumericalApproximation[Root, (RowDefault["540.", FEExpressionsNumericalApproximationElider]), Root[«1»&,7], ])/960,20]

RootReduce[(NumericalApproximation[Root, (RowDefault["540.", FEExpressionsNumericalApproximationElider]), Root[«1»&,7], ])/960]//Timing

Volume by pyramids [wrong!?]

<<MathWorld`Polyhedra`

interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"];

ConvexPolyhedronQ[interior]

SimplePolyhedronQ[interior]

N[Volume[interior],30]

faces=PolyhedronFaceTally[interior]

v=interior[[1]];

polys=PolyhedronPolygons[interior];

Volume by pyramids

<<MathWorld`Polyhedra`

(volp=PolyhedronVolume[interior,Debug->True,Method->"Pyramids"])//Timing

N[volp,30]

...wrong!?...

Volume by Gauss's theorem

vold=PolyhedronVolume[interior,Debug->True,Method->"Direct"]

N[vold,30]

Volume by Gauss's theorem

volg=PolyhedronVolume[interior,Debug->True,Method->"GaussLaw"]

N[volg,30]

Construction

int=RegionIntersection[Sequence@@PolyhedronData[pname,"Polyhedra"],PerformanceGoal->"Quality"]

Graphics3D[int]

Graphics3D[{{Opacity[0],p},Red,int},Boxed->False]

Exactify

DeleteDuplicates[Chop@int[[1]]]//Length

vexact=DeleteDuplicates[RootApproximant[Chop[int[[1]]]]]

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[inthull]]//Counts//Quiet

Find scale

intname=XXX;

PolyhedronData/@{pname,intname}

xyratio=((Max[Norm/@vexact[[All,;;2]]])/(Max[Norm/@PolyhedronData[intname,"VertexCoordinates"][[All,;;2]]]))//RootReduce//FullSimplify//Quiet

zratio=((Max[vexact[[All,3]]])/(Max[PolyhedronData[intname,"VertexCoordinates"][[All,3]]]))//RootReduce//FullSimplify

{xyratio,xyratio,zratio}

Numerically group

Union[Chop@int[[1]]]//Length

grouped=SplitBy[SortBy[{#,Round[1*^12#]}&/@Chop[int[[1]]],Last],Last][[All,All,1]];

Length[grouped]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

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

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

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

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

RecognizeGraph@PolyhedronGraph@convexhull

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

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhullreg]]//Tally//FullSimplify

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[convexhullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ConvexHullOf

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

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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

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

Divide@@midrs//FullSimplify

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

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[0],p},{Red,sphere}},Boxed->False]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p]//RootReduce)//Timing

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

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

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[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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: {"CubeTenCompound", 3}

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

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

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

CompoundInterior

intname=PolyhedronData[pname,"CompoundInterior","Name"]

PolyhedronData[pname,"CompoundInterior","Scale"]

PolyhedronData[pname,"CompoundInterior","RotationMatrix"]

PolyhedronData[pname,"CompoundInterior"]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

MyCircumsphere[interior]//Quiet

Insphere[interior]//Quiet

Midsphere[interior]

Construction

int=RegionIntersection[Sequence@@PolyhedronData[pname,"Polyhedra"],PerformanceGoal->"Quality"]

Graphics3D[int]

Graphics3D[{{Opacity[0],p},Red,int},Boxed->False]

Union[Chop@int[[1]]]//Length

Exactify

vexact=DeleteDuplicates[RootApproximant[Chop[int[[1]]]]]

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[inthull]]//Counts//Quiet

Find scale

intname=XXX;

PolyhedronData/@{pname,intname}

xyratio=((Max[Norm/@vexact[[All,;;2]]])/(Max[Norm/@PolyhedronData[intname,"VertexCoordinates"][[All,;;2]]]))//RootReduce//FullSimplify//Quiet

zratio=((Max[vexact[[All,3]]])/(Max[PolyhedronData[intname,"VertexCoordinates"][[All,3]]]))//RootReduce//FullSimplify

{xyratio,xyratio,zratio}

Numerically group

Union[Chop@int[[1]]]//Length

grouped=SplitBy[SortBy[{#,Round[1*^12#]}&/@Chop[int[[1]]],Last],Last][[All,All,1]];

rules=Flatten[Function[l,Rule[#,Mean[l]]&/@l]/@grouped,1];

newi=ConvexHullRegion[DeleteDuplicates[Chop[int[[1]]]/.rules]]

Midsphere[newi]

RecognizeGraph@PolyhedronGraph@newi

lengths=PolyhedronEdgeLengths[newi]

Divide@@MinMax[%lengths]

Round[10^12lengths]/10^12.//Counts

PolyhedronData["PentakisDodecahedron","EdgeLengths"]

Divide@@%//N

RootReduce[PolyhedronEdgeLengths[PolyhedronData["PentakisDodecahedron","Polyhedron"]]]//Counts

newi[[1]]

newi[[2]]

RootApproximant[((newi[[1]])/(Max[PolyhedronEdgeLengths[newi]])),4]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],newi},Boxed->False]

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

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

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhullreg]]//Tally//FullSimplify

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[convexhullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ConvexHullOf

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

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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

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

Divide@@midrs//FullSimplify

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

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

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[0],p},{Red,sphere}},Boxed->False]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p]//RootReduce)//Timing

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

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

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[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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

Construction

{"CubeTenCompound", 1}

cube2={
cube0=
RotateAboutAxis[Polyhedron[Cube],{1,1,1},ArcSin[Sqrt[3/8]]][[1]],
RotateAboutAxis[cube0,{0,1,GoldenRatio},2Pi/5]
};
Show[Graphics3D[cube10={
cube2 ,
RotateAboutAxis[#,{1,GoldenRatio,0},-2Pi/5]&/@cube2,
RotateAboutAxis[#,{1,GoldenRatio,0},-4Pi/5]&/@cube2,
RotateAboutAxis[#,{1,GoldenRatio,0},-6Pi/5]&/@cube2,
RotateAboutAxis[#,{1,GoldenRatio,0},-8Pi/5]&/@cube2
}],Boxed->False]//Timing

<<Simplify`;
Off[$MaxExtraPrecision::"meprec"];

(poly=Map[ToExact,Flatten[cube10],{3}]);//Timing

(v=PolyhedronVertices[poly])//InputForm
First/@poly/.Thread[v->Range[Length[v]]]

Construction figures

Determination of Relative Angle

cube2={
cube0=
RotateAboutAxis[Polyhedron[Cube],{1,1,1},0.6590581421687][[1]],
RotateAboutAxis[cube0,{0,1,GoldenRatio},-2Pi/5]
};
Show[Graphics3D[{
cube2 
}],ViewPoint->{2,0,0}]

v=PolyhedronVertices[cube2]

Show[Graphics3D[{
cube2 ,
PointSize[.02],
MapIndexed[{Point[#1],Text[#2[[1]],#1+{0,0,.07}]}&,v]
}],ViewPoint->{2,0,0}]

intersection3D[Line[l1_List?MatrixQ],Line[l2_List?MatrixQ]]:=Module[{a=-Subtract@@l1,b=-Subtract@@l2,c,axb,axb2},
axb2=#.#&[axb=Cross[a,b]];c=Subtract@@(First/@{l2,l1});Point[l1[[1]]+a Dot[Cross[c,b],axb]/axb2]]/;Dimensions[l1]==Dimensions[l2]=={2,3}

x1=intersection3D[Line[v[[{7,14}]]],Line[v[[{12,11}]]]]

x2=intersection3D[Line[v[[{15,14}]]],Line[v[[{12,16}]]]]

#.#&[First[x1]-v[[14]]]

#.#&[First[x2]-v[[14]]]

Ansatz

Rotation angle corresponds to the front face being cut in an isosceles right triangle

cube2={
cube0=
RotateAboutAxis[Polyhedron[Cube],{1,1,1},a][[1]],
RotateAboutAxis[cube0,{0,1,GoldenRatio},-2Pi/5]
};
s1=cube2 [[1,2,1]];
s2=cube2 [[2,6,1]];

a=.65;

Show[Graphics3D[{
Polygon[s1],
Polygon[s2],
PointSize[.02],
MapIndexed[{Point[#1],Text[#2[[1]],#1+{0,0,.07}]}&,s1],
MapIndexed[{Point[#1],Text[#2[[1]],#1+{0,0,.07},Background->White]}&,s2]
}],ViewPoint->{2,0,0}]

x1=intersection3D[Line[s1[[{3,4}]]],Line[s2[[{3,4}]]]];

x2=intersection3D[Line[s1[[{2,3}]]],Line[s2[[{1,4}]]]];

FindRoot[(#.#&[x1[[1]]-s2[[4]]])==(#.#&[x2[[1]]-s2[[4]]]),{a,.6,.7},WorkingPrecision->50]//Timing

FindRoot[(#.#&[x1[[1]]-s2[[4]]])==(#.#&[x2[[1]]-s2[[4]]]),{a,.6,.7},WorkingPrecision->60]//Timing

<<NumberTheory`Recognize`

eqn=(#.#&[x1[[1]]-s2[[4]]])-(#.#&[x2[[1]]-s2[[4]]]);

eqn2=eqn/.{Sin[a]->q,Cos[a]->Sqrt[1-q^2]};

Sin[0.65905803582640898287283212732302]

FindRoot[eqn2,{q,.7,.8},WorkingPrecision->50]//Timing

Recognize[Sin[0.659058035826408982872832127323020234923195483295357358426774258706197859`60],8,t]

N[Sqrt[3/8],50]

a1=N[ArcSin[Sqrt[3/8]],60]

a2=0.659058035826408982872832127323020234923195483295357358426774258706197859`60;

a1-a2

Construction Figure

cube2={
cube0=
RotateAboutAxis[Polyhedron[Cube],{1,1,1},ArcSin[Sqrt[3/8]]][[1]],
RotateAboutAxis[cube0,{0,1,GoldenRatio},-2Pi/5]
};
s1=cube2 [[1,2,1]];
s2=cube2 [[2,6,1]];
Show[GraphicsArray[
Graphics3D[#,ViewPoint->{2,0,0},Boxed->False]&/@
{
{cube0,cube2},
{Polygon[s1],Polygon[s2]}
}]
]

{"CubeTenCompound", 1} pieces

Off[$MaxExtraPrecision::"meprec"];

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

8+ hours

Timing[Length[lines=Map[Simplify,FaceIntersections[Flatten@Polyhedron[Cube10Compound]],{3}]]]

Timing[Length[lines2=Map[ToExact,lines,{3}]]]

Timing[Length[points=Intersection3D@@@KSubsets[lines2,2]]]

Timing[Length[p=First/@Select[DeleteCases[points,{}],#[[1]].#[[1]]≤1.2&&#[[1,2]]<0&]]]

Timing[Length[p2=Union[Map[ToExact,p,{2}]]]]

Length[p3=Select[p2,#.#≤1&]]//Timing

Show[Graphics3D[{Polyhedron[Cube10Compound],
PointSize[.002],
Point/@N[p3],
MapIndexed[Text[#2[[1]],#1+{0,0,.007},Background->White]&,N[p3]]
}],Boxed->False,ViewPoint->{-0,-1.5,.2}]

q5=p3[[{7,1136,285,1869,648,1393,622,1779,1619,9}]]

r5=Map[ToExact,Polygon2D[q5],{3}][[1]]

r5={{0,0},{0,Root[-9+24 #1+32 ((#1)^2)-64 ((#1)^3)+16 ((#1)^4)&,2]},{Root[9-240 #1+530 ((#1)^2)-400 ((#1)^3)+100 ((#1)^4)&,1],Root[-9+60 #1-110 ((#1)^2)+100 ((#1)^4)&,2]},{Root[1-36 #1+190 ((#1)^2)-288 ((#1)^3)+124 ((#1)^4)&,1],Root[9+12 #1-98 ((#1)^2)-128 ((#1)^3)+124 ((#1)^4)&,3]},{Root[81-576 #1-310 ((#1)^2)+352 ((#1)^3)+4 ((#1)^4)&,3],Root[9+12 #1-218 ((#1)^2)+152 ((#1)^3)+4 ((#1)^4)&,3]},{Root[-9+84 #1-88 ((#1)^2)-24 ((#1)^3)+36 ((#1)^4)&,2],Root[-9+84 #1-88 ((#1)^2)-24 ((#1)^3)+36 ((#1)^4)&,2]},{Root[9+12 #1-218 ((#1)^2)+152 ((#1)^3)+4 ((#1)^4)&,3],Root[81-576 #1-310 ((#1)^2)+352 ((#1)^3)+4 ((#1)^4)&,3]},{Root[9+12 #1-98 ((#1)^2)-128 ((#1)^3)+124 ((#1)^4)&,3],Root[1-36 #1+190 ((#1)^2)-288 ((#1)^3)+124 ((#1)^4)&,1]},{Root[-9+60 #1-110 ((#1)^2)+100 ((#1)^4)&,2],Root[9-240 #1+530 ((#1)^2)-400 ((#1)^3)+100 ((#1)^4)&,1]},{Root[-9+24 #1+32 ((#1)^2)-64 ((#1)^3)+16 ((#1)^4)&,2],0}};

q4=p3[[{815,258,424,883}]]

q4={{Root[1+4 #1-28 ((#1)^2)+16 ((#1)^3)+16 ((#1)^4)&,3],Root[1-4 #1-28 ((#1)^2)-16 ((#1)^3)+16 ((#1)^4)&,1],0},{(1/6) (-1+(Sqrt[10])),(1/6) (-1-(Sqrt[7+3 (Sqrt[5])])),(1/6) (1-(Sqrt[7-3 (Sqrt[5])]))},{(1/4) (1+(Sqrt[13-4 (Sqrt[10])])),-(1/(Sqrt[2])),(1/4) (1-(Sqrt[13-4 (Sqrt[10])]))},{Root[9-12 #1-100 ((#1)^2)+176 ((#1)^3)+16 ((#1)^4)&,3],Root[9-36 #1-20 ((#1)^2)+112 ((#1)^3)+16 ((#1)^4)&,2],0}};

r4=Map[FullSimplify,Polygon2D[q4],{3}][[1]]

r4=Map[FullSimplify,Polygon2D[RotateLeft[q4,1]],{3}][[1]]

r4={{0,0},{0,(1/2) (1+(Sqrt[2])-(Sqrt[5]))},{(1/4) (-8-7 (Sqrt[2])+4 (Sqrt[5])+3 (Sqrt[10])),(1/4) (-8-7 (Sqrt[2])+4 (Sqrt[5])+3 (Sqrt[10]))},{(1/2) (1+(Sqrt[2])-(Sqrt[5])),0}};

q3=p3[[{258,815,830,151,622,1393}]]

r3=Map[ToExact,Polygon2D[q3],{3}][[1]]

r3={{0,0},{0,(1/2) (1-(Sqrt[7-2 (Sqrt[10])]))},{Root[-1+4 #1+20 ((#1)^2)-48 ((#1)^3)+16 ((#1)^4)&,2],Root[9-48 #1-40 ((#1)^2)+64 ((#1)^3)+16 ((#1)^4)&,3]},{(Sqrt[(7/16)-((3 (Sqrt[5]))/16)]),Root[1-8 #1-40 ((#1)^2)+64 ((#1)^3)+64 ((#1)^4)&,3]},{Root[-41+142 #1+65 ((#1)^2)-86 ((#1)^3)+((#1)^4)&,2],Root[-9+60 #1+104 ((#1)^2)-200 ((#1)^3)+4 ((#1)^4)&,2]},{Root[-1+14 #1-37 ((#1)^2)+6 ((#1)^3)+9 ((#1)^4)&,3],0}};

q1=p3[[{1779,622,151}]]

r1=Map[ToExact,Polygon2D[q1],{3}][[1]]

r1={{0,0},{Root[121-1408 #1-70 ((#1)^2)+1304 ((#1)^3)+124 ((#1)^4)&,3],Root[121-1716 #1+1630 ((#1)^2)-408 ((#1)^3)+4 ((#1)^4)&,1]},{Root[1089-3432 #1-10528 ((#1)^2)+3008 ((#1)^3)+1984 ((#1)^4)&,3],0}};

q2=p3[[{151,830,1619,1779}]]

r2=Map[ToExact,Polygon2D[q2],{3}][[1]]

r2={{0,0},{(1/4) (-4+3 (Sqrt[2])),Root[-1+16 #1+14 ((#1)^2)-24 ((#1)^3)+4 ((#1)^4)&,2]},{Root[31+1000 #1-6240 ((#1)^2)+1600 ((#1)^3)+1600 ((#1)^4)&,3],Root[-1+100 #1-190 ((#1)^2)+100 ((#1)^4)&,2]},{Root[1089-3432 #1-10528 ((#1)^2)+3008 ((#1)^3)+1984 ((#1)^4)&,3],0}};

Show[Graphics[{ClosedLine[#]}],AspectRatio->Automatic]&/@{r1,r2,r3,r4,r5}

Show[Graphics[ClosedLine/@(piece1=
Table[RotationMatrix[n Pi/2].#&/@r5,{n,3}]
)],AspectRatio->Automatic]

Show[Graphics[ClosedLine/@(piece2={
r3,
{#[[1]],-#[[2]]}&/@r3,
RotationMatrix[3Pi/2].#&/@r4
})],AspectRatio->Automatic]

Show[Graphics[ClosedLine/@(piece3=
{r2,
{Root[1089-3432 #1-10528 ((#1)^2)+3008 ((#1)^3)+1984 ((#1)^4)&,3]-#[[1]],-#[[2]]}&/@r1
}
)],AspectRatio->Automatic]

Show[Graphics[ClosedLine/@(piece4=
{
{Root[1089-3432 #1-10528 ((#1)^2)+3008 ((#1)^3)+1984 ((#1)^4)&,3]-#[[1]],#[[2]]}&/@r1,
{#[[1]],-#[[2]]}&/@r2
})
],AspectRatio->Automatic]

Show[Graphics[net={
ClosedLine/@piece1,
ClosedLine/@piece2/.Line[x_]:>Line[{3/4-1/8,0}+#&/@x],
ClosedLine/@piece3/.Line[x_]:>Line[{1+1/4,0}+#&/@x],
ClosedLine/@piece4/.Line[x_]:>Line[{1+3/4,0}+#&/@x]
}],AspectRatio->Automatic]

net2=Map[ToExact,Flatten[net],{3}];

v=Union[Flatten[First/@net2,1]];

Drop[First[#],-1]&/@net2/.Thread[v->Range[Length[v]]]

v//InputForm

Show[Graphics[Net[Cube10Compound]],AspectRatio->Automatic]

s=FullSimplify/@RootReduce/@NetEdgeLengths[Cube10Compound]

ColumnForm[sides=RootReduce/@Sort[Union[s],Less]]

FullSimplify[ToRadicals/@sides]//ColumnForm

{3294225-251177850 ((#1)^2)+96805765 ((#1)^4)-9322390 ((#1)^6)+961 ((#1)^8)&[x],
136161-7875936 ((#1)^2)+37141816 ((#1)^4)-12566016 ((#1)^6)+1296 ((#1)^8)&[x]}//TraditionalForm

Length[sides]

sides//N

Show[Graphics[NetDiagram[Cube10Compound]],AspectRatio->Automatic]

FullSimplify[NetSurfaceArea[Cube10Compound]]

RootReduce[%]

N[%]

Ratio of circumradius/longest edge length

rs=FullSimplify/@Sqrt[#.#]&/@PolyhedronVertices[Cube10Compound];

Select[rs,#==Max[rs]&,1]

FullSimplify[(((Sqrt[3])/2)/((1/4) (4-(Sqrt[2])-2 (Sqrt[5])+(Sqrt[10]))))]

N[%]

{"CubeTenCompound", 2} from VertexSubsetCompound[{"DodecahedronTwoCompound", 2},"Cube"]

compound=VertexSubsetCompound[{"DodecahedronTwoCompound",2},"Cube"]

Graphics3D[compound]

(hulls=VertexSubsetHulls[compound,"Platonic"])//Timing

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

{"CubeTenCompound", 3} from VertexSubsetCompound[{"DodecahedronTwoCompound", 3},"Cube"]

compound=VertexSubsetCompound[{"DodecahedronTwoCompound",3},"Cube"]

Graphics3D[compound]

(hulls=VertexSubsetHulls[compound,"Platonic"])//Timing

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

PolyhedronData

PolyhedronDataString

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

WriteString[file,With[
{
base="Cube",
n=10,
facecnt=PolyhedronFaceCount[compound],
ind=3
},
PolyhedronDataString[compound,
"StandardName"->{base<>StringJoin@@(Capitalize/@StringSplit[IntegerName[n],"\[Hyphen]"])<>"Compound",ind},
"AlternateStandardNames"->{},
"Name"->IntegerName[ind,"Ordinal"]<>" "<>ToLowerCase[base]<>" "<>ToString[n]<>"\[Hyphen]compound",
"Information"->base<>ToString[n]<>"-Compound",
"PolyhedronIndices"->"Partition[Range["<>ToString[facecnt]<>"], "<>ToString[facecnt/n]<>"]",
"Classes"->{"Compound"}
]]]

Close[file]