Cube-Octahedron Compound

Author

Eric W. Weisstein
September 29, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Cube-OctahedronCompound.nb.

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

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

Variants

<<MathWorld`Polyhedra`

variants=PolyhedronData["CubeOctahedronCompound*"]

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

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

Polyhedra

GraphicsGrid[Identity[{
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"]},
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
]

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,{"Cube"}}
],
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]

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

Polyhedron

Orientations

PolyhedronData["CubeOctahedronCompound","Orientations"]

PolyhedronData["CubeOctahedronCompound"]

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

Polyhedron

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

Region

PolyhedronData["CubeOctahedronCompound","Region"]

Solid and dual

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

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

Properties

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="CubeOctahedronCompound","Polyhedron"]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Classes

PolyhedronData[pname,"Classes"]

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

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

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

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[convexhull=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhull]

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

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]//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[Pi/4,{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"]]]}

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]

EdgeLengths

PolyhedronData["CubeOctahedronCompound","EdgeLengths"]

PolyhedronData["CubeOctahedronCompound","Lines"]/.Line[{l__}]:>EuclideanDistance[l]//FullSimplify//Union

Hull

PolyhedronData["CubeOctahedronCompound","Hull","Name"]

((Max[Norm/@PolyhedronData["CubeOctahedronCompound","VertexCoordinates"]])/(Max[Norm/@PolyhedronData[{"CuboctahedronStellation",1},"VertexCoordinates"]]))//FullSimplify

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

With[{p="CubeOctahedronCompound"},{
Graphics3D[{Opacity[.3],Red,PolyhedronData[p,"Polyhedron"]},Axes->True],
Graphics3D[{Opacity[.3],Green,PolyhedronData[p,"Hull","Polyhedron"]},Axes->True]
}]

Show[%]

SurfaceArea

PolyhedronData["CubeOctahedronCompound","SurfaceArea"]

Total[SurfaceArea/@PolyhedronData["CubeOctahedronCompound","Polyhedra"]]

VertexSubsetHulls

VertexSubsetHulls[p,"Platonic"]

Volume

Points of Intersection

WriteLiveForm["cuboctdi.m",
Show[NonIntersectingPolygons[Graphics3D[{CubePlusOctahedron[[1]],{PointSize[.03],CubeOctahedronPoints}},
	opts]]]
]//Timing

Interior

<<Graphics`InequalityGraphics`

ineqs=Flatten[PolyhedronInequalities[Polyhedron[CubeOctahedronCompound],{x,y,z}]]

InequalityPlot3D[ineqs,{x},{y},{z},Boxed->False,Axes->False]

poly=PolyhedronFromInequalities[ineqs,{x,y,z}];

gr=Show[Graphics3D[{
Wireframe[Polyhedron[CubeOctahedronCompound]],
poly,
PointSize[.03],Point/@PolyhedronVertices[poly]
}],Boxed->False]

WriteLiveForm["cuboctco.m",gr]

Rhombic Dodecahedron

v=PolyhedronVertices[RhombicDodecahedron];

lines=Map[Line[v[[#]]]&,Transpose[Partition[#,2]]&/@PolyhedronFaces[RhombicDodecahedron],{2}];

points=Apply[Point[Midpoint[#]]&,lines,{2}];

gr=Show[Graphics3D[{Polyhedron[RhombicDodecahedron],lines,
PointSize[.04],points}],Boxed->False]

WriteLiveForm["rhomdodi.m",gr]

Construction

MidpointCumulate[Polyhedron[Cube],1/2];

Show[Graphics3D[CubeOctahedronCompound],Boxed->False]

Show[Graphics3D[poly=Flatten[{Polyhedron[Cube],Dual/@Polyhedron[Cube]}]],Boxed->False]

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

Net construction

v=PolyhedronVertices[CubeOctahedronCompound,Split->True];

Show[Graphics3D[{Polyhedron[CubeOctahedronCompound,Split->True],
PointSize[.002],
Point/@N[v],
MapIndexed[Text[#2[[1]],#1+{0,0,.007},Background->White]&,N[v]]
}],Boxed->False]

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

q1=v[[{12,14,22}]]

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

r1={{0,0},{(1/(2 (Sqrt[2]))),((Sqrt[(3/2)])/2)},{(1/(Sqrt[2])),0}};

q2=v[[{20,19,12}]]

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

r2={{0,0},{0,(1/2)},{(1/2),0}};

Sqrt[#.#]&[Subtract@@r1[[#]]]&/@{{1,2},{1,3},{2,3}}

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

Show[Graphics[piece2={
ClosedLine/@Table[RotationMatrix[n Pi/2+5Pi/4].#&/@r2,{n,-2,0}]
}],AspectRatio->Automatic]

Show[Graphics[net=
{piece1,
piece2/.Line[x_]:>Line[{3/2,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

<<Platonic`

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

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

sides=Sort[Union[s],Less]

sides//N

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

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