Dodecahedron 6-Compound

Author

Eric W. Weisstein
October 6, 2023

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

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

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

Variants

variants=PolyhedronData["DodecahedronSixCompound*"]

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

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[.005]],PolyhedronData[pname,"ConvexHull","Polyhedron"]}},PlotLabel->Style["convex hull",style],Boxed->False]
},
{pname,variants}]
],
Dividers->All,ImageSize->700]

Polyhedron: {"DodecahedronSixCompound", 1}

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

PolyhedronData[{"DodecahedronSixCompound",1}]

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

Polyhedron

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

Region

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

Solid and Dual

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

Polyhedron: {"DodecahedronSixCompound", 2}

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

Show[PolyhedronData[{"DodecahedronSixCompound",2}],Boxed->False]

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

Polyhedron

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

Region

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

Solid and Dual

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

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

Properties: {"DodecahedronSixCompound", 1}

Initialization

<<MathWorld`Polyhedra`

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

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

(sphere=Circumsphere[p])//Timing

(sphere=MyCircumsphere[p]//FullSimplify)//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[.1],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[.1],p},Red,int},Boxed->False]

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]

RecognizeGraph@PolyhedronGraph@newi

lengths=PolyhedronEdgeLengths[newi]

Divide@@MinMax[%lengths]

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

newi[[1]]

Sort[newi[[2]]]

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

Exactify: RootApproximant

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

Length[vexact]

Exactify: ToAlgebraicRoot

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

Length[vexact]

Plane intersections numerically

polygons=PolyhedronData[pname,"Polygons"]

Length@polygons

Binomial[%,3]

Length[nintersections=ThreePlaneIntersection/@Subsets[N[polygons,20],{3}]]//Timing

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

normineqs[l_,dx_:.0001]:=Function[Evaluate[Or@@(Function[f,f-dx<=Norm[#]<=f+dx]/@l)]]

Length[pos=Position[nintersections,Point[x_]/;normineqs[groupednorms][x]]//Flatten]//Quiet//Timing

Length[intersections=ThreePlaneIntersection/@Subsets[polygons,{3}][[pos]]]//Timing

Length[pts=Cases[intersections,Point[x_]:>Flatten[x]]]

Graphics3D[{AbsolutePointSize[5],Point[N[pts]],Opacity[.2],p}]

Length[pts2=DeleteDuplicates[Map[ToAlgebraicRoot,pts,{2}]]]//Quiet//Timing

Graphics3D[{AbsolutePointSize[5],Point[pts2],{Opacity[.2],p},Red,ConvexHullRegion[pts2]}]

vexact=pts2

Exact interior

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=Sort[inthull[[2]]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

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

lengths=Keys[%]

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

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

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

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

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

PolyhedronData[pname,"ConvexHull"]

convexhull=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]//Tally//Quiet//Timing

v=PolyhedronCoordinates[convexhull]

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

Graphics3D[{FaceForm[Green,Red],convexhull,MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

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

Show[%]

Graphics3D[{p,MapIndexed[Text[#2[[1]],#,Background->White]&,p[[1]]]}]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

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

ToConwayBasis[dehn]

DihedralAngles

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

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p],"Simplification"->RootReduce]//FullSimplify)//Tally

dih1===dih2

Dual

pname

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

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

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

Divide@@midrs//FullSimplify

N[%]

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]//Timing

sphere=MyInsphere[p//N[#,50]&]

RootApproximant[%[[2]]]//FullSimplify

N[%,20]

(sphere=MyInsphere[p])//Timing

Graphics3D[{{Opacity[.5],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])//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"]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

l={{"SixDodecahedra",{0,{{"DodecahedronSixCompound",1}}}}};

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

RenameGraphFiles[]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Length[Lookup[subsethulls,#]]&/@subsethulls[[All,1]]

Rule[#,Graphics3D[ConvexHullRegion[v[[#]]]&/@Lookup[subsethulls,#]]]&/@subsethulls[[All,1]]

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

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

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//Timing

PolyhedronVolume[p]//Timing

Volume[PolyhedronData[pname,"Region"]]

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Properties: {"DodecahedronSixCompound", 2}

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

(sphere=Circumsphere[p])//Timing

(sphere=MyCircumsphere[p]//FullSimplify)//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[.1],p},Red,interior},Boxed->False]

MyCircumsphere[interior]//Quiet

Insphere[interior//N]//Quiet

Midsphere[interior//N]

Construction

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

Graphics3D[int]

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

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]

RecognizeGraph@PolyhedronGraph@newi

lengths=PolyhedronEdgeLengths[newi]

Divide@@MinMax[%lengths]

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

newi[[1]]

Sort[newi[[2]]]

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

Exactify: RootApproximant

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

Length[vexact]

Exactify: ToAlgebraicRoot

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

Length[vexact]

Plane intersections numerically

polygons=PolyhedronData[pname,"Polygons"]

Length@polygons

Binomial[%,3]

Length[nintersections=ThreePlaneIntersection/@Subsets[N[polygons,20],{3}]]//Timing

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

normineqs[l_,dx_:.0001]:=Function[Evaluate[Or@@(Function[f,f-dx<=Norm[#]<=f+dx]/@l)]]

Length[pos=Position[nintersections,Point[x_]/;normineqs[groupednorms][x]]//Flatten]//Quiet//Timing

Length[intersections=ThreePlaneIntersection/@Subsets[polygons,{3}][[pos]]]//Timing

Length[pts=Cases[intersections,Point[x_]:>Flatten[x]]]

Graphics3D[{AbsolutePointSize[5],Point[N[pts]],Opacity[.2],p}]

Length[pts2=DeleteDuplicates[Map[ToAlgebraicRoot,pts,{2}]]]//Quiet//Timing

Graphics3D[{AbsolutePointSize[5],Point[pts2],{Opacity[.2],p},Red,ConvexHullRegion[pts2]}]

vexact=pts2

Exact interior

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=Sort[inthull[[2]]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

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

lengths=Keys[%]

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

pname

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

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

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

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

PolyhedronData[pname,"ConvexHull"]

convexhull=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]//Tally//Quiet//Timing

v=PolyhedronCoordinates[convexhull]

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

Graphics3D[{FaceForm[Green,Red],convexhull,MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

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

Show[%]

Graphics3D[{p,MapIndexed[Text[#2[[1]],#,Background->White]&,p[[1]]]}]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

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

ToConwayBasis[dehn]

DihedralAngles

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

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p],"Simplification"->RootReduce]//FullSimplify)//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=Tally[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[%]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]//Timing

sphere=MyInsphere[p//N[#,50]&]

RootApproximant[%[[2]]]//FullSimplify

N[%,20]

(sphere=MyInsphere[p])//Timing

Graphics3D[{{Opacity[.2],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])//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"]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

l={{"SixDodecahedra",{0,{{"DodecahedronSixCompound",1}}}}};

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

RenameGraphFiles[]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Length[Lookup[subsethulls,#]]&/@subsethulls[[All,1]]

Rule[#,Graphics3D[ConvexHullRegion[v[[#]]]&/@Lookup[subsethulls,#]]]&/@subsethulls[[All,1]]

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

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

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//Timing

PolyhedronVolume[p]//Timing

Volume[PolyhedronData[pname,"Region"]]

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Construction

{"DodecahedronSixCompound", 1}: OppositeFaceRotationCompound[dodecahedron]

(compound=OppositeFaceRotationCompound[PolyhedronData["Dodecahedron","Polyhedron"],"Simplification"->RootReduce])//Timing//Quiet

Graphics3D[compound]

{"DodecahedronSixCompound", 1} pieces

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

poly=Map[ToExact,Flatten[PolyhedronRotationCompound[Polyhedron[Dodecahedron],5][[{1,3,4,5,6,7}]]],{3}];

Partition[Range[12 6],12]

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

<<Combinatorica`

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

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

Timing[Length[f=FaceIntersections[Flatten[Polyhedron[Dodecahedron6Compound]]]]]

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

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

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

Timing[Length[p2=Select[p,#[[2]]<-.5&]]]

Show[Graphics3D[{Polyhedron[Dodecahedron6Compound],
PointSize[.01],
Point/@p2//N,
MapIndexed[Text[#2[[1]],#1+{0,0,.05},Background->White]&,p2//N]
}],Boxed->False,ViewPoint->{0,-2,0}]

q1=ToExact/@p2[[{4333,4360,1814,6544,6959}]]

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

q2=ToExact/@p2[[{4359,4360,4333}]]

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

q3=ToExact/@p2[[{6544,1814,2522,2534,727}]]

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

q4=ToExact/@p2[[{6959,6544,727}]]

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

q5=ToExact/@p2[[{4360,5917,3386}]]

q6=ToExact/@p2[[{1814,4360,3386,2522}]]

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

r6=Map[ToExact,Polygon2D[q6],{3}][[1]]

Show[Graphics[piece1=ClosedLine/@{r6[[2]]-r6[[1]]+#&/@r5,r6}],AspectRatio->Automatic]

Show[Graphics[piece2=ClosedLine/@{rr1=RotationMatrix[Pi/2].#&/@r1,
{-#[[1]],#[[2]]}&/@(RotationMatrix[Pi/2].#&/@r1),
{-#[[1]],#[[2]]}&@(rr1[[2]]-rr1[[1]])+RotationMatrix[ArcTan@@(rr1[[2]]-rr1[[1]])].#&/@r2
}],AspectRatio->Automatic,PlotRange->All]

Show[Graphics[piece3=ClosedLine/@{
rr4=RotationMatrix[-Pi/2].#&/@r4,
{-#[[1]],#[[2]]}&/@rr4,
(rr4[[2]]-rr4[[1]])+#&/@(RotationMatrix[-ArcTan@@(rr4[[3]]-rr4[[2]])].#&/@r3)
}],AspectRatio->Automatic,PlotRange->All]

Show[Graphics[net={piece1,
piece2/.Line[x_]:>Line[{1,1/4}+#&/@x],
piece3/.Line[x_]:>Line[{2,-1/4}+#&/@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

<<Platonic`

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

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

<<Simplify`

s=SqrtSimplify/@ToExact/@NetEdgeLengths[Dodecahedron6Compound]

sides=Sort[Union[s],Less]

sides//N

lengths=Sort[Transpose[{s/.Thread[sides->Range[Length[sides]]],NetEdges[Dodecahedron6Compound]}]]

NetSurfaceArea[Dodecahedron6Compound]//FullSimplify

N[%]

{"DodecahedronSixCompound", 2}: from {"CubeTwentyCompound", 1} [same appearance as "Dodecahedron5Compound"]

dodec=PolyhedronData[{"Dodecahedron","C3"},"Polyhedron"]

θ=FullSimplify[ArcCos[Sqrt[2/15(5+Sqrt[5])]]]

Graphics3D[{PolyhedronData["Dodecahedron","Polyhedron"],Table[Polyhedron[RotationMatrix[2Pi i/5,{0,0,1}].RotationMatrix[θ,{0,1,0}].#&/@dodec[[1]],dodec[[2]]],{i,0,4}]}]

Graphics3D[VertexSubsetCompound[{"CubeTwentyCompound",1},"Dodecahedron"]]

{"DodecahedronSixCompound", 3}: rotation about C5 axis [not added]

dodec=PolyhedronData[{"Dodecahedron","C5"},"Polyhedron"]

Graphics3D[{compound0=Table[Polyhedron[RotationMatrix[2Pi/5 i/5,{0,0,1}].#&/@dodec[[1]],dodec[[2]]],{i,0,5}]}]

PolyhedronData[{"Dodecahedron","C5"},"V"]

v=Join@@compound0[[All,1]]

f=Flatten[Table[20i+dodec[[2]],{i,0,5}],1]

Graphics3D[compound=Polyhedron[v,f]]

{"DodecahedronSixCompound", 4}: rotation about C3 axis [not added]

dodec=PolyhedronData[{"Dodecahedron","C3"},"Polyhedron"]

Graphics3D[{Table[Polyhedron[RotationMatrix[2Pi/3 i/6,{0,0,1}].#&/@dodec[[1]],dodec[[2]]],{i,0,5}]}]

{"DodecahedronSixCompound", 5}: rotation about C2 axis [not added]

dodec=PolyhedronData[{"Dodecahedron","C2"},"Polyhedron"]

Graphics3D[{Table[Polyhedron[RotationMatrix[Pi i/6,{0,0,1}].#&/@dodec[[1]],dodec[[2]]],{i,0,5}]}]

{"DodecahedronSixCompound", 6}: rotation about C3 axis + base dodecahedron [not added]

dodec=PolyhedronData[{"Dodecahedron","C3"},"Polyhedron"]

Graphics3D[{PolyhedronData["Dodecahedron","Polyhedron"],Table[Polyhedron[RotationMatrix[2Pi/3 i/5,{0,0,1}].#&/@dodec[[1]],dodec[[2]]],{i,0,4}]}]

{"DodecahedronSixCompound", 7}: rotation about C2 axis + base dodecahedron [not added]

dodec=PolyhedronData[{"Dodecahedron","C2"},"Polyhedron"]

Graphics3D[{PolyhedronData["Dodecahedron","Polyhedron"],Table[Polyhedron[RotationMatrix[Pi i/5,{0,0,1}].#&/@dodec[[1]],dodec[[2]]],{i,0,4}]}]

PolyhedronData

PolyhedronDataString

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

WriteString[file,With[
{
base="Dodecahedron",
n=6,
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]