Goddard-Henning Enneahedron

Author

Eric W. Weisstein
September 12, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Goddard-HenningEnneahedron.nb.

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

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

Polyhedron

Graphics3D[{Opacity[.3],PolyhedronData["GoddardHenningEnneahedron","Polyhedron"]},Boxed->False,Method->{"ShrinkWrap"->True},ImageSize->250]

Graphics3D[{FaceForm[Green,Red],p},Boxed->False]

Solid and dual

poly=PolyhedronData["GoddardHenningEnneahedron","Polyhedron"];
dual=poly/.Polyhedron[v_,f_]:>Polyhedron[-v,Reverse/@f]

Graphics3D[{{Opacity[.3],Green,poly,Red,dual},Opacity[.8],Yellow,PolyhedronData["GoddardHenningEnneahedron","Midsphere"]},Boxed->False,Method->{"ShrinkWrap"->True},ImageSize->250]

Net

PolyhedronData["GoddardHenningEnneahedron","Net"]

PolyhedronData["GoddardHenningEnneahedron","Net","Colored"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//FullSimplify//Timing

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[p]//Timing

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

FullSimplify[%]

LogSimplify[%]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

Simplify[3 (Subscript[⟨3⟩, 2])-(Sqrt[3]) (Subscript[⟨3⟩, 2])-20 (Subscript[⟨5⟩, 6])+5 (Subscript[⟨11⟩, 2])+(Sqrt[3]) (Subscript[⟨11⟩, 2])-5 (Subscript[⟨11⟩, 6])-(Sqrt[3]) (Subscript[⟨11⟩, 6])]

ToConwayBasis[dehn,WorkingPrecision->1000]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

SimplifyNumericallyDistinct[DihedralAngles[p]]//FullSimplify//Tally

EdgeCount

PolyhedronData[pname,"EdgeCount"]

PolyhedronEdges[p]//Length

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

SortBy[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p]],N]//Tally//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

Length[PolyhedronFaces[p]]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[p,"Simplification"->FullSimplify]//Timing

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]//FullSimplify//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

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

Integrate over polyhedron

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

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

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

MaxMemoryUsed[]/10.^9"GB"

N[rxy]

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

Divergence theorem [unevaluated integral]

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

N[rxy]

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

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

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

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

N[i]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

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

ineq=PolyhedronData["GoddardHenningEnneahedron","RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq](Sqrt[(x^2)+(y^2)+(z^2)]),{z,-Infinity,Infinity}])//Timing

N[i]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

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

N[i]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p])//FullSimplify//Timing

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

Net

PolyhedronData[pname,"Net"]

FullSimplify[NetEdgeLengths[PolyhedronData[pname,"Net"]]]//Union

PolyhedronEdgeLengths[PolyhedronData[pname,"Polyhedron"]]//Union

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

PolyhedronData[pname,"SurfaceArea"]

Skeleton

PolyhedronData[pname,"Skeleton"]

RecognizeGraph[%]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//FullSimplify//Timing

N[(1/2) (2+(Sqrt[3])+3 (Sqrt[5])+(Sqrt[15])+(Sqrt[9+4 (Sqrt[3])]))]

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

PolyhedronSurfaceArea[p]//RootReduce

VertexCount

PolyhedronData[pname,"VertexCount"]

PolyhedronCoordinates[p]//Length

VertexSubsetHulls

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

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

ineq=PolyhedronData["GoddardHenningEnneahedron","RegionFunction"][x,y,z]

(v=Integrate[Boole[ineq],{x,-Infinity,Infinity},{y,-Infinity,Infinity},{z,-Infinity,Infinity}])//Timing

FullSimplify[v]

Properties normalized to unit midsphere

GeneralizedDiameter

((PolyhedronData[pname,"GeneralizedDiameter"])/(PolyhedronData[pname,"Midradius"]))//FullSimplify

SurfaceArea

((PolyhedronData[pname,"SurfaceArea"])/((PolyhedronData[pname,"Midradius"])^2))//FullSimplify

Volume

((PolyhedronData[pname,"Volume"])/((PolyhedronData[pname,"Midradius"])^3))//FullSimplify

Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["GoddardHenningGraph"],1]}]

Graphics3D[poly2=Polyhedron[Normalize/@poly[[1]],poly[[2]]]]

Precision 20

(can=FindCanonicalPolyhedron[poly2,WorkingPrecision->1000,MaxIterations->5000,PrecisionGoal->20])//Timing

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

SimplePolyhedronQ[can]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

Precision 200

(can=FindCanonicalPolyhedron[poly2,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->200])//Timing

SortBy[ToAlgebraicRoot/@N[PolyhedronEdgeLengths[can],150]//Union//FullSimplify,N]

N[%,20]

v=PolyhedronCoordinates[can];

ToAlgebraicRoot[N[Max[Norm/@v],150]]

Norm/@v//N

Norm[v[[9]]]//N

v[[9]]//N

Graphics3D[{can,MapIndexed[Text[#2[[1]],#,Background->White]&,v]},Boxed->False]

FullSimplify[ToAlgebraicRoot@N[Norm[Mean[v[[{4,3,2,1}]]]-v[[9]]],150]-(Sqrt[3])]

eqn={
SquaredEuclideanDistance[{0,0,h},{x,0,d}]==c^2,
SquaredEuclideanDistance[{x,0,d},{b/2,b/2,-z}]==a^2
}/.Abs->Identity/.{h->(Sqrt[3]),z->(1/(Sqrt[3])),a->4 (Sqrt[(2/3)-(1/(Sqrt[3]))]),b->2 (Sqrt[(2/3)]),c->2 (Sqrt[6-3 (Sqrt[3])])}//FullSimplify

Solve[eqn,{d,x},PositiveReals]//FullSimplify

pts=Join[
Append[#,-z]&/@Tuples[{-1,1}b/2,2],
Append[#,d]&/@{{x,0},{-x,0},{0,x},{0,-x}},
{{0,0,h}}
]/.{h->(Sqrt[3]),z->(1/(Sqrt[3])),a->4 (Sqrt[(2/3)-(1/(Sqrt[3]))]),b->2 (Sqrt[(2/3)]),c->2 (Sqrt[6-3 (Sqrt[3])]),d->2-(Sqrt[3]),x->(Sqrt[2]) (-1+(Sqrt[3]))}

poly=ConvexHullRegion[pts]

SortBy[PolyhedronEdgeLengths[poly]//FullSimplify,N]//Tally

Graphics3D[{Opacity[.5],Red,poly,Yellow,Sphere[]}]

goddardhenning=ConvexHullRegion[FullSimplify[(pts/(4 (Sqrt[(2/3)-(1/(Sqrt[3]))])))]]

Graphics3D[goddardhenning=Polyhedron[]]

RecognizeGraph[SkeletonGraph[goddardhenning]]

SortBy[PolyhedronEdgeLengths[goddardhenning]//FullSimplify,N]//Tally

N[%[[All,1]]]

Net construction

v=PolyhedronData[pname,"VertexCoordinates"]

Graphics3D[{p,MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

SortBy[ArcCos[ToAlgebraicRoot/@Cos[PolygonAngle[Polygon[v[[{9,8,3,5}]]]]]]//FullSimplify//Quiet,N]

θ1=ArcCos[(2/3)];
θ2=ArcSec[4];
θ3=ArcCos[(1/12) (3-5 (Sqrt[3]))];

N[{θ1,θ2,θ3}]

SortBy[ArcCos[ToAlgebraicRoot/@Cos[PolygonAngle[Polygon[v[[{3,8,1}]]]]]]//FullSimplify//Quiet,N]

ϕ1=ArcCos[(1/4) (1+(Sqrt[3]))];
ϕ2=ArcCos[(1/4) (2-(Sqrt[3]))];

N[{ϕ1,ϕ2}]

{a,b,c}=(({4 (Sqrt[(2/3)-(1/(Sqrt[3]))]),2 (Sqrt[(2/3)]),2 (Sqrt[6-3 (Sqrt[3])])})/(4 (Sqrt[(2/3)-(1/(Sqrt[3]))])))//FullSimplify

N[{a,b,c}]

h=Sqrt[SquaredEuclideanDistance@@v[[{3,9}]]]//FullSimplify

{x,y}=Through[{Cos,Sin}[θ2/2]]//TrigExpand//FullSimplify

Graphics[{FaceForm[LightYellow],EdgeForm[Black],
Text[Style["4 ×",24],{-1.2,h/2}],
Polygon[{{0,0},{x,y},{0,h},{-x,y}}],
Text[Subscript[θ,1],{0,h},{-.2,3}],
Text[Subscript[θ,2],{0,0},{-.2,-2}],
Text[Subscript[θ,3],{x,y},{2,-.3}],
Text[Subscript[θ,3],{-x,y},{-2.3,-.3}],
Text[Style["c",Italic],Mean[{{-x,y},{0,h}}],{2,-.3}],
Text[Style["a",Italic],Mean[{{-x,y},{0,0}}],{2,.5}],

Polygon[{1.3+#,#2}&@@@{{0,0},{b,0},{b,b},{0,b}}],
Line[{1.3+#,#2}&@@@(.2{{0,1},{1,1},{1,0}})],
Text[Style["b",Italic],{1.3,0}+{b/2,b},{0,-1.8}],

Text[Style["4 ×",24],{3.7,(Sqrt[(a^2)-((((b/2)))^2)])/2}],
Polygon[{5+#,#2}&@@@{{-b/2,0},{b/2,0},{0,(Sqrt[(a^2)-((((b/2)))^2)])}}],
Text[Style["a",Italic],{4.5,.5}],
Text[Style["b",Italic],{5,-.2}],
Text[Subscript[ϕ,1],{4.5,.15}],
Text[Subscript[ϕ,2],{5,.6}]
},BaseStyle->Directive[18,FontFamily->"Times"]]

v=Join[
{{0,0}},
h Table[Through[{Cos,Sin}[(i-3/2) θ1-Pi/2]],{i,0,3}],
c Table[Through[{Cos,Sin}[i θ1-Pi/2]],{i,-2,2}]
];
v=Join[v,{v[[2]]+RotationMatrix[-ϕ1].(v[[7]]-v[[2]])b/a,v[[3]]+RotationMatrix[-ϕ1].(v[[8]]-v[[3]])b/a,v[[4]]+RotationMatrix[-ϕ1].(v[[9]]-v[[4]])b/a,v[[5]]+RotationMatrix[-ϕ1].(v[[10]]-v[[5]])b/a}];
v=Join[v,{v[[4]]+RotationMatrix[-Pi/2].(v[[13]]-v[[4]]),v[[13]]+RotationMatrix[Pi/2].(v[[4]]-v[[13]])}];
faces={{1,6,2,7},{1,7,3,8},{1,8,4,9},{1,9,5,10},{7,2,11},{8,3,12},{9,4,13},{14,10,5},{13,4,15,16}};
Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v,faces],Point[v],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

vnew=Map[ToAlgebraicRoot,v,{2}]//FullSimplify

facesnew=Sort[faces]

PolyhedronData[pname,"SurfaceArea"]//RootReduce

Total[Area[Polygon[vnew,#]]&/@faces]//ToAlgebraicRoot//FullSimplify

net=GraphicsComplex[vnew,Polygon[facesnew]];

SimplifyNumericallyDistinct[NetEdgeLengths[net]//Quiet,"Simplification"->FullSimplify]//Union

PolyhedronData

PolyhedronDataString

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

WriteString[file,PolyhedronDataString[goddardhenning,
"StandardName"->"GoddardHenningEnneahedron",
"Name"->"Goddard\[Hyphen]Henning enneahedron"
]]