Pentagonal Icositetrahedron

Author

Eric W. Weisstein
January 5, 2024

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

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

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

Figure

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

Solid

PolyhedronData["PentagonalIcositetrahedron","DefaultOrientation"]

PolyhedronData["PentagonalIcositetrahedron","Orientations"]

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

Compound of enantiomers

Show[%]

Solid and Dual

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

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

Dextro

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

Show[Most@%]

Laevo

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

Show[Most@%]

Net

PolyhedronData["PentagonalIcositetrahedron","Net"]

PolyhedronData["PentagonalIcositetrahedron","Net","Colored"]

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

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//RootReduce//Timing

PolyhedronCentroid[p]//RootReduce//Timing

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

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

s=RootReduce[Union[PolyhedronEdgeLengths[poly]]]

InputForm[%]

N[%]

t=Root[x^3-x^2-x-1,1]

RootReduce[(Sqrt[(1/(t+1))])]

RootReduce[(1/2)(Sqrt[t+1])]

Faces

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

PolyhedronFaceCounts[poly]

angles=FullSimplify[ArcCos/@(Dot[#1,-#2]&@@@Map[Unit,(Subtract@@@Nest[Partition[#,2,1,1]&,First[Polyhedron[PentagonalIcositetrahedron][[1]]],2]),{2}])]

N[Plus@@angles/Pi,20]

angles 180./Pi

RootReduce[(1/2)(1-t)]

RootReduce[2-t]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[p]//RootReduce//Timing

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//RootReduce//Timing

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

Root[-9879408+142560 ((#1)^2)-684 ((#1)^4)+((#1)^6)&,2]//StandardForm

RootReduce[3(Sqrt[((22(5t-1))/(4t-3))])]

RootReduce[PolyhedronSymmetricSurfaceArea[poly]/s[[1]]^2]

InputForm[%]

VertexSubsetHulls

(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

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

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

t=ExactConstant["tribonacci constant"];

RootReduce[PolyhedronSymmetricVolume[poly]]

RootReduce[(Sqrt[((11(t-4))/(2(20t-37)))])]

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

InputForm[%]

Perspective projections

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

{(NumericalApproximation[Root, (RowDefault["0.296", FEExpressionsNumericalApproximationElider]), Root[-1+3 #1+((#1)^2)+((#1)^3)&,1], ]),0,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{(NumericalApproximation[Root, (RowDefault["0.296", FEExpressionsNumericalApproximationElider]), Root[-1+3 #1+((#1)^2)+((#1)^3)&,1], ]),0,1},VertexLabels->"Name"]

g=PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{x,0,1},VertexLabels->"Name"]

v=GraphEmbedding[g];

FullSimplify[v[[37]]-v[[26]],x>0]

Solve[Thread[%==0],x]//FullSimplify

{(NumericalApproximation[Root, (RowDefault["0.544", FEExpressionsNumericalApproximationElider]), Root[-1+#1+((#1)^2)+((#1)^3)&,1], ]),0,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{(NumericalApproximation[Root, (RowDefault["0.544", FEExpressionsNumericalApproximationElider]), Root[-1+#1+((#1)^2)+((#1)^3)&,1], ]),0,1},VertexLabels->"Name"]

g=PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{x,0,1},VertexLabels->"Name"]

v=GraphEmbedding[g];

FullSimplify[v[[19]]-v[[38]],x>0]

Solve[Thread[%==0],x]//FullSimplify

{0,0,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{0,0,1},VertexLabels->"Name"]

{1,0,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{1,0,1},VertexLabels->"Name"]

{1,1,1}

PolyhedronProjectionGraph[PolyhedronData["PentagonalIcositetrahedron","Polyhedron"],{1,1,1},VertexLabels->"Name"]

Construction via Dual

Laevo

Show[Graphics3D[dual=Dual[Polyhedron[SnubCube]]],Boxed->False]//Timing

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

And@@OrientedQ[poly]

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

Dextro

Show[Graphics3D[dual=Dual[Polyhedron[SnubCube,"dextro"]]],Boxed->False]//Timing

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

And@@OrientedQ[poly]

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

Net construction

<<MathWorld`Graphs`

{a,b}=PolyhedronData["PentagonalIcositetrahedron","EdgeLengths"]

v=PolyhedronData["PentagonalIcositetrahedron","VertexCoordinates"];

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

{α,β}=SortBy[Union@ArcCos[ToAlgebraicRoot/@Cos[PolygonAngle[Polygon[v[[{2,33,35,26,29}]]]]]]//Quiet,N]

N[%]

r[i_,ang_,{i1_,i2_},sc_:1]:=v[[i]]+RotationMatrix[ang].(v[[i1]]-v[[i2]])sc

v={{0,0},{1,0},RotationMatrix[-β].{1,0},RotationMatrix[β].{1,0}};
v=Join[v,{v[[3]]+RotationMatrix[-β].(v[[1]]-v[[3]])}];
v=Join[v,{v[[5]]+RotationMatrix[-β].(v[[3]]-v[[5]])b}];
v=Join[v,{r[4,β,{1,4},b],r[2,-β,{1,2}]}];
v=Join[v,{r[2,-β,{8,2},b],r[8,β,{2,8}]}];
v=Join[v,{r[10,β,{8,10}]}];
v=Join[v,{r[11,-β,{10,11}],r[10,β,{11,10}]}];
v=Join[v,{r[13,β,{10,13},b],r[12,β,{11,12}]}];
v=Join[v,{r[15,β,{12,15}]}];
v=Join[v,{r[16,β,{15,16},b]}];
v=Join[v,{r[16,-β,{15,16}],r[15,β,{16,15}]}];
v=Join[v,{r[19,β,{15,19},b]}];
v=Join[v,{r[18,β,{16,18}]}];
v=Join[v,{r[21,β,{18,21}]}];
v=Join[v,{r[22,β,{21,22},b]}];
v=Join[v,{r[12,-β,{14,12},1/b],r[14,α,{12,14}]}];
v=Join[v,{r[24,-β,{12,24}]}];
v=Join[v,{r[26,-β,{25,26},b],r[25,β,{26,25}]}];
v=Join[v,{r[28,β,{25,28}]}];
v=Join[v,{r[25,β,{28,25},b],r[28,-β,{25,28}]}];
v=Join[v,{r[31,-β,{28,31}],r[13,-β,{10,13}],r[10,β,{13,10}]}];
v=Join[v,{r[34,β,{10,34},b]}];
v=Join[v,{r[33,β,{13,33}]}];
v=Join[v,{r[36,β,{33,36}]}];
v=Join[v,{r[37,β,{36,37},b]}];
v=Join[v,{r[1,β,{4,1}],r[4,-β,{1,4}]}];
v=Join[v,{r[40,-β,{4,40},b],r[4,-β,{40,4},b],r[40,β,{4,40}]}];
v=Join[v,{r[43,β,{40,43}],r[40,β,{43,40},b],r[43,-β,{40,43}]}];
v=Join[v,{r[46,-β,{43,46}],r[43,-β,{46,43}]}];
v=Join[v,{r[48,-β,{43,48}],r[46,β,{43,46},b]}];
v=Join[v,{r[48,-β,{49,48},b],r[49,β,{48,49}]}];
v=Join[v,{r[52,β,{49,52}],r[52,-β,{49,52}],r[49,β,{52,49},b]}];
v=Join[v,{r[54,-β,{52,54}]}];
v=Join[v,{r[45,α,{47,45}],r[47,-2β,{46,47}]}];
v=Join[v,{r[58,-β,{47,58}]}];
v=Join[v,{r[57,β,{59,57}]}];
v=Join[v,{r[60,β,{57,60}],r[59,-β,{57,59},b]}];
v=Join[v,{r[57,β,{60,57},b],r[60,-β,{57,60}]}];
v=Join[v,{r[64,-β,{60,64}]}];
v=Join[v,{r[47,β,{46,47}],r[46,-β,{47,46},b]}];
v=Join[v,{r[66,β,{47,66}]}];
v=Join[v,{r[66,β,{68,66}],r[68,-β,{66,68}]}];
v=Join[v,{r[70,-β,{68,70},b],r[68,-β,{70,68},b],r[70,β,{68,70}]}];
v=Join[v,{r[73,β,{70,73}]}];
faces={{1,3,5,6,2},{1,2,8,7,4},{8,2,9,11,10},{10,11,12,14,13},{12,11,17,16,15},{15,16,18,20,19},{16,23,22,21,18},{14,12,24,26,25},{25,26,27,29,28},{32,30,25,28,31},{10,13,33,35,34},{37,36,33,13,38},{4,40,41,39,1},{42,44,43,40,4},{43,46,47,45,40},{46,43,48,49,50},{48,51,53,52,49},{52,54,56,55,49},{45,47,58,59,57},{59,62,61,60,57},{63,57,60,64,65},{46,67,68,66,47},{68,70,71,69,66},{72,74,73,70,68}};
Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly=Polygon[v,faces],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

PolyhedronData["PentagonalIcositetrahedron","SurfaceArea"]

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

faces=Sort[faces]

v1=FullSimplify@Map[ToAlgebraicRoot,v,{2}]

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

net=GraphicsComplex[v1,Polygon[faces]];

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

%=={a,b}