Cube 2-Compound

Author

Eric W. Weisstein
September 25, 2023

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

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

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

Rotation of a Cube WRT to another along a (Subscript[C, 3]) axis

movie=Table[
Show[Graphics3D[{
Polyhedron[Cube],
RotateAboutAxis[Polyhedron[Cube],{1,1,1},θ],
Thickness[.02],Line[{{-1,-1,1},{1,-1,1}}/2],
Line[RotateAboutAxis[#,{1,1,1},θ]&/@({{1,-1,-1},{1,-1,1}}/2)]
}],Boxed->False,PlotRange->Table[{-1,1},{3}].9],{θ,0,2Pi/3-2Pi/3/20,2Pi/3/20}]

Show[GraphicsArray[Take[movie,{1,20,3}]],GraphicsSpacing->-.15,ImageSize->400]

<<GIF`;

Export[gifs<>"cuberot3.gif",movie]//Timing

Point of Intersection

{x1,x2}={{-1,-1,1},{1,-1,1}}/2

{x3,x4}=RotateAboutAxis[#,{1,1,1},α]&/@({{1,-1,-1},{1,-1,1}}/2)

a=x2-x1;
b=x4-x3;
c=x3-x1;

FullSimplify[c.Cross[a,b]]

FullSimplify[x1+a Dot[Cross[c,b],Cross[a,b]]/#.#&@Cross[a,b]]

x[α_]:=-((-12 Cos[α]+3 Cos[2 α]+(Sqrt[3]) (4 Sin[α]+Sin[2 α]))/(2 (6+2 Cos[α]+Cos[2 α]-2 (Sqrt[3]) (-1+Cos[α]) Sin[α])))

-Expand[-12 Cos[α]+3 Cos[2 α]+(Sqrt[3]) (4 Sin[α]+Sin[2 α])]/Expand[2 (6+2 Cos[α]+Cos[2 α]-2 (Sqrt[3]) (-1+Cos[α]) Sin[α])]

x[Pi/3]

Limit[x[α],α->#]&/@{0,2Pi/3}

Plot[x[α],{α,0,2π/3},PlotStyle->Red]

Show[Graphics3D[{
Polyhedron[Cube],
RotateAboutAxis[Polyhedron[Cube],{1,1,1},0.6590581421687],
Thickness[.02],Line[{{-1,-1,1},{1,-1,1}}/2],
Line[RotateAboutAxis[#,{1,1,1},0.6590581421687]&/@({{1,-1,-1},{1,-1,1}}/2)]
}],Boxed->False,PlotRange->Table[{-1,1},{3}].9]

Show[Graphics3D[{
Polyhedron[Cube],
RotateAboutAxis[Polyhedron[Cube],{1,1,1},0.38813],
Thickness[.02],Line[{{-1,-1,1},{1,-1,1}}/2],
Line[RotateAboutAxis[#,{1,1,1},0.38813]&/@({{1,-1,-1},{1,-1,1}}/2)]
}],Boxed->False,PlotRange->Table[{-1,1},{3}].9]

x[0.38813]

FindRoot[1/2-x[α]==1/3,{α,.6}]

1/2-x[0.666946322213381]

0.38813

q=x[0.6590581421687]

1/2-q

1/2+q

(1/2-q)/(1/2+q)

Variants

variants=PolyhedronData["CubeTwoCompound*"]

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

Solids and duals

GraphicsGrid[Table[With[{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
style=Directive[Black,Italic,FontFamily->"Times",14],
dname=PolyhedronData[pname,"Dual","Name"]
},
{
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]

Intersection 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[1],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]

TextGrid[
Prepend[
Table[{
pname,
RecognizeGraph@PolyhedronGraph@PolyhedronData[pname,"CompoundInterior","Polyhedron"],
PolyhedronData[pname,"CompoundInterior","Volume"],
RecognizeGraph@PolyhedronGraph@PolyhedronData[pname,"ConvexHull","Polyhedron"],
PolyhedronData[pname,"ConvexHull","Volume"]
},
{pname,variants}],
Thread[Style[{"compound","interior","interior volume","convex hull","convex hull volume"},Bold]]],
Dividers->All]

Polyhedron: {"CubeTwoCompound", 1}

Orientations

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

PolyhedronData[{"CubeTwoCompound",1},"DefaultOrientation"]

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

Polyhedron

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

Face orientation

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

Region

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

Solid and dual

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

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

Polyhedron: {"CubeTwoCompound", 2}

Orientations

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

PolyhedronData[{"CubeTwoCompound",2},"DefaultOrientation"]

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

Polyhedron

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

Face orientation

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

Region

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

Solid and dual

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

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

Properties: {"CubeTwoCompound", 1}

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

PolyhedronData[{"CubeTwoCompound",1},"AdjacentFaceIndices"]

AdjacentFaceIndices[p]===%

Beveled

Graphics3D[Bevel[p,.07],Boxed->False]

Circumsphere

s=PolyhedronData[{"CubeTwoCompound",1},"Circumsphere"]

Norm/@PolyhedronData[{"CubeTwoCompound",1},"VertexCoordinates"]//Union

Graphics3D[{p,Opacity[.2],s}]

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],PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

Construction

pname

int=RegionIntersection@@(PolyhedronData[pname,"Polyhedra"])

Graphics3D[int]

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

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

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

Length@%

inthull=ConvexHullRegion[Union@vexact]

faces=inthull[[2]]

intp=Polyhedron[vexact,faces]

PolyhedronData[pname,"CompoundInterior"]

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}

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

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

Show[%]

Construct using ConvexHullRegion

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

v=PolyhedronCoordinates[convexhullreg]

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

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

DihedralAngles

PolyhedronData[{"CubeTwoCompound",1},"DihedralAngles"]

%==DihedralAngles[p]

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]

Net

PolyhedronData[{"CubeTwoCompound",1},"Net"]

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

RegionFunction

PolyhedronData[{"CubeTwoCompound",1},"RegionFunction"]

Skeleton

g=PolyhedronData[{"CubeTwoCompound",1},"Skeleton"]

r=RecognizeGraph[g]

PolyhedronData[{"CubeTwoCompound",1},"Skeleton","Name"]

SurfaceArea

PolyhedronData[{"CubeTwoCompound",1},"SurfaceArea"]

PolyhedronSurfaceArea[p]//FullSimplify

VertexSubsetHulls

pname

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[{"CubeTwoCompound",1},"Volume"]

Properties: {"CubeTwoCompound", 2}

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

PolyhedronData[{"CubeTwoCompound",2},"AdjacentFaceIndices"]

AdjacentFaceIndices[p]===%2

Circumsphere

s=PolyhedronData[{"CubeTwoCompound",2},"Circumsphere"]

Norm/@PolyhedronData[{"CubeTwoCompound",2},"VertexCoordinates"]//Union

Graphics3D[{p,Opacity[.2],s}]

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],PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

Construction

int=RegionIntersection@@(PolyhedronData[pname,"Polyhedra"])

Graphics3D[int]

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

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

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

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

faces=inthull[[2]]

intname={"Prism",8};

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}

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

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

Show[%]

Construct using ConvexHullRegion

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

v=PolyhedronCoordinates[convexhullreg]

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

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

DihedralAngles

PolyhedronData[{"CubeTwoCompound",2},"DihedralAngles"]

%==DihedralAngles[p]

Length[%]

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]

Hull

((Max[PolyhedronData[{"CubeTwoCompound",2},"VertexCoordinates"][[All,-1]]])/(Max[PolyhedronData[{"Prism",{8,2}},"VertexCoordinates"][[All,-1]]]))//FullSimplify

((Max[PolyhedronData[{"CubeTwoCompound",2},"VertexCoordinates"][[All,1]]])/(Max[PolyhedronData[{"Prism",{8,2}},"VertexCoordinates"][[All,1]]]))//FullSimplify

PolyhedronData[{"CubeTwoCompound",2},"Hull",#]&/@{"Name","Scale"}

PolyhedronData[{"CubeTwoCompound",2},"Hull","Polyhedron"]

With[{p={"CubeTwoCompound",2}},{
Graphics3D[{Red,PolyhedronData[p,"Polyhedron"]},Axes->True],
Graphics3D[{Green,PolyhedronData[p,"Hull","Polyhedron"]},Axes->True]
}]

Graphics3D[{Opacity[.5],First/@%}]

Net

PolyhedronData[{"CubeTwoCompound",2},"Net"]

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

RegionFunction

PolyhedronData[{"CubeTwoCompound",2},"RegionFunction"]

Skeleton

g=PolyhedronData[{"CubeTwoCompound",2},"Skeleton"]

r=RecognizeGraph[g]

GraphData[r,"Graph","All"]

ToCommonEdges[GraphData[r],g]

SurfaceArea

PolyhedronData[{"CubeTwoCompound",2},"SurfaceArea"]

PolyhedronSurfaceArea[p]//FullSimplify

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[{"CubeTwoCompound",2},"Volume"]

Properties: {"CubeTwoCompound", 3}

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

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[.3],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]

GraphData[gname,"PolyhedralEmbeddings"]

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

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

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

Show[%]

Construct using ConvexHullRegion

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

v=PolyhedronCoordinates[convexhullreg]

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

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

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

Map[ToAlgebraicRoot,i,{2}]

PolyhedronInertiaTensor[p]//Timing

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

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

sphere=MyInsphere[p]

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

Midsphere[N[p,50]]

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

(sphere=Midsphere[p])//Timing

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

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

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

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

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

RenameGraphFiles[]

pname

With[{verts=PolyhedronData[pname,"Vertices"],faces=PolyhedronData[pname,"Faces","List"]},
ToCommonEdges[GraphData[gn],Graph[Range[Length[verts]],UndirectedEdge@@@Union[Sort/@Flatten[Partition[#,2,1,1]&/@faces,1]]]]]//Chop[#,1*^-5]&//N

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

pname

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

{"CubeTwoCompound", 1}: rotation about C3 axis

cube=PolyhedronData[{"Cube","C3"},"Polyhedron"]

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

{"CubeTwoCompound", 1} pieces

Off[N::"meprec"]

Timing[Length[f=FaceIntersections[Flatten[Polyhedron[Cube2Compound,"C3"]]]]]

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

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

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

Show[Graphics3D[{Polyhedron[Cube2Compound,"C3"],
PointSize[.02],
Point/@p,
MapIndexed[Text[#2[[1]],#1+{0,0,.05},Background->White]&,p]
}],Boxed->False,PlotRange->All,ViewPoint->{0,-2,0}]

p1=p[[{292,282,241}]];
p2=p[[{292,295,241}]];

ps=Map[ToExact,Polygon2D/@{p1,p2},{3}]

Show[Graphics[piece=ClosedLine@@@{
ps[[1]],
Map[{-#[[1]],#[[2]]}&,ps[[1]],{2}],
Map[-#&,ps[[2]],{2}]
}],AspectRatio->Automatic]

net=piece

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

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

Show[Graphics[NetDiagram[Cube2Compound,"C3"]],AspectRatio->Automatic,
PlotRange->All,PlotLabel->StyleForm["12×",FontSize->18,FontFamily->"Times"]]

Sort[Union[NetEdgeLengths[Cube2Compound,"C3"]],Less]

NetSurfaceArea[Cube2Compound,"C3"]//Simplify

PolyhedronEdgeLengths[Polyhedron[Cube2Compound,"C3"]]//Simplify

{"CubeTwoCompound", 2}

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

f=PolyhedronData["Cube","FaceIndices"]

vnew=Join[v,RotationMatrix[π/4,{0,0,1}].#&/@v]

SmallestRotation[l_]:=Sort[NestList[RotateRight,l,Length[l]-1]][[1]]

fnew=SmallestRotation/@Join[Sort[f],Sort[f+8]]

p=Polyhedron[vnew,fnew]

Graphics3D[{FaceForm[Green,Red],p}]

{"CubeTwoCompound", 3}: rotation about C2 axis

cube=PolyhedronData[{"Cube","C2"},"Polyhedron"]

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

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

f=Join[cube[[2]],8+cube[[2]]]

Graphics3D[compound=Polyhedron[v,f]]

PolyhedronData

PolyhedronDataString

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

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