Goldner-Harary Polyhedron

Author

Eric W. Weisstein
August 22, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Goldner-HararyPolyhedron.nb.

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

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

Solid

PolyhedronData["GoldnerHararyPolyhedron","Orientations"]

PolyhedronData["GoldnerHararyPolyhedron",{"V","E","F"}]

PolyhedronData["GoldnerHararyPolyhedron"]

GraphicsRow[{Graphics3D[{Opacity[.5],PolyhedronData["GoldnerHararyPolyhedron","Polyhedron"]},Boxed->False],},Spacings->-50]

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

Polyhedron

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

Solid and Dual

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

With[{p="GoldnerHararyPolyhedron"},Graphics3D[{Opacity[.5],
Green,PolyhedronData[p,"Polyhedron"],
Red,PolyhedronData[p,"Dual","Polyhedron"],
Yellow,PolyhedronData[p,"Midsphere"]},Boxed->False]]

Net

PolyhedronData["GoldnerHararyPolyhedron","Net"]

PolyhedronData["GoldnerHararyPolyhedron","Net","Colored"]

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

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

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

RegionCentroid[p]//Timing

PolyhedronCentroid[p]//Timing

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

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

Compound

PolyhedronData[pname,"Compound"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

PolyhedronData[pname,"ConvexHull"]

convexhull=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]

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

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

SimplifyNumericallyDistinct[DihedralAngles[p]]//Tally

Dual

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

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

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

TextGrid[{#,N[#,10],#2}&@@@Tally[SortBy[PolyhedronData[pname,"Lines"]/.Line[l_]:>(1/PolyhedronData[pname,"Midradius"]EuclideanDistance@@l)//FullSimplify,N]]//Quiet,Dividers->All]

lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p]];//Quiet

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

v=PolyhedronCoordinates[p];

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

Graph

g=PolyhedronGraph[PolyhedronData["GoldnerHararyPolyhedron","Polyhedron"],PolyhedronData["GoldnerHararyPolyhedron","Midradius"]]

Tally[EdgeLengths[g]//FullSimplify]

Show[{g,Graphics3D[Sphere[]]}]

Hull

PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

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}])/(Volume[p])))//Timing

PolyhedronInertiaTensor[p]//Timing

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

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

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

Integrate over polyhedron

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

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

Divergence theorem

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

N[rxy]

(rxysimp=FullSimplify[rxy])//Timing

N[rxysimp]

ResourceFunction["LogSimplify"][rxysimp]

N[%-rxysimp,1000]

N[%115]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

Integrate over Polyhedron

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

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

Divergence theorem

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

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

Integrate

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

Divergence theorem

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

CAD

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)

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

Boole Integrate doing z integral first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=CoordinateBounds[p]

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

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

NIntegrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}]

(i2=Integrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}])//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

N[%]

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

Integrate

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

Divergence theorem

(rxy=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"]]]//ToAlgebraicRoot//Timing

PolyhedronData[pname,"SurfaceArea"]

Polygons

PolyhedronData[pname,"FaceCount"]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

polygons=PolyhedronData[pname,"Polygons"]

Graphics3D[%]

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

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

With[{gn="GoldnerHararyGraph",verts=PolyhedronData[pname,"Vertices"],faces=PolyhedronData[pname,"Faces","List"]},
ToCommonEdges[GraphData[gn],Graph[Range[Length[verts]],UndirectedEdge@@@Union[Sort/@Flatten[Partition[#,2,1,1]&/@faces,1]]]]]//Chop[#,1*^-5]&//N

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//FullSimplify

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

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Graphics3D[{{Green,p},Blue,Opacity[.5],ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Perspective projections

Manipulate[PolyhedronProjectionGraph[p,{a,b,c}],{a,-1,1},{b,-1,1},{c,-1,1}]

XXX

PolyhedronProjectionGraph[p,#]&/@{}

Net construction

Canonical

<<MathWorld`Polyhedra`

Table[{poly=UnfoldPolyhedron[p,WorkingPrecision->1000],Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly}]},100]

{Polygon[],},

net=Polygon[];

Graphics[{FaceForm[LightYellow],EdgeForm[Black],net,MapIndexed[Text[#2[[1]],#,Background->White]&,v=net[[1]]]}]

rot=RotationMatrix[{v[[17]]-v[[5]],{1,0}}];

v2=(rot.(#-v[[1]]))&/@v;

v3=(#-v2[[8]])&/@v2;

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v3,net[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,v3]},Axes->True]

vexact=Map[ToAlgebraicRoot,v3,{2}]

net[[2]]//Sort

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

PolyhedronData[pname,"SurfaceArea"]

poly3d=PolyhedronData[pname,"Net","Polygons"]/.Polygon[v_]:>Polygon[Append[#,0]&/@v]

Graphics3D[{FaceForm[Green,Red],poly3d}]

Construction

3D Canonical construction from PolyhedralEmbedding

g=GraphData["GoldnerHararyGraph","Graph","Planar"][[1]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->4],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.1v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->20000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/5,"PlanarFactor"->1/5,Debug->True])//Timing

SimplePolyhedronQ[can]

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

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

lens={0.769800358919501`,1.9245008972987525`,2.309401076758503`,3.4641016151377544`};

s=RootApproximant/@lens

N[s-lens]

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]

Norm[v[[1]]]

h3=Sqrt[((s[[3]])^2)-(((((Sqrt[3])/3)s[[4]]))^2)]

EuclideanDistance@@v[[{5,2}]]

{x,y,z}/.Solve[{SquaredEuclideanDistance[v[[2]],{x,y,z}]==((s[[2]])^2),SquaredEuclideanDistance[v[[3]],{x,y,z}]==((s[[2]])^2),SquaredEuclideanDistance[v[[5]],{x,y,z}]==((s[[1]])^2)},{x,y,z},Reals]

EuclideanDistance@@v[[{5,6}]]

s[[1]]

v=Join[{#,0,#2}&@@@CirclePoints[((Sqrt[3])/3)s[[4]],3],{0,((2#)/(Sqrt[3])),0}&/@{-1,1},Flatten[Table[RotationMatrix[2Pi i/3,{0,1,0}].{-(1/(Sqrt[3])),((4j)/(3 (Sqrt[3]))),(1/3)},{i,0,2},{j,{-1,1}}],1]];
Show[g=Graph[Range@Length@v,UndirectedEdge@@@{e[4,1,2,3,1,5,2],{3,5},e[3,4,2],e[2,7,3,6,2,8,1,9,2],e[1,11,3,10,1],e[8,4,6],{4,10},e[7,5,11],{5,9}},VertexCoordinates->v,VertexLabels->Automatic],Boxed->True]

SortBy[Tally[FullSimplify[EdgeLengths[g]]],N[#[[1]]]&]

s

Graphics3D[{FaceForm[Green,Red],solid=ConvexHullRegion[v]}]

Midsphere[solid]

solid[[2]]//Length

g=PolyhedronGraph[solid]

RecognizeGraph[g]

PolyhedronData

PolyhedronDataString

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

WriteString[file,PolyhedronDataString[solid,
"Name"->"Goldner\[Hyphen]Harary polyhedron",
"StandardName"->"GoldnerHararyPolyhedron",
"Information"->"GoldnerHararyPolyhedron"
]]

Close[file]