Cuboctahedron Stellations

Author

Eric W. Weisstein
November 13, 2024

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

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

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

Table

TextGrid[
stellations=Cases[
{#,PolyhedronData[#,"NotationRules","Stellation"]}&/@PolyhedronData[All],
{_,{"Cuboctahedron",_}}],
Dividers->All]

Solid

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

PolyhedronData[{"CuboctahedronStellation",1}]

{p1=PolyhedronData["Cuboctahedron"],p2=PolyhedronData[{"CuboctahedronStellation",1}]}

Graphics3D[{Opacity[.2],
{Green,PolyhedronData["Cuboctahedron","GraphicsComplex"]},{Blue,PolyhedronData[{"CuboctahedronStellation",1},"GraphicsComplex"]}}]

Manipulate[AugmentedPolyhedron[PolyhedronData["Cuboctahedron","Polyhedron"],x]//Graphics3D,{x,0,2}]

Graphics3D/@Table[AugmentedPolyhedron[PolyhedronData["Cuboctahedron","Polyhedron"],x],{x,-1.5,1.5,.5}]

Diagram

Construction

pname="Cuboctahedron";

PolyhedronData[pname,"Orientations"]

Graphics3D[{PolyhedronData[pname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,PolyhedronData[pname,"Vertices"]]}]

Length[faces=PolyhedronData[pname,"Polygons"][[All,1]]]

planes=Take[#,3]&/@faces;

Graphics3D[
{
{Opacity[.7],PolyhedronData[pname,"Polyhedron"]},
DiscretizeRegion[RegionIntersection[Sphere[{0,0,0},3],InfinitePlane[#]],MeshCellStyle->0->None]&/@planes
},
Boxed->False]

Graphics3D[{{Red,PolyhedronData[pname,"Polyhedron"]},Opacity[.3],DiscretizeRegion[RegionIntersection[Ball[{0,0,0},3],InfinitePlane[#]],MeshCellStyle->1->None]&/@planes},Boxed->False]

Triangular face

faces[[-1]]//Length

Length[lines3D=
DeleteCases[
With[{planeindx=-1},
RegionIntersection[InfinitePlane[planes[[planeindx]]],InfinitePlane[#]]&/@Drop[planes,{planeindx}]],
_EmptyRegion
]//RootReduce//FullSimplify]//Timing

Graphics3D[{Red,#},PlotRange->2]&/@lines3D

Show[%]

Binomial[Length@lines3D,2]

indx=Subsets[Range@Length@lines3D,{2}];
Length[intersections3D=Cases[{#,FullSimplify@RootReduce[RegionIntersection@@lines3D[[#]]]}&/@indx,{i_,Point[p_]}:>{i,p}]]//Timing

Length[pts3D=intersections3D[[All,2]]//Union]

indexedintersections=intersections3D/.Thread[pts3D->Range[Length[pts3D]]]

clines=Table[Union@Select[indexedintersections,MemberQ[#[[1]],i]&][[All,-1]],{i,Length[lines3D]}]

longestlines=OrderedPointsOnLineSegment[pts3D,#]&/@clines

Graphics3D[{
Thickness[.005],lines3D,
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[pts3D[[#[[{1,-1}]]]]],Background->White]&,longestlines]},
{Red,Sphere[pts3D,.2]}
},
PlotRange->3,ImageSize->Medium,ViewPoint->{0,0,2}
]

norm=(Sqrt[3])Normalize[Cross[pts3D[[1]]-pts3D[[2]],pts3D[[3]]-pts3D[[2]]]]

v3D=RotationMatrix[{norm,{0,0,1}}].#&/@pts3D

Equal@@v3D[[All,-1]]

v2D=Most/@v3D

v=v2D;

Clear[text]

text[text_,indx_,style___]:=Module[{p=Mean[v[[indx]]]},
Style[If[p=={0.,0.},Text[text,p],Table[Text[text,RotationMatrix[2Pi i/4].p],{i,0,3}]],Directive[style]]]

Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[v[[#]]],Background->White]&,longestlines]},
{Red,PointSize[.015],Point[v]},
Blue,MapIndexed[Text[#2[[1]],#,{0,-1.3},Background->White]&,v]
},BaseStyle->Directive[FontFamily->"Times",16,Bold]]

diagram1=Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Red,PointSize[.015],Point[v]}
},
BaseStyle->Directive[FontFamily->"Times",16,Bold]]

Square face

faces[[2]]//Length

Length[lines3D=
DeleteCases[
With[{planeindx=2},
RegionIntersection[InfinitePlane[planes[[planeindx]]],InfinitePlane[#]]&/@Drop[planes,{planeindx}]],
_EmptyRegion
]//RootReduce//FullSimplify]//Timing

Graphics3D[{Red,#},PlotRange->2]&/@lines3D

Show[%]

Binomial[Length@lines3D,2]

indx=Subsets[Range@Length@lines3D,{2}];
Length[intersections3D=Cases[{#,FullSimplify@RootReduce[RegionIntersection@@lines3D[[#]]]}&/@indx,{i_,Point[p_]}:>{i,p}]]//Timing

Length[pts3D=intersections3D[[All,2]]//Union]

radius=Max[Norm[Most[#]]&/@pts3D]//FullSimplify//Quiet

N[%]

Equal@@(#[[-1]]&/@pts3D)

indexedintersections=intersections3D/.Thread[pts3D->Range[Length[pts3D]]]

clines=Table[Union@Select[indexedintersections,MemberQ[#[[1]],i]&][[All,-1]],{i,Length[lines3D]}]

longestlines=OrderedPointsOnLineSegment[pts3D,#]&/@clines

Graphics3D[{
Thickness[.005],lines3D,
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[pts3D[[#[[{1,-1}]]]]],Background->White]&,longestlines]},
{Red,Sphere[pts3D,.15 #/2.5]}
},
PlotRange->#,ImageSize->Medium,ViewPoint->{0,0,2}
]&/@{2.7,5}

v=RotationMatrix[Pi/4].#&/@(Most/@pts3D);

Max[Norm/@v]//FullSimplify//Quiet

N[%]

Clear[text]

text[text_,indx_,style___]:=Module[{p=Mean[v[[indx]]]},
Style[If[p=={0.,0.},Text[text,p],Table[Text[text,RotationMatrix[2Pi i/4].p],{i,0,3}]],Directive[style]]]

Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[v[[#]]],Background->White]&,longestlines]},
{Red,PointSize[.015],Point[v]},
Blue,MapIndexed[Text[#2[[1]],#,{0,-1.3},Background->White]&,v]
},BaseStyle->Directive[FontFamily->"Times",16,Bold]]

diagram2=Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Red,PointSize[.015],Point[v]}
},
BaseStyle->Directive[FontFamily->"Times",16,Bold]]

Figures

PolyhedronData["Cuboctahedron","Orientations"]

Triangular face

GraphicsGrid[Partition[StellationFigure[PolyhedronData[{"Cuboctahedron","C3"},"Polyhedron"]],3]]

Square face

GraphicsGrid[Partition[StellationFigure[PolyhedronData[{"Cuboctahedron","C4"},"Polyhedron"]],3]]

Both

GraphicsRow[
{
Show[diagram1,PlotLabel->"triangular face"],
Show[diagram2,PlotLabel->"square face"]
},
BaseStyle->Directive[FontFamily->Times,Italic,14]]

Configurations

Triangular face

v={{-(5/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)},{-2,(2/(Sqrt[3]))},{-2,-(1/(Sqrt[3]))},{-(3/2),(1/(2 (Sqrt[3])))},{-(3/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)},{-1,(2/(Sqrt[3]))},{-1,-(1/(Sqrt[3]))},{-(1/2),(1/(2 (Sqrt[3])))+(Sqrt[3])},{-(1/2),(1/(2 (Sqrt[3])))},{-(1/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)},{0,(5/(Sqrt[3]))},{0,(2/(Sqrt[3]))},{0,-(1/(Sqrt[3]))},{0,-(4/(Sqrt[3]))},{(1/2),(1/(2 (Sqrt[3])))+(Sqrt[3])},{(1/2),(1/(2 (Sqrt[3])))},{(1/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)},{1,(2/(Sqrt[3]))},{1,-(1/(Sqrt[3]))},{(3/2),(1/(2 (Sqrt[3])))},{(3/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)},{2,(2/(Sqrt[3]))},{2,-(1/(Sqrt[3]))},{(5/2),-(1/(Sqrt[3]))-((Sqrt[3])/2)}};

lines={{4,9,16,20},{1,5,10,17,21,24},{11,15,18,20,23,24},{1,3,4,6,8,11},{6,9,13,17},{10,13,16,18},{14,17,19,20,22},{2,4,7,10,14},{3,7,13,19,23},{8,12,16,19,21},{5,7,9,12,15},{2,6,12,18,22}};

Tally[Length/@lines]//Sort

ConfigurationDiagram[v,lines,.5,VertexLabels->None]

ConfigurationNotation[lines]

levi=LeviGraph[lines]

RecognizeGraph[levi]

g=ConfigurationGraph[v,lines]

RecognizeGraph[g]

Through[{VertexCount,EdgeCount}[g]]

OrdinaryLineGraph[g]

RecognizeGraph@%

Square face

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

lines={{3,10,14,17,20,24,28},{2,6,9,11,14,16,21},{1,5,9,12,15,19,26},{8,13,15,18,20,23,27},{16,17,18,19},{10,11,12,13},{5,11,17,23},{6,12,18,24},{21,22,23,24,25,26},{3,4,5,6,7,8},{1,4,10,16,22,27},{2,7,13,19,25,28}};

Tally[Length/@lines]//Sort

ConfigurationDiagram[v,lines,.5,VertexLabels->None]

ConfigurationNotation[lines]

levi=LeviGraph[lines]

RecognizeGraph[levi]

g=ConfigurationGraph[v,lines]

g=

LabelGraph@g

EdgeList[g]

RecognizeGraph[g]

Through[{VertexCount,EdgeCount}[g]]

OrdinaryLineGraph[g]

RecognizeGraph@%

Properties

Initialization

<<MathWorld`Polyhedra`

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

Centroid

Graphics3D[{AbsolutePointSize[10],
Point[{0,0,0}],{Blue,Point[PolyhedronData[pname,"Centroid"]]},Opacity[.2],PolyhedronData[pname,"GraphicsComplex"]}]

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

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

{
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[π/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"]]]}

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

PolyhedronData[pname,"Lines"]/.Line[l_]:>EuclideanDistance@@l//FullSimplify//Union//Quiet

Faces

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p,{0,0,0}])/(Volume[p]))//RootReduce//Timing

PolyhedronInertiaTensor[p]//Timing

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

MeanCylindricalRadius

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

MeanSquareCylindricalRadius

((NIntegrate[(x^2)+(y^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(x^2)+(y^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//FullSimplify)//Timing

N[i]

MeanSphericalRadius

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

MeanSquareSphericalRadius

((NIntegrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//FullSimplify)//Timing

N[i]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p])//Timing

SimplePolyhedron

SimplePolyhedronQ[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//RootReduce

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

VertexSubsetHulls

PolyhedronData[pname,"VertexSubsetHulls"]

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Construction XXX

AugmentedPolyhedron[PolyhedronData["Cuboctahedron","Polyhedron"],x]