Jessen's Orthogonal Icosahedron

Author

Eric W. Weisstein
October 16, 2023

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

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

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

StandardName

Changed from "JessensOrthogonalIcosahedron" to "JessenOrthogonalIcosahedron" (possessive s dropped) in V13.2

PolyhedronData["JessensOrthogonalIcosahedron","StandardName"]

Graphics

Solid

PolyhedronData["JessenOrthogonalIcosahedron","Orientations"]

Graphics3D[{Opacity[.8],PolyhedronData["JessenOrthogonalIcosahedron","Polyhedron"]},Boxed->False]

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

Graphic

GraphicsRow[Graphics3D[{Opacity[.8],PolyhedronData["JessenOrthogonalIcosahedron","Polyhedron"]},ViewPoint->#,ViewVertical->{0,0,1},Boxed->False]&/@{{1.3,-2.4,2},{0,10,0},{2,0,5}}]

Show[Graphics3D[{frame[octahedron[1]],
			{PointSize[.02],Point/@OctahedronIcosahedronPoints[2]},
		JessensOrthogonalPolyhedron
		}],Boxed->False,PlotRange->All,ViewPoint->{2.348, -1.728, 1.718}]

Flatten[Thread/@PolyhedronData["JessenOrthogonalIcosahedron","VertexSubsetHulls"]]

Graphics3D[{
{Opacity[.5],PolyhedronData["JessenOrthogonalIcosahedron","Polyhedron"]},
Thick,PolyhedronLines[ConvexHullRegion[PolyhedronData["JessenOrthogonalIcosahedron","Vertices"][[#2]]]]
},Boxed->False]&@@@Flatten[Thread/@PolyhedronData["JessenOrthogonalIcosahedron","VertexSubsetHulls"]]

j=JessensOrthogonalPolyhedron[][[2]];
v=j /. Polygon->centroid;
Show[Graphics3D[{
			{PointSize[.03],Point/@v},
			Polygon[v[[{1,2,8,7}]]],
			Polygon[v[[{3,4,6,5}]]],
			Polygon[v[[{1,2,5,6}]]],
			Polygon[v[[{2,5,3,8}]]],
			Polygon[v[[{1,6,4,7}]]],
			Polygon[v[[{3,4,7,8}]]],
			j /. Polygon->line
		}],Boxed->False]

v=FullSimplify[PolyhedronData["JessenOrthogonalIcosahedron","Polygons"]/.Polygon[v_]:>Mean[v]]

Graphics3D[{
PolyhedronLines[PolyhedronData["JessenOrthogonalIcosahedron","Polyhedron"]],
Point[v],
ConvexHullRegion[v]
},Boxed->False]

Net

PolyhedronData["JessenOrthogonalIcosahedron","Net"]

Properties

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="JessenOrthogonalIcosahedron","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]//FullSimplify//Timing

PolyhedronCentroid[p]//FullSimplify//Quiet//Timing

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]//FullSimplify

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

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

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

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

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

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

v=PolyhedronCoordinates[convexhull]

Sort[(convexhull[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]//Tally//FullSimplify

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[convexhullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

Faces

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p,{0,0,0}])/vol)//RootReduce//Timing

PolyhedronInertiaTensor[p]//Timing

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

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

Integrate over polyhedron [unevaluated]

$Version

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

Integrate over polyhedron [wrong]

bug(428846): Integrate[Sqrt[x^2 + y^2], {x, y, z} ∈ PolyhedronData["JessenOrthogonalIcosahedron", "Polyhedron"]] gives wrong complex result

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

N[i]

CAD over  1/XX [no region function]

PolyhedronData[pname,"RegionFunction"]

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&]

Show[Graphics3D[{Opacity[.2],p}],RegionPlot3D[ImplicitRegion[reg,{x,y,z}],PlotPoints->50]]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)//FullSimplify

cad=CylindricalDecomposition[reg,{x,y,z},"Function"]

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

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

ByteCount[rxyzlog=LogSimplify[rxyz,"ZeroTestNumericalPrecision"->10000,WorkingPrecision->10000,Debug->True]]//Timing

ByteCount[rxyzcollect=Collect[TrigToExp[rxyzlog],Log[_]]//RootReduce]//Timing

Divergence theorem [bad integrals #16, 17]

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

Polygon 16

NIntegrate[1/18 (-Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+s Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+t Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+4 s t Log[6]-8 s t Log[-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]]+4 ((s)^2+(t)^2) Log[(-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2])/Sqrt[6]]),{t,0,1},{s,0,1-t}]

bug(428636): Integrate[1/4 Sqrt[1/4 + (1/2 - s)^2] - 1/2 (1/2 - s)^2 Log[-(1/2) + Sqrt[1/4 + (1/2 - s)^2]], {t, 0, 1}, {s, 0, 1 - t}] returns result with incorrect imaginary part

(i1=Integrate[1/18 (-Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+s Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+t Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+4 s t Log[6]-8 s t Log[-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]]+4 ((s)^2+(t)^2) Log[(-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2])/Sqrt[6]]),{t,0,1},{s,0,1-t}])//Timing

N[i1]

Integrate[1/18 (-Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+s Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+t Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+4 s t Log[6]-8 s t Log[-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]]+4 ((s)^2+(t)^2) Log[(-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2])/Sqrt[6]]),{s,0,1-t}]

i1s=Integrate[1/18 (-Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+s Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+t Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]+4 s t Log[6]-8 s t Log[-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2]]+4 ((s)^2+(t)^2) Log[(-1+s+t+Sqrt[1-2 s+5 (s)^2-2 t-6 s t+5 (t)^2])/Sqrt[6]]),s]

i1ss=FullSimplify[Limit[i1s,s->1-t,Direction->"FromAbove"]-Limit[i1s,s->0,Direction->"FromBelow"]]

NIntegrate[i1ss,{t,0,1},WorkingPrecision->20]

(i1st = Integrate[i1ss, {t, 0, 1}])//Timing

N[i1st]

Polygon 17 [wrong even when done as indefinite]

bug(441127)

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-t}]

(i1=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-t}])//Timing

N[i1]

(i2=Integrate[1/108 (-6 s Sqrt[5 s^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 s^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-t},GenerateConditions->True])//Timing

N[i2]

Plot3D[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-t}]

i2s=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),s]

i2s=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),s,GenerateConditions->True]

i2s/.{t->.5,s->.5}

Plot3D[#[i2s],{t,0,1},{s,0,1-t},PlotRange->All,AxesLabel->{t,s},PlotPoints->100]&/@{Re,Im}

Solve[s==1-2t,t]

Show[
Plot3D[Im[i2s],{t,0,1},{s,0,1-t},PlotRange->All,AxesLabel->{t,s},PlotPoints->100],
ParametricPlot3D[{t,s,Im[i2s]}/.s->(1-1.99t),{t,0,1}],PlotRange->{{0,1},{0,1},Automatic}]

i2ss=FullSimplify[Limit[i2s,s->1-t,Direction->"FromAbove"]-Limit[i2s,s->0,Direction->"FromBelow"]]

i2ss=(4/27) (((-1+2 t))^3) Log[1-2 t]-(((((1-2 t))^2) (100 (Sqrt[(((-1+2 t))^2)])+125 (-1+2 t) Log[4 (((1-2 t))^2)]-2 (Sqrt[5]) (-1+2 t) (Log[4-8 t-2 (Sqrt[5]) (Sqrt[(((-1+2 t))^2)])]+6 Log[4-8 t+2 (Sqrt[5]) (Sqrt[(((-1+2 t))^2)])])))/3375)+(1/108) (-8 (((1-2 t))^2) (-1+t)-(8/3) (((-1+t))^3)+8 (((-1+t))^2) (-1+2 t)+(2/25) (Sqrt[1+t (-2+5 t)]) (-11+t (4+11 t))+(4/25) (Sqrt[1+t (-2+5 t)]) (3+t (-17+22 t))-16 (((-1+2 t))^3) Log[-t]-4 (-1+t) (1+t (-5+7 t)) (Log[6]-2 Log[1-t+(Sqrt[1+t (-2+5 t)])])+8 (((-1+2 t))^3) Log[-1+t+(Sqrt[1+t (-2+5 t)])]-((8 (((-1+2 t))^3) Log[-1-3 t-(Sqrt[5+5 t (-2+5 t)])])/(25 (Sqrt[5])))-((48 (((-1+2 t))^3) Log[-1-3 t+(Sqrt[5+5 t (-2+5 t)])])/(25 (Sqrt[5]))));

i2ss/.t->.2

Plot[Evaluate@Through[{Re,Im}[i2ss]],{t,0,1}]

NIntegrate[i2ss,{t,0,1},WorkingPrecision->30]

NIntegrate[Re@i2ss,{t,0,1},WorkingPrecision->30]

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-t},WorkingPrecision->30]

(i1st = Integrate[i2ss, {t, 0, 1}])//Timing

Solve[s==1-2t,t]

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-2t,1-t}]

(i3=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-2t,1-t}])//Timing

(i1=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,0,1-2t}])//Timing

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,1-2t,1-t}]

(i2=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,1-2t,1-t}])//Timing

N[i2]

(i2=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1},{s,1-2t,1-t},GenerateConditions->True])//Timing

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1/2,1},{s,0,1-t}]

eww% math14.0
Mathematica 14.0.0 Kernel for Mac OS X ARM (64-bit)
Copyright 1988-2023 Wolfram Research, Inc.

In[1]:= $Version                                                                
Out[1]= 14.0.0 for Mac OS X ARM (64-bit) (October 16, 2023)

In[2]:= i = Integrate[1/108 (-6 s Sqrt[5 (s)^2 + 4 (1 - 2 t)^2 + 8 s (-1 + 2 t)] - 24 (-1 + s + 2 t)^2 Log[(s + Sqrt[5 (s)^2 + 4 (1 - 2 t)^2 + 8 s (-1 + 2 t)])/Sqrt[6]]), {t, 0, 1/2, 1}, {s, 0, 1 - t}]; // Timing                            
Out[2]= {1069.96, Null}

In[3]:= NumericQ[i]                                                             
Out[3]= False

In[4]:= Head[i]                                                                 
Out[4]= Integrate

(ii=Integrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1/2,1},{s,0,1-t}])//Timing

NIntegrate[1/108 (-6 s Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)]-24 (-1+s+2 t)^2 Log[(s+Sqrt[5 (s)^2+4 (1-2 t)^2+8 s (-1+2 t)])/Sqrt[6]]),{t,0,1/2,1},{s,0,1-t}]

Divergence theorem (GenerateConditions -> True) [unevaluated integrals]

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

Divergence theorem ("IntegrationIntervals"->{0,1/2,1})

(rxy=MeanCylindricalRadius[p,Debug->True,"IntegrationIntervals"->{0,1/2,1},"Simplification"->FullSimplify])//Timing

N[rxy,20]

ByteCount[rxy]

rxylog=LogSimplify[rxy]

N[%]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

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

(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)

Integrate over polyhedron [unevaluated]

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

Divergence theorem [unevaluated integrals]

48 GB+

(rxy=MeanSphericalRadius[p,Debug->True,"IntegrationIntervals"->{0,1/2,1},"Simplification"->Simplify])//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

N[%]

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

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

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//FullSimplify//Timing

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

VertexSubsetHulls

PolyhedronData[pname,"VertexSubsetHulls"]

Graphics3D[p]

Graphics3D[{
{Red,p},
{Opacity[.4],Blue,ConvexHullRegion[PolyhedronData[pname,"Vertices"][[#2]]]}
}]&@@@Flatten[Thread/@PolyhedronData[pname,"VertexSubsetHulls"]]

Platonic

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

Volume

PolyhedronData["JessensOrthogonalIcosahedron","Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Construction

V13.2

pV131=PolyhedronData["JessensOrthogonalIcosahedron","Polyhedron"]

https://en.wikipedia.org/wiki/Jessen%27s_icosahedron#Construction_and_geometric_properties

pV132=Polyhedron[]/.Polyhedron[v_,f_]:>Polyhedron[v/.x_?NumericQ:>Which[
Abs[x]==1/4 (1+Sqrt[5]),
	Sign[x] Sqrt[2/3],
Abs[x]==1/2,
	Sign[x] 1/Sqrt[6],
True,
	0
],f]

Graphics3D[pV132]

Shortest edge length == 1 (PolyhedronData convention):

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[pV132]]//Union

Cyclic permutations of the coordinates (±2, ±1, 0) (e.g., Jessen):

FullSimplify[Sqrt[6]%]

Graphics3D[PolyhedronData["JessenOrthogonalIcosahedron","Polyhedron"],ViewPoint->{0,10,0},ViewVertical->{0,0,1}]

PolyhedronData["JessensOrthogonalIcosahedron","DihedralAngles"]//Tally

DihedralAngles[pV132]//Tally

pV132//PolyhedronCoordinates

Pre-V13.2 using 1/ϕ vertices

Graphics3D[p=Polyhedron[{{0,-GoldenRatio^(-1),1-GoldenRatio^(-1)},{0,-GoldenRatio^(-1),-1+GoldenRatio^(-1)},{0,GoldenRatio^(-1),1-GoldenRatio^(-1)},{0,GoldenRatio^(-1),-1+GoldenRatio^(-1)},{1-GoldenRatio^(-1),0,-GoldenRatio^(-1)},{1-GoldenRatio^(-1),0,GoldenRatio^(-1)},{-1+GoldenRatio^(-1),0,-GoldenRatio^(-1)},{-1+GoldenRatio^(-1),0,GoldenRatio^(-1)},{-GoldenRatio^(-1),1-GoldenRatio^(-1),0},{-GoldenRatio^(-1),-1+GoldenRatio^(-1),0},{GoldenRatio^(-1),1-GoldenRatio^(-1),0},{GoldenRatio^(-1),-1+GoldenRatio^(-1),0}},{{6,1,3},{6,1,12},{6,12,5},{6,3,11},{6,5,11},{12,1,10},{12,10,2},{5,12,2},{3,11,9},{1,3,8},{1,10,8},{10,2,7},{10,8,7},{3,9,8},{9,8,7},{5,2,4},{2,7,4},{7,9,4},{11,9,4},{11,4,5}}]]

PolyhedronData["JessensOrthogonalIcosahedron","Polyhedron"]

InputForm[%]

Old

line[l_List]:=Line[Join[l,{l[[1]]}]]
frame[p_]:=Union[Sort[p[[1]] /. Polygon->line]]
centroid[l_List]:=(Plus@@l)/Length[l]

p5[n_]:=Mod[n-1,5]+1
JessensOrthogonalPolyhedron[a_:1,ang_:0]:=Module[
		{topV,botV,top,bot,midtop,midbot,i,quads,tris,
		r=a/(Sqrt[50-10Sqrt[5]]/5)},
	topV=Table[r{2/5 Sqrt[5]Cos[2/5 Pi i+ang],
						2/5 Sqrt[5]Sin[2/5 Pi i+ang],Sqrt[5]/5},
		{i,5}];
	botV=-topV;
	top=Table[{{0,0,r},topV[[i]],topV[[p5[i+1]]]},{i,5}];
	bot=-top;
	midtop=Table[{topV[[i]],botV[[p5[i+3]]],topV[[p5[i+1]]]},{i,5}];
	midbot=-midtop;
		quads={			
			Polygon[{top[[3,1]],top[[3,3]],midtop[[3,2]]}],
			Polygon[{top[[3,1]],top[[3,2]],midtop[[3,2]]}],
			Polygon[{top[[4,2]],top[[4,3]],midbot[[2,3]]}] ,
			Polygon[{top[[4,2]],midbot[[1,3]],midbot[[2,3]]}] ,
			Polygon[{top[[4,1]],top[[4,3]],top[[1,3]]}] , 
			Polygon[{top[[4,3]],top[[5,3]],top[[1,3]]}],
				Polygon[{bot[[2,2]],bot[[2,1]],midbot[[5,1]]}],
				Polygon[{midbot[[1,1]],bot[[2,2]],midbot[[5,1]]}],
				Polygon[{bot[[4,2]],midbot[[4,2]],midtop[[3,1]]}],
				Polygon[{midtop[[3,1]],midbot[[5,1]],bot[[4,2]]}],
				Polygon[{midbot[[3,2]],midbot[[3,1]],bot[[4,1]]}],
				Polygon[{bot[[4,1]],bot[[4,2]],midbot[[3,2]]}]
};
	tris={
			Polygon[top[[2]]] ,Polygon[top[[4]]],
				Polygon[bot[[2]]] ,Polygon[bot[[4]]],
				Polygon[midbot[[1]]],Polygon[midbot[[5]]],
				Polygon[midtop[[1]]],Polygon[midtop[[5]]]
	} ;
		{quads,tris}
]

Net construction

V13.2

<<MathWorld`Polyhedra`

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

{Polygon[],},

{Polygon[],},

{Polygon[],},

{Polygon[],},

net=Polygon[];

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

v[[{7,13}]][[All,2]]

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

net[[2]]//Sort

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

PolyhedronData[pname,"SurfaceArea"]

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

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

Pre-V13.2

θ=ArcCos[GoldenRatio/2];

FullSimplify[θ]

θ=π/5;
h=(Sqrt[3])/2;
x1=RotationMatrix[2π/5].{1,Sqrt[3]}/2//FullSimplify;
x2=GoldenRatio RotationMatrix[π/5].{1,Sqrt[3]}/2//FullSimplify;
x4=x2+RotationMatrix[-3π/5-π/3].{-1,0}//FullSimplify;
x5=x4+RotationMatrix[-2π/5].(x2-x4)//FullSimplify;
x7=x6+RotationMatrix[2π/5].(x4-x6)//FullSimplify;
x8=x6+RotationMatrix[π/3].(x7-x6)//FullSimplify;
x9=x7+RotationMatrix[-2π/5].(x8-x7)//FullSimplify;
x10=x7+GoldenRatio RotationMatrix[-π/5].(x8-x7)//FullSimplify;
x11=x10+RotationMatrix[π/3].(x9-x10)//FullSimplify;
x12=x10+RotationMatrix[3π/5].(x11-x10)//FullSimplify;
x13=x11+RotationMatrix[-π/3-2π/5].(x9-x11)//FullSimplify;
x14=x10+RotationMatrix[-π/3].(x8-x10);
x15=x14+RotationMatrix[-3π/5].(x8-x14);
x16=x8+RotationMatrix[2π/5].(x14-x8);
x17=x14+RotationMatrix[-π/3].(x15-x14);

Graphics[{EdgeForm[Black],Yellow,Polygon[{{0,0},{1,Sqrt[3]}/2,{1,0}}],
Polygon[{{0,0},x1,x2}],Polygon[{{0,0},{1,Sqrt[3]}/2,x2}],
Polygon[{x2,x2-{1,0},x3=x2+{-1/2,h}}],
Polygon[{x2,x4,{1/2,h}}],Polygon[{x2,x4,x3}],Polygon[{x4,x5,x3}],
Polygon[{x4,x4+{1/2,h},x6=x4+{1,0}}],Polygon[{{1/2,h},x4,x6}],
Polygon[{x6,x7,{1/2,h}}],Polygon[{x7,x8,x6}],Polygon[{x7,x9,x10}],
Polygon[{x8,x7,x10}],Polygon[{x9,x10,x11}],Polygon[{x10,x12,x11}],Polygon[{x11,x13,x12}],Polygon[{x10,x8,x14}],Polygon[{x14,x8,x15}],Polygon[{x8,x16,x15}],Polygon[{x14,x17,x15}],
{Black,MapIndexed[Text[#2[[1]],#,Background->White]&,{x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17}]},
{Red,PointSize[.02],Point[x10],Line[{{x7,x9}}]}}]

Graphics[{EdgeForm[Black],Yellow,g={Polygon[{{0,0},{1,Sqrt[3]}/2,{1,0}}],
Polygon[{{0,0},x1,x2}],Polygon[{{0,0},{1,Sqrt[3]}/2,x2}],
Polygon[{x2,x2-{1,0},x3=x2+{-1/2,h}}],
Polygon[{x2,x4,{1/2,h}}],Polygon[{x2,x4,x3}],Polygon[{x4,x5,x3}],
Polygon[{x4,x4+{1/2,h},x6=x4+{1,0}}],Polygon[{{1/2,h},x4,x6}],
Polygon[{x6,x7,{1/2,h}}],Polygon[{x7,x8,x6}],Polygon[{x7,x9,x10}],
Polygon[{x8,x7,x10}],Polygon[{x9,x10,x11}],Polygon[{x10,x12,x11}],Polygon[{x11,x13,x12}],Polygon[{x10,x8,x14}],Polygon[{x14,x8,x15}],Polygon[{x8,x16,x15}],Polygon[{x14,x17,x15}]}}]

g//N

g1=FullSimplify[RootReduce[g]]

net=NetFromPolygons[g1]

Graphics[{Yellow,EdgeForm[Black],net}]

PolyhedronData["JessensOrthogonalIcosahedron","NetImage"]

Normal[PolyhedronData["JessensOrthogonalIcosahedron","Edges"]][[1]]/.Line[x_]:>Norm[Subtract@@x]//FullSimplify//Union

Wrong

From Ed Pegg, Jr.
March 13, 2007

Show[Graphics[g={{AbsoluteThickness[0],Line[{{{519.000000,-3619.000000},{3360.000000,1306.000000}}}],Line[{{{3360.000000,1306.000000},{6200.000000,-3619.000000}}}],Line[{{{6200.000000,-3619.000000},{519.000000,-3619.000000}}}],Line[{{{3360.000000,1306.000000},{9041.000000,1306.000000}}}],Line[{{{9041.000000,1306.000000},{11881.000000,-3619.000000}}}],Line[{{{11881.000000,-3619.000000},{6200.000000,-3619.000000}}}],Line[{{{6200.000000,-3619.000000},{3360.000000,-8543.000000}}}],Line[{{{3360.000000,-8543.000000},{6200.000000,-13467.000000}}}],Line[{{{6200.000000,-13467.000000},{9041.000000,-8543.000000}}}],Line[{{{9041.000000,-8543.000000},{6200.000000,-3619.000000}}}],Line[{{{9041.000000,-8543.000000},{11881.000000,-3619.000000}}}],Line[{{{9041.000000,-8543.000000},{14721.000000,-8543.000000}}}],Line[{{{14721.000000,-8543.000000},{17562.000000,-3619.000000}}}],Line[{{{17562.000000,-3619.000000},{11881.000000,-3619.000000}}}],Line[{{{17562.000000,-3619.000000},{20402.000000,-8543.000000}}}],Line[{{{20402.000000,-8543.000000},{14721.000000,-8543.000000}}}],Line[{{{14721.000000,-8543.000000},{17562.000000,-13467.000000}}}],Line[{{{17562.000000,-13467.000000},{23243.000000,-13467.000000}}}],Line[{{{23243.000000,-13467.000000},{20402.000000,-8543.000000}}}],Line[{{{20402.000000,-8543.000000},{26083.000000,-8543.000000}}}],Line[{{{26083.000000,-8543.000000},{23243.000000,-13467.000000}}}],Line[{{{20402.000000,-8543.000000},{23243.000000,-3619.000000}}}],Line[{{{23243.000000,-3619.000000},{28924.000000,-3619.000000}}}],Line[{{{28924.000000,-3619.000000},{26083.000000,-8543.000000}}}],Line[{{{26083.000000,-8543.000000},{28924.000000,-13467.000000}}}],Line[{{{28924.000000,-13467.000000},{26083.000000,-18391.000000}}}],Line[{{{26083.000000,-18391.000000},{23243.000000,-13467.000000}}}],Line[{{{20402.000000,-8543.000000},{28924.000000,-3619.000000}}}],Line[{{{26083.000000,-18391.000000},{26083.000000,-8543.000000}}}],Line[{{{23243.000000,-13467.000000},{14721.000000,-8543.000000}}}],Line[{{{9041.000000,-8543.000000},{17562.000000,-3619.000000}}}],Line[{{{11881.000000,-3619.000000},{3360.000000,1306.000000}}}],Line[{{{6200.000000,-3619.000000},{6200.000000,-13467.000000}}}],Line[{{{9041.000000,-8543.000000},{11881.000000,-13467.000000}}}],Line[{{{11881.000000,-13467.000000},{6200.000000,-13467.000000}}}],Line[{{{28924.000000,-3619.000000},{31764.000000,-8543.000000}}}],Line[{{{31764.000000,-8543.000000},{26083.000000,-8543.000000}}}],Line[{{{11881.000000,-3619.000000},{14721.000000,1306.000000}}}],Line[{{{14721.000000,1306.000000},{17562.000000,-3619.000000}}}],Line[{{{23243.000000,-13467.000000},{20402.000000,-18391.000000}}}],Line[{{{20402.000000,-18391.000000},{26083.000000,-18391.000000}}}]}}/.Line[{x_}]:>Line[x]],AspectRatio->Automatic]

ShowLabeledGraph[gg=LinesToGraph[g],AspectRatio->Automatic]

Show[Graphics3D[#]]&/@N[Flatten[Normal[PolyhedronData["JessensOrthogonalIcosahedron","Faces"]]]]

Show/@{Graphics3D[Polygon[{{0.5`,0.`,0.8090169943749475`},{0.`,-0.8090169943749473`,0.5`},{0.`,0.8090169943749475`,0.5`}}]],Graphics3D[Polygon[{{0.5`,0.`,0.8090169943749475`},{0.`,-0.8090169943749473`,0.5`},{0.8090169943749475`,-0.5`,0.`}}]],Graphics3D[Polygon[{{0.5`,0.`,0.8090169943749475`},{0.8090169943749475`,-0.5`,0.`},{0.5`,0.`,-0.8090169943749473`}}]],Graphics3D[Polygon[{{0.5`,0.`,0.8090169943749475`},{0.`,0.8090169943749475`,0.5`},{0.8090169943749475`,0.5`,0.`}}]],Graphics3D[Polygon[{{0.5`,0.`,0.8090169943749475`},{0.5`,0.`,-0.8090169943749473`},{0.8090169943749475`,0.5`,0.`}}]],Graphics3D[Polygon[{{0.8090169943749475`,-0.5`,0.`},{0.`,-0.8090169943749473`,0.5`},{-0.8090169943749473`,-0.5`,0.`}}]],Graphics3D[Polygon[{{0.8090169943749475`,-0.5`,0.`},{-0.8090169943749473`,-0.5`,0.`},{0.`,-0.8090169943749473`,-0.5`}}]],Graphics3D[Polygon[{{0.5`,0.`,-0.8090169943749473`},{0.8090169943749475`,-0.5`,0.`},{0.`,-0.8090169943749473`,-0.5`}}]],Graphics3D[Polygon[{{0.`,0.8090169943749475`,0.5`},{0.8090169943749475`,0.5`,0.`},{-0.8090169943749473`,0.5`,0.`}}]],Graphics3D[Polygon[{{0.`,-0.8090169943749473`,0.5`},{0.`,0.8090169943749475`,0.5`},{-0.5`,0.`,0.8090169943749475`}}]],Graphics3D[Polygon[{{0.`,-0.8090169943749473`,0.5`},{-0.8090169943749473`,-0.5`,0.`},{-0.5`,0.`,0.8090169943749475`}}]],Graphics3D[Polygon[{{-0.8090169943749473`,-0.5`,0.`},{0.`,-0.8090169943749473`,-0.5`},{-0.5`,0.`,-0.8090169943749473`}}]],Graphics3D[Polygon[{{-0.8090169943749473`,-0.5`,0.`},{-0.5`,0.`,0.8090169943749475`},{-0.5`,0.`,-0.8090169943749473`}}]],Graphics3D[Polygon[{{0.`,0.8090169943749475`,0.5`},{-0.8090169943749473`,0.5`,0.`},{-0.5`,0.`,0.8090169943749475`}}]],Graphics3D[Polygon[{{-0.8090169943749473`,0.5`,0.`},{-0.5`,0.`,0.8090169943749475`},{-0.5`,0.`,-0.8090169943749473`}}]],Graphics3D[Polygon[{{0.5`,0.`,-0.8090169943749473`},{0.`,-0.8090169943749473`,-0.5`},{0.`,0.8090169943749475`,-0.5`}}]],Graphics3D[Polygon[{{0.`,-0.8090169943749473`,-0.5`},{-0.5`,0.`,-0.8090169943749473`},{0.`,0.8090169943749475`,-0.5`}}]],Graphics3D[Polygon[{{-0.5`,0.`,-0.8090169943749473`},{-0.8090169943749473`,0.5`,0.`},{0.`,0.8090169943749475`,-0.5`}}]],Graphics3D[Polygon[{{0.8090169943749475`,0.5`,0.`},{-0.8090169943749473`,0.5`,0.`},{0.`,0.8090169943749475`,-0.5`}}]],Graphics3D[Polygon[{{0.8090169943749475`,0.5`,0.`},{0.`,0.8090169943749475`,-0.5`},{0.5`,0.`,-0.8090169943749473`}}]]}

PolyhedronData["JessensOrthogonalIcosahedron","EdgeLengths"]

v=Vertices[gg]

v1=(#-v[[1]])&/@v

v2=(Round[(({2First[#],2Last[#]/Sqrt[3]})/u)]{(1/2),(Sqrt[3])/2})&/@v1

ShowLabeledGraph[ChangeVertices[gg,List/@v2],AspectRatio->Automatic]

Sort[Sort/@Most/@ExtractCycles[gg]]

{{1,3,5},{2,4,5},{3,5,9},{3,7,9},{4,5,6},{4,6,8},{5,6,9},{6,9,13},{6,10,13},{9,11,13},{10,12,16},{10,13,15},{10,15,16},{14,16,18},{15,16,19},{15,17,21},{15,19,21},{16,18,19},{18,19,20},{19,21,22}}//Length

PolyhedronData

PolyhedronDataString

PolyhedronDataString[{Polyhedron[JessensOrthogonalPolyhedron],"JessensOrthogonalIcosahedron","Jessens's orthogonal icosahedron"},{"Concave","Shaky"}]