Conway-Guy Polyhedron

Author

Eric W. Weisstein
November 2, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Conway-GuyPolyhedron.nb.

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

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

Source

Figure

Reshetov 2014

https://research.nvidia.com/sites/default/files/pubs/2014-03_A-unistable-polyhedron/polytop-ijcga-rev2.pdf
https://www.researchgate.net/publication/280172577_A_unistable_polyhedron_with_14_faces

Conway’s Spiral and a Discrete Gömböc with 21 Point Masses
Gábor Domokos & Flórián Kovács
https://arxiv.org/pdf/2103.13727.pdf

Polyhedron

Orientations

PolyhedronData["ConwayGuyPolyhedron","Orientations"]

PolyhedronData["ConwayGuyPolyhedron","DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData["ConwayGuyPolyhedron","Polyhedron"]},Axes->True,AxesLabel->{"x","y","z"}]

Face orientation

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

Region

PolyhedronData["ConwayGuyPolyhedron","Region"]

Net

PolyhedronData["ConwayGuyPolyhedron","Net"]

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

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

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

RegionCentroid[p]//RootReduce//Timing

PolyhedronCentroid[p]//RootReduce//Quiet

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[N[p,50]]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

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

Show[%,RenderingOptions->{"3DRenderingMethod"->"BSPTree"}]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

RootReduce@DihedralAngles[p]//Timing

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

dname=PolyhedronData[pname,"Dual","Name"]

PolyhedronData[pname,"Dual","Scale"]

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->FullSimplify]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

N[%]

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

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

v=p[[1]];

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

RootReduce[%]//FullSimplify

Hull

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

RootReduce[i]//Timing

(i=PolyhedronInertiaTensor[p])//Timing

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

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

ClosestMeanCylindricalRadius[%]

Integrate over polyhedron

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

N[rxy]

Divergence theorem [crashes kernel]

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

N[rxy]

LogSimplify[rxy]//FullSimplify

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

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

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

CAD over  1/XX

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/5]x]

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)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxy]

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

ByteCount[rxycollect=Collect[TrigToExp[rxylog],Log[_]]//RootReduce]//Timing

MeanInteriorLineSegmentLength

lbar=PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax},
Method->{"GlobalAdaptive","MaxErrorIncreases"->1*^4}]//Timing

Integration

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

cad=CylindricalDecomposition[ineq[x1,y1,z1]&&ineq[x2,y2,z2],{x1,y1,z1,x2,y2,z2},"Function"]

(1/(vol^2)) Integrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[cad],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

Length[lines=Partition[RandomPoint[N@reg,10^7],2]]//Timing

Graphics3D[{{Opacity[.2],EdgeForm[],BoundaryDiscretizeRegion[reg]},Red,Line/@Take[lines,UpTo@1000]},AspectRatio->Automatic]

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

ClosestMeanSphericalRadius[%]

Integrate over polyhedron

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

N[rxyz]

Divergence theorem

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

N[rxyz]

LogSimplify[rxyz]//FullSimplify

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)

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

N[rxyz,20]

rxysimp1=ResourceFunction["LogSimplify"][rxy]//FullSimplify

CAD over  1/XX

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/5]x]

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

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

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

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

Integrate over Polyhedron

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

N[rxy2]

RootReduce[rxy2]

Divergence theorem

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

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

N[%]

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

Integrate over polyhedron

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

N[rxy2]

RootReduce[rxy2]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[p,Debug->True,"Simplification"->RootReduce]//Timing

Midsphere[N[p,50]]

Net

PolyhedronData[pname,"Net"]

(area1=Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]])

N[area1]

RootReduce[area1]//Timing

(area2=PolyhedronData[pname,"SurfaceArea"])

N[area2]

N[area1-area2,1000]

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

area3=Total[Area/@Flatten[poly3d]]

area3-area1

Graphics3D[{FaceForm[Green,Red],poly3d},Axes->True,AxesLabel->{"x","y","z"}]

NotationRules

PolyhedronData[pname,"NotationRules"]

Orientations

PolyhedronData[pname,"Orientations"]

PolyhedronData[pname,"DefaultOrientation"]

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

Polygons

PolyhedronData[pname,"FaceCount"]

PolyhedronFaceTally[p]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

{RegionPlot3D[ImplicitRegion[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}],PlotPoints->50],
Graphics3D[p]}

Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[p,{x,y,z}]

ineq=FullSimplify[%]

ineq/.{x->#,y->#2,z->#3}

{Region@ImplicitRegion[ineq,{x,y,z}],Graphics3D[p]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Cases[Union[emb,{pname}],Alternatives@@PolyhedronData[All]]}}}

StableFaces

stable=StableFaces@@{p,zbar=PolyhedronData[pname,"Centroid"]}

stablefaces=PolyhedronData[pname,"Polygons"][[stable]]

Graphics3D[{{Red,AbsolutePointSize[6],Point[zbar]},{Opacity[.2],Drop[PolyhedronData[pname,"Polygons"],stable]},Yellow,stablefaces},Boxed->False]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]//RootReduce//Timing

SurfaceArea[p]//FullSimplify//Timing

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

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

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

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

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

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

%===Range@Length@v

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

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Volume[PolyhedronData[pname,"Region"]]//FullSimplify

Volume[ImplicitRegion[Evaluate@PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}]]

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Construction

Ed Pegg 2005 [wrong; all faces are stable]

Original code by Ed Pegg, Jr.
May 10, 2005

UniP={{21,-57},{42,-50},{60,-34},{72,-13},{77,14},{72,41},{57,68},{32,88},{0,100}};
UniPc =Flatten[{UniP,Map[{-#[[1]],#[[2]]}&,Reverse[Drop[UniP,-1]]]},1];
zplane[{x_,y_},a_,b_] := {a x,y,b(-(2/157) (-11881+67 y))};

Cross Section

Graphics[{
Line[Append[UniPc,First[UniPc]]],
LightGray,Line[{{0,0},#}]&/@UniPc
},AspectRatio->Automatic]

Solid

Graphics3D[poly=Orient@Flatten[{Map[Polygon,Flatten[Table[{{zplane[UniP[[n]],1,1],zplane[UniP[[n]],1,-1],zplane[UniP[[n+1]],1,-1],zplane[UniP[[n+1]],1,1]},{zplane[UniP[[n]],-1,1],zplane[UniP[[n]],-1,-1],zplane[UniP[[n+1]],-1,-1],zplane[UniP[[n+1]],-1,1]}},{n,1,8}],1]],
Polygon[{zplane[UniP[[1]],-1,1],zplane[UniP[[1]],-1,-1],zplane[UniP[[1]],1,-1],zplane[UniP[[1]],1,1]}],Polygon[Table[zplane[UniPc[[n]],1,1],{n,1,17}]],Polygon[Table[zplane[UniPc[[n]],1,-1],{n,17}]]}],Boxed->False,ViewPoint->{2,5.4,1},ViewVertical->{0,1,.065}]

v=DeleteDuplicates[Join@@poly[[All,1]]]

f=poly[[All,1]]/.Thread[v->Range@Length@v]

p=Polyhedron[{#3,#1,#2}&@@@v,f]

p=Polyhedron[]

v=p[[1]];

Graphics3D[LabelPolyhedron@p]

EuclideanDistance@@v[[{33,34}]]

EuclideanDistance@@v[[{1,8}]]

132/42

StableFaces[p]

Graphics3D[{AbsolutePointSize[8],Point[{0,0,0}],FaceForm[Green,Red],Opacity[.7],p},Ticks->None,AxesLabel->{"x","y","z"},Axes->True]

Length/@{v,f}

Halfner

Modified from https://demonstrations.wolfram.com/SomeUnistablePolyhedra/

solid[m_,ep_,n1_,k1_]:=Module[{k,fi,delta,r1,r2,s11,s21,zac,cikli,kor1,del=(Pi-2(Pi/m+ep))/(m-2)},fi=Join[{0},Table[Pi/m+ep+i del,{i,0,m-2}],{Pi}];delta=Join[{0,Pi/m+ep},Table[del,{m-2}],{Pi/m+ep}];r1[1]=3;
r1[n_]:=r1[n-1]/Cos[delta[[n]]];r2=Table[r1[n],{n,m+1}];s11=Graphics[{{Thickness[0.01],Line[Table[{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]]},{n,m+1}]]},{Thickness[0.001],Table[Line[{{0,0},{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]]}}],{n,m+1}]}}];s21=Graphics[{Thickness[0.01],Line[Table[{Re[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]]},{n,m+1}]]}];
k=(n1-k1)/r2[[m+1]];
zac=Table[{n,If[n==2m-1,1,n+1],If[n==2m-1,1,n+1]+2m-1,n+2m-1},{n,2m-1}];
cikli=Join[zac,{Reverse[Range[2m-1]]},{Range[2m,4m-2]}];
kor1=Join[Table[{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],k  Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]]-n1},{n,2,m+1}],Reverse[Table[{Re[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],k  Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]]-n1},{n,2,m}]],Table[{Re[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]],-k  Im[r2[[n]]Exp[I(-Pi/2+fi[[n]])]]+n1},{n,2,m+1}],Reverse[Table[{Re[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]],-k  Im[r2[[n]]Exp[I(-Pi/2-fi[[n]])]]+n1},{n,2,m}]]];{{s11,s21},{cikli,kor1},r2[[m+1]]}]

ConwayGuySolid[m_,ep_,n1_,k1_]:=Module[{f,v},
{f,v}=solid[m,ep,n1,k1][[2]];
Polyhedron[{#3,#1,#2}&@@@v,f]
]

v=ConwayGuySolid[9,0,a,b][[1]];

Simplify[{EuclideanDistance@@v[[{9,26}]],EuclideanDistance@@v[[{34,17}]]},Assumptions->0<b<a]

Not unistable:

Graphics3D[p=ConwayGuySolid[9,0,12,4]]

StableFaces[N[p,20]]

Unistable:

Graphics3D[p=ConwayGuySolid[9,0,30,1.35]]

StableFaces[N[p,20]]

ps=Table[ConwayGuySolid[9,0,30,k1],{k1,{0,1,135/100,10,20,30}}]

Graphics3D[#,ImageSize->Medium]&/@ps

StableFaces/@N[ps,20]

Table[StableFaces[ConwayGuySolid[m,0,30,135/100]//N[#,20]&],{m,9,12}]

Monitor[unistable=Select[Flatten[Table[{{a,b},ConwayGuySolid[9,0,a,b]},{a,40},{b,a}],1],Length[StableFaces[N[#[[2]],30]]]==1&],{a,b}]//Timing

unistable/.p_Polyhedron:>Graphics3D[p]

Graphics3D[LabelPolyhedron@(p=ConwayGuySolid[9,0,29,1])]

StableFaces[N[p]]

p//InputForm

Net construction

By hand

p=ConwayGuySolid[9,0,29,1]

v=p[[1]]

Graphics3D[LabelPolyhedron@p]

dx=EuclideanDistance@@p[[1,{1,18}]]/2//FullSimplify

N[%]

PolyhedronEdgeLengths[N[p]]//Sort

fullcap1=Reverse@Range[17]

m=RotationMatrix[{Cross[v[[17]]-v[[1]],v[[2]]-v[[1]]],{0,0,1}}]//RootReduce

(rot=m.#&/@v[[fullcap1]]//RootReduce)//Timing

Equal@@rot[[All,-1]]

Graphics[{EdgeForm[Black],FaceForm[None],Polygon[Most/@rot]},Axes->True]

vmin=rot[[All,1]]//Min

Graphics[{EdgeForm[Black],FaceForm[None],Polygon[vleft={vmin-#-dx,#2}&@@@rot]},Axes->True]

Graphics[{EdgeForm[Black],FaceForm[None],Polygon[vright={dx-vmin+#,#2}&@@@Reverse[rot]]},Axes->True]

EuclideanDistance@@@Partition[vleft,2,1,1]

cap1=Range[9];
cap2=Range[18,26];

lines=Transpose[{cap1,cap2}]

Graphics3D[vlines=Line/@lines/.i_Integer:>v[[i]],Boxed->False]

widths=EuclideanDistance@@@(Partition[vlines,2,1]/.Line[x_]:>Mean[x])//RootReduce

EuclideanDistance@@@Partition[v[[{1,17,34,18}]],2,1,1]

N[%]

vpos=Accumulate[Prepend[widths,3 Tan[(π/9)]]]

lengths=v[[cap1,1]]

tips=Rest@Transpose[{lengths,vpos}]

v1=Join[Reverse@vright,Reverse@vleft,tips,{-#,#2}&@@@tips,{-#,-#2}&@@@tips,{#,-#2}&@@@tips];
f1=Join[
{Range[17]},{Range[18,34]},
Join[#,Reverse[#2]]&@@@Partition[Table[{i,i+8},{i,35,42}],2,1],
Join[#,Reverse[#2]]&@@@Partition[Table[{i,i+8},{i,51,58}],2,1],
{{17,43,35,18},{1,17,18,34},{51,1,34,59}}
];
Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v1,f1],MapIndexed[Text[#2[[1]],#]&,v1]}]

EuclideanDistance@@v1[[{42,50}]]

PolygonEdgeLengths[N[Polygon[v1,f1]]]//Sort

v1simp=v1/2//RootReduce;//Timing

v1simp

Sort[f1]

Area[Polygon[v1simp[[f1[[-2]]]]]]//N

Graphics3D[{LabelPolyhedron@PolyhedronData["ConwayGuyPolyhedron","Polyhedron"]}]

netarea=NumericalSort[Area[Polygon[v1simp[[#]]]]&/@f1];

solidarea=NumericalSort[Area/@PolyhedronData["ConwayGuyPolyhedron","Polygons"]];

netarea-solidarea//N//Chop

RootReduce[netarea-solidarea]

UnfoldPolyhedron

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[[18]]-v[[1]],{1,0}}];

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

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

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

net[[2]]//Sort

PolyhedronData

PolyhedronDataString

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

WriteString[file,PolyhedronDataString[
p,
"StandardName"->"ConwayGuyPolyhedron",
"Name"->"Conway\[Hyphen]Guy polyhedron",
"Classes"->{"Unistable"},
"Information"->"Conway-GuyPolyhedron",
TimeConstraint->5
]]

Close[file]