Pentagonal Hexecontahedron

Author

Eric W. Weisstein
January 5, 2024

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

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

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

Figure

With[{pname="PentagonalHexecontahedron"},
GraphicsRow[{
Graphics3D[{Opacity[.8],PolyhedronData[pname,"Polyhedron"]},Boxed->False],
Graphics3D[{PolyhedronData[pname,"Lines"]},Boxed->False],
PolyhedronData[pname,"Net"]
},ImageSize->700]]

Solid

PolyhedronData["PentagonalHexecontahedron","Orientations"]

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

Compound of enantiomers

Show[%]

Solid and Dual

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

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

Dextro

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

Show[Most@%]

Laevo

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

Show[Most@%]

Net

PolyhedronData["PentagonalHexecontahedron","Net"]

PolyhedronData["PentagonalHexecontahedron","Net","Colored"]

NetPrintout[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],"PentagonalHexecontahedron.pdf"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[p]

ConvexHull

"Dextro"

dextro={pname,"Dextro"}

convexhullname=PolyhedronData[dextro,"ConvexHull","Name"]

PolyhedronData[dextro,"ConvexHull","Scale"]

{Graphics3D[{Red,Opacity[.5],PolyhedronData[dextro,"Polyhedron"]}],Graphics3D[{Blue,Opacity[.5],PolyhedronData[dextro,"ConvexHull","Polyhedron"]}]}

Show[%]

"Laevo"

laevo={pname,"Laevo"}

convexhullname=PolyhedronData[laevo,"ConvexHull","Name"]

PolyhedronData[laevo,"ConvexHull","Scale"]

{Graphics3D[{Red,Opacity[.5],PolyhedronData[laevo,"Polyhedron"]}],Graphics3D[{Blue,Opacity[.5],PolyhedronData[laevo,"ConvexHull","Polyhedron"]}]}

Show[%]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//RootReduce//Tally

Show[Graphics3D[{poly,
MapIndexed[Text[#2[[1]],#1]&,Centroid/@poly//N]
}],Boxed->False]

Edge 1

Show[Graphics3D[p=poly[[{31,59}]]],Boxed->False]

d1=π-RootReduce[DihedralAngle@@p]

N[d1]180/Pi

Edge 2

Show[Graphics3D[p=poly[[{24,59}]]],Boxed->False]

d2=π-RootReduce[DihedralAngle@@p]

N[d2]180/Pi

Summary

Equal@@{d1,d2}

InputForm[d1]

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

Faces

Show[GraphicsArray[partition[PolyhedronFaces[poly],15]]]

PolyhedronFaceCounts[poly]

<<Utilities`Simplify`

Timing[angles=ArcCos[ExactRoot[N[#,100],6]]&/@(Dot[#1,-#2]&@@@Map[ExactRoot[N[#,100],16]&,Map[Unit,(Subtract@@@Nest[Partition[#,2,1,1]&,First[Polyhedron[PentagonalHexecontahedron][[1]]],2]),{2}],
{3}])]

Sort[angles 180./Pi]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[p]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p])/(Volume[p]))//Timing

PolyhedronInertiaTensor[p]//Timing

MeanCylindricalRadius

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

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

N[i]

MeanCylindricalSquareRadius

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

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

N[i]

r=RootApproximant[N[i,1000],64]

N[i-r,5000]

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]

MeanSphericalSquareRadius

((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"])))//Timing

N[i]

r=RootApproximant[N[i,1000],64]

N[i-r,5000]

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]

SurfaceArea

s0=PolyhedronData[pname,"SurfaceArea"]

(s=SurfaceArea[p])//Timing

s2=RootApproximant[N[s,5000],128]

N[s-s2,5000]

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

VertexSubsetHulls

p="PentagonalHexecontahedron";
v=PolyhedronData[p,"VertexCoordinates"];

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

g=Function[poly,Graphics3D[{
{Gray,Opacity[.2],EdgeForm[Thick],PolyhedronData[p,"Faces"]},ConvexHull3D[N[PolyhedronData[p,"VertexCoordinates"]][[#]]]&/@poly},Boxed->False]]/@h[[All,2]]

Volume

v=PolyhedronData[pname,"Volume"]

(v1=Volume[p])//Timing

va=RootApproximant[N[v1,1000],64]

N[v1-va,5000]

(v2=PolyhedronVolume[p,Method->"GaussLaw"])//Timing

vb=RootApproximant[N[v2,1000],64]

N[v2-vb,5000]

FullSimplify[PolyhedronSymmetricVolume[poly]/s[[1]]^3]

InputForm[%]

PolyhedronData["PentagonalHexecontahedron","Volume"]

N[%]

PolyhedronData["PentagonalHexecontahedron","Volume"]/((PolyhedronData["PentagonalHexecontahedron","ρ"])^3)//N

vol=With[{xx=((1/2)*(GoldenRatio+Sqrt[GoldenRatio-5/27]))^(1/3)+((1/2)*(GoldenRatio-Sqrt[GoldenRatio-5/27]))^(1/3)},
(20/31)*((-9*GoldenRatio-7)+(-2*GoldenRatio+57)/xx+(2*(-5*GoldenRatio+3))/xx^2)
]

vol//TraditionalForm

N[vol]

FullSimplify[vol]

Perspective projections

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

PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],#]&/@N[PolyhedronData["PentagonalHexecontahedron","VertexCoordinates"]]

{3+(Sqrt[5]),0,1}

PolyhedronData["PentagonalHexecontahedron","VertexCoordinates"][[5]]

{(NumericalApproximation[Root, (RowDefault["-3.74", FEExpressionsNumericalApproximationElider]), Root[1-225 ((#1)^2)+6318 ((#1)^4)-468396 ((#1)^6)+5037876 ((#1)^8)-10161774 ((#1)^10)+700569 ((#1)^12)&,1], ]),0,(NumericalApproximation[Root, (RowDefault["-0.714", FEExpressionsNumericalApproximationElider]), Root[1-360 ((#1)^2)+1567728 ((#1)^4)-197429184 ((#1)^6)+1651746816 ((#1)^8)-3954686976 ((#1)^10)+2869530624 ((#1)^12)&,2], ])}/(NumericalApproximation[Root, (RowDefault["-0.714", FEExpressionsNumericalApproximationElider]), Root[1-360 ((#1)^2)+1567728 ((#1)^4)-197429184 ((#1)^6)+1651746816 ((#1)^8)-3954686976 ((#1)^10)+2869530624 ((#1)^12)&,2], ])//RootReduce

PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],{3+(Sqrt[5]),0,1}]

{-1,(Sqrt[3 (9-4 (Sqrt[5]))]),-(3-(Sqrt[5])),-ArcTan[(1/2)-(3/(2 (Sqrt[5])))]}

g=PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],{-1,(Sqrt[3 (9-4 (Sqrt[5]))]),-(3-(Sqrt[5])),-ArcTan[(1/2)-(3/(2 (Sqrt[5])))]},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[5]]-v[[6]])//FullSimplify

{-.61,.255,-.465}/.61

PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],{-1,.41,-.7},VertexLabels->"Name"]

g=PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],{-1,x,-y},VertexLabels->"Name"];

v=GraphEmbedding[g];

FullSimplify[v[[6]]-v[[90]],x>0&&y>0]

Solve[Thread[Numerator[%]==0],{x,y}]//FullSimplify

N[%]

{0,0,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalHexecontahedron","Polyhedron"],{0,0,1}]

Construction via Dual

Laevo

dual=Dual[poly=Polyhedron[SnubDodecahedron,"laevo"]];
Show[GraphicsArray[Graphics3D[#,Boxed->False]&/@{dual,poly,{dual,poly}}]]

<<Utilities`Simplify`

ExactRoot[N[dual[[1,1,1,1]],100],12]

ExactRoot[N[dual[[1,1,1,1]],200],12]

ExactRoot[N[dual[[1,1,1,1]],500],12]

RootReduce[dual[[1,1,1,1]]]

ORIGINAL (WRONG)

(v=PolyhedronVertices[poly])//InputForm
First/@poly/.Thread[v->Range[Length[v]]]

New

Timing[poly1=Orient[Map[ExactRoot[#,12]&,N[dual,100],{4}]];]

Timing[poly=Orient[Map[RootReduce,dual,{4}]];]

Length/@{poly,poly1}

Equal@@@Transpose[{poly,poly1}]

Requires > 13 hours

expr1=(v=PolyhedronVertices[poly])//InputForm
expr2=First/@poly/.Thread[v->Range[Length[v]]]

Dextro

dual=Dual[poly=Polyhedron[SnubDodecahedron,"dextro"]];
Show[GraphicsArray[Graphics3D[#,Boxed->False]&/@{dual,poly,{dual,poly}}]]

New

<<Utilities`Simplify`

Timing[poly=Orient[Map[ExactRoot[#,12]&,N[dual,100],{4}]];]

And@@OrientedQ[poly]

New

expr1=(v=PolyhedronVertices[poly])//InputForm
expr2=First/@poly/.Thread[v->Range[Length[v]]]

Original

(v=PolyhedronVertices[poly])//InputForm
First/@poly/.Thread[v->Range[Length[v]]]

Net construction

PolyhedronData["PentagonalHexecontahedron","EdgeLengths"]

({one,a}=SortBy[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[PolyhedronData["PentagonalHexecontahedron","Polyhedron"]]]//Union,N]//Quiet)//Timing

a=(NumericalApproximation[Root, (RowDefault["1.75", FEExpressionsNumericalApproximationElider]), Root[1-11 #1+51 ((#1)^2)-128 ((#1)^3)+177 ((#1)^4)-122 ((#1)^5)+31 ((#1)^6)&,4], ]);

{a}//N

PolyhedronData["PentagonalHexecontahedron","FaceCountRules"]

Graphics3D[{poly=PolyhedronData["PentagonalHexecontahedron","Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,v=PolyhedronData["PentagonalHexecontahedron","VertexCoordinates"]]}]

Graphics3D[{pent=Polygon[v[[{91,53,43,49,74}]]],MapIndexed[Text[#2[[1]],#,Background->White]&,v=PolyhedronData["PentagonalHexecontahedron","VertexCoordinates"]]}]

γ=VectorAngle[v[[53]]-v[[91]],v[[43]]-v[[91]]]//RootReduce

γ=ArcCos[(NumericalApproximation[Root, (RowDefault["0.929", FEExpressionsNumericalApproximationElider]), Root[961-962112 ((#1)^2)+4298704 ((#1)^4)-5867200 ((#1)^6)+2477568 ((#1)^8)-1225728 ((#1)^10)+1478656 ((#1)^12)&,8], ])];

N[%]

L=RootReduce[EuclideanDistance@@v[[{43,91}]]]

L=(NumericalApproximation[Root, (RowDefault["2.39", FEExpressionsNumericalApproximationElider]), Root[361-3952 ((#1)^2)+16071 ((#1)^4)-30062 ((#1)^6)+25872 ((#1)^8)-9180 ((#1)^10)+961 ((#1)^12)&,8], ]);

SortBy[ArcCos[ToAlgebraicRoot/@Cos[PolygonAngle[pent]]]//Quiet//FullSimplify,N]

N[%]

{α,β}=Union@%%

{α,β}={ArcCos[(NumericalApproximation[Root, (RowDefault["0.383", FEExpressionsNumericalApproximationElider]), Root[-31-128 #1+168 ((#1)^2)+888 ((#1)^3)+384 ((#1)^4)-384 ((#1)^5)+64 ((#1)^6)&,4], ])],ArcCos[(NumericalApproximation[Root, (RowDefault["-0.472", FEExpressionsNumericalApproximationElider]), Root[1-24 ((#1)^2)+24 ((#1)^3)+64 ((#1)^4)-128 ((#1)^5)+64 ((#1)^6)&,1], ])]};

Rotate[PolyhedronData["PentagonalHexecontahedron","Net"],.22]

Graphics[{FaceForm[LightYellow,Red],EdgeForm[Black],Polygon[v=PolyhedronData["PentagonalHexecontahedron","NetCoordinates"],PolyhedronData["PentagonalHexecontahedron","NetFaceIndices"]],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

Graphics[{FaceForm[LightYellow,Red],EdgeForm[Black],Polygon[v,Take[f,5]],MapIndexed[Text[#2[[1]],#,Background->White]&,Take[v,7]]}]

v=Join[
{{0,0}},
a Table[Through[{Cos,Sin}[i α]],{i,-2,3}],
Take[Flatten[Table[L Through[{Cos,Sin}[j γ+i α]],{i,-2,3},{j,{-1,1}}],1],{2,-2}]]//N[#,10000]&;
v=Join[v,SimilarityTransform[v,{{7,17},{16,17}},Range[17]]];
v=Join[v,SimilarityTransform[v,{{16,17},{20,26}},Range[17]]];
v=Join[v,SimilarityTransform[v,{{16,17},{21,28}},Range[17]]];
v=Join[v,SimilarityTransform[v,{{16,17},{22,30}},Range[17]]];
v=Join[v,SimilarityTransform[v,{{16,17},{23,32}},Range[17]]];

Length[v]

v=Join[v,SimilarityTransform[v,{{4,12},{12,4}},Range[102]]];

f={{1,2,8,9,3},{1,3,10,11,4},{1,4,12,13,5},{1,5,14,15,6},{1,6,16,17,7}};f=Join@@Table[f+17i,{i,0,5}];
f=Join[f,102+f];
Graphics[{FaceForm[LightYellow,Red],EdgeForm[Black],Polygon[v,f],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

PolygonAngle[Polygon[v[[{1,3,11,12,4}]]]]//N

PolyhedronData["PentagonalHexecontahedron","SurfaceArea"]//N

Total[Area[Polygon[v,#]]&/@f]//N

rot=RotationMatrix[{v[[106]]-v[[114]],{0,1}}];

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

Graphics[{FaceForm[LightYellow,Red],EdgeForm[Black],Polygon[v2,f]},Axes->True]

vexact=Map[ToAlgebraicRoot[#,WorkingPrecision->1000]&,v2,{2}];//Timing

ToAlgebraicRoot@Area[Polygon[vexact,f]]//FullSimplify

ToAlgebraicRoot@Total[Area[Polygon[vexact,#]]&/@f]//FullSimplify

PolyhedronData["PentagonalHexecontahedron","SurfaceArea"]

vfinal=Union[vexact];

ffinal=Sort[vexact[[#]]&/@f/.Thread[vfinal->Range[Length[vfinal]]]]

vfinal//FullSimplify

Graphics[{FaceForm[LightYellow,Red],EdgeForm[Black],Polygon[vfinal,ffinal]},Axes->True]

ToAlgebraicRoot@Total[Area[Polygon[vfinal,#]]&/@ffinal]//FullSimplify