Square Cupola

Author

Eric W. Weisstein
September 9, 2023

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

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

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

Polyhedron

PolyhedronData["SquareCupola","Orientations"]

PolyhedronData["SquareCupola"]

Net

PolyhedronData["SquareCupola","Net"]

PolyhedronData["SquareCupola","Net","Colored"]

NetPrintout[PolyhedronData["SquareCupola","Polyhedron"],"SmallTriakisOctahedron.pdf"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//FullSimplify

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]//FullSimplify

sphere=MyCircumsphere[p]

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

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

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,"BasisTerms"->{30,20}]//FullSimplify)//Timing

ToConwayBasis[dehn,"BasisTerms"->{30,20}]

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

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

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[p]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

Integrate over polyhedron [unevaluated]

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol))//Timing

CAD

mtrott 2023-09-09: It seems to me that a x-y-z-CAD is not optimal for these solids because of their geometry.  Make 'nice' polyhedral cones/wedges from the triangular and square faces to either {0,0,0} or {0,0,-1}.
There will be just a few few of them (around 3, depending on how you cut). Each of these is a pretty simple object and Integrate[Sqrt[x^2 + y^2]...] will probably give a much simpler result.

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

N[rxy,20]

(rxysimp=ResourceFunction["LogSimplify"][rxy]//RootReduce)//Timing

CAD over  1/4

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&x>0&&y>0]

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

4((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

CAD over  1/8

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<x]

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

8((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

(rxy=8((Integrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol))//Timing

rxysimp1=ResourceFunction["LogSimplify"][rxy]//FullSimplify

Simplify`SimplifyCount[rxysimp1]

rxysimp2=rxysimp1//RootReduce

N[rxysimp2,20]

Simplify`SimplifyCount[rxysimp2]

RootReduce[(NumericalApproximation[Root, (RowDefault["8.21", FEExpressionsNumericalApproximationElider, " × ", (Superscript["10", "-16"])]), Root[1-6646114628989760 #1+6613979812735372457543815978496 ((#1)^2)+788559700230276256629118190935144070758400 ((#1)^3)+16750685342357093314235493352508168438826867124928512 ((#1)^4)&,4], ]){(NumericalApproximation[Root, (RowDefault["1.07", FEExpressionsNumericalApproximationElider, " × ", (Superscript["10", "15"])]), Root[255595174291337483432548421516543097516279100417-2709012459185966929089785312412922131700 #1+5115985416972366195254639261754 ((#1)^2)-5844975973568620 ((#1)^3)+((#1)^4)&,3], ]),(NumericalApproximation[Root, (RowDefault["-1.31", FEExpressionsNumericalApproximationElider, " × ", (Superscript["10", "13"])]), Root[255595174291337483432548421516543097516279100417-33007873097000505817427063370728513140 #1+757533085854815780130039710 ((#1)^2)+71226163581340 ((#1)^3)+((#1)^4)&,2], ]), (NumericalApproximation[Root, (RowDefault["-1.07", FEExpressionsNumericalApproximationElider, " × ", (Superscript["10", "15"])]), Root[255595174291337483432548421516543097516279100417+2709012459185966929089785312412922131700 #1+5115985416972366195254639261754 ((#1)^2)+5844975973568620 ((#1)^3)+((#1)^4)&,2], ]),(NumericalApproximation[Root, (RowDefault["3.98", FEExpressionsNumericalApproximationElider, " × ", (Superscript["10", "14"])]), Root[1070348584894778337299762239483130343652527370183947519312427839898579816809864436537536832698597376-83406714023070564259418678881264473287004552303505443465414046458504730400284672 ((#1)^2)+498093858598607789071203692633552348620696137851243149960448 ((#1)^4)-3301425020394001515492842247872 ((#1)^6)+((#1)^8)&,7], ])}]

rxysimp3=FullSimplify[Log[(NumericalApproximation[Root, (RowDefault["3.61", FEExpressionsNumericalApproximationElider]), Root[1+12 #1-2 ((#1)^2)-4 ((#1)^3)+((#1)^4)&,4], ])] (1/16) (7+5 (Sqrt[2]))+ArcSinh[1+(Sqrt[2])](1/16) (-3+2 (Sqrt[2]))+ArcSinh[1](1/16) (-7-5 (Sqrt[2]))+(NumericalApproximation[Root, (RowDefault["0.327", FEExpressionsNumericalApproximationElider]), Root[1-64 ((#1)^2)+512 ((#1)^4)&,4], ])]

N[rxysimp3,20]

ResourceFunction["LogSimplify"][rxysimp3]

Simplify`SimplifyCount[rxysimp3]

Divergence theorem [unevaluated integral]

(rxy=MeanCylindricalRadius[p,Debug->True])//Timing

N[rxy]

ResourceFunction["LogSimplify"][rxy]//FullSimplify

Divergence theorem "Simplification" -> FullSimplify [unevaluated integral]

(rxy=MeanCylindricalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

Divergence theorem "IntegrationIntervals" ->{0,1/3,1/2,2/3,1} [unevaluated integral]

(rxy=MeanCylindricalRadius[p,"IntegrationIntervals"->{0,1/3,1/2,2/3,1},Debug->True])//Timing

Divergence theorem GenerateConditions -> True, Simplification" -> FullSimplify [unevaluated integral]

(rxy=MeanCylindricalRadius[p,"Simplification"->FullSimplify ,GenerateConditions->True,Debug->True])//Timing

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

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

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

N[i]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

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

N[i]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

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

N[i]

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]

Graphics3D[{{Opacity[.5],p},{Blue,Midsphere[p]}},Boxed->False]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//FullSimplify

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

VertexSubsetHulls

PolyhedronData[pname,"VertexSubsetHulls"]

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p,Method->"GaussLaw"]//FullSimplify

Perspective projections

Manipulate[PolyhedronProjectionGraph[PolyhedronData["Cuboctahedron","Polyhedron"],{a,b,c}],{a,-1,1},{b,-1,1},{c,-1,1}]

XXX

PolyhedronProjectionGraph[PolyhedronData["DuererSolid","Polyhedron"],]