Square Pyramid

Author

Eric W. Weisstein
September 8, 2023

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

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

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

Polyhedron

Equliateral

PolyhedronData[{"Pyramid",4}]

Polyhedron

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

Region

PolyhedronData[{"Pyramid",4},"Region"]

Solid and dual

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

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

General

Show[Graphics3D[Pyramid[4,1.4]],Boxed->False]

Show[Graphics3D[Polyhedron[JohnsonSolid[1]]],Boxed->False,ViewPoint->{2,2,2}]

PolyhedronName[JohnsonSolid[1]]

Wireframe

Show[Graphics[HiddenWireframe[Pyramid[4,1.4],BoxRatios->{1,1,1.4}]],AspectRatio->Automatic]

Construction for h==a/2

Octant[Polygon[v_List]]:=Module[{
tri=Append[#,{0,0,0}]&/@Partition[v,2,1,1],
off=.2Centroid[v]
},
{
Polygon[off+#&/@v],
Function[p,Polygon[off+#&/@p]]/@tri
}
]

Show[Graphics3D[Octant/@Polyhedron[Cube][[1]]],Boxed->False]

(1/3)(a^2)((1/2)a)

Properties: General a, h

Centroid

PolyhedronData[pname,"Centroid"]

(1/(((a^2) h)/3))Assuming[a>0&&h>0,Integrate[{x,y,z}Boole[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]]

bug(358629): Square pyramid RegionCentroid[ImplicitRegion[0 <= z <= h && Max[Abs[x], Abs[y]] <= a (1 - z/h)/2, {x, y, z}]] should return {0, 0, h/4} instead of unevaluated with a message

RegionCentroid[ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}]]

Edge Length

e=FullSimplify[Sqrt[h^2+a^2 Csc[Pi/n]^2/4]/.n->4]

(Subscript[J, 1])

Simplify[e/.h->Sqrt[2]a/2,a>0]

GeneralizedDiameter

Assuming[a>0&&h>0,MaxValue[{
(x1-x2)^2+(y1-y2)^2+(z1-z2)^2,
0≤z1≤h&&Max[Abs[x1],Abs[y1]]≤(1/2) a (1-(z1/h))&&
0≤z2≤h&&Max[Abs[x2],Abs[y2]]≤(1/2) a (1-(z2/h))
},{x1,y1,z1,x2,y2,z2}
]]

Inequalities

Block[{a=2,h=3},RegionPlot3D[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,-.6a,.6a},{y,-.6a,.6a},{z,-.1,1.1h}]]

InertiaTensor

(1/(((a^2) h)/3))Assuming[a>0&&h>0,Integrate[InertiaMatrix[{x,y,z}]Boole[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]]

FullSimplify[%]

bug(358629): Square pyramid RegionCentroid[ImplicitRegion[0 <= z <= h && Max[Abs[x], Abs[y]] <= a (1 - z/h)/2, {x, y, z}]] should return {0, 0, h/4} instead of unevaluated with a message

MomentOfInertia[ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}]]

MeanCylindricalRadius

?MeanCylindricalRadius

Assuming[a>0&&h>0,Integrate[(Sqrt[(x^2)+(y^2)])ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}],{x,y,z}∈FullRegion[3]]]

MeanSphericalRadius

?MeanCylindricalRadius

Assuming[a>0&&h>0,Integrate[(Sqrt[(x^2)+(y^2)+(z^2)])ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}],{x,y,z}∈FullRegion[3]]]

MeanSquareCylindricalRadius

?MeanCylindricalRadius

Assuming[a>0&&h>0,Integrate[((x^2)+(y^2))ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}],{z,0,h},{x,-a/2,a/2},{y,-a/2,a/2}]]

MeanSquareSphericalRadius

?MeanCylindricalRadius

Assuming[a>0&&h>0,Integrate[((x^2)+(y^2)+(z^2))ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}],{x,y,z}∈FullRegion[3]]]

ParametricRegion

Region

Slant Height

s=FullSimplify[Sqrt[h^2+a^2 Cot[Pi/n]^2/4]/.n->4]

(Subscript[J, 1])

Simplify[s/.h->Sqrt[2]a/2,a>0]

Surface Area

S=FullSimplify[(1/4) a n (a Cot[(π/n)]+(Sqrt[4 (h^2)+(a^2) ((Cot[(π/n)])^2)]))/.n->4]

Simplify[S/.h->Sqrt[2]a/2,a>0]

Volume

v=1/3 h a^2

Simplify[v/.h->Sqrt[2]a/2,a>0]

Assuming[a>0&&h>0,Integrate[Boole[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]]

Volume[ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}]]

Assuming[a>0,Volume[ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}]]]

bug(358628): Square pyramid Volume[ImplicitRegion[0 <= z <= h && Max[Abs[x], Abs[y]] <= 1/2 a (1 - z/h), {x, y, z}]] returns unevaluated

Assuming[a>0&&h>0,Volume[ImplicitRegion[0≤z≤h&&Max[Abs[x],Abs[y]]≤a(1-(z/h))/2,{x,y,z}]]]

Vertex Subset Hulls

p={"Pyramid",4};

Platonic

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

Properties: equilateral (Johnson)

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"Pyramid",4},"Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

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

RegionCentroid[p]

PolyhedronCentroid[p]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

Graphics3D[{{Opacity[.4],Yellow,sphere},Green,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]//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//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"]

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

PolyhedronInertiaTensor[p]

Insphere

PolyhedronData[pname,"Insphere"]

sphere=Insphere[p]

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

sphere=MyInsphere[p]

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

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

Integrate over polyhedron [wrong]

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

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

N[rxy]

bug(439994): Integrate[Sqrt[x^2 + y^2], {x, y, z} ∈ {"Pyramid", 4}] gives wrong complex result

Divergence theorem

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

N[rxy]

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

CAD

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

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

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

Integrate over Polyhedron

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

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

N[rxy2]

Divergence theorem

(rxy2=MeanSquareCylindricalRadius[p,Debug->True])//Timing

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

Integrate over polyhedron [unevaluated]

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

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

N[rxyz]

Divergence theorem [bad integral(s)]

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

N[rxyz]

ResourceFunction["LogSimplify"][rxyz]//FullSimplify

CAD [unevaluated]

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

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

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

N[rxyz,20]

CAD over  1/8 [unevaluated]

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

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

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

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

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

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Integrate over polyhedron

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

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

N[rxy2]

CAD

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

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

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

Integrate over region

reg=PolyhedronData[pname,"RegionFunction"][x,y,z]

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

Divergence theorem

(rxy2=MeanSquareSphericalRadius[p,Debug->True])//Timing

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

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//RootReduce

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

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[p,{x,y,z}]

FullSimplify[%]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

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

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

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]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Volume[PolyhedronData[pname,"Region"]]

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]