Great Icosahedron

Author

Eric W. Weisstein
October 12, 2023

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

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

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

Solid

Variants

variants={"GreatIcosahedron","GreatIcosahedronHull"};

PolyhedronData/@variants

PolyhedronData[#,"FaceCount"]&/@variants

Length[PolyhedronData[#,"Polyhedra"]]&/@variants

UniformPolyhedron

uniform=UniformPolyhedron[stdname="GreatIcosahedron"]

PolyhedronFaceTally[uniform]

indices=UniformPolyhedronIndex[stdname]

UniformPolyhedron/@{
stdname,
Lookup[indices,"Wenninger"],
Sequence@@(List@@@Normal[indices]/."Maeder"->"Uniform")
}

SameQ@@%

Graphics3D/@(polys=Polygon[uniform[[1]],#]&/@uniform[[2]])

Graphics3D[#,Boxed->False]&/@{uniform,polys}

Bulatov

BulatovUniformName[UniformPolyhedronIndex[stdname,"Kaleido"]]

BulatovUniformGraphics3D[UniformPolyhedronIndex[stdname,"Kaleido"],Boxed->False]

bulatov=BulatovUniformPolyhedron[UniformPolyhedronIndex[stdname,"Kaleido"]]

Graphics3D/@(polys=Polygon[bulatov[[1]],#]&/@bulatov[[2]])

PolyhedronFaceTally[bulatov]

Graphics3D[#,Boxed->False]&/@{bulatov,polys}

Maeder

MaederUniformName[UniformPolyhedronIndex[stdname,"Maeder"]]

wythoff=MaederWythoffSymbol[UniformPolyhedronIndex[stdname,"Maeder"]]

With[{n=UniformPolyhedronIndex[stdname,"Maeder"]},Import["https://www.mathconsult.ch/static/unipoly/"<>If[n<10,"0",""]<>ToString[n]<>".html","Images"]][[1]]

maeder=MaederUniformPolyhedron[UniformPolyhedronIndex[stdname,"Maeder"]]

Graphics3D/@(polys=Polygon[maeder[[1]],#]&/@maeder[[2]])

PolyhedronFaceTally[maeder]

Graphics3D[#,Boxed->False]&/@{maeder,polys}

Properties: "GreatIcosahedron" == {"IcosahedronStellation", 11}, {"Uniform", 53}, {"UniformDual", 52}

Kepler-Poinsot solid consisting of intersecting triangular faces

Initialization

<<MathWorld`Polyhedra`

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

AlternateStandardNames

PolyhedronData[pname,"AlternateStandardNames"]

Circumsphere

PolyhedronData["GreatIcosahedron","Circumsphere"]

SimplifyNumericallyDistinct[Norm/@PolyhedronData["GreatIcosahedron","VertexCoordinates"]]//Union

EdgeLengths

PolyhedronData["GreatIcosahedron","EdgeLengths"]

Faces

Show[GraphicsArray[partition[PolyhedronFaces[Polyhedron[GreatIcosahedron][[1]]],5]]]

Graphics3D/@PolyhedronData["GreatIcosahedron","Polygons"]

Graphics3D[{Hue[RandomReal[]],#}&/@PolyhedronData["GreatIcosahedron","Polygons"]]

GeneralizedDiameter

PolyhedronData["GreatIcosahedron","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["GreatIcosahedron","Hull",#]&/@{"Name","Scale"}

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===hullname&]

InertiaTensor

PolyhedronData["GreatIcosahedron","InertiaTensor"]

Net

PolyhedronData["GreatIcosahedron","Net"]

Polygons

PolyhedronFaceTally[p]

Graphics3D/@PolyhedronData["GreatIcosahedron","Polygons"]

RegionFunction

PolyhedronData["GreatIcosahedron","RegionFunction"]

Simple

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData["GreatIcosahedron","Skeleton"]

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

GraphData[gn,"PolyhedralEmbeddings"]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

PolyhedronData[pname,"F"]

PolyhedronFaceTally[p]

20 times area of an equilateral triangle with edge length == 1

(20)((1/4)(Sqrt[3]))

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

SurfaceArea[p]//ToAlgebraicRoot//FullSimplify

bug(440963): WindingPolygon[triangle] generates very large expressions

Total[Area/@(PolyhedronData[pname,"Polygons"]/.Polygon[v_]:>WindingPolygon[v,"EvenOddRule"])]//ToAlgebraicRoot//Timing

Total[Area/@(PolyhedronData[pname,"Polygons"]/.Polygon[v_]:>WindingPolygon[v,"NonzeroRule"])]//ToAlgebraicRoot//Timing

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

The volume isn't necessarily well defined since the faces intersect only another and it is only the complete collection of them that enclose a volume (which has bits of the faces inside it)

PolyhedronData["GreatIcosahedron","Volume"]

Properties: {"IcosahedronStellation", 11}

non-convex hull consisting of isosceles triangular faces

Initialization

p=PolyhedronData[{"IcosahedronStellation",11},"Polyhedron"]

Centroid

xbar1=RegionCentroid[p];//Timing

xbar2=PolyhedronCentroid[p,vol];//Timing

N/@{xbar1,xbar2}//Chop

ByteCount/@{xbar1,xbar2}

xbar2

Circumsphere

PolyhedronData[{"IcosahedronStellation",11},"Circumsphere"]

SimplifyNumericallyDistinct[Norm/@PolyhedronData[{"IcosahedronStellation",11},"VertexCoordinates"]]//Union

EdgeLengths

PolyhedronData[{"IcosahedronStellation",11},"EdgeLengths"]

N[%]

RootReduce[PolyhedronData[{"IcosahedronStellation",11},"Lines"]/.Line[x_]:>EuclideanDistance@@x]//FullSimplify

Tally[%]

SortBy[%[[All,1]],N]

N[%]

Faces

Show[GraphicsArray[partition[PolyhedronFaces[myGi[[1]]],5]]]

GeneralizedDiameter

PolyhedronData[{"IcosahedronStellation",11},"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify

InertiaTensor

PolyhedronData[{"IcosahedronStellation",11},"InertiaTensor"]

N[%]

i1=MomentOfInertia[p,{0,0,0}]/vol;//Timing

N[i1]//Chop

FullSimplify[RootReduce[i1]]//Timing

PolyhedronInertiaTensor[p//N,vol]//Chop

i2=PolyhedronInertiaTensor[p,vol];//Timing

i2

N[i2]

Net

PolyhedronData[{"IcosahedronStellation",11},"Net"]

Polygons

Graphics3D/@PolyhedronData[{"IcosahedronStellation",11},"Polygons"]

RegionFunction

reg=PolyhedronData[{"IcosahedronStellation",11},"RegionFunction"]

Length[v=PolyhedronData[{"IcosahedronStellation",11},"VertexCoordinates"]]

Graphics3D[{PolyhedronData[{"IcosahedronStellation",11},"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

To get region, add pyramids forming dimpled interior.  Then append star spikes

Graphics3D[AugmentedPolyhedron[PolyhedronData["Dodecahedron","Polyhedron"],-Sqrt[1/10(5-Sqrt[5])]]]

Simple

SimplePolyhedronQ[PolyhedronData[{"IcosahedronStellation",11},"Polyhedron"]]

Skeleton

g=PolyhedronData[{"IcosahedronStellation",11},"Skeleton"]

r=RecognizeGraph[g]

GraphData[r,"Graph","All"]

SurfaceArea

PolyhedronData[{"IcosahedronStellation",11},"SurfaceArea"]

SurfaceArea[p]//RootReduce//FullSimplify

Volume

vol=PolyhedronData[{"IcosahedronStellation",11},"Volume"]

Volume[p]//FullSimplify//Timing

Volume[p]//FullSimplify//Timing

N[((25 (9+5 (Sqrt[5])))/(8 (Sqrt[2])))]

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

Convex Hull

Intersecting

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

solid=npoly;
hull=ConvexHull3D[PolyhedronVertices[solid]];
WriteLiveForm["gricohul.m",
Show[Graphics3D[{
solid,
Thickness[.01],SpiderWeb/@hull
},opts]]
]

solid=Polyhedron[GreatIcosahedron][[1]];
hull=ConvexHull3D[PolyhedronVertices[solid]];
WriteLiveForm["gricohul.m",
Show[Graphics3D[{
solid,
Thickness[.01],SpiderWeb/@hull
},Boxed->False]]
]

Show[GraphicsArray[{
Graphics3D[{
solid,
Thickness[.01],SpiderWeb/@hull
},Boxed->False],
Graphics3D[hull,Boxed->False]
}],GraphicsSpacing->{-.2,0}]

Platonic

VertexSubsetHulls[p,"Platonic","Icosahedra"->True]//Timing

Split

p={"GreatIcosahedron","Split"};
v=PolyhedronData[p,"VertexCoordinates"];

Platonic

(h=VertexSubsetHulls[p,"Platonic"])//Timing

h2=Insert[h,"Icosahedron"->{{1,2,3,16,19,46,47,74,77,90,91,92}},-2]

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

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

GraphicsGrid[Partition[g,3],Spacings->-100]

Icosahedron

VertexSubsetHulls[p,"Icosahedron"]//Timing

v3=Position[v,_?(N[Norm[#]]==s[[3]]&),1]//Flatten

Graphics3D[{PolyhedronData[{"GreatIcosahedron","Split"},"Faces"],PointSize[.05],Point[v[[v3]]]},Boxed->False]

Graphics3D[ch3=ConvexHull3D[v[[v3]]],Boxed->False]

Truncated Icosahedron (Squashed)

v1=Position[v,_?(N[Norm[#]]==s[[1]]&),1]//Flatten

Graphics3D[{PolyhedronData[{"GreatIcosahedron","Split"},"Faces"],PointSize[.1],Point[v[[v1]]]},Boxed->False]

Graphics3D[ch1=ConvexHull3D[v[[v1]]],Boxed->False]

Construction: "GreatIcosahedron"

From equilateral triangles in the Icosahedron

Graphics3D[{FaceForm[Green,Red],Polygon/@Select[Subsets[PolyhedronData["Icosahedron","Vertices"],{3}],Union[FullSimplify[Norm/@(Subtract@@@Partition[#,2,1,1])]]=={GoldenRatio}&]}]

v=PolyhedronData["Icosahedron","Vertices"];
Graphics3D[{FaceForm[Green,Red],poly=Polyhedron[v,Select[Subsets[Range[Length[v]],{3}],Union[FullSimplify[Norm/@(Subtract@@@Partition[v[[#]],2,1,1])]]=={GoldenRatio}&]]}]

Construction: {"IcosahedronStellation", 11}

Core from cumulation

Graphics3D[core=AugmentedPolyhedron[PolyhedronData["Dodecahedron","Polyhedron"],-Sqrt[1/10(5-Sqrt[5])],WorkingPrecision->Infinity]]

Length[vcore=Union[RootReduce@core[[1]]]]//Quiet

Tally[RootReduce[Norm/@vcore]]

Ratio of the distance to the dimple center to the distance to a point on the rim:

coreratio=((NumericalApproximation[Root, (RowDefault["0.588", FEExpressionsNumericalApproximationElider]), Root[5-20 ((#1)^2)+16 ((#1)^4)&,3], ])/(NumericalApproximation[Root, (RowDefault["1.40", FEExpressionsNumericalApproximationElider]), Root[9-36 ((#1)^2)+16 ((#1)^4)&,4], ]))//RootReduce//FullSimplify

Graphics3D[triangles=Polygon[core[[2]]/.i_Integer:>core[[1,i]]]]

(SquaredEuclideanDistance@@@Partition[#,2,1,1])&/@triangles[[1]]//RootReduce//Quiet//Timing

Pentagrammic pyramid net

rim=Table[{Cos[2Pi i/16],Sin[2Pi i/16]},{i,9,-1,-1}];
rim2=Table[{{Cos[2Pi (i-1)/16],Sin[2Pi (i-1)/16]},
(1+(Sqrt[2-(Sqrt[2+(Sqrt[2])])])){Cos[2Pi i/16],Sin[2Pi i/16]},
{Cos[2Pi i/16],Sin[2Pi i/16]}
},{i,8,-1,-2}];

Show[Graphics[{
Line[rim],
Line[{{0,0},#}]&/@rim,
Line/@rim2
}],AspectRatio->Automatic,PlotRange->All]

Pentagrammic pyramids

addn[n_,k_,m_]:=Mod[n+k-1,m]+1

addn[i_,di_,m_]:=Mod[i+di,m]/. 0->m

Distance from the centroid of the dimpled core to a dimple center:

r=Min[Norm/@PolyhedronCoordinates[core]]//RootReduce//FullSimplify//Quiet

pentgrammicPyramid[rim_List,c_List]:=Module[{i,r,
(*
h=Normalize[c](1+GoldenRatio) *)
h=Normalize[c](Sqrt[(25/8)+((11 (Sqrt[5]))/8)])},
r=Table[(rim[[i]]+rim[[addn[i,1,5]]])/2-Sqrt[15]/10 Normalize[((rim[[i]]+rim[[addn[i,1,5]]])/2-c)],{i,5}];
Table[{
Polygon[{rim[[i]],r[[i]],h}],
Polygon[Reverse@{rim[[addn[i,1,5]]],r[[i]],h}],
Polygon[{rim[[i]],rim[[addn[i,1,5]]],r[[i]]}]
},{i,5}]
]

Length[dodecpolys=RootReduce[PolyhedronData["Dodecahedron","Polygons"]]]

(pyramids=Table[pentgrammicPyramid[f=dodecpolys[[i,1]],RootReduce[r Normalize[Mean[f]]]],{i,12}]//RootReduce);//Quiet//Timing

Graphics3D[{FaceForm[Green,Red],pyramids},Axes->True]

Pick the upward-pointing pyramid:

Graphics3D[pyramid=pentgrammicPyramid[f=dodecpolys[[4,1]],r Normalize[Mean[f]]]]

v=RootReduce[Union@@Flatten[pyramid][[All,1]]]//Union

Length[v]

Tally[RootReduce[Norm/@v]]

N[%]

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

(EuclideanDistance@@@Partition[#,2,1,1])&/@RootReduce[Flatten[pyramid][[All,1]]]//RootReduce//Quiet

Union@@%

edgelengths=SortBy[%169,N]

N[edgelengths]

Find the intersection of the five planes determine by the "flaps" of the pyramid:

RegionIntersection@@(InfinitePlane/@({{5,3,10},{3,4,7},{6,11,4},{2,9,6},{5,8,2}}/.i_Integer:>v[[i]]))//RootReduce

This agrees with r.

Now pick a pyramid adjacent to the first:

Graphics3D[pyramid2=pentgrammicPyramid[f=dodecpolys[[2,1]],r Normalize[Mean[f]]]]

Graphics3D[{pyramid,pyramid2}]

v2=RootReduce[Union@@Flatten[pyramid2][[All,1]]]//Union

{Graphics3D[{
pyramid,MapIndexed[Text[Subscript[#2[[1]],1],#,Background->White]&,v]
}],Graphics3D[{
pyramid,MapIndexed[Text[Subscript[#2[[1]],1],#,Background->White]&,v],
pyramid2,MapIndexed[Text[Subscript[#2[[1]],2],#,Background->White]&,v2]
}]}

Line of intersection of adjacent pyramids:

Intersection[v,v2]

Figure out spike height if the variable h in pentagrammicPyramid is set incorrectly (say 1+GoldenRatio):

PlaneNormal[InfinitePlane[{v1_,v2_,v3_}]]:=Normalize[Cross[v1-v2,v3-v2]]

n1=FullSimplify[PlaneNormal[InfinitePlane[{z,1,1}v[[{1,3,7}]]]],z>0]

n2=PlaneNormal[InfinitePlane[v2[[{5,3,10}]]]]//RootReduce

Solve[n1[[2]]==n2[[2]],z]//FullSimplify

N[%]

Use the corrected height and make sure corresponding faces on adjacent pyramids are coplanar:

n1=RootReduce[PlaneNormal[InfinitePlane[v[[{1,3,7}]]]]]

n2=PlaneNormal[InfinitePlane[v2[[{5,3,10}]]]]//RootReduce

Display built-in and constructed:

pyramids2=pyramids/.Polygon[v_]:>Polygon[RootReduce[v/edgelengths[[1]]]];

{
Graphics3D[{Opacity[.5],FaceForm[Red],pyramids2},Axes->True],
Graphics3D[{Opacity[.5],FaceForm[Yellow],N@PolyhedronData[{"IcosahedronStellation",11},"GraphicsComplex"]},Axes->True]}

Show[%]

Length[vs=Union@@Flatten[pyramids2][[All,1]]]

Graphics3D[{FaceForm[Green,Red],poly=Polyhedron[vs,Flatten[pyramids2][[All,1]]/.Thread[vs->Range[Length[vs]]]]}]

Verify that the volume of the constructed solid:

Volume[poly]//RootReduce//Quiet//Timing

(NumericalApproximation[Root, (RowDefault["44.6", FEExpressionsNumericalApproximationElider]), Root[47265625-2060000 ((#1)^2)+1024 ((#1)^4)&,4], ])//FullSimplify

… agrees with the built-in:

PolyhedronData[{"IcosahedronStellation",11},"Volume"]

PolyhedronData[{"IcosahedronStellation",11},"Volume"]//N

Volume[PolyhedronData[{"IcosahedronStellation",11},"Polyhedron"]]//RootReduce//Quiet//Timing

Triangular Face

h=Sqrt[3]/2(1+2GoldenRatio);
a={0,0}; 
b={-(1/2+GoldenRatio),h};
c={1/2+GoldenRatio,h};
(Subscript[a, 1])={-1/2,h};
(Subscript[a, 2])={1/2,h};
m=((Subscript[a, 1])+(Subscript[a, 2]))/2;
(Subscript[c, 1])=(b-a)GoldenRatio/(1+2GoldenRatio);
(Subscript[c, 2])=(b-a)(1+GoldenRatio)/(1+2GoldenRatio);
(Subscript[b, 2])=(c-a)GoldenRatio/(1+2GoldenRatio);
(Subscript[b, 1])=(c-a)(1+GoldenRatio)/(1+2GoldenRatio);
P=LineLineIntersection[{(Subscript[b, 1]),(Subscript[a, 1])},{(Subscript[c, 2]),(Subscript[a, 2])}];
(Subscript[P, 1])=LineLineIntersection[{(Subscript[a, 1]),(Subscript[c, 1])},{b,(Subscript[b, 1])}];
(Subscript[P, 2])=LineLineIntersection[{(Subscript[a, 2]),(Subscript[b, 2])},{(Subscript[c, 2]),c}];
(Subscript[T, 1])=LineLineIntersection[{(Subscript[c, 2]),(Subscript[b, 1])},{(Subscript[c, 1]),(Subscript[a, 2])}];
(Subscript[T, 2])=LineLineIntersection[{(Subscript[c, 2]),c},{(Subscript[a, 1]),(Subscript[b, 2])}];
(Subscript[T, 3])=LineLineIntersection[{(Subscript[c, 2]),(Subscript[b, 1])},{(Subscript[a, 1]),(Subscript[b, 2])}];
Show[Graphics[{
{GrayLevel[.7],Polygon/@{{b,(Subscript[P, 1]),(Subscript[a, 1])},{c,(Subscript[P, 2]),(Subscript[a, 2])},{P,(Subscript[a, 1]),(Subscript[a, 2])}}},
{GrayLevel[0],Polygon[{(Subscript[T, 1]),(Subscript[T, 2]),(Subscript[T, 3])}]},
PointLabels[{a,"A",b,"B",c,"C",m,"M",
(Subscript[a, 1]),"(Subscript[A, 1])",(Subscript[a, 2]),"(Subscript[A, 2])",(Subscript[b, 1]),"(Subscript[B, 1])",(Subscript[b, 2]),"(Subscript[B, 2])",(Subscript[c, 1]),"(Subscript[C, 1])",(Subscript[c, 2]),"(Subscript[C, 2])",
P,"P",(Subscript[P, 1]),"(Subscript[P, 1])",(Subscript[P, 2]),"(Subscript[P, 2])",(Subscript[T, 1]),"(Subscript[T, 1])",(Subscript[T, 2]),"(Subscript[T, 2])",(Subscript[T, 3]),"(Subscript[T, 3])"
},.02,{.02,.02}],
Line[{a,b,c,a}],
Line/@{{(Subscript[c, 2]),c},{(Subscript[b, 1]),b},{(Subscript[c, 1]),(Subscript[a, 1])},{(Subscript[a, 2]),(Subscript[b, 2])},{(Subscript[b, 2]),(Subscript[a, 1])},{(Subscript[c, 1]),(Subscript[a, 2])},{(Subscript[c, 2]),(Subscript[a, 2])},{(Subscript[b, 1]),(Subscript[a, 1])},{(Subscript[c, 2]),(Subscript[b, 1])}}
}],AspectRatio->Automatic]

FullSimplify[FunctionExpand[m-P]]

FullSimplify[FunctionExpand[m-(Subscript[T, 2])]]

FullSimplify[FunctionExpand[(Subscript[T, 3])-(Subscript[T, 1])]]

Together//@FullSimplify[FunctionExpand[Sqrt[(c-(Subscript[P, 2])).(c-(Subscript[P, 2]))]]]

Together//@FullSimplify[FunctionExpand[Sqrt[((Subscript[a, 2])-(Subscript[P, 2])).((Subscript[a, 2])-(Subscript[P, 2]))]]]