Braced Polygon

Author

Eric W. Weisstein
December 28, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/BracedPolygon.nb.

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

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

<<MathWorld`Graphs`

Table from Friedman

Friedman: https://erich-friedman.github.io/mathmagic/0100.html

A number of these are either updated at the bottom of the page or elsewhere (Ed's braced heptagon)

Lists

Laman

GraphData[{"Laman","BracedPolygon"}]

Non-Laman (non-minimal = overbraced):

Complement@@GraphData/@{"BracedPolygon","Laman"}

TriangleFree

GraphData[{"TriangleFree","BracedPolygon"}]

SquareFree

GraphData[{"SquareFree","BracedPolygon"}]

TriangleFree + SquareFree

GraphData[{"SquareFree","TriangleFree","BracedPolygon"}]

Matchstick

MatchstickBracedPolygons=Sort[{GraphData[#,"NotationRules","BracedPolygon"],GraphData[#,"V"],GraphData[#,"M"],#}&/@Select[GraphData["BracedPolygon"],Or@@(ContainsAll[{"Matchstick","BracedPolygon"}]/@GraphData[#,"EmbeddingClasses"])&]];
gridlines=Thread[Accumulate[Join[{1},Length/@Split[MatchstickBracedPolygons[[All,1,1]]]]]->True];

TextGrid[
MatchstickBracedPolygons,
Dividers->{All,gridlines},
Alignment->{{{Decimal},Left},Automatic}]

All

BracedPolygons=Sort[{GraphData[#,"NotationRules","BracedPolygon"],GraphData[#,"V"],GraphData[#,"M"],#}&/@GraphData["BracedPolygon"]];
gridlines=Thread[Accumulate[Join[{1},Length/@Split[BracedPolygons[[All,1,1]]]]]->True];

TextGrid[
BracedPolygons,
Dividers->{All,gridlines},
Alignment->{{{Decimal},Left},Automatic}]

Triangle-free

Reduced BracedSquare2 from Somsky (14 vertices, 25 edges, Jan. 3, 2021)

From  William R Somsky via Ed Pegg, Jen 3, 2021

somsky=IndexGraph@Subgraph[ed29poly,{1,2,3,4,5,21,13,17,14,18,7,10,8,28}]

Through[{VertexCount,EdgeCount}[somsky]]

LamanGraphQ[somsky]//Timing

FindCycle[somsky,{3}]

Reduced BracedSquare2  (12 vertices, 21 edges, Jan. 3, 2021)

Ed's

Jan 3, 2021

v={{0,0},{1/2,-(1/2)},{1/2,1/2},{-(1/2),-(1/2)},{-(1/2),1/2},{1/4 (1+Sqrt[7]),1/4 (1-Sqrt[7])},{1/4 (-1-Sqrt[7]),1/4 (-1+Sqrt[7])},{1/4 (-1+Sqrt[7]),1/4 (1+Sqrt[7])},{1/4 (2+Sqrt[7]),1/4},{-(1/4),1/4 (-2+Sqrt[7])},{-(1/4),1/4 (2+Sqrt[7])},{1/4 (-2+Sqrt[7]),1/4}};

e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<1*^-4&]//Quiet

ed12=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

RigidityAnalysisDiagram[]

Through[{VertexCount,EdgeCount}[ed12]]

LamanGraphQ[ed12]

FindCycle[ed12,{3}]

Make Laman by removing vertices from the original 29-node BracedSquare2

ed29poly=GraphData[{"BracedSQquareTriangleFree",{68,1}}]

n=VertexCount[ed29poly]

Vertices that are not part of the square:

vl=Complement[VertexList[ed29poly],{1,2,4,5}]

Length[vl]

Do[Print[{n,Binomial[25,n],SelectFirst[Subsets[vl,{n}],LamanGraphQ[MyFastVertexDelete[ed29poly,#]]&]//Timing}],{n,15,19}]

Length[sets=Select[Subsets[vl,{17}],LamanGraphQ[MyFastVertexDelete[ed29poly,#]]&]]//Timing

sets

gs=VertexDelete[ed29poly,#]&/@sets

uniq=#[[1,2]]&/@SplitBy[SortBy[{CanonicalGraph[#],#}&/@gs,First],First]

RigidityAnalysisDiagram/@IndexGraph/@{,,}

GraphicsRow[SetProperty[#,VertexLabels->None]&/@StyleGraphs[uniq,VertexSize->{"Scaled",.04}]]

Pick[uniq,IsomorphicGraphQ[#,ed12]&/@uniq]

VertexList/@uniq//Column

SquareCount[g0_Graph]:=Module[{g=IndexGraph[g0],v,cyc},
v=GraphEmbedding[g];
cyc=FindCycle[g,{4},All][[All,All,1]];
Total[Boole[SquaredEuclideanDistance@@v[[#[[{1,3}]]]]==SquaredEuclideanDistance@@v[[#[[{2,4}]]]]==2&/@cyc]]
]

SquareCount/@uniq

FindCycle[#,{3}]&/@uniq

CyclePolynomial[#,x]&/@uniq//Column

%68//Column

Through[{VertexCount,EdgeCount}[#]]&/@uniq//Union

Flexible graph based on 2 hodfish (40 vertices; 77 edges; Ed Pegg, Dec 29, 2020)

From Ed Pegg Jr. Dec 29, 2020

The square can be braced without triangles with perpendicular hodfishes. [not true; the graph is flexible]
This is sort of like showing that a person can run a mile in five hours or less. This record will not stand -- if list as a record, within hours it will be broken. 
Likely some subset of this graph also has the square and is also rigid.

Construction

eck=RootReduce[#+1/2&/@GraphData["HochbergODonnellFishGraph","VertexCoordinates"]];

erk=Reverse/@eck;

yum=Union[Join[erk,eck]];

kk=Sort[Flatten[Position[yum,#]&/@erk]]

cc=Sort[Flatten[Position[yum,#]&/@eck]]

ee=Select[Subsets[Range[Length[yum]],{2}], Chop[1-EuclideanDistance@@N[yum[[#]]]]==0&];

eec=Intersection[Subsets[cc,{2}],ee];

eek=Intersection[Subsets[kk,{2}],ee];

Graphics

Graphics[{Style[Table[Text[n,yum[[n]]],{n,1,Length[yum]}],24], Green,Line[yum[[#]]]&/@eec, Cyan,Line[yum[[#]]]&/@eek, Red,  Line[yum[[#]]]&/@Complement[ee,Join[eek,eec]]  }]

Graph

g=Graph[Range[Length[yum]],UndirectedEdge@@@Union[Sort/@eec,Sort/@eek],VertexCoordinates->yum,VertexLabels->"Name"]

RecognizeGraph[g]

RigidGraphQ[g]

Diagrams

RecognizeGraph/@{doublehodfish,doublehodfishwithlines}

FindCycle[#,{3}]&/@{doublehodfish,doublehodfishwithlines}

LamanGraphQ/@{doublehodfish,doublehodfishwithlines}

g2=HighlightGraph[doublehodfishwithlines,Style[UndirectedEdge@@@#,Directive[Thick,#2]]&@@@{{Complement[ee,eek,eec],Directive[Red,Dashed]},{eec,Cyan},{eek,Green}}]

g3=HighlightGraph[doublehodfish,Style[UndirectedEdge@@@#,Directive[Thick,#2]]&@@@{{eec,Cyan},{eek,Green},{Intersection[eek,eec],Red}}]

GraphicsRow[{GraphData["HochbergODonnellFishGraph"]//StyleGraphs,g3}]

Attempt to make Rigid

VertexCount[g]

Symmetrically distinct vertices that are not part of the square:

vl=Complement[VertexList[g],{1,2,8,9}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],RigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Unit-Distance and Laman but not Rigid

Square (21 edges, triangle-free) two graphs; vertex-deletion from {"BracedSquare", {68, 1}}

g1=;

LamanGraphQ[g1]//Timing

RigidGraphQ[g1,Debug->True]//Timing

g2=;

LamanGraphQ[g2]//Timing

RigidGraphQ[g2,Debug->True]//Timing

Heptagon (35 edges) vertex-deletion from {"BracedHeptagon", {42, 1}})

g1=;

RecognizeGraph[g1]

LamanGraphQ[g1,Debug->True]//Timing

RigidGraphQ[g1]

Khodulyov construction

Jeremy Tan (Oct. 26, 2021): Andrei Khodulyov's solutions for the heptagon and 11-gon are just instances of an "equal angles" method using Peaucellier-Lipkin linkages that works for all n-gons with n at least 7. A function to explicitly construct such bracings is in khodulyov.nb, where I also calculate the exact number of edges it uses. The result is asymptotically optimal -- 19(n-3) + 4 - (n mod 2), *linear* in the number of sides (the polygon itself obviously needs n sides). My cyclotomic bracings and even bracings based on rhombus tilings use at least a quadratic number of edges and hence lose out to the equal angles method in the long run. Put simply, Khodulyov killed the braced polygon problem.

Table[19(n-3)+4-Mod[n,2],{n,7,16}]

EdgeCount/@Table[KhodulyovBracedPolygonGraph[n],{n,7,15}]//Quiet

Degenerate

Tam: "The above procedure doesn't work at n=12, but hey, Khodulyov himself found a much better bracing for that"

(data=Monitor[Table[{n,DegenerateGraphEmbeddingQ[KhodulyovBracedPolygonGraph[n],"Type"->"VertexVertex"]},{n,7,20}],n])//Quiet//Timing

Cases[data,{n_,True}:>n]

7

From Friedman:

g=KhodulyovBracedPolygonGraph[7]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

LamanGraphQ[g]

RigidGraphQ[g]

8

HighlightGraph[g=KhodulyovBracedPolygonGraph[8,VertexLabels->Automatic],{10,35}]

EdgeCount[g]

RecognizeGraph[g]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

UnitDistanceGraphEmbeddingQ[g,Debug->True]

LamanGraphQ[g]

RigidGraphQ[g]

9

HighlightGraph[g=KhodulyovBracedPolygonGraph[9,VertexLabels->Automatic],{11,53}]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g,Debug->True]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

10

g=KhodulyovBracedPolygonGraph[10,VertexLabels->"Name"]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g,Debug->True]//Timing

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

11

g=KhodulyovBracedPolygonGraph[11]

EdgeCount[g]

RecognizeGraph[g]

DegenerateGraphEmbeddingTypes[g]//Timing

UnitDistanceGraphEmbeddingQ[g,Debug->True]

LamanGraphQ[g]

RigidGraphQ[g]

12

g=KhodulyovBracedPolygonGraph[12,VertexLabels->Automatic]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g,Debug->True]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

13

g=KhodulyovBracedPolygonGraph[13,VertexLabels->Automatic]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g,Debug->True]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

14

g=KhodulyovBracedPolygonGraph[14,VertexLabels->Automatic]

EdgeCount[g]

RecognizeGraph[g]

DegenerateGraphEmbeddingTypes[g]//Timing

UnitDistanceGraphEmbeddingQ[g,Debug->True]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

15

g=KhodulyovBracedPolygonGraph[15,VertexLabels->Automatic]

EdgeCount[g]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g,Debug->True]

Select[SplitBy[SortBy[MapIndexed[{#,#2[[1]]}&,Round[10^6GraphEmbedding[g]]],First],First],Length[#]>1&][[All,All,-1]]

LamanGraphQ[g]

RigidGraphQ[g]

Embeddings

{"BracedHexagon", {29, 1}}

Names

GraphData[{"BracedHexagon",{29,1}},"StandardName"]

GraphData[{"BracedHexagon",{29,1}},"StandardNames"]

Primary

GraphData[{"BracedHexagon",{29,1}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"BracedHexagon",{29,1}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"BracedHexagon",{29,1}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"BracedHexagon",{29,1}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"BracedHexagon",{29,1}},"Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData[{"BracedHexagon",{29,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"BracedHexagon",{29,1}},"Graph","Degenerate"]

Configuration

GraphData[{"BracedHexagon",{29,1}},"Configuration"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Configuration"]//StyleGraphs

Perspective

GraphData[{"BracedHexagon",{29,1}},"Graph","Perspective"]//StyleGraphs

HoneycombToroidal construction

GraphData[{"BracedHexagon",{29,1}},"NotationRules","HoneycombToroidal"]

GeneralizedPetersen

GraphData[{"BracedHexagon",{29,1}},"Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData[{"BracedHexagon",{29,1}},"Graph","IGraph"]//StyleGraphs

Bilateral

GraphData[{"BracedHexagon",{29,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"BracedHexagon",{29,1}},"Graph","Circular"]//StyleGraphs

Circular construction

GraphData[{"BracedHexagon",{29,1}},"Hamiltonian"]

GraphData[{"BracedHexagon",{29,1}},"HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData[{"BracedHexagon",{29,1}}],All][[All,All,1]]]

circ=CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedHexagon",{29,1}}],#]&/@hc

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph/@circ],
CircularCanonicalGraphEmbedding]]//Timing

gs=bilat

Length[quad=DeleteDuplicatesBy[Union@Select[bilat,BilateralGraphEmbeddingQ[#,Axis->"X"]&],CircularCanonicalGraphEmbedding[#,4]&]]

quad

Planar

GraphData[{"BracedHexagon",{29,1}},"Planar"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"BracedHexagon",{29,1}},{"RCN","CN"}]

GraphData[{"BracedHexagon",{29,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->86400])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData[{"BracedHexagon",{29,1}}],"CrossingNumber"->cn])//PolyhedralGraphQ

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[g,"OuterFace"->#]&/@faces

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData[{"BracedHexagon",{29,1}}],"CrossingNumber"->cn,RandomSeed->n]],{n,500}],Max[OuterFace[#]]<=GraphData[{"BracedHexagon",{29,1}},"V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData[{"BracedHexagon",{29,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,500}]//Union//Timing

GraphData[{"BracedHexagon",{29,1}},"V"]

CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->10]//Timing

CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->60]//Timing

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"BracedHexagon",{29,1}}],"CrossingNumber"->5],-.65]

v={#/7,#2/6}&@@@{{0,0},{7,0},{1,1},{5,1},{1,2},{4,2},{2,3},{3,3},{2,4},{3,4},{4,4},{6,4},{2,5},{5,5},{0,6},{7,6}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,4,7,3,1,15,16,2,3,5,15,13,14,16],e[5,6,11,13],e[2,12,14,4,6,8,7,9,10,11,12],{8,10},{9,14},{5,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

LocalCrossingCount@g

v={#/7,#2/6}&@@@{{0,0},{7,0},{1,1},{5,1},{1,2},{4,2},{2,3},{3,3},{2,4},{3,4},{4,4},{6,4},{2,5},{5,5},{0,6},{7,6}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,4,7,3,1,15,16,2,3,5,15,13,14,16],e[5,6,11,13],e[2,12,14,4,6,8,7,9,10,11,12],{8,10},{9,14},{5,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

MinimalLocalCrossing

GraphData[{"BracedHexagon",{29,1}},"LocalCrossingNumber"]

GraphData[{"BracedHexagon",{29,1}},"Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalLocalCrossing construction

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

(cn=CrossingNumber[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->1])//AbsoluteTiming

Select[Table[MinimalCrossingGraph[GraphData[{"BracedHexagon",{29,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,500}],!AdjacentCrossingsQ[#,cn]&]//Union//Timing

GraphPlot@

v={#/5,#2/7}&@@@{{0,0},{5,0},{1,1},{3,2},{4+1/2,2},{1,3},{2,3},{3,3},{2,4},{3,4},{2,5},{3-3/4,5},{2,6},{0,7},{2,7},{5,7}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,16,15,14,1,6],e[14,11],e[14,3,2,4,8,10,9,12,16],e[3,7,9,11,13,15],e[6,7,8],e[6,4,5,13,6],{12,13},{5,10},{3,5}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

LocalCrossingCount@g

RectilinearCrossingCount@g

Circulant

GraphData[{"BracedHexagon",{29,1}},"Circulant"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Circulant"]//StyleGraphs

Complement graph

compl=GraphData[{"BracedHexagon",{29,1}},"ComplementGraph","Name"]

Line graph

GraphData[{"BracedHexagon",{29,1}},"Line"]

LineGraphQ[GraphData[{"BracedHexagon",{29,1}}]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]=== {"BracedHexagon",{29,1}}&]

RootGraph[GraphData[{"BracedHexagon",{29,1}}]]

RecognizeGraph[%]

Halin

GraphData[{"BracedHexagon",{29,1}},"Halin"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"BracedHexagon",{29,1}},"Rigid"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"BracedHexagon",{29,1}},"Flexible"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"BracedHexagon",{29,1}},"LCF"]

GraphData[{"BracedHexagon",{29,1}},"HamiltonianCycleCount"]

GraphData[{"BracedHexagon",{29,1}},"LCFSignature"]

GraphData[{"BracedHexagon",{29,1}},"LCFNotations"]

GraphData[{"BracedHexagon",{29,1}},"Graph","LCF"]//StyleGraphs

Tally[LCFNotation[#][[2]]&/@%]

UnitDistance

GraphData[{"BracedHexagon",{29,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"BracedHexagon",{29,1}}],Debug->True]//Timing

GraphData[{"BracedHexagon",{29,1}},"Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"BracedHexagon",{29,1}},"VertexList"],GraphData[{"BracedHexagon",{29,1}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]],MaxIterations->500]&/@Complement@@(GraphData[{"BracedHexagon",{29,1}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"BracedHexagon",{29,1}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"BracedHexagon",{29,1}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"BracedHexagon",{29,1}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"BracedHexagon",{29,1}}],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Matchstick

GraphData[{"BracedHexagon",{29,1}},"Matchstick"]

GraphData[{"BracedHexagon",{29,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"BracedHexagon",{29,1}},"Edges"]]

3D All

GraphData[{"BracedHexagon",{29,1}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"BracedHexagon",{29,1}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"BracedHexagon",{29,1}},"Polyhedral"]

GraphData[{"BracedHexagon",{29,1}},"Graph",{"3D","Polyhedron"}]

{"BracedPentagon", {40, 1}}

Names

GraphData[{"BracedPentagon",{40,1}},"StandardName"]

GraphData[{"BracedPentagon",{40,1}},"StandardNames"]

Primary

GraphData[{"BracedPentagon",{40,1}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"BracedPentagon",{40,1}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"BracedPentagon",{40,1}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embeddings

GraphDataEmbeddings[GraphData[{"BracedPentagon",{40,1}}]]

Default embedding

GraphPlot[Graph[GraphData[{"BracedPentagon",{40,1}},"VertexList"],GraphData[{"BracedPentagon",{40,1}},"Edges"]]]

v={};
g=Graph[Range@Length@v,UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

g=FindCorrespondingGraph[,v]

RecognizeGraph@g

Degenerate

GraphData[{"BracedPentagon",{40,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"BracedPentagon",{40,1}},"Graph","Degenerate"]

HouseOfGraphs

hogid=GraphData[{"BracedPentagon",{40,1}},"NotationRules","HouseOfGraphs"]

HouseOfGraphsLookup[hogid]

HouseOfGraphsGraph[hogid]//StyleGraphs[#,ImageSize->Small]&

GeneralizedPetersen

GraphData[{"BracedPentagon",{40,1}},"Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData[{"BracedPentagon",{40,1}},"Graph","IGraph"]//StyleGraphs

Bilateral

GraphData[{"BracedPentagon",{40,1}},"Graph","Bilateral"]//StyleGraphs

Grid[DeleteCases[Monitor[{g=#,BilateralGraphEmbeddingTypes[#],GraphSymmetryGroup[#]}&/@GraphData[{"BracedPentagon",{40,1}},"Graph","All"],g],{_,_,TransformationGroup[{}]}],Dividers->All,Alignment->{{Center,{Left}}}]//Quiet

Circular

GraphData[{"BracedPentagon",{40,1}},"Graph","Circular"]//StyleGraphs

Circular construction

GraphData[{"BracedPentagon",{40,1}},"Hamiltonian"]

GraphData[{"BracedPentagon",{40,1}},"LCF"]

GraphData[{"BracedPentagon",{40,1}},"HamiltonianCycleCount"]

Planar

GraphData[{"BracedPentagon",{40,1}},"Planar"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossingNumber: "EmbeddingScheme" -> 1

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->1,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 2

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->2,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 3

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],"EmbeddingScheme"->3,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber crossings.uos.de [verified 16]

https://crossings.uos.de/job/new

ExportString[GraphData[{"BracedPentagon",{40,1}}],"DOT"]

-------- Forwarded Message --------
Subject: 	[crossings.uos.de] Braced 5 40 1 succeeded
Date: 	Sat, 20 Sep 2025 15:03:22 +0200
From: 	confirm@vm524.rz.uni-osnabrueck.de
To: 	eww@wolfram.com
CC: 	mirwagner@uos.de, markus.chimani@uos.de

Dear Eric Weisstein,

we have successfully computed the crossing number of your graph (Braced 5 40 1).
The graph has a crossing number of 16.

Please visit this link for detailed results: https://crossings.uos.de/job/ldcDodLg7AsI0H1U2KJL8A

MinimalCrossing

GraphData[{"BracedPentagon",{40,1}},"CN"]

GraphData[{"BracedPentagon",{40,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalRectilinearCrossing

GraphData[{"BracedPentagon",{40,1}},"RCN"]

GraphData[{"BracedPentagon",{40,1}},"Graph","MinimalRectilinearCrossing"]//StyleGraphs

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],Automatic,All,"Size"->Automatic,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

Select[gs,GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]

Take[gs,UpTo[100]]

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],Automatic,All,"Size"->XXX,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

Select[gs,GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]

Take[gs,UpTo[100]]

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],TimeConstraint->1])//AbsoluteTiming

Tutte:

(g=MinimalCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],"CrossingNumber"->cn])//PolyhedralGraphQ//AbsoluteTiming

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

TutteGraphs=BilateralGraph[CenterGraph@IGLayoutTutte[g,"OuterFace"->#],"ReturnNonbilateralGraph"->True]&/@faces

TutteGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData[{"BracedPentagon",{40,1}},"V"]])]
}&/@TutteGraphs;

Cases[TutteGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Select[Cases[TutteGraphsWithOuterCrossingPointCounts,{g_,1}:>g],Length[OuterFace[#]]>3&]

TutteGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData[{"BracedPentagon",{40,1}},"V"]],Table[False,cn]],
SameTest->Equal
]
}&/@TutteGraphs;

DeleteCases[
TutteGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]

Random:

(RandomGraphs=Table[MinimalCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],"CrossingNumber"->cn,RandomSeed->n],{n,5000}]//Union)//Timing

RandomGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData[{"BracedPentagon",{40,1}},"V"]])]
}&/@RandomGraphs;

Small numbers of crossing points on the boundary:

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Select[Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,1}:>g],Length[OuterFace[#]]>3&]

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData[{"BracedPentagon",{40,1}},"V"]],Table[False,cn]],
SameTest->Equal
]
}&/@RandomGraphs;

DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]/.g_Graph:>BilateralGraph[CenterGraph@g,"ReturnNonbilateralGraph"->True]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

RectilinearLocalCrossingCount[g]

MinimalLocalCrossing

GraphData[{"BracedPentagon",{40,1}},{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData[{"BracedPentagon",{40,1}},"Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData[{"BracedPentagon",{40,1}},{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData[{"BracedPentagon",{40,1}},"Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

(cn=CrossingNumber[GraphData[{"BracedPentagon",{40,1}}],TimeConstraint->10])//AbsoluteTiming

(gs=Select[Table[MinimalCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"BracedPentagon",{40,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

(gs=Select[Table[MinimalCrossingGraph[GraphData[{"BracedPentagon",{40,1}}],"CrossingNumber"->(cn=XXX),RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"BracedPentagon",{40,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

Circulant

GraphData[{"BracedPentagon",{40,1}},"Circulant"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Circulant"]//StyleGraphs

Circulant construction

GraphData[{"BracedPentagon",{40,1}},"NotationRules","Circulant"]

(ci=CirculantIndices[GraphData[{"BracedPentagon",{40,1}}]])//Timing

CirculantGraph1@@@ci

Cases[GraphData[{"BracedPentagon",{40,1}},"StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData[{"BracedPentagon",{40,1}},"ComplementGraph","Name"]

Line graph

GraphData[{"BracedPentagon",{40,1}},"Line"]

LineGraphQ[GraphData[{"BracedPentagon",{40,1}}]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]==={"BracedPentagon",{40,1}}&]

RootGraph[GraphData[{"BracedPentagon",{40,1}}]]

Halin

GraphData[{"BracedPentagon",{40,1}},"Halin"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"BracedPentagon",{40,1}},"Rigid"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"BracedPentagon",{40,1}},"Flexible"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"BracedPentagon",{40,1}},"LCF"]

GraphData[{"BracedPentagon",{40,1}},"HamiltonianCycleCount"]

GraphData[{"BracedPentagon",{40,1}},"LCFSignature"]

GraphData[{"BracedPentagon",{40,1}},"LCFNotations"]

GraphData[{"BracedPentagon",{40,1}},"Graph","LCF"]//StyleGraphs

Tally[LCFNotation[#][[2]]&/@%]

LCF compute all

Divisors[GraphData[{"BracedPentagon",{40,1}},"V"]]

Length[FindHamiltonianCycle[GraphData[{"BracedPentagon",{40,1}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"BracedPentagon",{40,1}}],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

Take[gs,-4]

BilateralGraphEmbeddingQ/@gs

UnitDistance

GraphData[{"BracedPentagon",{40,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"BracedPentagon",{40,1}}],Debug->True]//Timing

GraphData[{"BracedPentagon",{40,1}},"Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"BracedPentagon",{40,1}},"VertexList"],GraphData[{"BracedPentagon",{40,1}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]],MaxIterations->500]&/@Complement@@(GraphData[{"BracedPentagon",{40,1}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"BracedPentagon",{40,1}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"BracedPentagon",{40,1}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"BracedPentagon",{40,1}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"BracedPentagon",{40,1}}],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Select[IndexGraph/@gs,!DegenerateGraphEmbeddingQ[#]&&GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]//Timing

Matchstick

GraphData[{"BracedPentagon",{40,1}},"Matchstick"]

GraphData[{"BracedPentagon",{40,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"BracedPentagon",{40,1}},"Edges"]]

3D construction

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

3D All

GraphData[{"BracedPentagon",{40,1}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"BracedPentagon",{40,1}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"BracedPentagon",{40,1}},"Polyhedral"]

GraphData[{"BracedPentagon",{40,1}},"Graph",{"3D","Polyhedron"}]

Braced triangle

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{3,_},_,_,gn_}:>gn],Dividers->All]

"TriangleGraph"

HighlightGraphRegularPolygons[GraphData["TriangleGraph"],3]

FirstOrderRigidGraphQ[GraphData["TriangleGraph"]]

RigidGraphQ[GraphData["TriangleGraph"]]

GraphData["TriangleGraph","Graph","UnitDistance"]//StyleGraphs

GraphData["TriangleGraph","Graph","Rigid"]//StyleGraphs

Braced square

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{4,_},_,_,gn_}:>gn],Dividers->All]

{"BracedSquare" , {19, 1}} = Khodulyov (19 rods)

Andrei Khodulyov's solution

Graph

HighlightGraphRegularPolygons[GraphData[{"BracedSquare",{19,1}}],4]

g=GraphData[gn={"BracedSquare",{19,1}}]//StyleGraphs

GraphData[gn,"LCF"]

GraphData[gn,"Graph","UnitDistance"]//StyleGraphs

GraphData[gn,"Graph","All"]//StyleGraphs

UnitDistanceGraphQ[g,WorkingPrecision->∞]//FullSimplify

Graphic

Figure contributed by
Ed Pegg, Jr.
August 12 and 14, 2003

graphic=Show[With[{a={1+Sqrt[2]/2,1+Sqrt[2]/2},b={1+Sqrt[2]/2,Sqrt[2]/2},
d={Root[-23+24 #1+144 ((#1)^2)-288 ((#1)^3)+144 ((#1)^4)&,4],(1/12) (2+(Sqrt[2])) (3+(Sqrt[3]))},
e={Root[-23+24 #1+144 ((#1)^2)-288 ((#1)^3)+144 ((#1)^4)&,3],-(1/12) (2+(Sqrt[2])) (-3+(Sqrt[3]))}},
With[{c=Reverse[b],f=Reverse[d],g=Reverse[e]},Graphics[{
Line[{{1,1},a}],Line[{{0,1},c}],Line[{{1,0},b}],Line[{a,b}],Line[{a,c}],Line[{d,b}],Line[{e,b}],Line[{d,{0,1}}],Line[{e,{0,1}}],Line[{e,d}],Line[{f,g}],Line[{c,g}],Line[{c,f}],Line[{f,{1,0}}],Line[{g,{1,0}}],
AbsoluteThickness[3],RGBColor[1,0,0],
Line[{{0,0},{0,1},{1,1},{1,0},{0,0}}]}]]],AspectRatio-> Automatic]

Rigid

GraphData[{"BracedSquare",{19,1}},"Graph","Rigid"]//StyleGraphs

GraphData[{"BracedSquare",{19,1}},"EmbeddingClasses"]

FirstOrderRigidGraphQ[GraphData[{"BracedSquare",{19,1}}]]

RigidGraphQ[GraphData[{"BracedSquare",{19,1}}]]

Construction

lines=Join@@Cases[graphic,Line[x_]:>Partition[x,2,1],∞]

v=Union[Flatten[lines,1]]

e=Sort/@Sort[lines/.Thread[v->Range[Length[v]]]]

HighlightGraph[g=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->Automatic],Style[UndirectedEdge@@@Partition[{1,2,4,3},2,1,1],Directive[Red,Thick]]]

EdgeCount[g]

EuclideanDistance@@@(List@@@EdgeList[g]/.i_Integer:>v[[i]])//FullSimplify

UnitDistanceGraphQ[g]

GraphData

file=OpenWrite["~/braced-square-19.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedSquare",{19,1}},
"Name"->"19\[Hyphen]rod braced square graph",
"EmbeddingClasses"->{"Integral","MinimalIntegral","Primary","UnitDistance"}]]

Close[file]

{"BracedSquare", {21, 1}} = Friedman/Pegg (21 rods)

GraphData[{"BracedSquare",{21,1}}]//StyleGraphs

GraphData[{"BracedSquare",{21,1}},"Graph","All"]//StyleGraphs

Laman

LamanGraphQ[GraphData[{"BracedSquare",{21,1}}],Debug->True]

Rigid

GraphData[{"BracedSquare",{21,1}},"Graph","Rigid"]

FirstOrderRigidGraphQ[GraphData[{"BracedSquare",{21,1}}]]

RigidGraphQ[GraphData[{"BracedSquare",{21,1}}]]

HighlightGraphRegularPolygons[GraphData[{"BracedSquare",{21,1}}],4]

Search for subgraphs by removing vertices

g=GraphData[{"BracedSquare",{21,1}},"Graph","Labeled"]

n=VertexCount[g]

Vertices that are not part of the square:

vl=Complement[VertexList[g],{1,4,11,12}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction

https://erich-friedman.github.io/mathmagic/0100.html

s=Sqrt[3]/2;

v={{0,0},{1,0},{1/2,-s},{-1/2,-s},{-1,0},{0,Sqrt[2]},{1,1}/Sqrt[2],{-1,1}/Sqrt[2]};

{x,y}/.Solve[(x-v[[6,1]])^2+(y-v[[6,2]])^2==(x-v[[2,1]])^2+(y-v[[2,2]])^2==1,{x,y}]//FullSimplify

v={{0,0},{1,0},{1/2,-s},{-1/2,-s},{-1,0},{0,Sqrt[2]},{1,1}/Sqrt[2],{-1,1}/Sqrt[2],{(1/2)-(1/(Sqrt[6])),(1/(Sqrt[2]))-(1/(2 (Sqrt[3])))},{(1/2)+(1/(Sqrt[6])),(Sqrt[(7/12)+(1/(Sqrt[6]))])},{-1,1}{(1/2)-(1/(Sqrt[6])),(1/(Sqrt[2]))-(1/(2 (Sqrt[3])))},{-1,1}{(1/2)+(1/(Sqrt[6])),(Sqrt[(7/12)+(1/(Sqrt[6]))])}};

e=Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@v[[#]]-1]<.001&]//Quiet

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

g=;

r=RecognizeGraph[g]

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

Heptagon embedding

Rotate[GraphData[{"BracedSquare",{21,1}},"Graph",{"Labeled","All"}][[3]],-1.8]

v=CirclePoints[7];

v1=Join[v,Mean[v[[#]]]&/@{{2,6},{2,4},{4,6}}];

v2=Join[v1,Table[v1[[10]]+(v1[[9]]-v1[[10]])i/3,{i,2}]];

e=Join[Partition[Range[7],2,1,1],{{6,8},{2,8},{2,9},{4,9},{10,4},{6,10},{7,8},{1,8},{5,10},{3,9},{8,11},{4,11},{8,12},{4,12}}];

g=Graph[Range[Length[v2]],UndirectedEdge@@@e,VertexCoordinates->v2,VertexLabels->"Name"]

RecognizeGraph[g]

Pegg (Sqrt[6]) graph (21 rods) = {"BracedSquare", {21, 1}}

From Ed Pegg's computational prospecting NB, March 2018

Graphic

Module[{name,num,root,vals},name=Row[{"Braced square graph (in ",Sqrt[6],")"}];root=(Sqrt[6]);
vals={{{0,0},{0,0}},{{12,0},{0,0}},{{-12,0},{0,0}},{{0,0},{24,0}},{{-3,0},{9,0}},{{3,0},{9,0}},{{5,-2},{7,-2}},{{5,2},{7,2}},{{-5,-2},{7,2}},{{-5,2},{7,-2}},{{-6,0},{6,0}},{{6,0},{6,0}}}/12;
points=Map[Function[x,RootReduce[Sign[x.{1,root}](Sqrt[Abs[(x).{1,root}]])]],vals,{2}];
unitlines=Select[Subsets[points,{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,N[x]]]]==0]];
Text[Column[{name,Graphics[{EdgeForm[{Black}],Cyan,Opacity[.2],Polygon[points[[{1,11,4,12}]]],Opacity[1],Black,Line[unitlines],White,Table[Tooltip[Disk[points[[n]],.04],n],{n,1,Length[points]}]},ImageSize->{450,350}]},Alignment->Center]]]

Length[points]

Graph

g=GraphData[gn={"BracedSquare",{21,1}}]

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]

GraphData[gn,"LCF"]

GraphData[gn,"Graph","UnitDistance"]//StyleGraphs

GraphData[gn,"Graph","All"]//StyleGraphs

Construction

bracedsquare=System`Graph[Range[Length[points]],UndirectedEdge@@@(unitlines/.Thread[points->Range[Length[points]]]),VertexCoordinates->points]

EdgeCount[bracedsquare]

RecognizeGraph@bracedsquare

UnitDistanceGraphQ[bracedsquare,WorkingPrecision->∞]//FullSimplify

GraphData

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

WriteString[file,GraphDataString[bracedsquare,
"StandardName"->"BracedSquareGraph",
"Name"->"braced square graph"
]]

Close[file]

{"BracedSquare", {21, 1}}

{"BracedSquare", {21, 2}} = (triangle-free, 17-vertex removal from {"BracedSquare", {68, 1}})

Found by Ed Pegg, William Somsky, and Eric Weisstein on or around Jan 3, 2021

Independently found by Parcly Taxel  (Jeremy Tan) a few hours before that:

https://math.stackexchange.com/questions/3958870/bracing-a-polygon-without-triangles

GraphData[{"BracedSquare",{21,2}}]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedSquare",{21,2}}],4]

Search for subgraphs by removing vertices

g=GraphData[{"BracedSquare",{21,2}},"Graph","Labeled"]

n=VertexCount[g]

Vertices that are not part of the first square:

vl=Complement[VertexList[g],{2,12,6,9}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Vertices that are not part of the second square:

vl=Complement[VertexList[g],{1,2,4,5}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction by 17-vertex removal from {"BracedSquare", {68, 1}}

g1=VertexDelete[GraphData[{"BracedSquare",{68,1}}],{6,7,8,10,13,14,15,17,18,19,21,22,23,24,25,26,28}]

RecognizeGraph[g1]

g=GraphData[{"BracedSquare",{68,1}},"Graph","Labeled"]

n=VertexCount[g]

vl=Complement[VertexList[g],{1,2,4,5}]

nl=Length[vl]

Length[sets=Select[Subsets[vl,{17}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]]//Timing

sets//Column

gs=VertexDelete[GraphData[{"BracedSquare",{68,1}}],#]&/@sets

Counts[CanonicalForm/@gs]

So these are all the same graph.

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedSquare",{21,2}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedSquare",{21,2}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Laman

LamanGraphQ[GraphData[{"BracedSquare",{21,2}}]]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedSquare",{21,2}}]]

GraphData

uniq

EdgeCount/@uniq

file=OpenWrite["~/braced-triangle-free-square.m"]

Do[WriteString[file,GraphDataString[IndexGraph[uniq[[i]]],
"StandardName"->{"BracedSquareTriangleFree",{21,i}},
"Name"->"21\[Hyphen]rod braced square triangle\[Hyphen]free graph "<>ToString[i]
]],{i,Length[uniq]}]

Close[file]

{"BracedSquare", {27, 1} = Gardner (27 rods) =  (matchstick)

GraphData[{"BracedSquare",{27,1}},"Graph","All"]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedSquare",{27,1}}],4]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedSquare",{27,1}}],Debug->True]

Graphic

Graph

g=GraphData[gn={"BracedSquare",{27,1}}]

GraphData[gn,"LCF"]

GraphData[gn,"Graph","UnitDistance"]//StyleGraphs

GraphData[gn,"Graph","All"]//StyleGraphs

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->∞]//FullSimplify

Construction

CirclePoints[{Csc[Pi/4]/2,π/2},4]

{x,y}/.ToRules[Reduce[x<0&&y<0&&And@@Thread[EuclideanDistance[{x,y},#]&/@v[[{2,3}]]==1],{x,y},Reals]]//FullSimplify

{x,y}/.ToRules[Reduce[x<0&&y<0&&And@@Thread[EuclideanDistance[{x,y},#]&/@v[[{2,5}]]==1],{x,y},Reals]]//FullSimplify

{x,y}/.ToRules[Reduce[x<0&&y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{2,7}]]==1],{x,y},Reals]]//FullSimplify

{x,y}/.{ToRules[Reduce[x<0&&y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{9,11}]]==1],{x,y},Reals]]}//FullSimplify

v={{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0},{0,-(1/(Sqrt[2]))},{(1/(Sqrt[2])),0},{-(1/2) (Sqrt[2+(Sqrt[3])]),-(1/2) (Sqrt[2+(Sqrt[3])])},{(1/2) (Sqrt[2+(Sqrt[3])]),-(1/2) (Sqrt[2+(Sqrt[3])])},{-(1/2) (Sqrt[3 (2+(Sqrt[3]))]),(1/4) ((Sqrt[2])-(Sqrt[6]))},{(1/2) (Sqrt[3 (2+(Sqrt[3]))]),(1/4) ((Sqrt[2])-(Sqrt[6]))},{-(Sqrt[2]),(1/(Sqrt[2]))},{(Sqrt[2]),(1/(Sqrt[2]))},{0,1+(1/(Sqrt[2]))},
{-(Sqrt[(7/12)+(1/(Sqrt[6]))]),(1/2)+(1/(Sqrt[2]))+(1/(Sqrt[6]))},{(1/6) (-3 (Sqrt[2])+(Sqrt[3])),(1/2)+(1/(Sqrt[2]))-(1/(Sqrt[6]))},
{(Sqrt[(7/12)+(1/(Sqrt[6]))]),(1/2)+(1/(Sqrt[2]))+(1/(Sqrt[6]))},{(1/6) (3 (Sqrt[2])-(Sqrt[3])),(1/2)+(1/(Sqrt[2]))-(1/(Sqrt[6]))}};

e=Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@v[[#]]-1]<1*^-7&]

HighlightGraph[g=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],Style[UndirectedEdge@@@Partition[Range[4],2,1,1],Directive[Red,Thick]]]

Equal@@v[[{1,9,10}]][[All,2]]

EdgeCount[g]

RecognizeGraph[g]

GraphData

file=OpenWrite["~/braced-square-27.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedSquare",{27,1}},
"Name"->"27\[Hyphen]rod braced square",
"EmbeddingClasses"->{"Integral","MinimalIntegral","Primary","UnitDistance"}]]

Close[file]

Circular embedding

GraphData[{"BracedSquare",{27,1}},"Graph","All"][[2]]

{"BracedSquare", {68, 1}} = Ed Pegg (68 rods)  (triangle-free)

GraphData[{"BracedSquare",{68,1}}]//StyleGraphs

GraphRegularPolygons[GraphData[{"BracedSquare",{68,1}}],4]

Length[%]

HighlightGraphRegularPolygons[GraphData[{"BracedSquare",{68,1}}],4]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedSquare",{68,1}}]]

Search for Rigid graphs by vertex deletion

g=GraphData[{"BracedSquare",{68,1}},"Graph","Labeled"]

n=VertexCount[g]

vl=Complement[VertexList[g],{1,2,4,5}]

nl=Length[vl]

Do[Print[{n,Binomial[nl,n],SelectFirst[Subsets[vl,{n}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{n,0,nl}]

Construction

https://math.stackexchange.com/questions/2675079/doubling-the-cube-with-unit-sticks/

Construction from Ed's polynomials

v=RootReduce[ReIm/@Flatten[x/.Solve[#==0]&/@
{x,1-2 x+2 x^2,1+2 x+2 x^2,2-2 x+x^2-2 x^3+2 x^4,2+2 x+x^2+2 x^3+2 x^4,1+2 x+6 x^2-16 x^3+8 x^4,1-6 x+14 x^2-8 x^3+8 x^4,1+6 x+14 x^2+8 x^3+8 x^4,1-2 x+6 x^2+16 x^3+8 x^4}]]

e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<10^-4&]//Quiet

ed29poly=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

ed29poly=;

Through[{VertexCount,EdgeCount}[ed29poly]]

IsomorphicGraphQ[ed29,ed29poly]

FirstOrderRigidGraphQ[ed29poly]

Construction from Geometry

eqns=SquaredEuclideanDistance@@@{
{{1,-1}/2,{x,y}},
{{y,1-x},{x,y}},
{{x,y},{b,a}},
{{0,0},{a,b}}
}/.Abs:>Identity

vars=Variables[eqns]

soln=Flatten@Solve[Thread[eqns==1],vars,PositiveReals]//FullSimplify

XXX
v=Outer[List,Tuples[{-1,1},2],Tuples[{Identity,Reverse},2],{{y,x},{b,a},{x-1,y},{x,y},{0,0}},1]
XXX

v=FullSimplify[Union[Flatten[Table[{i,j}op1[#]&/@{{y,x},{b,a},{x-1,y},{x,y},{1,1}/2},{i,{-1,1}},{j,{-1,1}},{op1,{Identity,Reverse}}],3],{{0,0}}]/.soln]

Length[v]

e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<10^-4&]//Quiet

ed29=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

ed29=

RecognizeGraph[ed29]

Through[{VertexCount,EdgeCount}[g]]

LamanGraphQ[ed29,Debug->True]

Trianglefree

FindCycle[ed29,{3}]

Parcy Taxel claims it is a subgraph of hodfish, but I don't see that...

GraphData["HochbergODonnellFishGraph","Laman"]

GraphicsRow[{ed29,GraphData["HochbergODonnellFishGraph"]}//StyleGraphs,ImageSize->Large]

GraphData["HochbergODonnellFishGraph","V"]

In

https://math.stackexchange.com/questions/2675079/doubling-the-cube-with-unit-sticks/

Parcly Taxel claims the hodfish is a subgraph of this graph, but it don't seem so:

Show[{ed29,SetProperty[GraphData["HochbergODonnellFishGraph"],VertexStyle->Red]}]

Intersection@@(RootReduce/@GraphEmbedding/@{ed29,GraphData["HochbergODonnellFishGraph"]})

Length[%]

GraphData

file=OpenAppend["~/braced-triangle-free-square.m"]

ed29poly=

WriteString[file,GraphDataString[ed29poly,
"StandardName"->{"BracedSquareTriangleFree",{68,1}},
"Name"->"68\[Hyphen]rod braced square triangle\[Hyphen]free graph 1",
"Skip"->{"Anarboricity","Arboricity","ConnectedInducedSubgraphPolynomial","DominatingSets","GracefulLabeling","HamiltonianPaths","HamiltonianWalks","MinimalVertexCovers","MinimumWeightFractionalEdgeColoring","PathPolynomial","Skewness"}
]]

Close[file]

Braced pentagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{5,_},_,_,gn_}:>gn],Dividers->All]

{"BracedPentagon", {31, 1}} = Khodulyov (31 rods)

GraphData[{"BracedPentagon",{31,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedPentagon",{31,1}},"Graph","UnitDistance"]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedPentagon",{31,1}}],5]

Search for subgraphs by removing vertices

g=GraphData[{"BracedPentagon",{31,1}},"Graph","Labeled"]

n=VertexCount[g]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],{1,2,3,4,5}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction

Friedman: https://erich-friedman.github.io/mathmagic/0100.html

v1=CirclePoints[Csc[Pi/5]/2,5];

Graph[Range[Length[v1]],{},VertexCoordinates->v1,VertexLabels->"Name"]

v1[[4]]//N

v2=Join[v1,{v1[[4]]+{1,0},v1[[2]]-{1,0}}];

e=.

h=v[[4,2]]//FullSimplify

(soln=Solve[
FullSimplify@{SquaredEuclideanDistance[{a,b},v2[[4]]]==1,
SquaredEuclideanDistance[{c,d},v2[[4]]]==1,
SquaredEuclideanDistance[{c,d},{a,b}]==1,
SquaredEuclideanDistance[{a,b},{x,y}]==1,
SquaredEuclideanDistance[{c,d},{x,y}]==1,
SquaredEuclideanDistance[{ee,h},{x,y}]==1,
SquaredEuclideanDistance[{x,y},v2[[2]]]==1&&y>0&&b>0&&c>0&&ee<1/2}/.Abs:>Identity,{a,b,c,d,ee,x,y},Reals]//FullSimplify)

N[soln]

v3=Join[v2,{{a,b},{c,d},{x,y},{ee,h},{x,2h-y},{a,2h-b},{c,2h-d}}/.soln[[1]]]

p1=Mean[v3[[{6,7}]]]//FullSimplify

p2=Mean[v3[[{7,11}]]]//FullSimplify

v4=Join[v3,{p1-{0,Sqrt[1-SquaredEuclideanDistance[p1,v3[[7]]]]},p2-{0,Sqrt[1-SquaredEuclideanDistance[p2,v3[[7]]]]}}]//FullSimplify

soln2=Solve[{
SquaredEuclideanDistance[v4[[15]],{x,y}]==1,
SquaredEuclideanDistance[v4[[16]],{x,y}]==1,
SquaredEuclideanDistance[v4[[1]],{x,y}]==1,
SquaredEuclideanDistance[v4[[12]],{x,y}]==1},{x,y},Reals]

v5=Join[v4,{{x,y}/.soln2[[1]]}]//FullSimplify;

v=v5;

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

EdgeCount[g]

RecognizeGraph[g]

CN=3 construction

GraphPlot[MinimalCrossingGraph[GraphData[{"BracedPentagon",{31,1}}],VertexLabels->None]]

GraphData[{"BracedPentagon",{31,1}},{"V","M"}]

RegionIntersection[Line[v[[{1,3}]]],Line[v[[{2,6}]]]][[1,1]]

Mean[v[[{1,11}]]]

v=Join[CirclePoints[{1,π/2},6],{{-(1/(2 (Sqrt[3]))),(1/2)},{(1/(2 (Sqrt[3]))),(1/2)},{0,-1/8},{-1/5,-1/8},{-2/5,-1/8},{2/5,-1/8},{-(1/5),(7/16)},{0,0},{0,1/2},{0,1/3},{1/10,1/8}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[6],2,1,1],{{2,7},{6,8},{3,7},{1,7},{1,8},{5,8},{5,11},{5,12},{9,12},{10,9},{10,11},{3,11},{4,9},{11,13},{1,13},{10,14},{12,14},{10,15},{11,16},{15,16},{1,15},{14,17},{12,16},{16,17},{1,17}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Laman

LamanGraphQ[g,Debug->True]//Timing

GraphData

file=OpenWrite["~/braced-pentagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedPentagon",{31,1}},
"AlternateStandardNames"->{{"BracedPolygon",{5,{31,1}}}},
"Name"->"31\[Hyphen]rod braced pentagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{5,31}},
"Skip"->{"AlmostHamiltonian","Arboricity","HamiltonianWalks"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedPentagon", {33, 1}} (removed vertices from {"BracedPentagon", {20, 1}})

GraphData[{"BracedPentagon",{33,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedPentagon",{33,1}},"Hamiltonian"]

GraphData[{"BracedPentagon",{33,1}},"HamiltonianCycleCount"]

g=CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedPentagon",{33,1}}]]

r=RecognizeGraph[g]

Search for Rigid subgraphs by removing vertices

pents=GraphRegularPolygons[cc1,5]

g=;

n=VertexCount[g]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],pents[[1]]]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

g2=IndexGraph@VertexDelete[g,{1,2}]

pents=GraphRegularPolygons[g2,5]

HighlightGraphRegularPolygons[g2,5]

Table[CycleCount[g2,n],{n,3,6}]

Through[{VertexCount,EdgeCount}[g2]]

FirstOrderRigidGraphQ[g2]

LamanGraphQ[g2,Debug->True]

{"BracedPentagon", {40, 1}} one of the 2 cc's of {"UnitDistance", {40, 1}} from Ed)

Subgraph

GraphData[{"BracedPentagon",{40,1}},"Graph","UnitDistance"]//StyleGraphs

All

GraphData[{"BracedPentagon",{40,1}},"Graph","All"]//StyleGraphs

LCF

GraphData[{"BracedPentagon",{40,1}},"Graph","LCF"]//StyleGraphs

GraphData[{"BracedPentagon",{40,1}},"LCFSignature"]

GraphData[{"BracedPentagon",{40,1}},"Hamiltonian"]

GraphData[{"BracedPentagon",{40,1}},"HamiltonianCycles"]

GraphData[{"BracedPentagon",{40,1}},"LCF"]

LCF[GraphData[{"BracedPentagon",{40,1}}],All]

r=RecognizeGraph[g]

Construction from {"UnitDistance", {40, 1}}

cc=ConnectedGraphComponents[GraphData[{"UnitDistance",{40,1}},"Graph","All"][[1]]]

FirstOrderRigidGraphQ/@cc

IsomorphicGraphQ@@cc

cc1=IndexGraph@cc[[1]]

g=;

g=cc1;

LamanGraphQ[cc1,Debug->True]

FirstOrderRigidGraphQ[cc1]

UnitDistanceGraphEmbeddingQ[cc1]

pents=GraphRegularPolygons[cc1,5]

Table[CycleCount[cc1,n],{n,3,6}]

HighlightGraphRegularPolygons[cc1,5]

GraphData

file=OpenWrite["~/braced-pent-2.m"]

WriteString[file,GraphDataString[g2,
"StandardName"->{"BracedPentagon",{33,1}},
"Name"->"33\[Hyphen]rod braced pentagon 1",
"Information"->"BracedPolygon",
TimeConstraint->60
]]

Close[file]

{"BracedPentagon", {69, 1}} = O'Beirne (69 rods) [matchstick]

Martin Gardner says, in his "Sixth Book of Mathematical Games", that T. H. O'Beirne managed to find a rigid pentagon using only 69 rods, but he didn't give the solution (Friedman 2000–2006).

Graph

g=GraphData[gn={"BracedPentagon",{69,1}}]

HighlightGraphRegularPolygons[GraphData[{"BracedPentagon",{69,1}}],5]

GraphData[gn,"LCF"]

GraphData[gn,"Graph","UnitDistance"]//StyleGraphs

GraphData[gn,"Graph","All"]//StyleGraphs

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->∞]//FullSimplify//Quiet

Graphic

Figure contributed by
Ed Pegg, Jr.
August 12 and 14, 2003

Show[Graphics[graphic={Line[{{7982,-6619.25},{7279,-2731.25}}],Line[{{7982,-6619.25},{11590,-8226.25}}],Line[{{8395,-10548.3},{7982,-6619.25}}],Line[{{9615,-14306.3},{11590,-17727.3}}],Line[{{10887,-4338.25},{7279,-2731.25}}],Line[{{10887,-4338.25},{14785,-3705.25}}],Line[{{11177,-2098.25},{7279,-2731.25}}],Line[{{11177,-2098.25},{14372,223.75}}],Line[{{11177,-2098.25},{14785,-3705.25}}],Line[{{11590,-17727.3},{13564,-14306.3}}],Line[{{11590,-8226.25},{10887,-4338.25}}],Line[{{13564,-14306.3},{15539,-17727.3}}],Line[{{14785,-10548.3},{12810,-7127.25}}],Line[{{14785,-10548.3},{16759,-7127.25}}],Line[{{14785,-10548.3},{18733,-10548.3}}],Line[{{14785,-3705.25},{12810,-7127.25}}],Line[{{14785,-3705.25},{14372,223.75}}],Line[{{14785,-3705.25},{16759,-7127.25}}],Line[{{14785,-3705.25},{18733,-3705.25}}],Line[{{15539,-17727.3},{11590,-17727.3}}],Line[{{15539,-17727.3},{17513,-14306.3}}],Line[{{16759,-7127.25},{12810,-7127.25}}],Line[{{16759,-7127.25},{18733,-10548.3}}],Line[{{16759,-7127.25},{18733,-3705.25}}],Line[{{17513,-14306.3},{13564,-14306.3}}],Line[{{17513,-14306.3},{18733,-10548.3}}],Line[{{17513,-14306.3},{20155,-17242.3}}],Line[{{18321,223.75},{14372,223.75}}],Line[{{18321,223.75},{18733,-3705.25}}],Line[{{18733,-10548.3},{21376,-13484.3}}],Line[{{19146,-7634.25},{18733,-3705.25}}],Line[{{19146,-7634.25},{22192,-10149.3}}],Line[{{19146,-7634.25},{22341,-5312.25}}],Line[{{19146,-7634.25},{22845,-6252.25}}],Line[{{20155,-17242.3},{21376,-13484.3}}],Line[{{21376,-13484.3},{17513,-14306.3}}],Line[{{21376,-13484.3},{24018,-16420.3}}],Line[{{21928,-1383.25},{18321,223.75}}],Line[{{21928,-1383.25},{18733,-3705.25}}],Line[{{21928,-1383.25},{22341,-5312.25}}],Line[{{22192,-10149.3},{25238,-12663.3}}],Line[{{22341,-5312.25},{18733,-3705.25}}],Line[{{22341,-5312.25},{24798,-2219.25}}],Line[{{22845,-6252.25},{22192,-10149.3}}],Line[{{24018,-16420.3},{20155,-17242.3}}],Line[{{24018,-16420.3},{25238,-12663.3}}],Line[{{24798,-2219.25},{26246,-5895.25}}],Line[{{25238,-12663.3},{21376,-13484.3}}],Line[{{25238,-12663.3},{27695,-9570.25}}],Line[{{25891,-8767.25},{22192,-10149.3}}],Line[{{25891,-8767.25},{22845,-6252.25}}],Line[{{25891,-8767.25},{25238,-12663.3}}],Line[{{26246,-5895.25},{22341,-5312.25}}],Line[{{26246,-5895.25},{27695,-9570.25}}],Line[{{26246,-5895.25},{28703,-2802.25}}],Line[{{27695,-9570.25},{29144,-13245.3}}],Line[{{27695,-9570.25},{30152,-6477.25}}],Line[{{28703,-2802.25},{24798,-2219.25}}],Line[{{28703,-2802.25},{30152,-6477.25}}],Line[{{29144,-13245.3},{25238,-12663.3}}],Line[{{29144,-13245.3},{31601,-10152.3}}],Line[{{30152,-6477.25},{26246,-5895.25}}],Line[{{30152,-6477.25},{31601,-10152.3}}],Line[{{31601,-10152.3},{27695,-9570.25}}],Red,AbsoluteThickness[3],Line[{{13564,-14306.3},{9615,-14306.3},{8395,-10548.3},{11590,-8226.25},{14785,-10548.3},{13564,-14306.3}}]},AspectRatio->Automatic]]

(rotated and flipped version of the one given in Fig. T6, p. 71, of Frederickson 2002)

Search for Rigid subgraphs by removing vertices

g=GraphData[{"BracedPentagon",{69,1}},"Graph","Labeled"]

n=VertexCount[g]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],{3,4,10,12,8}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedPentagon",{69,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedPentagon",{69,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Laman

LamanGraphQ[pentagon,Debug->True]//Timing

Construction

lines=Join@@Cases[graphic,Line[x_]:>Partition[x,2,1],∞];

v=Union[Flatten[lines,1]]

e=Sort/@Sort[lines/.Thread[v->Range[Length[v]]]]

EuclideanDistance@@v[[{3,4}]]

v=v/3951.071247142982`;

mean=Mean[v[[{3,4,10,12,8}]]]

v=(#-mean)&/@v

v={{-1.0910458785366466`,2.2413769446460003`},{-0.9131194489617966`,1.257340019771155`},{-0.8085908352855338`,0.26291350750790654`},{-0.499813816677686`,-0.6882209481710206`},{-0.1778758103914715`,1.8346518062010733`},{-0.10447799449288464`,2.401586660038433`},{0.0000506191833786751`,-1.5540620798574518`},{0.0000506191833786751`,0.8506148813262282`},{0.308827637791226`,1.1287672939901825`},{0.4996619591275513`,-0.6882209481710206`},{0.7041634599760274`,2.98927537906091`},{0.8086920736522907`,0.26291350750790654`},{0.8086920736522907`,1.9948615215935057`},{0.999526394988616`,-1.5540620798574518`},{1.3083034135964637`,1.1287672939901825`},{1.499137734932789`,-0.6882209481710206`},{1.703639235781265`,2.98927537906091`},{1.8079147535406368`,0.26291350750790654`},{1.8079147535406368`,1.9948615215935057`},{1.9124433672168997`,1.0004476641261015`},{2.1678171473606036`,-1.4313105601649876`},{2.4768472618853425`,-0.48017610448606085`},{2.616556208009549`,2.5825502406159826`},{2.6833735300689523`,0.36389877834768614`},{2.7210848216858117`,1.5881363831485786`},{2.8486451637992176`,1.350226221270401`},{3.1455266743131562`,-1.2232657164800282`},{3.3429414894886658`,2.3709620540945395`},{3.454303692921004`,-0.2723843567179931`},{3.6195753266512702`,0.71368999028783`},{3.709424377147816`,1.4405814636007301`},{4.076160360723858`,0.5104539690238123`},{4.33128104495067`,2.223407134546691`},{4.4428963442999`,-0.41968618034894956`},{4.698017028526712`,1.2932796399697735`},{5.064753012102754`,0.36313949059701134`}};

gapprox=HighlightGraph[g=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->Automatic],Style[UndirectedEdge@@@Partition[{3,4,10,12,8},2,1,1],Directive[Red,Thick]]]

EdgeCount[gapprox]

vexact=RootApproximant/@v

Length[vexact]

e=Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@vexact[[#]]-1]<1*^-7&];//Quiet
HighlightGraph[System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->vexact,VertexLabels->Automatic],Style[UndirectedEdge@@@Partition[{3,4,10,12,8},2,1,1],Directive[Red,Thick]]]

CirclePoints[Csc[Pi/5]/2,5]//FullSimplify//ToRadicals

{x,y}/.ToRules[Reduce[y<0&&And@@Thread[EuclideanDistance[{x,y},#]&/@v[[{5,1}]]==1],{x,y},Reals]]//FullSimplify

v[[8]]+v[[2]]-v[[1]]//FullSimplify//ToRadicals

{x,y}/.ToRules[Reduce[y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{3,4}]]==1],{x,y},Reals]]//FullSimplify//ToRadicals

{x,y}/.ToRules[Reduce[y<0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{8,9}]]==1],{x,y},Reals]]//FullSimplify

{x,y}/.ToRules[Reduce[y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{2,9}]]==1],{x,y},Reals]]//FullSimplify//ToRadicals

{x,y}/.ToRules[Reduce[y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{2,12}]]==1],{x,y},Reals]]//FullSimplify//ToRadicals

{x,y}/.{ToRules[Reduce[y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{13,12}]]==1],{x,y},Reals]]}//FullSimplify//ToRadicals

{x,y}/.{ToRules[Reduce[y>0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{12,14}]]==1],{x,y},Reals]]}//FullSimplify//ToRadicals

{x,y}/.{ToRules[Reduce[y<0&&And@@Thread[SquaredEuclideanDistance[{x,y},#]&/@v[[{8,11}]]==1],{x,y},Reals]]}//FullSimplify

c

FullSimplify[v[[10]]+v[[16]]-v[[3]]]

FullSimplify[v[[14]]+v[[17]]-v[[16]]]

FullSimplify[v[[15]]+v[[19]]-v[[14]]]

v[[14]]+RotationMatrix[-Pi/3].(v[[18]]-v[[14]])//FullSimplify

v[[8]]+RotationMatrix[-Pi/3].(v[[11]]-v[[8]])//FullSimplify

rot[{i_,j_},sign_]:=v[[i]]+RotationMatrix[sign Pi/3].(v[[j]]-v[[i]])//FullSimplify

rot[{11,21},1]

rot[{11,22},1]

rot[{15,20},-1]

rot[{15,24},-1]

rot[{25,15},1]

Mean[v[[{26,23}]]]//FullSimplify

rot[{35,31},1]

rot[{30,31},1]

rot[{32,33},-1]

rot[{32,25},-1]

Mean[v[[{25,30}]]]//FullSimplify

Mean[v[[{23,30}]]]//FullSimplify

rot[{23,25},-1]

rot[{27,28},-1]

rot[{27,26},-1]

v={{(1/2),-(1/2) (Sqrt[1+(2/(Sqrt[5]))])},{(1/4) (1+(Sqrt[5])),(1/2) (Sqrt[(1/10) (5-(Sqrt[5]))])},{0,(Sqrt[(1/10) (5+(Sqrt[5]))])},{(1/4) (-1-(Sqrt[5])),(1/2) (Sqrt[(1/10) (5-(Sqrt[5]))])},{-(1/2),-(1/2) (Sqrt[1+(2/(Sqrt[5]))])},{0,-((Sqrt[3])/2)-(1/2) (Sqrt[1+(2/(Sqrt[5]))])},{1,-((Sqrt[3])/2)-(1/2) (Sqrt[1+(2/(Sqrt[5]))])},{(3/2),-(1/2) (Sqrt[1+(2/(Sqrt[5]))])},{(1/4) (5+(Sqrt[5])),(1/2) (Sqrt[(1/10) (5-(Sqrt[5]))])},{(1/8) (-1-(Sqrt[5])-(Sqrt[6 (5-(Sqrt[5]))])),(1/4) (Sqrt[7+(13/(Sqrt[5]))+(Sqrt[78+(174/(Sqrt[5]))])])},{(1/8) (11+(Sqrt[5])+(Sqrt[6 (5+(Sqrt[5]))])),-(1/4) (Sqrt[5-(7/(Sqrt[5]))+(Sqrt[6-(6/(Sqrt[5]))])])},{(1/4) (3+(Sqrt[5])),(1/20) (10 (Sqrt[3])+(Sqrt[50-10 (Sqrt[5])]))},{(1/4) (-1+(Sqrt[5])),(1/20) (10 (Sqrt[3])+(Sqrt[50-10 (Sqrt[5])]))},{(1/4) (1+(Sqrt[5])),(Sqrt[3])+(1/2) (Sqrt[(1/10) (5-(Sqrt[5]))])},{(1/4) (5+(Sqrt[5])),(Sqrt[3])+(1/2) (Sqrt[(1/10) (5-(Sqrt[5]))])},{(1/8) (1+(Sqrt[5]))-(1/488) (Sqrt[976 (Sqrt[6 (3665-941 (Sqrt[5]))])-366 (35+(Sqrt[5]))]),√Root[11296321-127454410 #1+1065155195 ((#1)^2)-5132397250 ((#1)^3)+12980196025 ((#1)^4)-17709113000 ((#1)^5)+12887918000 ((#1)^6)-4572560000 ((#1)^7)+595360000 ((#1)^8)&,4]},{(1/488) (-61 (Sqrt[30-6 (Sqrt[5])])-(Sqrt[976 (Sqrt[6 (3665-941 (Sqrt[5]))])-366 (35+(Sqrt[5]))])),√Root[35324826601-1630985676080 #1+10936315142720 ((#1)^2)-27357796515200 ((#1)^3)+34467897510400 ((#1)^4)-24158811136000 ((#1)^5)+9504793088000 ((#1)^6)-1932636160000 ((#1)^7)+152412160000 ((#1)^8)&,4]},{(1/8) (1+(Sqrt[5])-(Sqrt[30-6 (Sqrt[5])])),(1/4) (Sqrt[71+(53/(Sqrt[5]))-(Sqrt[894-(1986/(Sqrt[5]))])])},{(1/8) (3+3 (Sqrt[5])-(Sqrt[30-6 (Sqrt[5])])),(1/4) (Sqrt[67+(73/(Sqrt[5]))+(Sqrt[942+(2094/(Sqrt[5]))])])},{(1/8) (11+3 (Sqrt[5])-(Sqrt[30-6 (Sqrt[5])])),(1/4) (Sqrt[67+(73/(Sqrt[5]))+(Sqrt[942+(2094/(Sqrt[5]))])])},{(1/8) (13-(Sqrt[5])+(Sqrt[6 (5+(Sqrt[5]))])),-(1/4) (Sqrt[17+(13/(Sqrt[5]))+(Sqrt[102-(6/(Sqrt[5]))])])},{(1/4) (6+(Sqrt[6 (5+(Sqrt[5]))])),-(1/2) (Sqrt[(Sqrt[6+(6/(Sqrt[5]))])-(11/10) (-5+(Sqrt[5]))])},{(1/4) (5+(Sqrt[5])+(Sqrt[6 (5+(Sqrt[5]))])),-(1/2) (Sqrt[5-(8/(Sqrt[5]))-2 (Sqrt[3-(6/(Sqrt[5]))])])},{(1/2) (3+(Sqrt[5])),(Sqrt[(7/2)+(1/(2 (Sqrt[5])))+(Sqrt[6 (1+(1/(Sqrt[5])))])])},{(1/8) (11+3 (Sqrt[5])+(Sqrt[30-6 (Sqrt[5])])),(1/4) (Sqrt[43-(47/(Sqrt[5]))+(Sqrt[174+(366/(Sqrt[5]))])])},{(1/8) (9+(Sqrt[5])+(Sqrt[30-6 (Sqrt[5])])),(1/4) (Sqrt[47-(67/(Sqrt[5]))-(Sqrt[1662-(3714/(Sqrt[5]))])])},{(1/16) (19+3 (Sqrt[5])+(Sqrt[150+66 (Sqrt[5])])),(1/8) (Sqrt[109-(233/(Sqrt[5]))+3 (Sqrt[1158-(2586/(Sqrt[5]))])])},{(1/8) (13+2 (Sqrt[5])+(Sqrt[15+6 (Sqrt[5])])),(1/4) (Sqrt[(1/2) (106-(169/(Sqrt[5]))+(Sqrt[16635-(35454/(Sqrt[5]))]))])},{(1/16) (27+5 (Sqrt[5])+3 (Sqrt[6 (5+(Sqrt[5]))])),(1/8) (Sqrt[143-(253/(Sqrt[5]))+(Sqrt[32478-(72606/(Sqrt[5]))])])},{(1/4) (9+2 (Sqrt[5])+(Sqrt[15+6 (Sqrt[5])])),(1/2) (Sqrt[(1/2) (34-(41/(Sqrt[5]))-(Sqrt[1371-(3054/(Sqrt[5]))]))])},{(1/8) (14+3 (Sqrt[5])+(Sqrt[75+30 (Sqrt[5])])),(1/4) (Sqrt[(1/2) (74-(109/(Sqrt[5]))-(Sqrt[6675-(14286/(Sqrt[5]))]))])},{(1/16) (29+7 (Sqrt[5])+(Sqrt[30 (5+(Sqrt[5]))])),(1/8) (Sqrt[179-(233/(Sqrt[5]))+(Sqrt[24270-(46734/(Sqrt[5]))])])},{(1/8) (15+4 (Sqrt[5])+(Sqrt[75-30 (Sqrt[5])])),(1/4) (Sqrt[(1/2) (130-(89/(Sqrt[5]))+(Sqrt[7995+(114/(Sqrt[5]))]))])},{(1/16) (37+9 (Sqrt[5])+3 (Sqrt[30-6 (Sqrt[5])])),(1/8) (Sqrt[313-(293/(Sqrt[5]))+31 (Sqrt[102-(186/(Sqrt[5]))])])},{(1/16) (35+7 (Sqrt[5])+(Sqrt[6 (85+31 (Sqrt[5]))])),(1/8) (Sqrt[281-(293/(Sqrt[5]))-19 (Sqrt[246-(426/(Sqrt[5]))])])},{(1/16) (27+5 (Sqrt[5])+5 (Sqrt[6 (5+(Sqrt[5]))])),-(1/40) (Sqrt[4175-665 (Sqrt[5])-5 (Sqrt[30 (25225-7829 (Sqrt[5]))])])}
};
e=Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@v[[#]]-1]<1*^-7&];//Quiet
g=HighlightGraph[System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->Automatic,Axes->True],Style[UndirectedEdge@@@Partition[Range[5],2,1,1],Directive[Red,Thick]]]

EdgeCount[g]

IsomorphicGraphQ[g,gapprox]

UnitDistanceEmbeddingGraphQ[g]

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->Infinity]//FullSimplify

ToCommonEdges[g,gapprox]//FullSimplify

ToRadicals[%]

GraphData

file=OpenWrite["~/braced-pentagon-27.m"]

WriteString[file,GraphDataString[gapprox,
"StandardName"->{"BracedPentagon",{69,1}},
"Name"->"69\[Hyphen]rod braced pentagon 1",
"EmbeddingClasses"->{"Integral","MinimalIntegral","Primary","UnitDistance"},
TimeConstraint->10
]]

Close[file]

{"BracedPentagon", {75, 1}} = Friedman (75 rods)

GraphData[{"BracedPentagon",{75,1}}]//StyleGraphs

GraphData[{"BracedPentagon",{75,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedPentagon",{75,1}},"Graph","Planar"]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedPentagon",{75,1}}],5]

Crash in PolygonAngle : bug (403848)

Length[cyc=FindCycle[GraphData[{"BracedPentagon",{75,1}}],{5},All]]

Table[i->HighlightGraph[GraphData[{"BracedPentagon",{75,1}}],cyc[[i]]],{i,21}]

HighlightGraph[GraphData[{"BracedPentagon",{75,1}}],Style[cyc[[4]],Directive[Red,Thick]]]

Laman

LamanGraphQ[g,Debug->True]//Timing

Construction

https://erich-friedman.github.io/mathmagic/0100.html

s=Sqrt[3]/2;
v1=Join[
Table[{x,0},{x,-2,2}],
Table[{x,-s},{x,-3/2,3/2,1}],
Union@@Table[{0,(Sqrt[5])}+i/3({2j,0}-{0,(Sqrt[5])}),{i,0,2},{j,-1,1,2}]
];

u=RotationMatrix[π/3].Subtract@@v1[[{13,12}]]//FullSimplify

v1[[12]]+

v2=Join[v1,
Table[v1[[12]]+u+i(v[[13]]-v[[12]]),{i,0,2}],
Table[v1[[12]]+{-1,1}u+i(v[[11]]-v[[12]]),{i,0,2}],
{{0,-1}}
]//FullSimplify;

v=v2;

d=v2[[2]]-v2[[21]]

v3=Join[v2,{0,-1}+#&/@(RotationMatrix[π/4].#&/@(({0,Sqrt[2]}+#)&/@{{-1,0},{0,0},{1,0},{-1/2,s},{1/2,s}}))];//FullSimplify

v4=Join[v3,UnitDistancePoints@@v[[{21,24}]],UnitDistancePoints@@v[[{21,22}]]]//FullSimplify;

X={x,y}/.FullSimplify[Solve[{SquaredEuclideanDistance[v4[[21]],{x,y}]==4,SquaredEuclideanDistance[v4[[12]],{x,y}]==4,x>0},{x,y},Reals]][[1]]

v5=Join[v4,{Mean[{X,v4[[21]]}],X,Mean[{X,v4[[12]]}]}]//FullSimplify;

{topa,topb}=UnitDistancePoints@@v[[{12,33}]]//FullSimplify

v6=Join[v5,{topb,topb+v5[[33]]-v5[[12]]}];

v7=Join[v6,{First[UnitDistancePoints@@v[[{21,31}]]//FullSimplify]}];

v8=Join[v7,{Last[UnitDistancePoints@@v[[{31,36}]]//FullSimplify]}];

v9=Join[v8,{Last[UnitDistancePoints@@v[[{3,31}]]//FullSimplify]}];

v10=Join[v9,{First[UnitDistancePoints@@v[[{33,38}]]//FullSimplify]}];

v11=Join[v10,{Last[UnitDistancePoints@@v[[{31,39}]]//FullSimplify]}];

v=FullSimplify@Union[v11];

e=Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@v[[#]]-1]<1*^-4&]//Quiet

Length[e]

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

Planar construction

GraphPlot[PlanarGraph[GraphData[{"BracedPentagon",{75,1}}]]]

v=Join[CirclePoints[{Csc[Pi/13]/2,-π/2},13],{{-(1/2) Csc[(π/13)] Sin[((2 π)/13)],-(1/2) Csc[(π/13)] Sin[((5 π)/26)]},{(1/2) Csc[(π/13)] Sin[((2 π)/13)],-(1/2) Csc[(π/13)] Sin[((5 π)/26)]},{-(1/3) Cos[(π/13)],-(1/2) Csc[(π/13)] Sin[((5 π)/26)]},{(1/3) Cos[(π/13)],-(1/2) Csc[(π/13)] Sin[((5 π)/26)]}},
{{-Cos[(π/13)],-(1/2) Csc[(π/13)] Sin[(π/26)]},{(1/24) (-20 Cos[(π/13)]+Csc[(π/26)]),-(1/2) Csc[(π/13)] Sin[(π/26)]},{(1/12) (-8 Cos[(π/13)]+Csc[(π/26)]),-(1/2) Csc[(π/13)] Sin[(π/26)]},{(1/8) (-4 Cos[(π/13)]+Csc[(π/26)]),-(1/2) Csc[(π/13)] Sin[(π/26)]},{(1/6) (-2 Cos[(π/13)]+Csc[(π/26)]),-(1/2) Csc[(π/13)] Sin[(π/26)]},{(1/24) (-4 Cos[(π/13)]+5 Csc[(π/26)]),-(1/2) Csc[(π/13)] Sin[(π/26)]},{-Cos[(π/13)],-(1/4) Csc[(π/13)] (Sin[(π/26)]+Sin[((5 π)/26)])}},
{{(1/24) (-20 Cos[(π/13)]+Csc[(π/26)]),(1/24) (4 Cos[(π/13)]+Csc[(π/26)]-6 Sec[(π/26)])},{(1/12) (-8 Cos[(π/13)]+Csc[(π/26)]),(1/24) (4 Cos[(π/13)]+Csc[(π/26)]-6 Sec[(π/26)])},{(1/8) (-4 Cos[(π/13)]+Csc[(π/26)]),(1/24) (4 Cos[(π/13)]+Csc[(π/26)]-6 Sec[(π/26)])},{(1/6) (-2 Cos[(π/13)]+Csc[(π/26)]),(1/24) (4 Cos[(π/13)]+Csc[(π/26)]-6 Sec[(π/26)])}},
{{(NumericalApproximation[Root, (RowDefault["1.60", FEExpressionsNumericalApproximationElider]), Root[-25+160 #1-288 ((#1)^2)+56 ((#1)^3)+288 ((#1)^4)-256 ((#1)^5)+64 ((#1)^6)&,6], ]),((Csc[(π/13)] Sin[(π/26)] (2 Cos[(π/26)]+Cos[((3 π)/26)]+Cos[((5 π)/26)]+Sin[((2 π)/13)]))/(2 (Cos[((3 π)/26)]+Cos[((5 π)/26)]+Sin[(π/13)]+Sin[((2 π)/13)])))},{(((Sqrt[2])+Cos[(π/52)]+Cos[((5 π)/52)]+Cos[((7 π)/52)]+Cos[((9 π)/52)]+Cos[((11 π)/52)]+Sin[(π/52)]+Sin[((5 π)/52)]-Sin[((7 π)/52)]+Sin[((9 π)/52)]-Sin[((11 π)/52)])/(2 ((Sqrt[2])+Cos[((9 π)/52)]+Sin[((9 π)/52)]))),((Csc[(π/13)] (Cos[(π/26)]-Cos[((3 π)/26)]+Cos[((5 π)/26)]+2 Sin[((2 π)/13)]+2 Sin[((3 π)/13)]))/(4 (Cos[(π/52)]-Sin[(π/52)]) ((Sqrt[2])+Cos[((9 π)/52)]+Sin[((9 π)/52)])))},{(1/2) ((NumericalApproximation[Root, (RowDefault["1.60", FEExpressionsNumericalApproximationElider]), Root[-25+160 #1-288 ((#1)^2)+56 ((#1)^3)+288 ((#1)^4)-256 ((#1)^5)+64 ((#1)^6)&,6], ])+(((Sqrt[2])+Cos[(π/52)]+Cos[((5 π)/52)]+Cos[((7 π)/52)]+Cos[((9 π)/52)]+Cos[((11 π)/52)]+Sin[(π/52)]+Sin[((5 π)/52)]-Sin[((7 π)/52)]+Sin[((9 π)/52)]-Sin[((11 π)/52)])/(2 ((Sqrt[2])+Cos[((9 π)/52)]+Sin[((9 π)/52)])))),(1/8) Csc[(π/13)] (((4 Sin[(π/26)] (Cos[(π/13)]-Sin[(π/26)]+Sin[((3 π)/26)]))/(-1+2 Cos[(π/13)]-2 Sin[(π/26)]+2 Sin[((3 π)/26)]))+((Cos[(π/26)]-Cos[((3 π)/26)]+Cos[((5 π)/26)]+2 Sin[((2 π)/13)]+2 Sin[((3 π)/13)])/((Cos[(π/52)]-Sin[(π/52)]) ((Sqrt[2])+Cos[((9 π)/52)]+Sin[((9 π)/52)]))))}},
{{(1/6) (1-4 Cos[(π/13)]),(1/6) Csc[(π/13)] (Cos[(π/13)]-2 Sin[(π/26)])},{(2/3) ((Sin[(π/26)])^2),(1/6) Csc[(π/13)] (2 Cos[(π/13)]-Sin[(π/26)])}},
{{(1/2)-(1/2) Csc[(π/13)] Sin[((3 π)/13)],(1/2) Cos[((3 π)/13)] Csc[(π/13)]},{(1/2)-(1/2) Csc[(π/13)] Sin[((3 π)/13)],(1/2) Csc[(π/13)] Sin[((3 π)/26)]}},
{{-Cos[((2 π)/13)],(1/6) Csc[(π/13)] (2 Cos[((3 π)/13)]+Sin[((3 π)/26)])},{-Cos[((2 π)/13)],(1/6) Csc[(π/13)] (Cos[((3 π)/13)]+2 Sin[((3 π)/26)])}},
{{(1/3) (-Cos[((2 π)/13)]-Cos[((3 π)/26)] Csc[(π/13)]),(1/2) Csc[(π/13)] Sin[((3 π)/26)]},{(1/6) (-4 Cos[((2 π)/13)]-Cos[((3 π)/26)] Csc[(π/13)]),(1/2) Csc[(π/13)] Sin[((3 π)/26)]}}];

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[13],2,1,1],Partition[Range[18,23],2,1],{{12,14},{14,16},{16,17},{15,17},{3,15},{13,14},{2,15},{1,14},{1,15},{4,15},{11,14},{4,23},{14,24},{18,24},{8,18},{11,18},{17,24},{23,28},{4,28},{18,25},{25,26},{20,27},{27,28},{19,25},{20,26},{21,27},{22,28},{19,26},{22,27},{4,29},{5,29},{7,30},{6,30},{30,31},{29,31},{6,31},{5,31},{25,32},{18,32},{32,33},{7,33},{8,33},{8,32},{9,34},{8,34},{8,36},{8,37},{34,36},{36,37},{35,37},{35,39},{37,39},{10,38},{9,38},{11,38},{11,39},{11,35}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Minimized by removing vertices

n=VertexCount[g]

fix={36,38,19,20,37};

vl=Complement[VertexList[g],fix]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

GraphData

file=OpenWrite["~/braced-pentagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedPentagon",{75,1}},
"Name"->"75\[Hyphen]rod braced pentagon 1",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{5,75}},
"Skip"->{"Arboricity","ConnectedInducedSubgraphPolynomial","DominatingSets","HamiltonianWalks","LowerMatchingNumber","MaximumIndependentEdgeSets","MinimumCoveringsByMaximalCliques"}
]]

Close[file]

Braced hexagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{6,_},_,_,gn_}:>gn],Dividers->All]

{"BracedHexagon", {11, 1}} = Friedman (11 rods) [matchstick]

https://erich-friedman.github.io/mathmagic/0100.html

GraphData[{"BracedHexagon",{11,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedHexagon",{11,1}},"EmbeddingClasses"]

HighlightGraphRegularPolygons[GraphData[{"BracedHexagon",{11,1}}],6]

All

GraphData[{"BracedHexagon",{11,1}},"Graph","All"]//StyleGraphs

UnitDistance

GraphData[{"BracedHexagon",{11,1}},"Graph","UnitDistance"]//StyleGraphs

Rigid

GraphData[{"BracedHexagon",{11,1}},"Graph","Rigid"]//StyleGraphs

GraphData[{"BracedHexagon",{11,1}},"EmbeddingClasses"]

RigidGraphQ/@GraphData[{"BracedHexagon",{11,1}},"Graph","All"]

Construction

EdgeDelete[WheelGraph[7,VertexLabels->"Name"],1\[UndirectedEdge]5]

RecognizeGraph[%]

GraphData[{7,780},"Graph","All"]

GetGraphData[{7,780},"File"]

{"BracedHexagon", {29, 1}} = Pegg/Taxel (29 rods) (triangle-free)

gs=GraphData[{"BracedHexagon",{29,1}},"Graph","All"]//StyleGraphs

FirstOrderRigidGraphQ/@gs

UnitDistanceGraphEmbeddingQ/@gs

TriangleFreeGraphQ/@gs

HighlightGraphRegularPolygons[GraphData[{"BracedHexagon",{29,1}}],6]

Construction

Embedding from Ed Pegg, Jan 4, 2021

https://math.stackexchange.com/questions/3958870/bracing-a-polygon-without-triangles

"@EdPegg I came up with that exact graph too. Did you cheat and look at my Shibuya repo? I am going to publish this. – Parcly Taxel 17 hours ago"

v={{0,0},{1,0},{-1,0},{(1/2),((Sqrt[3])/2)},{-(1/2),((Sqrt[3])/2)},{-(1/2),-((Sqrt[3])/2)},{(1/2),-((Sqrt[3])/2)},{Root[-121-243 #1+72 ((#1)^3)+2592 ((#1)^6)&,1],Root[16-1323 ((#1)^2)+11664 ((#1)^4)-20736 ((#1)^6)-559872 ((#1)^8)+6718464 ((#1)^12)&,1]},{Root[2+45 #1+342 ((#1)^2)+1296 ((#1)^3)+2808 ((#1)^4)+2592 ((#1)^5)+864 ((#1)^6)&,2],Root[16384-218475 ((#1)^2)+1060020 ((#1)^4)-2608416 ((#1)^6)+3623616 ((#1)^8)-2612736 ((#1)^10)+746496 ((#1)^12)&,3]},{Root[83-207 #1+342 ((#1)^2)-1296 ((#1)^3)+2808 ((#1)^4)-2592 ((#1)^5)+864 ((#1)^6)&,2],Root[16384-218475 ((#1)^2)+1060020 ((#1)^4)-2608416 ((#1)^6)+3623616 ((#1)^8)-2612736 ((#1)^10)+746496 ((#1)^12)&,3]},{Root[-193+297 #1+2538 ((#1)^2)+6552 ((#1)^3)+9720 ((#1)^4)+7776 ((#1)^5)+2592 ((#1)^6)&,1],Root[937024-11776131 ((#1)^2)+35601444 ((#1)^4)-57337632 ((#1)^6)+56127168 ((#1)^8)-30233088 ((#1)^10)+6718464 ((#1)^12)&,3]},{Root[704-3897 #1+10548 ((#1)^2)-15552 ((#1)^3)+12528 ((#1)^4)-5184 ((#1)^5)+864 ((#1)^6)&,2],Root[121-7011 ((#1)^2)+173232 ((#1)^4)-1776384 ((#1)^6)+5909760 ((#1)^8)-3732480 ((#1)^10)+746496 ((#1)^12)&,1]},{Root[604-279 #1-3267 ((#1)^2)+1656 ((#1)^3)+3240 ((#1)^4)-3888 ((#1)^5)+1296 ((#1)^6)&,1],Root[1936-113859 ((#1)^2)+326673 ((#1)^4)-1307664 ((#1)^6)+3429216 ((#1)^8)-3359232 ((#1)^10)+1679616 ((#1)^12)&,2]},{Root[-11-414 #1+108 ((#1)^2)+414 ((#1)^3)-405 ((#1)^4)+324 ((#1)^6)&,1],Root[279841-971244 ((#1)^2)+2838078 ((#1)^4)-5385204 ((#1)^6)+3593241 ((#1)^8)-997272 ((#1)^10)+104976 ((#1)^12)&,3]},{Root[16+1368 #1+3780 ((#1)^2)+5274 ((#1)^3)+4455 ((#1)^4)+1944 ((#1)^5)+324 ((#1)^6)&,1],Root[279841-971244 ((#1)^2)+2838078 ((#1)^4)-5385204 ((#1)^6)+3593241 ((#1)^8)-997272 ((#1)^10)+104976 ((#1)^12)&,3]},{Root[29282+118341 #1+197154 ((#1)^2)+175032 ((#1)^3)+87480 ((#1)^4)+23328 ((#1)^5)+2592 ((#1)^6)&,1],Root[937024-11776131 ((#1)^2)+35601444 ((#1)^4)-57337632 ((#1)^6)+56127168 ((#1)^8)-30233088 ((#1)^10)+6718464 ((#1)^12)&,3]}};

e=Complement[
Select[Subsets[Range[Length[v]],{2}],Abs[SquaredEuclideanDistance@@v[[#]]-1]<1*^-5&]//Quiet,
{{1,3},{1,4},{1,7}}
]

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

UnitDistanceGraphEmbeddingQ[g]

Through[{VertexCount,EdgeCount}[g]]

FirstOrderRigidGraphQ[g]

LamanGraphQ[g]

Alternate embedding construction

Found by Jeremy Tam, communicated by Ed Pegg, Jr. Jan 5, 2021

https://math.stackexchange.com/questions/3958870/bracing-a-polygon-without-triangles

v={{0,0},{1,0},{-1,0},{(1/2),((Sqrt[3])/2)},{-(1/2),((Sqrt[3])/2)},{-(1/2),-((Sqrt[3])/2)},{(1/2),-((Sqrt[3])/2)},{(NumericalApproximation[Root, (RowDefault["0.917", FEExpressionsNumericalApproximationElider]), Root[83-207 #1+342 ((#1)^2)-1296 ((#1)^3)+2808 ((#1)^4)-2592 ((#1)^5)+864 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-0.400", FEExpressionsNumericalApproximationElider]), Root[16384-218475 ((#1)^2)+1060020 ((#1)^4)-2608416 ((#1)^6)+3623616 ((#1)^8)-2612736 ((#1)^10)+746496 ((#1)^12)&,2], ])},{(NumericalApproximation[Root, (RowDefault["0.417", FEExpressionsNumericalApproximationElider]), Root[11-81 #1+180 ((#1)^2)-432 ((#1)^4)+864 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.466", FEExpressionsNumericalApproximationElider]), Root[121-7011 ((#1)^2)+173232 ((#1)^4)-1776384 ((#1)^6)+5909760 ((#1)^8)-3732480 ((#1)^10)+746496 ((#1)^12)&,4], ])},{(NumericalApproximation[Root, (RowDefault["0.417", FEExpressionsNumericalApproximationElider]), Root[11-81 #1+180 ((#1)^2)-432 ((#1)^4)+864 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-1.27", FEExpressionsNumericalApproximationElider]), Root[495616+2999277 ((#1)^2)+29086992 ((#1)^4)-53362368 ((#1)^6)+32410368 ((#1)^8)-8211456 ((#1)^10)+746496 ((#1)^12)&,2], ])},{(NumericalApproximation[Root, (RowDefault["0.443", FEExpressionsNumericalApproximationElider]), Root[-121+243 #1-72 ((#1)^3)+2592 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-0.533", FEExpressionsNumericalApproximationElider]), Root[16-1323 ((#1)^2)+11664 ((#1)^4)-20736 ((#1)^6)-559872 ((#1)^8)+6718464 ((#1)^12)&,1], ])},{(NumericalApproximation[Root, (RowDefault["1.36", FEExpressionsNumericalApproximationElider]), Root[64-774 #1+2511 ((#1)^2)-4572 ((#1)^3)+5184 ((#1)^4)-3888 ((#1)^5)+1296 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-0.933", FEExpressionsNumericalApproximationElider]), Root[861184-7066224 ((#1)^2)+19512009 ((#1)^4)-26501904 ((#1)^6)+19945440 ((#1)^8)-8398080 ((#1)^10)+1679616 ((#1)^12)&,1], ])},{(NumericalApproximation[Root, (RowDefault["1.36", FEExpressionsNumericalApproximationElider]), Root[64-774 #1+2511 ((#1)^2)-4572 ((#1)^3)+5184 ((#1)^4)-3888 ((#1)^5)+1296 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.799", FEExpressionsNumericalApproximationElider]), Root[38353249-103135950 ((#1)^2)+174983409 ((#1)^4)-254159856 ((#1)^6)+151795296 ((#1)^8)-28553472 ((#1)^10)+1679616 ((#1)^12)&,3], ])},{(NumericalApproximation[Root, (RowDefault["1.86", FEExpressionsNumericalApproximationElider]), Root[529-2691 #1+5805 ((#1)^2)-6975 ((#1)^3)+4941 ((#1)^4)-1944 ((#1)^5)+324 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-0.0671", FEExpressionsNumericalApproximationElider]), Root[121-27405 ((#1)^2)+107973 ((#1)^4)+303183 ((#1)^6)+1056321 ((#1)^8)-682344 ((#1)^10)+104976 ((#1)^12)&,2], ])},{(NumericalApproximation[Root, (RowDefault["0.943", FEExpressionsNumericalApproximationElider]), Root[-193-297 #1+2538 ((#1)^2)-6552 ((#1)^3)+9720 ((#1)^4)-7776 ((#1)^5)+2592 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.333", FEExpressionsNumericalApproximationElider]), Root[937024-11776131 ((#1)^2)+35601444 ((#1)^4)-57337632 ((#1)^6)+56127168 ((#1)^8)-30233088 ((#1)^10)+6718464 ((#1)^12)&,3], ])},{(NumericalApproximation[Root, (RowDefault["0.443", FEExpressionsNumericalApproximationElider]), Root[-121+243 #1-72 ((#1)^3)+2592 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["1.20", FEExpressionsNumericalApproximationElider]), Root[4840680625-9892887075 ((#1)^2)+8218699344 ((#1)^4)-3632610240 ((#1)^6)+906432768 ((#1)^8)-120932352 ((#1)^10)+6718464 ((#1)^12)&,3], ])}};

e=Complement[
Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<1*^-4&],
{1,#}&/@{2,5,6}]//Quiet

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

r=RecognizeGraph[g]

GraphData[{"BracedHexagon",{29,1}}]

IsomorphicGraphQ[g,GraphData[{"BracedHexagon",{29,1}}]]

FirstOrderRigidGraphQ[g]

UnitDistanceGraphEmbeddingQ[g]

Vertex removal (gives no smaller rigid graphs)

vl=Complement[VertexList[g],{2,4,5,3,6,7}]

nl=Length[vl]

Do[Print[{n,Binomial[nl,n],SelectFirst[Subsets[vl,{n}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{n,0,nl}]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedHexagon",{29,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedHexagon",{29,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

GraphData

file=OpenWrite["~/braced-hexagon.m"]

WriteString[file,GraphDataString[IndexGraph[g],
"StandardName"->{"BracedHexagon",{29,1}},
"AlternateStandardNames"->{{"BracedPolygon",{6,{29,1}}}},
"Name"->"29\[Hyphen]rod braced hexagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{6,29}},
"Skip"->{"AlmostHamiltonian","Arboricity","HamiltonianWalks"},
Debug->True,
TimeConstraint->60
]]

Close[file]

Braced heptagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{7,_},_,_,gn_}:>gn],Dividers->All]

{"BracedHeptagon", {35, 1}} (delete 2 vertices from {"BracedHeptagon", {42, 1}})

GraphData[{"BracedHeptagon",{35,1}},"Graph","Labeled"]

Through[{VertexCount,EdgeCount}[GraphData[{"BracedHeptagon",{35,1}}]]]

CrossingNumber[%]

HighlightGraphRegularPolygons[GraphData[{"BracedHeptagon",{35,1}}],7]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedHeptagon",{35,1}}]]

Construction from {"BracedHeptagon", {42, 1}} by vertex deletion

GraphData[{"BracedHeptagon",{42,1}},"Graph","Labeled"]//StyleGraphs

vl=Complement[VertexList[GraphData[{"BracedHeptagon",{42,1}}]],Range[7]]

Length[sets=Monitor[Select[Subsets[vl,{2}],FirstOrderRigidGraphQ[VertexDelete[GraphData[{"BracedHeptagon",{42,1}}],set=#]]&],set]]//Timing

There is one additional Laman graph which however is not rigid

sets

gs=VertexDelete[GraphData[{"BracedHeptagon",{42,1}}],#]&/@sets

split=SplitBy[SortBy[{CanonicalGraph[#],#}&/@gs,First],First];

uniq=#[[1,2]]&/@split

g=uniq[[1]]

g=

Through[{VertexCount,EdgeCount}[g]]

r=RecognizeGraph[g]

CanonicalForm[g]

ToCommonEdges[g,GraphData[r]]

FirstOrderRigidGraphQ[g]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedHeptagon",{35,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedHeptagon",{35,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Laman

LamanGraphQ[g,Debug->True]//Timing

Rigidity

FirstOrderRigidGraphQ[g,Debug->True]//Timing

Construction

https://math.stackexchange.com/questions/3954719/is-this-braced-heptagon-a-rigid-graph/

g=IndexGraph@VertexDelete[GraphData[{"BracedHeptagon",{42,1}},"Graph","Labeled"],{10,15}]

RecognizeGraph[g]

EdgeCount@g

GraphData

file=OpenWrite["~/braced-heptagon.m"]

WriteString[file,GraphDataString[IndexGraph[uniq[[1]]],
"StandardName"->{"BracedHeptagon",{35,2}},
"AlternateStandardNames"->{{"BracedPolygon",{7,{35,2}}}},
"Name"->"35\[Hyphen]rod braced heptagon graph 2",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{7,35}},
"Skip"->{"AlmostHamiltonian","Arboricity","HamiltonianWalks"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedHeptagon", {42, 1}} = formerly {"UnitDistance", {21, 2}}

GraphData[{"BracedHeptagon",{42,1}},"StandardNames"]

GraphData[{"BracedHeptagon",{42,1}},"StandardName"]

Graph

(g=GraphData[gn={"BracedHeptagon",{42,1}}])//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedHeptagon",{42,1}}],7]

Crash in PolygonAngle: bug(403848)

Length[cyc=FindCycle[GraphData[{"BracedHeptagon",{42,1}}],{7},All]]

Table[i->HighlightGraph[GraphData[{"BracedHeptagon",{42,1}}],cyc[[i]]],{i,Length[cyc]}]

HighlightGraph[GraphData[{"BracedHeptagon",{42,1}}],Style[cyc[[164]],Directive[Red,Thick]]]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedHeptagon",{42,1}}]]

Embeddings

GraphData[gn,"Graph","UnitDistance"]//StyleGraphs

LCF

GraphData[gn,"Graph","LCF"]//StyleGraphs

All

GraphData[gn,"Graph","All"]//StyleGraphs

GraphData[gn,"LCF"]

GraphData[gn,"LCFSignature"]

GraphPlot[GraphData[{"BracedHeptagon",{42,1}},"EdgeList"]]

gs=Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"BracedHeptagon",{42,1}},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

LCF compute all

Length[FindHamiltonianCycle[GraphData[{"BracedHeptagon",{42,1}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"BracedHeptagon",{42,1}}],All])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

Properties

GraphData[gn,"ChromaticNumber"]

GraphData[gn,"Graph","All"]/.g_System`Graph:>SetProperty[g,{
System`VertexStyle->MapIndexed[#2[[1]]->{Red,Yellow,Green,Blue}[[#]]&,GraphData[gn,"MinimumVertexColoring"]],
VertexSize->Medium}]

GraphData[gn,"UnitDistance"]

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->∞]//FullSimplify

GraphData[gn,"CyclePolynomial"][x]

GraphData[gn,"Girth"]

Make Rigid by removing vertices

g=GraphData[{"BracedHeptagon",{42,1}},"Graph","Labeled"]

n=VertexCount[g]

vl=Complement[VertexList[g],Range[7]]

nl=Length[vl]

Do[Print[{n,Binomial[nl,n],SelectFirst[Subsets[vl,{n}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{n,0,nl}]

Graphic

points=Flatten[Table[RootReduce[#.RotationMatrix[{0,-1,1}[[n]]Pi/21]&/@(CirclePoints[7]/EuclideanDistance[{0,1},CirclePoints[7][[4+n]]])],{n,1,3}],1];
unitlines=Select[Subsets[Range[21],{2}],Chop[N[1-Quiet@EuclideanDistance@@points[[#]]]]==0&];
Graphics[{EdgeForm[{Black,Thick}],Line[points[[#]]]&/@unitlines,White,Disk[#,.05]&/@points,Black,Table[Style[Text[n,points[[n]]],10],{n,1,Length[points]}]},ImageSize->500]

Construction

Rigid per https://math.stackexchange.com/questions/3954719/is-this-braced-heptagon-a-rigid-graph/ (2020)

From Ed Pegg, Jr.
Mar 8, 2018

https://math.stackexchange.com/questions/2622496/4-chromatic-unit-distance-graph-with-no-4-cycles

"4-chromatic unit distance graph with no 4-cycles."

Length[points]

unitlines

g=System`Graph[Range[21],UndirectedEdge@@@unitlines,VertexCoordinates->points]

RecognizeGraph[g]

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->∞]//FullSimplify

GraphData["UnitDistance",21]

GraphData[{"UnitDistance",{21,1}},"Name"]

CayleyGroup

GraphData[{"UnitDistance",{21,2}},"CayleyGraphGeneratingGroupNames"]

GraphData[{"UnitDistance",{21,2}},"CayleyGraphGeneratingGroups"]

From Ed Pegg,, May 29, 2020
In which it is claimed [AFAICT] that {"SemidirectProduct", {{"CyclicGroup", 7}, {"CyclicGroup", 3}}}} is the Frobenius 21 group.

GroupOrder[group]

order21=FiniteGroupData[21]

FiniteGroupData[#,"PermutationRepresentation"]&/@order21//Column

FiniteGroupData[#,"PermutationGroupRepresentation"]&/@order21//Column

{"AbelianGroup", {7, 3}} -> {Circulant,{21,{3,7}}}

g1=Graph[UndirectedEdge@@@Union[Sort/@List@@@EdgeList[CayleyGraph[AbelianGroup[{7,3}]]]]]

RecognizeGraph[g1]

{"SemidirectProduct", {{"CyclicGroup", 7}, {"CyclicGroup", 3}}} (Ed says this is "the Frobenius 21 group")

FiniteGroupData[{"SemidirectProduct",{{"CyclicGroup",7},{"CyclicGroup",3}}},"PermutationGroupRepresentation"]

CayleyGraph[%]

UndirectedGraph[%]

RecognizeGraph[%]

FiniteGroupData[{"SemidirectProduct",{{"CyclicGroup",7},{"CyclicGroup",3}}},"PermutationRepresentation"]

FiniteGroupData[{"SemidirectProduct",{{"CyclicGroup",7},{"CyclicGroup",3}}},"MatrixRepresentation"]

FiniteGroupData[{"SemidirectProduct",{{"CyclicGroup",7},{"CyclicGroup",3}}},"CayleyGraph"]

TextGrid[DeleteCases[{#,FiniteGroupData[{"SemidirectProduct",{{"CyclicGroup",7},{"CyclicGroup",3}}},#]}&/@FiniteGroupData["Properties"],{_,_Missing}],Dividers->All]

GraphData

file=OpenWrite["~/unit-distance-21-2"]

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{21,2}},
"Name"->"21\[Hyphen]unit distance graph 2",
"Skip"->{"Arboricity","Cactus","HamiltonianWalks","IrredundantSets","MinimumWeightFractionalEdgeColoring","Skewness"}
]]

Close[file]

{"BracedHeptagon", {59, 1}} from Masaki (59 rods)

GraphData[{"BracedHeptagon",{59,1}}]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedHeptagon",{59,1}}],7]

All Embeddings

GraphData[{"BracedHeptagon",{59,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedHeptagon",{59,1}},"Graph","Planar"]//StyleGraphs

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedHeptagon",{59,1}}]]

Search for subgraphs by removing vertices

g=GraphData[{"BracedHeptagon",{59,1}},"Graph","Labeled"]

n=VertexCount[g]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],Range[7]]

Length[vl]

Do[Print[{k,Binomial[n,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,Length[vl]}]

Construction

h=Sqrt[(2^2)-((((3/2)))^2)]

Mean[{{-3/2,-h},{0,0}}]

s=Sqrt[3]/2;
v1={
{0,0},{-(3/4),-((Sqrt[7])/4)},{(3/4),-((Sqrt[7])/4)},
{-3/2,-h},{-1/2,-h},{1/2,-h},{3/2,-h},{-1,-s-h},{0,-s-h},{1,-s-h}
};

p1={x,y}/.Solve[SquaredEuclideanDistance[v1[[2]],{x,y}]==SquaredEuclideanDistance[v1[[1]],{x,y}]==1&&x<0,{x,y},Reals][[1]]//FullSimplify

p2={x,y}/.Solve[SquaredEuclideanDistance[v1[[2]],{x,y}]==SquaredEuclideanDistance[v1[[4]],{x,y}]==1&&x<0,{x,y},Reals][[1]]//FullSimplify

v=Join[v1,{p1,p2,{-1,1}p1,{-1,1}p2}];

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g0=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

emb=GraphEmbedding[g0]

v0=CirclePoints[Csc[Pi/7]/2,7];

v1=Join[v0,{v0[[2]]+v0[[4]]-v0[[3]],v0[[6]]+v0[[4]]-v0[[5]]}];

Graph[Range[Length[v1]],{},VertexCoordinates->v1,VertexLabels->"Name"]

ArcTan@@(v1[[8]]-Mean[v1[[{6,7}]]])//FullSimplify

v2=Join[v1,(v1[[8]]+RotationMatrix[-4Pi/14].#)&/@emb,(v1[[9]]+RotationMatrix[4Pi/14].#)&/@emb]//RootReduce//DeleteDuplicates;//Timing

v2

v3=Join[v1,(v1[[8]]+RotationMatrix[-4Pi/14].#)&/@emb,(v1[[9]]+RotationMatrix[4Pi/14].#)&/@emb]//FullSimplify//DeleteDuplicates;//Timing

v3

v=v2;

Length[e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet]

HighlightGraph[g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],Range[7]]

g=

Construction without RootReduce

g0=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

g1=VertexDelete[,{1,5,6}]

emb=GraphEmbedding[g1]

v0=CirclePoints[Csc[Pi/7]/2,7];

v1=Join[v0,{v0[[2]]+v0[[4]]-v0[[3]],v0[[6]]+v0[[4]]-v0[[5]]}];

v2=Join[v1,(v1[[8]]+RotationMatrix[-4Pi/14].#)&/@emb,(v1[[9]]+RotationMatrix[4Pi/14].#)&/@emb]//FullSimplify;//Timing

v=v2

Length[e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet]

g=Graph[Range@Length[v],UndirectedEdge@@@e,VertexCoordinates->v]

RecognizeGraph[g]

Planar construction

GraphPlot[PlanarGraph[GraphData[{"BracedHeptagon",{59,1}}]]]

v=Join[
CirclePoints[{Csc[Pi/10]/2,-π/2},10],
CirclePoints[12/10,4],
CirclePoints[8/10,7],
Table[{(2/5) Sin[(π/7)]x,2/10},{x,-2,2}],
Table[{(4/5) Sin[(π/7)]x,-(4/5) Sin[(π/14)]},{x,-1,1}],
{{(4/5) Sin[(π/7)],0},{1,0}}
];

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[10],2,1,1],Partition[Range[15,21],2,1,1],Partition[Range[22,26],2,1],{{8,13},{7,13},{5,12},{4,12},{2,11},{3,11},{9,14},{10,14},{14,20},{14,11},{11,16},{1,11},{1,14},{9,13},{6,13},{6,12},{3,12},{6,19},{6,17},{20,27},{20,22},{19,22},{21,27},{21,28},{28,29},{16,29},{15,28},{15,29},{16,26},{16,30},{24,30},{25,30},{26,30},{19,23},{19,24},{22,27},{11,31},{17,31}}],VertexCoordinates->v,VertexLabels->"Name"]

r=RecognizeGraph[g]

PlanarGraphEmbeddingQ[g]

ToCommonEdges[g,GraphData[r]]//FullSimplify

Laman

LamanGraphQ[heptagon,Debug->True]//Timing

GraphData

file=OpenWrite["~/braced-heptagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHeptagon",{59,1}},
"AlternateStandardNames"->{{"BracedPolygon",{5,{59,1}}}},
"Name"->"59\[Hyphen]rod braced heptagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{7,59}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedHeptagon", {79, 1}} = Khodulyov linkage construction (79 rods)

Construction

Figure from Friedman

g=KhodulyovBracedPolygonGraph[7]

EdgeCount[g]

Algebraic root objects

g=GraphData[{"BracedHeptagon",{79,1}},"Graph"]

GraphData[{"BracedHeptagon",{79,1}},"EmbeddingClasses"]

GraphData[{"BracedHeptagon",{79,1}}]//UnitDistanceGraphEmbeddingQ

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-7.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHeptagon",{79,1}},
"AlternateStandardNames"->{{"BracedPolygon",{7,{79,1}}}},
"Name"->"79\[Hyphen]rod braced heptagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{7,79}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced octagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{8,_},_,_,gn_}:>gn],Dividers->All]

{"BracedOctagon", {31, 1}} = Khodulyov (31 rods)

GraphData[{"BracedOctagon",{31,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedOctagon",{31,1}},"Graph","UnitDistance"]//StyleGraphs

GraphData[{"BracedOctagon",{31,1}},"Graph","MinimalCrossing"]//StyleGraphs

CrossingNumber[#,TimeConstraint->10]&/@%

HighlightGraphRegularPolygons[GraphData[{"BracedOctagon",{31,1}}],8]

Search for subgraphs by removing vertices

g=GraphData[{"BracedOctagon",{31,1}},"Graph","Labeled"]

VertexCount[g]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],Range[8]]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedOctagon",{31,1}}]]

Laman

LamanGraphQ[GraphData[{"BracedOctagon",{31,1}}],Debug->True]//Timing

Construction

https://erich-friedman.github.io/mathmagic/0100.html

v1=CirclePoints[Csc[Pi/8]/2,8];

Graph[Range[8],{},VertexCoordinates->v1,VertexLabels->"Name"]

v2=Join[v1,{v1[[5]]-{0,1},v1[[4]]-{0,1},v1[[2]]-{1,0}}];

v3=Join[v2,
{x,y}/.Solve[SquaredEuclideanDistance[v2[[9]],{x,y}]==SquaredEuclideanDistance[v2[[3]],{x,y}]==1,{x,y}]//FullSimplify,
{x,y}/.Solve[SquaredEuclideanDistance[v2[[8]],{x,y}]==SquaredEuclideanDistance[v2[[10]],{x,y}]==1,{x,y}]//FullSimplify,
{x,y}/.Solve[SquaredEuclideanDistance[v2[[1]],{x,y}]==SquaredEuclideanDistance[v2[[9]],{x,y}]==1,{x,y}]//FullSimplify
];

v=v3;

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

EdgeCount[g]

RecognizeGraph[g]

CrossingNumber[g,TimeConstraint->10]

Crossing number 2 construction

MinimalCrossingGraph[GraphData[{"BracedOctagon",{31,1}}],"CrossingNumber"->2,VertexLabels->None]

GraphPlot[%]

GraphData[{"BracedOctagon",{31,1}},{"V","M"}]

v={{0,0},{1,0},{1,1/2},{1,1},{3/5,1},{0,1},{0,3/5},{1+Sqrt[3]/2,1/2},{1/5,1/5},{1/5,3/5},{2/5,2/5},{3/5,1/5},{4/5,1/5},{3/5,3/5},{2/5,3/5},{3/5,2/5},{2/5,3/5+1/16}};

g=Graph[Range[Length[v]],UndirectedEdge@@@{{1,2},{2,3},{3,4},{4,5},{5,6},{6,7},{3,8},{1,7},{2,8},{4,8},{4,10},{6,10},{1,10},{9,10},{9,12},{9,11},{11,12},{10,13},{5,14},{12,16},{14,16},{10,15},{14,15},{10,11},{13,16},{2,12},{2,13},{10,17},{14,17},{15,17},{4,16}},VertexCoordinates->v,VertexLabels->"Name"]

Through[{VertexCount,EdgeCount}[g]]

r=RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphData

file=OpenWrite["~/braced-octagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedOctagon",{31,1}},
"AlternateStandardNames"->{{"BracedPolygon",{8,{31,1}}}},
"Name"->"31\[Hyphen]rod braced octagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{8,31}},
"Skip"->{"AlmostHamiltonian","Arboricity","HamiltonianWalks"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedOctagon", {45, 1}} = Friedman (45 rods)

GraphData[{"BracedOctagon",{45,1}}]//StyleGraphs

GraphData[{"BracedOctagon",{45,1}},"Graph","All"]//StyleGraphs

UnitDistanceGraphEmbeddingQ[GraphData[{"BracedOctagon",{45,1}}]]

GraphData[{"BracedOctagon",{45,1}},"CrossingNumber"]

GraphData[{"BracedOctagon",{45,1}},"Planar"]

HighlightGraphRegularPolygons[GraphData[{"BracedOctagon",{45,1}}],8]

Search for subgraphs by removing vertices

g=GraphData[{"BracedOctagon",{45,1}},"Graph","Labeled"]

VertexCount[g]

Vertices that are not part of the dodecagon:

vl=Complement[VertexList[g],{3,5,12,4,2,6,13,7}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction

https://erich-friedman.github.io/mathmagic/0100.html

I can make a rigid octagon with 45 rods:

v0=CirclePoints[{Csc[Pi/8]/2,0},8];

ArcTan@@Subtract@@v[[{8,1}]]//FullSimplify

g1=;

v1=GraphEmbedding[g1];
left=(RotationMatrix[-3π/8].(#-v1[[2]])+v[[6]])&/@v1;

g2=IndexGraph@VertexDelete[g1,{7,8}]

v2=GraphEmbedding[g2];
right=(RotationMatrix[3π/8].(#-v2[[5]])+v[[8]])&/@v2;

v=FullSimplify[Join[v0,left,right]]//Union;//Timing

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

g=;

RecognizeGraph[g]

EdgeCount[g]

Construction for RCN = 1

GraphPlot[MinimalCrossingGraph[GraphData[{"BracedOctagon",{45,1}}],VertexLabels->None]]

v=Join[
CirclePoints[Csc[Pi/7]/2,7],
{#(1/8) Csc[(π/14)],-(1/4) Csc[(π/7)] (-1+Sin[(π/14)])}&/@{-1,1},
{{0,-(1/2) Csc[(π/7)] Sin[(π/14)]},{-2/3,0},{0,0},{-4/10,2/10}},
Table[{i/10,1/5},{i,0,4}],
Table[{-i/10,2/5},{i,0,2}],
Table[{-i/10 2/3,3/5},{i,0,3}]
];

v=Join[v,Table[{i/5,1/5},{i,3}]]

v={{(1/2),-(1/2) Cot[(π/7)]},{(1/2) Cos[(π/14)] Csc[(π/7)],-(1/2) Csc[(π/7)] Sin[(π/14)]},{(1/2) Cos[((3 π)/14)] Csc[(π/7)],(1/2) Csc[(π/7)] Sin[((3 π)/14)]},{0,(1/2) Csc[(π/7)]},{-(1/2) Cos[((3 π)/14)] Csc[(π/7)],(1/2) Csc[(π/7)] Sin[((3 π)/14)]},{-(1/2) Cos[(π/14)] Csc[(π/7)],-(1/2) Csc[(π/7)] Sin[(π/14)]},{-(1/2),-(1/2) Cot[(π/7)]},{-(1/8) Csc[(π/14)],-(1/4) Csc[(π/7)] (-1+Sin[(π/14)])},{(1/8) Csc[(π/14)],-(1/4) Csc[(π/7)] (-1+Sin[(π/14)])},{0,-(1/2) Csc[(π/7)] Sin[(π/14)]},{-(2/3),0},{0,0},{-(2/5),(1/5)},{0,(1/5)},{(1/10),(1/5)},{(1/5),(1/5)},{(3/10),(1/5)},{(2/5),(1/5)},{0,(2/5)},{-(1/10),(2/5)},{-(1/5),(2/5)},{0,(3/5)},{-(1/15),(3/5)},{-(2/15),(3/5)},{-(1/5),(3/5)},{(1/5),(1/5)},{(2/5),(1/5)},{(3/5),(1/5)}}

g=IndexGraph@EdgeAdd[VertexDelete[Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[7],2,1,1],{{6,8},{4,8},{5,8},{4,9},{2,9},{3,9},{7,10},{1,10},{6,10},{2,10},{10,11},{4,11},{2,12},{10,18},{13,14},{14,15},{15,16},{16,17},{17,18},{11,12},{12,13},{13,25},{4,25},{4,24},{4,23},{4,22},{4,15},{14,19},{19,22},{19,23},{25,24},{23,22},{21,20},{20,19},{14,20},{14,21},{21,13},{13,24},{4,18}}],VertexCoordinates->v,VertexLabels->"Name"],{15,16,17,18}],UndirectedEdge@@@{{14,26},{26,27},{4,28},{10,28},{27,28},{4,26}}]

GraphData

file=OpenWrite["~/braced-octagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedOctagon",{45,1}},
"AlternateStandardNames"->{{"BracedPolygon",{8,{45,1}}}},
"Name"->"45\[Hyphen]rod braced octagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{8,45}},
Debug->True,
TimeConstraint->60
]]

Close[file]

Braced nonagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{9,_},_,_,gn_}:>gn],Dividers->All]

{"BracedNonagon", {51, 1}} = Khodulyov (51 rods)

HighlightGraphRegularPolygons[GraphData[{"BracedNonagon",{51,1}}],9]

Crash in PolygonAngle: bug(403848)

Length[cyc=FindCycle[GraphData[{"BracedNonagon",{51,1}}],{9},All]]

Table[i->HighlightGraph[GraphData[{"BracedNonagon",{51,1}}],cyc[[i]]],{i,Length[cyc]}]

HighlightGraph[GraphData[{"BracedNonagon",{51,1}}],Style[cyc[[341]],Directive[Red,Thick]]]

All

GraphData[{"BracedNonagon",{51,1}},"Graph","All"]

MinimalCrossing

GraphData[{"BracedNonagon",{51,1}},"Graph","MinimalCrossing"]

UnitDistance

GraphData[{"BracedNonagon",{51,1}},"Graph","UnitDistance"]

Properties

GraphData[{"BracedNonagon",{51,1}},"CN"]

Laman

LamanGraphQ[GraphData[{"BracedNonagon",{51,1}}],Debug->True]//Timing

Search for subgraphs by removing vertices

VertexCount[g=GraphData@{"BracedNonagon",{51,1}}]

Vertices that are not part of the pentagon:

vl=Complement[VertexList[g],Range[9]]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction

v1=CirclePoints[Csc[Pi/9]/2,9];

EuclideanDistance@@Take[v1,2]//FullSimplify

v2=Join[v1,v1[[#]]+v1[[5]]-v1[[6]]&/@{7,8},{v1[[1]]+v1[[3]]-v1[[2]]}];

v3=Join[v2,{v2[[11]]+v2[[5]]-v2[[10]]}];

eqns=RootReduce[SquaredEuclideanDistance@@@{{v3[[13]],{x,y}},{{x,y},{a,b}},{{x,y},{c,d}},{{a,b},{c,d}},{{a,b},v3[[2]]},{{c,d},v3[[2]]}}/.Abs:>Identity]

Length[eqns]

vars=Variables[eqns]

(nsoln=NSolve[Join[Thread[eqns==1],{0<a<c,0<b<d}],vars,Reals])//Timing

(soln=Solve[Join[Thread[eqns==1],{0<a<c,0<b<d}],vars,Reals])//Timing

gbs[[1]]//N

Length[gbs]

Length[gbs=GroebnerBasis[eqns-1,#,Complement[vars,{#}],MonomialOrder->EliminationOrder]&/@vars]//Timing

gbx=GroebnerBasis[eqns-1,x,Complement[vars,{x}],MonomialOrder->EliminationOrder];//Timing

Solve[gbx==0,x]//RootReduce

gby=GroebnerBasis[eqns-1,y,Complement[vars,{y}],MonomialOrder->EliminationOrder];//Timing

Solve[gby==0,y]//RootReduce

gba=GroebnerBasis[eqns-1,a,Complement[vars,{a}],MonomialOrder->EliminationOrder];//Timing

Solve[RootReduce@gba==0,a]

gbb=GroebnerBasis[eqns-1,b,Complement[vars,{b}],MonomialOrder->EliminationOrder];//Timing

Solve[RootReduce@gbb==0,b]

gbc=GroebnerBasis[eqns-1,c,Complement[vars,{c}],MonomialOrder->EliminationOrder];//Timing

Solve[RootReduce@gbc==0,c]

gbd=GroebnerBasis[eqns-1,d,Complement[vars,{d}],MonomialOrder->EliminationOrder];//Timing

Solve[RootReduce@gbd==0,d]

N[RegionDistance[Line[v3[[{3,4}]]],{(NumericalApproximation[Root, (RowDefault["1.03", FEExpressionsNumericalApproximationElider]), Root[27-486 #1-324 ((#1)^2)+2448 ((#1)^3)-864 ((#1)^4)-2016 ((#1)^5)+1216 ((#1)^6)&,5], ]),(NumericalApproximation[Root, (RowDefault["0.986", FEExpressionsNumericalApproximationElider]), Root[26569-2171460 ((#1)^2)+25086096 ((#1)^4)-77459712 ((#1)^6)+101297664 ((#1)^8)-60079104 ((#1)^10)+13307904 ((#1)^12)&,10], ])}],10]

Solve[SquaredEuclideanDistance[{p,q},{(NumericalApproximation[Root, (RowDefault["1.03", FEExpressionsNumericalApproximationElider]), Root[27-486 #1-324 ((#1)^2)+2448 ((#1)^3)-864 ((#1)^4)-2016 ((#1)^5)+1216 ((#1)^6)&,5], ]),(NumericalApproximation[Root, (RowDefault["0.986", FEExpressionsNumericalApproximationElider]), Root[26569-2171460 ((#1)^2)+25086096 ((#1)^4)-77459712 ((#1)^6)+101297664 ((#1)^8)-60079104 ((#1)^10)+13307904 ((#1)^12)&,10], ])}]==SquaredEuclideanDistance[{p,q},v2[[3]]]==1/.Abs:>Identity,{p,q},Reals]//Simplify//RootReduce

P={(NumericalApproximation[Root, (RowDefault["0.442", FEExpressionsNumericalApproximationElider]), Root[-1+84 #1-252 ((#1)^2)+152 ((#1)^3)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.180", FEExpressionsNumericalApproximationElider]), Root[-1+168 ((#1)^2)-6480 ((#1)^4)+69312 ((#1)^6)&,5], ])};

X={(NumericalApproximation[Root, (RowDefault["1.03", FEExpressionsNumericalApproximationElider]), Root[27-486 #1-324 ((#1)^2)+2448 ((#1)^3)-864 ((#1)^4)-2016 ((#1)^5)+1216 ((#1)^6)&,5], ]),(NumericalApproximation[Root, (RowDefault["0.986", FEExpressionsNumericalApproximationElider]), Root[26569-2171460 ((#1)^2)+25086096 ((#1)^4)-77459712 ((#1)^6)+101297664 ((#1)^8)-60079104 ((#1)^10)+13307904 ((#1)^12)&,10], ])};

{A,CC}=UnitDistancePoints[X,RootReduce@v3[[2]]]//RootReduce

v3[[13]]+P-X//Simplify//RootReduce

Z={(NumericalApproximation[Root, (RowDefault["-0.419", FEExpressionsNumericalApproximationElider]), Root[27-486 #1-324 ((#1)^2)+2448 ((#1)^3)-864 ((#1)^4)-2016 ((#1)^5)+1216 ((#1)^6)&,2], ]),(NumericalApproximation[Root, (RowDefault["-0.329", FEExpressionsNumericalApproximationElider]), Root[26569-2171460 ((#1)^2)+25086096 ((#1)^4)-77459712 ((#1)^6)+101297664 ((#1)^8)-60079104 ((#1)^10)+13307904 ((#1)^12)&,5], ])};

yhat=Normalize[v3[[12]]-v3[[2]]]//RootReduce

FlipAcrossLine[yhat_,p_]:=Module[{proj=yhat(p.yhat)},p+2(proj-p)]

ZP=FlipAcrossLine[Z]//RootReduce

{B,DD}=UnitDistanceTwoPoints[ZP,RootReduce@v3[[2]]]//RootReduce

v4=Join[v3,{X,P,Z,A,CC,ZP,B,DD},FlipAcrossLine/@{A,P,DD,B,X,CC}];

v=v4//RootReduce

e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<1*^-4&]//Quiet

g=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

EdgeCount[g]

FirstOrderRigidGraphQ[g]

UnitDistanceGraphEmbeddingQ[g]

SetProperty[g,VertexLabels->None]

g=;

MinimalRectilinearCrossing constuction

GraphData[{"BracedNonagon",{51,1}},{"RCN","CN"}]

GraphData[{"BracedNonagon",{51,1}},"V"]

GraphPlot@MinimalCrossingGraph[GraphData[{"BracedNonagon",{51,1}}],"CrossingNumber"->4]

v={{0,0},{9,0},{4+1/2,1},{3+1/2,2},{4,2},{5,2},{6-1/2,2},{3,3},{4+1/2,3},{6,3},{0,4},{1,4},{3,4},{6,4},{8,4},{9,4},{2,5},{7,5},{1,6},{2,6},{3,6},{6,6},{7,6},{8,6},{0,7},{4+1/2,7},{9,7}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,16,27,26,25,11,1,17,21,26,24,16],{24,27},e[11,19,26],{25,19},e[11,12,13,9,14,15,16],e[13,8,4,5,6,7,10,14,26,13],e[8,1,9,2,18,23,22,26],e[22,18,15],e[12,17,20,21],e[1,3,7],{3,5},{2,10},{20,26},{23,26},{2,7},{4,1}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphData

file=OpenWrite["~/braced-nonagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedNonagon",{51,1}},
"AlternateStandardNames"->{{"BracedPolygon",{9,{51,1}}}},
"Name"->"51\[Hyphen]rod braced nonagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{9,51}},
"Skip"->{"AlmostHamiltonian","Arboricity","ConnectedInducedSubgraphs","ConnectedInducedSubgraphPolynomial","DominatingSets","MinimumWeightFractionalColoring","HamiltonianWalks","MinimalVertexCovers","Skewness","MinimumCoveringsByMaximalCliques","MinimumWeightFractionalEdgeColoring"}
]]

Close[file]

Pegg (124 rods) [not rigid]

Asked Ed about it Dec 22, 2020

http://www.mathpuzzle.com/riginona.gif

v1=CirclePoints[Csc[Pi/9]/2,9];

Clear[pt]

pt[l_,{i_Integer,j_,n_}]:=UnitDistancePoint[l[[i]],l[[j]],n]

pt[l_,i_]:=pt[l,#]&/@i

v2=RootReduce@Join[v1,pt[v1,{{3,5,2},{5,7,2},{1,3,2},{4,5,1},{5,6,1},{1,2,1},{8,9,1},{1,9,1},{7,9,2}}]];

v3=RootReduce@Join[v2,pt[v2,{{5,14,1},{3,13,1}}]];

v4=RootReduce@Join[v3,pt[v3,{{9,16,2},{7,16,1},{5,12,1},{1,15,1},{3,15,2},{14,19,2}}]];

v5=RootReduce@Join[v4,pt[v4,{{3,20,1},{15,24,2},{16,21,1},{7,22,1},{7,14,2}}]];

v6=RootReduce@Join[v5,pt[v5,{{16,29,1},{7,30,1},{11,23,1},{13,27,2},{3,27,1},{15,28,2},{14,26,2}}]];

v7=RootReduce@Join[v6,pt[v6,{{16,32,1},{15,37,2},{14,38,2},{13,35,2},{30,32,1},{30,33,2},{33,38,2},{36,27,1}}]];

v8=RootReduce@Join[v7,pt[v7,{{43,30,2},{33,44,1},{36,37,2},{13,42,2},{27,42,1}}]];

v9=RootReduce@Join[v8,pt[v8,{{42,50,1},{49,46,1},{46,51,1}}]];

v10=RootReduce@Join[v9,pt[v9,{{42,52,1},{46,54,1},{51,54,2}}]];

v11=RootReduce@Join[v10,pt[v10,{{54,56,2},{42,55,1}}]];

no

v=v11;
e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<=1*^-4&]//Quiet;
HighlightGraph[g1=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],UndirectedEdge@@@Partition[Range[9],2,1,1]]

EdgeCount[g1]

FirstOrderRigidGraphQ[g1]

e2=Complement[
Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<=1*^-4&]//Quiet,
{{10,11},{10,20},{18,22},{12,25},{11,31},{4,23},{8,34},{12,34},{4,35},{8,39},{2,40},{6,41},{22,43},{31,45},{25,49},{20,51},{51,57},{35,59}}
];
HighlightGraph[g2=Graph[Range[Length[v]],UndirectedEdge@@@e2,VertexCoordinates->v,VertexLabels->"Name"],UndirectedEdge@@@Partition[Range[9],2,1,1]]

FirstOrderRigidGraphQ[g2]

EdgeCount[g2]

SetProperty[g2,VertexLabels->None]

g2=

FirstOrderRigidGraphQ[%]

List@@@EdgeList[g2]

GraphEmbedding[g2]

g=;

RecognizeGraph[g]

FirstOrderRigidGraphQ[g,Debug->True]

LamanGraphQ[g,Debug->True]

Braced decagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{10,_},_,_,gn_}:>gn],Dividers->All]

{"BracedDecagon", {55, 1}} = Khodulyov (55 rods)

GraphData[{"BracedDecagon",{55,1}},"Graph","Labeled"]

HighlightGraphRegularPolygons[GraphData[{"BracedDecagon",{55,1}}],10]

Laman

LamanGraphQ[GraphData[{"BracedDecagon",{55,1}}],Debug->True]//Timing

Construction

https://erich-friedman.github.io/mathmagic/0100.html

v1=CirclePoints[Csc[Pi/10]/2,10];

v2=FullSimplify@Join[v1,Normalize/@v1[[;;;;2]],Normalize/@v1[[{2,4}]],{{0,0}},{v1[[1]]+Normalize[-v1[[1]]]}];

eqns=SquaredEuclideanDistance@@@{
{{0,0},{bx,by}},
{{0,0},{ax,ay}},
{{ax,ay},{bx,by}},
{{ax,ay},{cx,cy}},
{{bx,by},{cx,cy}},
{v2[[1]],{cx,cy}}}/.Abs:>Identity

vars=Variables[eqns]

(nsoln=NSolve[Join[Thread[eqns==1],{0<ax<bx}],vars,Reals])//Timing

(soln=RootReduce@Solve[Join[Thread[eqns==1],{0<ax<bx}],vars,Reals])//Timing

{AA,BB,CC}={{ax,ay},{bx,by},{cx,cy}}/.soln[[1]]

v3=Join[v2,{{ax,ay},{bx,by},{cx,cy}}/.soln[[1]]];

yhat=Normalize[v3[[1]]]//RootReduce

FlipAcrossLine[yhat_,p_]:=Module[{proj=yhat(p.yhat)},p+2(proj-p)]

{AAp,BBp,CCp}=FlipAcrossLine[yhat,#]&/@{AA,BB,CC}//RootReduce

DD=DeleteCases[UnitDistancePoints[CC,CCp]//FullSimplify,v[[1]]][[1]]

EE=DeleteCases[UnitDistancePoints[v[[10]],CCp]//FullSimplify,v[[1]]][[1]]//RootReduce

FF=DeleteCases[UnitDistancePoints[DD,EE]//RootReduce,CC][[1]]

GG=DeleteCases[UnitDistancePoints[v3[[19]],EE]//RootReduce,FF][[1]]

v4=Join[v3,{AAp,BBp,CCp,DD,EE,FF,GG}];

v=v4;

e=Select[Subsets[Range[Length[v]],{2}],Abs[1-SquaredEuclideanDistance@@v[[#]]]<1*^-4&]//Quiet

e2=Complement[e,{{12,19}}]

g=Graph[Range[Length[v]],UndirectedEdge@@@e2,VertexCoordinates->v,VertexLabels->"Name"]

FirstOrderRigidGraphQ[g]

EdgeCount[g]

Search for subgraphs by removing vertices

VertexCount[g]

Vertices that are not part of the decagon:

vl=Complement[VertexList[g],Range[10]]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

GraphData

file=OpenWrite["~/braced-decagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedDecagon",{55,1}},
"AlternateStandardNames"->{{"BracedPolygon",{10,{55,1}}}},
"Name"->"55\[Hyphen]rod braced decagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{10,55}},
"Skip"->{"AlmostHamiltonian","Arboricity","ConnectedInducedSubgraphs","ConnectedInducedSubgraphPolynomial","DominatingSets","EigenvectorCentralities","HITSCentralities","MinimumWeightFractionalColoring","HamiltonianWalks","MinimalVertexCovers","Skewness","MinimumCoveringsByMaximalCliques","MinimumWeightFractionalEdgeColoring"}
]]

Close[file]

Friedman (99 rods)

https://erich-friedman.github.io/mathmagic/0100.html

And I can make a rigid decagon with 99 rods:

Braced hendecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{11,_},_,_,gn_}:>gn],Dividers->All]

{"BracedHendecagon", {79, 1}}

Jeremy Tan

GraphData[{"BracedHendecagon",{79,1}}]//StyleGraphs

Construction

From Jeremy Tan
Communicated by Ed Pegg, Jt.
October 16, 2021

https://math.stackexchange.com/questions/4277731/on-the-representation-of-sqrt-pm-p-in-the-integral-basis-of-mathbb-q-zet

Rigid, but not first-order rigid

cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]{1,-1}

vects=Table[Exp[2k I Pi/11],{k,0,10}];

outer=Table[RootReduce[Total[vects[[1;;k]]]],{k,0,10}];

rhombchain[k_]:=RootReduce[Accumulate[{outer[[k]]+vects[[Mod[k+1,11,1]]],vects[[Mod[k+2,11,1]]],vects[[Mod[k+3,11,1]]]}]]

rhombs=Join[rhombchain[3],rhombchain[10],rhombchain[6],rhombchain[2],rhombchain[9][[;;2]]];

spindles=RootReduce[Flatten[Table[{cu[rhombs[[k]],rhombs[[k+1]]],cu[rhombs[[k]],rhombs[[k+2]]]},{k,3,12,3}]],Method->"Recursive"];

vertices=ReIm/@Join[outer,rhombs,spindles]//RootReduce[#,Method->"Recursive"]&

vertices={{0,0},{1,0},{(NumericalApproximation[Root, (RowDefault["1.84", FEExpressionsNumericalApproximationElider]), Root[-1+30 #1-140 ((#1)^2)+224 ((#1)^3)-144 ((#1)^4)+32 ((#1)^5)&,5], ]),(NumericalApproximation[Root, (RowDefault["0.541", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,7], ])},{(NumericalApproximation[Root, (RowDefault["2.26", FEExpressionsNumericalApproximationElider]), Root[1+2 #1-60 ((#1)^2)+152 ((#1)^3)-128 ((#1)^4)+32 ((#1)^5)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.45", FEExpressionsNumericalApproximationElider]), Root[-11+396 ((#1)^2)-4048 ((#1)^4)+9152 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(NumericalApproximation[Root, (RowDefault["2.11", FEExpressionsNumericalApproximationElider]), Root[1-4 #1-20 ((#1)^2)+104 ((#1)^3)-112 ((#1)^4)+32 ((#1)^5)&,5], ]),(NumericalApproximation[Root, (RowDefault["2.44", FEExpressionsNumericalApproximationElider]), Root[-11+440 ((#1)^2)-4752 ((#1)^4)+14784 ((#1)^6)-8448 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["1.46", FEExpressionsNumericalApproximationElider]), Root[1-12 #1-4 ((#1)^2)+80 ((#1)^3)-96 ((#1)^4)+32 ((#1)^5)&,5], ]),(NumericalApproximation[Root, (RowDefault["3.20", FEExpressionsNumericalApproximationElider]), Root[-11+264 ((#1)^2)-2288 ((#1)^4)+8448 ((#1)^6)-11264 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(1/2),(NumericalApproximation[Root, (RowDefault["3.48", FEExpressionsNumericalApproximationElider]), Root[-11+660 ((#1)^2)-7392 ((#1)^4)+21120 ((#1)^6)-14080 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-0.459", FEExpressionsNumericalApproximationElider]), Root[-1-4 #1+20 ((#1)^2)+16 ((#1)^3)-64 ((#1)^4)+32 ((#1)^5)&,1], ]),(NumericalApproximation[Root, (RowDefault["3.20", FEExpressionsNumericalApproximationElider]), Root[-11+264 ((#1)^2)-2288 ((#1)^4)+8448 ((#1)^6)-11264 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-1.11", FEExpressionsNumericalApproximationElider]), Root[-1-20 #1+60 ((#1)^2)-24 ((#1)^3)-48 ((#1)^4)+32 ((#1)^5)&,1], ]),(NumericalApproximation[Root, (RowDefault["2.44", FEExpressionsNumericalApproximationElider]), Root[-11+440 ((#1)^2)-4752 ((#1)^4)+14784 ((#1)^6)-8448 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-1.26", FEExpressionsNumericalApproximationElider]), Root[1-14 #1+52 ((#1)^2)-40 ((#1)^3)-32 ((#1)^4)+32 ((#1)^5)&,1], ]),(NumericalApproximation[Root, (RowDefault["1.45", FEExpressionsNumericalApproximationElider]), Root[-11+396 ((#1)^2)-4048 ((#1)^4)+9152 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(NumericalApproximation[Root, (RowDefault["-0.841", FEExpressionsNumericalApproximationElider]), Root[-1+6 #1+12 ((#1)^2)-32 ((#1)^3)-16 ((#1)^4)+32 ((#1)^5)&,1], ]),(NumericalApproximation[Root, (RowDefault["0.541", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,7], ])},{(NumericalApproximation[Root, (RowDefault["1.70", FEExpressionsNumericalApproximationElider]), Root[23-64 #1-16 ((#1)^2)+152 ((#1)^3)-128 ((#1)^4)+32 ((#1)^5)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.53", FEExpressionsNumericalApproximationElider]), Root[-11+1760 ((#1)^2)-7744 ((#1)^4)+10560 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["1.04", FEExpressionsNumericalApproximationElider]), Root[1-4 #1-20 ((#1)^2)+104 ((#1)^3)-112 ((#1)^4)+32 ((#1)^5)&,4], ]),(NumericalApproximation[Root, (RowDefault["2.29", FEExpressionsNumericalApproximationElider]), Root[-11+792 ((#1)^2)-7568 ((#1)^4)+17600 ((#1)^6)-8448 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["0.0846", FEExpressionsNumericalApproximationElider]), Root[1-12 #1-4 ((#1)^2)+80 ((#1)^3)-96 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["2.57", FEExpressionsNumericalApproximationElider]), Root[-5819+28776 ((#1)^2)-49456 ((#1)^4)+36608 ((#1)^6)-11264 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-0.415", FEExpressionsNumericalApproximationElider]), Root[-1+6 #1+12 ((#1)^2)-32 ((#1)^3)-16 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.910", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(NumericalApproximation[Root, (RowDefault["0.585", FEExpressionsNumericalApproximationElider]), Root[-11+110 #1-308 ((#1)^2)+352 ((#1)^3)-176 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["0.910", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(NumericalApproximation[Root, (RowDefault["1.43", FEExpressionsNumericalApproximationElider]), Root[67-170 #1-12 ((#1)^2)+232 ((#1)^3)-160 ((#1)^4)+32 ((#1)^5)&,3], ]),(NumericalApproximation[Root, (RowDefault["1.45", FEExpressionsNumericalApproximationElider]), Root[-11+396 ((#1)^2)-4048 ((#1)^4)+9152 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(1/2),(NumericalApproximation[Root, (RowDefault["2.91", FEExpressionsNumericalApproximationElider]), Root[-5819+46420 ((#1)^2)-83424 ((#1)^4)+54912 ((#1)^6)-14080 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-0.155", FEExpressionsNumericalApproximationElider]), Root[-1-4 #1+20 ((#1)^2)+16 ((#1)^3)-64 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["2.16", FEExpressionsNumericalApproximationElider]), Root[-5819+37048 ((#1)^2)-63536 ((#1)^4)+42240 ((#1)^6)-11264 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-0.297", FEExpressionsNumericalApproximationElider]), Root[-1+2 #1+16 ((#1)^2)-24 ((#1)^3)-48 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["1.17", FEExpressionsNumericalApproximationElider]), Root[-11+4884 ((#1)^2)-18304 ((#1)^4)+20416 ((#1)^6)-8448 ((#1)^8)+1024 ((#1)^10)&,8], ])},{(NumericalApproximation[Root, (RowDefault["1.42", FEExpressionsNumericalApproximationElider]), Root[-1+30 #1-140 ((#1)^2)+224 ((#1)^3)-144 ((#1)^4)+32 ((#1)^5)&,4], ]),(NumericalApproximation[Root, (RowDefault["0.910", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,9], ])},{(NumericalApproximation[Root, (RowDefault["1.27", FEExpressionsNumericalApproximationElider]), Root[23-64 #1-16 ((#1)^2)+152 ((#1)^3)-128 ((#1)^4)+32 ((#1)^5)&,4], ]),(NumericalApproximation[Root, (RowDefault["1.90", FEExpressionsNumericalApproximationElider]), Root[-11+352 ((#1)^2)-2816 ((#1)^4)+7744 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["0.618", FEExpressionsNumericalApproximationElider]), Root[23-70 #1+24 ((#1)^2)+104 ((#1)^3)-112 ((#1)^4)+32 ((#1)^5)&,2], ]),(NumericalApproximation[Root, (RowDefault["2.66", FEExpressionsNumericalApproximationElider]), Root[-11+484 ((#1)^2)-3520 ((#1)^4)+9152 ((#1)^6)-8448 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["-0.699", FEExpressionsNumericalApproximationElider]), Root[1+8 #1+8 ((#1)^2)-40 ((#1)^3)-32 ((#1)^4)+32 ((#1)^5)&,1], ]),(NumericalApproximation[Root, (RowDefault["1.53", FEExpressionsNumericalApproximationElider]), Root[-11+1760 ((#1)^2)-7744 ((#1)^4)+10560 ((#1)^6)-5632 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["0.142", FEExpressionsNumericalApproximationElider]), Root[-1+6 #1+12 ((#1)^2)-32 ((#1)^3)-16 ((#1)^4)+32 ((#1)^5)&,3], ]),(NumericalApproximation[Root, (RowDefault["0.990", FEExpressionsNumericalApproximationElider]), Root[-11+220 ((#1)^2)-1232 ((#1)^4)+2816 ((#1)^6)-2816 ((#1)^8)+1024 ((#1)^10)&,10], ])},{(NumericalApproximation[Root, (RowDefault["0.313", FEExpressionsNumericalApproximationElider]), Root[331+4494 #1-8544 ((#1)^2)-148680 ((#1)^3)+465408 ((#1)^4)+36288 ((#1)^5)-1340928 ((#1)^6)+1078272 ((#1)^7)+539136 ((#1)^8)-870912 ((#1)^9)+248832 ((#1)^10)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.59", FEExpressionsNumericalApproximationElider]), Root[1-4044 ((#1)^2)+1120608 ((#1)^4)-81984960 ((#1)^6)+2373857280 ((#1)^8)-31956000768 ((#1)^10)+212787191808 ((#1)^12)-688400695296 ((#1)^14)+954559365120 ((#1)^16)-438581329920 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["-0.644", FEExpressionsNumericalApproximationElider]), Root[331+4494 #1-8544 ((#1)^2)-148680 ((#1)^3)+465408 ((#1)^4)+36288 ((#1)^5)-1340928 ((#1)^6)+1078272 ((#1)^7)+539136 ((#1)^8)-870912 ((#1)^9)+248832 ((#1)^10)&,2], ]),(NumericalApproximation[Root, (RowDefault["1.88", FEExpressionsNumericalApproximationElider]), Root[1-4044 ((#1)^2)+1120608 ((#1)^4)-81984960 ((#1)^6)+2373857280 ((#1)^8)-31956000768 ((#1)^10)+212787191808 ((#1)^12)-688400695296 ((#1)^14)+954559365120 ((#1)^16)-438581329920 ((#1)^18)+61917364224 ((#1)^20)&,20], ])},{(NumericalApproximation[Root, (RowDefault["0.813", FEExpressionsNumericalApproximationElider]), Root[17161-19650 #1-572952 ((#1)^2)+2402424 ((#1)^3)-2766816 ((#1)^4)-2871936 ((#1)^5)+11069568 ((#1)^6)-12648960 ((#1)^7)+7257600 ((#1)^8)-2115072 ((#1)^9)+248832 ((#1)^10)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.88", FEExpressionsNumericalApproximationElider]), Root[1-4044 ((#1)^2)+1120608 ((#1)^4)-81984960 ((#1)^6)+2373857280 ((#1)^8)-31956000768 ((#1)^10)+212787191808 ((#1)^12)-688400695296 ((#1)^14)+954559365120 ((#1)^16)-438581329920 ((#1)^18)+61917364224 ((#1)^20)&,20], ])},{(NumericalApproximation[Root, (RowDefault["-0.144", FEExpressionsNumericalApproximationElider]), Root[17161-19650 #1-572952 ((#1)^2)+2402424 ((#1)^3)-2766816 ((#1)^4)-2871936 ((#1)^5)+11069568 ((#1)^6)-12648960 ((#1)^7)+7257600 ((#1)^8)-2115072 ((#1)^9)+248832 ((#1)^10)&,2], ]),(NumericalApproximation[Root, (RowDefault["1.59", FEExpressionsNumericalApproximationElider]), Root[1-4044 ((#1)^2)+1120608 ((#1)^4)-81984960 ((#1)^6)+2373857280 ((#1)^8)-31956000768 ((#1)^10)+212787191808 ((#1)^12)-688400695296 ((#1)^14)+954559365120 ((#1)^16)-438581329920 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["0.540", FEExpressionsNumericalApproximationElider]), Root[199+29694 #1-328116 ((#1)^2)+1068192 ((#1)^3)-781200 ((#1)^4)-2916000 ((#1)^5)+8163072 ((#1)^6)-9403776 ((#1)^7)+5785344 ((#1)^8)-1866240 ((#1)^9)+248832 ((#1)^10)&,4], ]),(NumericalApproximation[Root, (RowDefault["1.91", FEExpressionsNumericalApproximationElider]), Root[2195953321-75711582228 ((#1)^2)+885633785712 ((#1)^4)-5076773086464 ((#1)^6)+16167151210752 ((#1)^8)-29852233454592 ((#1)^10)+31937648910336 ((#1)^12)-19257196068864 ((#1)^14)+6256663658496 ((#1)^16)-1006157168640 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["1.39", FEExpressionsNumericalApproximationElider]), Root[199+29694 #1-328116 ((#1)^2)+1068192 ((#1)^3)-781200 ((#1)^4)-2916000 ((#1)^5)+8163072 ((#1)^6)-9403776 ((#1)^7)+5785344 ((#1)^8)-1866240 ((#1)^9)+248832 ((#1)^10)&,8], ]),(NumericalApproximation[Root, (RowDefault["2.45", FEExpressionsNumericalApproximationElider]), Root[2195953321-75711582228 ((#1)^2)+885633785712 ((#1)^4)-5076773086464 ((#1)^6)+16167151210752 ((#1)^8)-29852233454592 ((#1)^10)+31937648910336 ((#1)^12)-19257196068864 ((#1)^14)+6256663658496 ((#1)^16)-1006157168640 ((#1)^18)+61917364224 ((#1)^20)&,20], ])},{(NumericalApproximation[Root, (RowDefault["0.431", FEExpressionsNumericalApproximationElider]), Root[67+5580 #1-90180 ((#1)^2)+397512 ((#1)^3)-428688 ((#1)^4)-1442880 ((#1)^5)+5156352 ((#1)^6)-6998400 ((#1)^7)+4893696 ((#1)^8)-1741824 ((#1)^9)+248832 ((#1)^10)&,4], ]),(NumericalApproximation[Root, (RowDefault["1.35", FEExpressionsNumericalApproximationElider]), Root[17161-106869528 ((#1)^2)+11634243120 ((#1)^4)-346594061376 ((#1)^6)+3691295421696 ((#1)^8)-12636562857984 ((#1)^10)+19186374500352 ((#1)^12)-14365795958784 ((#1)^14)+5400570101760 ((#1)^16)-949399584768 ((#1)^18)+61917364224 ((#1)^20)&,18], ])},{(NumericalApproximation[Root, (RowDefault["0.840", FEExpressionsNumericalApproximationElider]), Root[67+5580 #1-90180 ((#1)^2)+397512 ((#1)^3)-428688 ((#1)^4)-1442880 ((#1)^5)+5156352 ((#1)^6)-6998400 ((#1)^7)+4893696 ((#1)^8)-1741824 ((#1)^9)+248832 ((#1)^10)&,6], ]),(NumericalApproximation[Root, (RowDefault["2.26", FEExpressionsNumericalApproximationElider]), Root[17161-106869528 ((#1)^2)+11634243120 ((#1)^4)-346594061376 ((#1)^6)+3691295421696 ((#1)^8)-12636562857984 ((#1)^10)+19186374500352 ((#1)^12)-14365795958784 ((#1)^14)+5400570101760 ((#1)^16)-949399584768 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["0.634", FEExpressionsNumericalApproximationElider]), Root[-1583+27828 #1-181980 ((#1)^2)+557208 ((#1)^3)-678816 ((#1)^4)-597024 ((#1)^5)+3227904 ((#1)^6)-4821120 ((#1)^7)+3711744 ((#1)^8)-1492992 ((#1)^9)+248832 ((#1)^10)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.53", FEExpressionsNumericalApproximationElider]), Root[109561-284751144 ((#1)^2)+9470229840 ((#1)^4)-121531167936 ((#1)^6)+768270956544 ((#1)^8)-2581166932992 ((#1)^10)+4683826446336 ((#1)^12)-4544369049600 ((#1)^14)+2349849968640 ((#1)^16)-608854081536 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["0.484", FEExpressionsNumericalApproximationElider]), Root[-1583+27828 #1-181980 ((#1)^2)+557208 ((#1)^3)-678816 ((#1)^4)-597024 ((#1)^5)+3227904 ((#1)^6)-4821120 ((#1)^7)+3711744 ((#1)^8)-1492992 ((#1)^9)+248832 ((#1)^10)&,4], ]),(NumericalApproximation[Root, (RowDefault["0.545", FEExpressionsNumericalApproximationElider]), Root[109561-284751144 ((#1)^2)+9470229840 ((#1)^4)-121531167936 ((#1)^6)+768270956544 ((#1)^8)-2581166932992 ((#1)^10)+4683826446336 ((#1)^12)-4544369049600 ((#1)^14)+2349849968640 ((#1)^16)-608854081536 ((#1)^18)+61917364224 ((#1)^20)&,15], ])},{(NumericalApproximation[Root, (RowDefault["0.277", FEExpressionsNumericalApproximationElider]), Root[2167-6930 #1-116688 ((#1)^2)+902088 ((#1)^3)-2626272 ((#1)^4)+3573504 ((#1)^5)-1520640 ((#1)^6)-1824768 ((#1)^7)+2737152 ((#1)^8)-1368576 ((#1)^9)+248832 ((#1)^10)&,3], ]),(NumericalApproximation[Root, (RowDefault["1.99", FEExpressionsNumericalApproximationElider]), Root[36084049-2015010444 ((#1)^2)+42576461856 ((#1)^4)-423915145920 ((#1)^6)+2074844077056 ((#1)^8)-5295915343872 ((#1)^10)+7520851648512 ((#1)^12)-6121362751488 ((#1)^14)+2808640438272 ((#1)^16)-665611665408 ((#1)^18)+61917364224 ((#1)^20)&,20], ])},{(NumericalApproximation[Root, (RowDefault["0.699", FEExpressionsNumericalApproximationElider]), Root[2167-6930 #1-116688 ((#1)^2)+902088 ((#1)^3)-2626272 ((#1)^4)+3573504 ((#1)^5)-1520640 ((#1)^6)-1824768 ((#1)^7)+2737152 ((#1)^8)-1368576 ((#1)^9)+248832 ((#1)^10)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.08", FEExpressionsNumericalApproximationElider]), Root[36084049-2015010444 ((#1)^2)+42576461856 ((#1)^4)-423915145920 ((#1)^6)+2074844077056 ((#1)^8)-5295915343872 ((#1)^10)+7520851648512 ((#1)^12)-6121362751488 ((#1)^14)+2808640438272 ((#1)^16)-665611665408 ((#1)^18)+61917364224 ((#1)^20)&,17], ])},{(NumericalApproximation[Root, (RowDefault["0.284", FEExpressionsNumericalApproximationElider]), Root[-131+474 #1+6216 ((#1)^2)-32328 ((#1)^3)-20448 ((#1)^4)+324864 ((#1)^5)-359424 ((#1)^6)-663552 ((#1)^7)+1617408 ((#1)^8)-1119744 ((#1)^9)+248832 ((#1)^10)&,5], ]),(NumericalApproximation[Root, (RowDefault["1.71", FEExpressionsNumericalApproximationElider]), Root[17161-2296092 ((#1)^2)+120687264 ((#1)^4)-3169264320 ((#1)^6)+44279654400 ((#1)^8)-332944183296 ((#1)^10)+1304319614976 ((#1)^12)-2484147585024 ((#1)^14)+2127549431808 ((#1)^16)-665611665408 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["-0.365", FEExpressionsNumericalApproximationElider]), Root[-131+474 #1+6216 ((#1)^2)-32328 ((#1)^3)-20448 ((#1)^4)+324864 ((#1)^5)-359424 ((#1)^6)-663552 ((#1)^7)+1617408 ((#1)^8)-1119744 ((#1)^9)+248832 ((#1)^10)&,2], ]),(NumericalApproximation[Root, (RowDefault["2.47", FEExpressionsNumericalApproximationElider]), Root[17161-2296092 ((#1)^2)+120687264 ((#1)^4)-3169264320 ((#1)^6)+44279654400 ((#1)^8)-332944183296 ((#1)^10)+1304319614976 ((#1)^12)-2484147585024 ((#1)^14)+2127549431808 ((#1)^16)-665611665408 ((#1)^18)+61917364224 ((#1)^20)&,20], ])},{(NumericalApproximation[Root, (RowDefault["0.861", FEExpressionsNumericalApproximationElider]), Root[1-36 #1+108 ((#1)^2)+3240 ((#1)^3)-24768 ((#1)^4)+26784 ((#1)^5)+252288 ((#1)^6)-984960 ((#1)^7)+1472256 ((#1)^8)-995328 ((#1)^9)+248832 ((#1)^10)&,9], ]),(NumericalApproximation[Root, (RowDefault["1.69", FEExpressionsNumericalApproximationElider]), Root[109561-18159192 ((#1)^2)+835769808 ((#1)^4)-17445260736 ((#1)^6)+187129792512 ((#1)^8)-1035442455552 ((#1)^10)+2766287241216 ((#1)^12)-3551111331840 ((#1)^14)+2179577217024 ((#1)^16)-608854081536 ((#1)^18)+61917364224 ((#1)^20)&,19], ])},{(NumericalApproximation[Root, (RowDefault["-0.100", FEExpressionsNumericalApproximationElider]), Root[1-36 #1+108 ((#1)^2)+3240 ((#1)^3)-24768 ((#1)^4)+26784 ((#1)^5)+252288 ((#1)^6)-984960 ((#1)^7)+1472256 ((#1)^8)-995328 ((#1)^9)+248832 ((#1)^10)&,2], ]),(NumericalApproximation[Root, (RowDefault["1.96", FEExpressionsNumericalApproximationElider]), Root[109561-18159192 ((#1)^2)+835769808 ((#1)^4)-17445260736 ((#1)^6)+187129792512 ((#1)^8)-1035442455552 ((#1)^10)+2766287241216 ((#1)^12)-3551111331840 ((#1)^14)+2179577217024 ((#1)^16)-608854081536 ((#1)^18)+61917364224 ((#1)^20)&,20], ])}};

edges=UnitEdges[vertices]

edges={1\[UndirectedEdge]2,1\[UndirectedEdge]11,1\[UndirectedEdge]15,1\[UndirectedEdge]25,2\[UndirectedEdge]3,2\[UndirectedEdge]16,2\[UndirectedEdge]21,3\[UndirectedEdge]4,3\[UndirectedEdge]12,3\[UndirectedEdge]17,4\[UndirectedEdge]5,4\[UndirectedEdge]21,5\[UndirectedEdge]6,5\[UndirectedEdge]12,5\[UndirectedEdge]22,6\[UndirectedEdge]7,6\[UndirectedEdge]13,6\[UndirectedEdge]18,6\[UndirectedEdge]23,7\[UndirectedEdge]8,7\[UndirectedEdge]14,8\[UndirectedEdge]9,8\[UndirectedEdge]18,9\[UndirectedEdge]10,9\[UndirectedEdge]19,9\[UndirectedEdge]24,10\[UndirectedEdge]11,10\[UndirectedEdge]15,10\[UndirectedEdge]20,11\[UndirectedEdge]24,12\[UndirectedEdge]13,13\[UndirectedEdge]14,14\[UndirectedEdge]26,14\[UndirectedEdge]27,14\[UndirectedEdge]28,14\[UndirectedEdge]29,15\[UndirectedEdge]16,15\[UndirectedEdge]26,15\[UndirectedEdge]27,16\[UndirectedEdge]17,16\[UndirectedEdge]28,16\[UndirectedEdge]29,17\[UndirectedEdge]30,17\[UndirectedEdge]31,17\[UndirectedEdge]32,17\[UndirectedEdge]33,18\[UndirectedEdge]19,18\[UndirectedEdge]30,18\[UndirectedEdge]31,19\[UndirectedEdge]20,19\[UndirectedEdge]32,19\[UndirectedEdge]33,20\[UndirectedEdge]34,20\[UndirectedEdge]35,20\[UndirectedEdge]36,20\[UndirectedEdge]37,21\[UndirectedEdge]22,21\[UndirectedEdge]34,21\[UndirectedEdge]35,22\[UndirectedEdge]23,22\[UndirectedEdge]36,22\[UndirectedEdge]37,23\[UndirectedEdge]38,23\[UndirectedEdge]39,23\[UndirectedEdge]40,23\[UndirectedEdge]41,24\[UndirectedEdge]25,24\[UndirectedEdge]38,24\[UndirectedEdge]39,25\[UndirectedEdge]40,25\[UndirectedEdge]41,26\[UndirectedEdge]27,28\[UndirectedEdge]29,30\[UndirectedEdge]31,32\[UndirectedEdge]33,34\[UndirectedEdge]35,36\[UndirectedEdge]37,38\[UndirectedEdge]39,40\[UndirectedEdge]41};

g0=Graph[Range[Length[vertices]],edges,VertexCoordinates->vertices]

g=

RecognizeGraph[g]

UnitDistanceGraphQ[g]

crashes:

HighlightGraphRegularPolygons[g0,11]

Through[{VertexCount,EdgeCount}[g]]

First-order rigidity

FirstOrderRigidGraphQ[g,Debug->True]//Timing

From Jeremy Tan, via Ed Pegg Jr., Oct 20, 2021

hendecagon-proof.nb contains my proof of the rigidity of my hendecagon bracing originally in Shibuya <https://github.com/Parcly-Taxel/Shibuya/blob/main/shibuya/brace11gon/brace11gonproof.py>, translated to the Mathematica context. It is not first-order rigid - that's why Somsky's code didn't catch it; that only checks for first-order rigidity. From the nullspace of the Jacobian (rigidity) matrix, which here is spanned by two vectors v_1 and v_2, I define a new function g(a,b) = f(x_0+a*v_1+b*v_2) and show that the Hessian of the first coordinate is positive-definite. That means that even if I stay in the nullspace, any small non-zero displacement will violate the corresponding constraint, so the graph is rigid. The whole proof is analogous to my proof of the braced 35-edge heptagon with my vertex deletions that I posted on MSE; the graph I obtained (getting a degree-2 vertex on the outside) is rigid, but not first-order rigid.

Third-order rigidity

From Jeremy Tan, via Ed Pegg Jr., Oct 20, 2021

(*Suppose the braced hendecagon has edge 0 fixed horizontally at the bottom, then (Subscript[t, i]) for 1 <= i <= 10 is the Weierstrass parameter of edge i's angle, going counterclockwise from edge 0. The remaining rhombus edges have all sides parallel to one of these 11 outer edges, so introduce no new variables; the diamonds are rigid bodies and will be treated as "distance = (Sqrt[3])" constraints*)
vars=Array[(Subscript[t, #])&,10];

x0=Array[(Subscript[t, #])->ToNumberField[Tan[# Pi/11],Tan[Pi/11]]&,10];

evars=Prepend[vars,0];

vecs={1-#^2,2#}/(1+#^2)&/@evars;

(*This function, called with a spindle orientation index, returns both constraints enforced by the (Sqrt[3]) diamonds of the corresponding spindle*)
cpart[k_]:=Module[{svecs=RotateLeft[vecs,4k],va,vb},va=Total[svecs[[{10,1,2,4,5,6}]]];vb=Total[svecs[[{10,2,4,5,6}]]];{va.va-3,vb.vb-3}]

(*The 11 outer edges must obviously form a closed loop, hence the first two constraints*)
f=Join[{Total[(1-evars^2)/(1+evars^2)],Total[2evars/(1+evars^2)]},Flatten[Array[cpart[#]&,4,0]]];

(*Check that the regular hendecagon satisfies all the constraints*)
f/.x0

(*The Jacobian's nullspace, which in this case is the domain of infinitesimal flexibility, is spanned by two vectors (Subscript[v, 1]) and (Subscript[v, 2]). Yet this does not immediately mean the graph is flexible*)
nullvecs=NullSpace[D[f,{vars}]/.x0]

(*Define a nullspace function g(a,b) = f((Subscript[x, 0])+(Subscript[av, 1])+(Subscript[bv, 2]))*)
g[a_,b_]:=f/.(Rule@@@Transpose@{vars,(#[[2]]&/@x0)+{a,b}.nullvecs})

(*The eigenvalues of the Hessian of g[[1]] are all positive. Hence any small nonzero change of the (Subscript[t, i]) within the nullspace will violate the corresponding constraint; since f can only possibly stay zero in the nullspace, this implies that x0 above is an isolated root of f and the graph is rigid*)
RootReduce[Eigenvalues[D[g[a,b][[1]],{{a,b},2}]/.{a->0,b->0}]]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedHendecagon",{79,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedHendecagon",{79,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Subgraph showing hendecagon

pvertices=ReIm/@Join[outer,rhombs[[;;5]],spindles[[;;4]]]//RootReduce[#,Method->"Recursive"]&

pedges=UnitEdges[pvertices]

subg=Graph[Range[Length[pvertices]],pedges,VertexCoordinates->pvertices]

subg=

RecognizeGraph[subg]

FirstOrderRigidGraphQ[subg]

Through[{VertexCount,EdgeCount}[subg]]

GraphData

file=OpenWrite["~/braced-11.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{41,1}},
"Name"->"41\[Hyphen]unit distance graph 1",
"Information"->"Unit-DistanceGraph",
"Skip"->{"Arboricity","DominatingSets","EdgeCovers","HamiltonianWalks","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedHendecagon", {155, 1}} = Khodulyov linkage construction (155 rods)

Construction

Image from Friedman

g=KhodulyovBracedPolygonGraph[11]

EdgeCount[g]

LamanGraphQ[g]

FirstOrderRigidGraphQ[g]

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedHendecagon",{155,1}},"Graph"]

GraphData[{"BracedHendecagon",{155,1}},"EmbeddingClasses"]

GraphData[{"BracedHendecagon",{155,1}}]//UnitDistanceGraphEmbeddingQ

Through[{VertexCount,EdgeCount}[g]]

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-11.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHendecagon",{155,1}},
"AlternateStandardNames"->{{"BracedPolygon",{11,{155,1}}}},
"Name"->"155\[Hyphen]rod braced hendecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{11,155}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced dodecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{12,_},_,_,gn_}:>gn],Dividers->All]

{"BracedDodecagon", {49, 1}} = Khodulyov (49 rods)

GraphData[{"BracedDodecagon",{49,1}},"Graph","All"]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedDodecagon",{49,1}}],12]

Rigid

FirstOrderRigidGraphQ[GraphData[{"BracedDodecagon",{49,1}}]]

Search for subgraphs by removing vertices

g=GraphData[{"BracedDodecagon",{49,1}},"Graph","Labeled"]

VertexCount[g]

Vertices that are not part of the dodecagon:

vl=Complement[VertexList[g],{2,13,15,14,12,1,6,16,18,19,17,7}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

CN=1 construction

MinimalCrossingGraph[GraphData[{"BracedDodecagon",{49,1}}],"CrossingNumber"->1]

GraphPlot[SetProperty[MinimalCrossingGraph[GraphData[{"BracedDodecagon",{49,1}}]],VertexLabels->None]]

v1=Join[CirclePoints[12],CirclePoints[1/2,6],{{0,0}}];

v2=Join[v1,Table[v[[15]]+(v[[4]]-v[[15]])i/4,{i,3}]];

v3=Join[v2,{Mean[v2[[{14,21}]]]}];

v4=Join[v3,{Mean[v3[[{4,23}]]],{5/9,5/9}}];

v=Join[v4,{Mean[v4[[{15,25}]]]}];

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[12],2,1,1],Partition[Range[13,17],2,1],{{13,18}},{#,19}&/@{13,14,15,16,17,18},{{12,18},{1,13},{2,13},{3,14},{10,17},{9,17},{8,16},{7,16},{6,15},{5,15},{4,14},{15,20},{23,21},{21,5},{4,22},{23,24},{24,4},{22,24},{22,23},{15,26},{26,25},{26,20},{20,25},{25,4},{25,21},{23,15}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

RectilinearCrossingCount[g]

SetProperty[g,VertexLabels->None]

Construction

Friedman: https://erich-friedman.github.io/mathmagic/0100.html

v1=Join[CirclePoints[Csc[Pi/12]/2,12],CirclePoints[{Csc[Pi/6]/2,π/6},6],{{0,0}}];

Rotate[g1=GraphData[{"BracedSquare",{19,1}},"Graph","Labeled"],-2.5]

emb=GraphEmbedding[g1];

v2=(v1[[1]]+RotationMatrix[2Pi/12-Pi].(#-emb[[4]]))&/@emb;

ArcTan@@(v1[[18]]-v1[[1]])//FullSimplify

v=Join[v1,v2]//FullSimplify//Union;

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=EdgeDelete[Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],UndirectedEdge@@@{{5,9},{2,5}}]

EdgeCount[g]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedDodecagon",{49,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedDodecagon",{49,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Laman

LamanGraphQ[g,Debug->True]//Timing

GraphData

file=OpenWrite["~/braced-dodecagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedDodecagon",{49,1}},
"AlternateStandardNames"->{{"BracedPolygon",{12,{49,1}}}},
"Name"->"49\[Hyphen]rod braced dodecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{12,49}},
"Skip"->{"Arboricity","DominatingSets","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedDodecagon", {51, 1}} = Friedman (51 rods)

GraphData[{"BracedDodecagon",{51,1}},"Graph","All"]//StyleGraphs

GraphData[{"BracedDodecagon",{51,1}},"Graph","UnitDistance"]//StyleGraphs

GraphData[{"BracedDodecagon",{51,1}},"Graph","Planar"]//StyleGraphs

HighlightGraphRegularPolygons[GraphData[{"BracedDodecagon",{51,1}}],12]

FirstOrderRigidGraphQ[GraphData[{"BracedDodecagon",{51,1}}],Debug->True]

LamanGraphQ[GraphData[{"BracedDodecagon",{51,1}}],Debug->True]//Timing

GraphData[{"BracedDodecagon",{51,1}},"Laman"]

Search for subgraphs by removing vertices

g=GraphData[{"BracedDodecagon",{51,1}},"Graph","Labeled"]

VertexCount[g]

Vertices that are not part of the dodecagon:

vl=Complement[VertexList[g],{4,9,16,20,21,17,10,5,13,15,14,12}]

nl=Length[vl]

Do[Print[{k,Binomial[nl,k],SelectFirst[Subsets[vl,{k}],FirstOrderRigidGraphQ[VertexDelete[g,#]]&]//Timing}],{k,0,nl}]

Construction

https://erich-friedman.github.io/mathmagic/0100.html

I can make a rigid dodecagon with 51 rods:

v0=Join[{{0,0}},CirclePoints[Csc[Pi/12]/2,12],CirclePoints[Csc[Pi/6]/2,6]];

g1=;

RecognizeGraph[g1]

v1=GraphEmbedding[g1];

left=(RotationMatrix[π/4-π/3].(#-v1[[1]])+v0[[12]])&/@v1;

v=Join[v0,left]//FullSimplify//Union;

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=EdgeDelete[Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],UndirectedEdge@@@{{6,11},{11,21}}]

g0=;

RecognizeGraph[g]

Through[{EdgeCount,VertexCount}[g]]

RecognizeGraph[g]

PlanarGraphQ[g]

Planar construction

GraphPlot[PlanarGraph[SetProperty[g,VertexLabels->None]]]

v0=Join[{{0,0}},CirclePoints[{Csc[Pi/12]/2,π/6},12],CirclePoints[{Csc[Pi/6]/2,π/12},6]];

dy=Last[Subtract@@v0[[{3,14}]]]/3;
dx=1/10;

v1=Flatten[Table[v0[[14]]+{i dx,j dy},{j,2},{i,-3,3,2}],1];

v=Join[v0,v1];

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g=EdgeAdd[EdgeDelete[Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"],UndirectedEdge@@@{{8,17},{1,17}}],UndirectedEdge@@@{{14,20},{14,21},{14,22},{14,23},{20,24},{23,27},{20,21},{22,23},{24,25},{25,26},{26,27},{3,24},{3,25},{3,26},{3,27},{21,24},{22,27}}]

g=;

Subgraph[g,{3,24,25,26,27,20,21,22,23,14}]

IsomorphicGraphQ[g,g0]

ToCommonEdges[g,g0]//FullSimplify

2-D embedding

file=OpenWrite["~/braced-dodecagon.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedDodecagon",{51,1}},
"AlternateStandardNames"->{{"BracedPolygon",{12,{51,1}}}},
"Name"->"51\[Hyphen]rod braced dodecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon"},
"NotationRules"->{"BracedPolygon"->{12,51}},
"Skip"->{"Arboricity","DominatingSets","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

Braced tridecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{13,_},_,_,gn_}:>gn],Dividers->All]

{"BracedTridecagon", {151, 1}} = Tan (151 rods)

GraphData[{"BracedTridecagon",{151,1}}]

LamanGraphQ[GraphData[{"BracedTridecagon",{151,1}}]]//Timing

UnitDistanceGraphQ[GraphData[{"BracedTridecagon",{151,1}}]]

Properties

GraphData[{"BracedTridecagon",{151,1}},{"V","M"}]

Construction from scratch

Jeremy Tan, Oct 26, 2021

cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]

z=AlgebraicNumber[Exp[2I Pi/13],{0,1}];

vects=Table[z^k,{k,0,12}];

p=Table[Total[vects[[1;;k]]],{k,0,12}];

bridge[i_,d_]:=Module[{cuc,q0,q1,q2,q3,q4,q5,q6,rl0,rl1,rl2,rl3,rr0,rr1,rr2,rr3},
cuc[a_,b_]:=If[d>0,cu[a,b],cu[b,a]];
q0=p[[i+1]]+p[[Mod[i+2d,13]+1]]-p[[Mod[i+d,13]+1]];
q1=p[[i+1]]+p[[Mod[i-2d,13]+1]]-p[[Mod[i-d,13]+1]];
q2=q0+q1-p[[i+1]];
q3=p[[Mod[i-3d,13]+1]]+q1-p[[Mod[i-2d,13]+1]];
q4=q2+q3-q1;
q5=p[[Mod[i+3d,13]+1]]+p[[Mod[i+5d,13]+1]]-p[[Mod[i+4d,13]+1]];
q6=q5+p[[Mod[i+6d,13]+1]]-p[[Mod[i+5d,13]+1]];
rl0=cuc[q3,q4];
rr0=cuc[q4,q3];
rl1=(q6+rl0)/2;
rr1=(q6+rr0)/2;
rl2=cuc[q6,rl1];
rl3=cuc[rl1,rl0];
rr2=cuc[rr0,rr1];
rr3=cuc[rr1,q6];
{{q0,q1,q2,q3,q4,q5,q6},{rl0,rl1,rl2,rl3,rr0,rr1,rr2,rr3}}]

{qs,rs}=Transpose[bridge@@@{{5,1},{5,-1},{0,1},{0,-1},{8,1}}];

tridecV=ReIm/@Join[p,DeleteDuplicates[Flatten[qs]],Flatten[rs]];

(*21\[UndirectedEdge]35 is not part of the cyclotomic construction; these vertices just happen to have separation 1*)
tridecE=DeleteCases[UnitEdges[tridecV],21\[UndirectedEdge]35];

Length/@{tridecV,tridecE}

g=Graph[Range[77],tridecE,VertexCoordinates->tridecV]

tridecpartV=ReIm/@Flatten[{p,bridge[0,1]}];
tridecpartE=UnitEdges[tridecpartV];
Graph[Range[Length[tridecpartV]],tridecpartE,VertexCoordinates->tridecpartV]

Algebraic root objects

v=GraphEmbedding[GraphData[{"BracedTridecagon",{151,1}}]]

(exactv=Table[Print[i];ToAlgebraicRoot[#,Debug->True]&/@v[[i]],{i,Length[v]}])//Timing

g=Graph[Range[77],GraphData[{"BracedTridecagon",{151,1}},"Edges"],VertexCoordinates->exactv]

RecognizeGraph[g]

Reconstruction from LamanGraph NB

Original from Jeremy Tan, Oct 26, 2021 (contains correct vertices but incorrect = non-unit egdes):

g0=;

Reconstruct unit edges:

u0=UnitEdges[v=GraphEmbedding[g0]]

g1=Graph[Range[Length[v]],u0,VertexCoordinates->v]

EdgeCount/@{g0,g1}

Delete extra edge:

SelectFirst[u0,IsomorphicGraphQ[EdgeDelete[g1,#],g0]&]

u=Complement[u0,{16\[UndirectedEdge]24}]

g=Graph[Range[Length[v]],u,VertexCoordinates->v]

Laman:

LamanGraphQ[g]//Timing

Not first-order rigid:

FirstOrderRigidGraphQ[g]

UD:

UnitDistanceGraphEmbeddingQ[g]

RecognizeGraph[g]

GraphData

file=OpenWrite["~/braced-13.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedTridecagon",{151,1}},
"AlternateStandardNames"->{{"BracedPolygon",{13,{151,1}}}},
"Name"->"151\[Hyphen]rod braced tridecagon graph 1",
"Information"->"BracedPolygon",
"NotationRules"->{"BracedPolygon"->{13,151}},
"Classes"->{"Braced","Laman","UnitDistance"},
"Skip"->{"Arboricity","DominatingSets","EdgeCovers","HamiltonianWalks","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedTridecagon", {193, 1}} = Khodulyov linkage construction (193 rods)

Construction

Image from Friedman

g=KhodulyovBracedPolygonGraph[13]

EdgeCount[g]

LamanGraphQ[g]

FirstOrderRigidGraphQ[g]

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedTridecagon",{193,1}},"Graph"]

GraphData[{"BracedTridecagon",{193,1}},"EmbeddingClasses"]

GraphData[{"BracedTridecagon",{193,1}}]//UnitDistanceGraphEmbeddingQ

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-13.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedTridecagon",{193,1}},
"AlternateStandardNames"->{{"BracedPolygon",{13,{193,1}}}},
"Name"->"193\[Hyphen]rod braced tridecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{13,193}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced tetradecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{14,_},_,_,gn_}:>gn],Dividers->All]

{"BracedTetradecagon", {91, 1}} = Somsky (91 rods)

GraphData[{"BracedTetradecagon",{91,1}}]

LamanGraphQ[GraphData[{"BracedTetradecagon",{91,1}}]]//Timing

UnitDistanceGraphQ[GraphData[{"BracedTetradecagon",{91,1}}]]

GraphEmbedding[GraphData[{"BracedTetradecagon",{91,1}}]]

Construction

From "A New Braced Heptagon"
WRSomsky <wrsomsky@gmail.com>
December 2020

Nested-7 Graph:

ring1=CirclePoints[{r1,ϕ1},7];
ring2=CirclePoints[{r2,ϕ2},7];
ring3=CirclePoints[{r3,ϕ3},7];
nodes=Join[ring1,ring2,ring3];

SQD[p_,q_]:=(p[[1]]-q[[1]])^2+(p[[2]]-q[[2]])^2

r1=Select[NSolve[SQD[ring1[[1]],ring1[[1+1]]]==1,WorkingPrecision->10000],r1>0/.#&][[1,1,2]];
r2=Select[NSolve[SQD[ring2[[1]],ring2[[1+2]]]==1,WorkingPrecision->10000],r2>0/.#&][[1,1,2]];
r3=Select[NSolve[SQD[ring3[[1]],ring3[[1+3]]]==1,WorkingPrecision->10000],r3>0/.#&][[1,1,2]];

ϕ1=π/2; (* Put point 1 at top *)
ϕ2=FindRoot[SQD[nodes[[1]],nodes[[9]]]==1,{ϕ2,ϕ1},WorkingPrecision->10000][[1,2]];
ϕ3=FindRoot[SQD[nodes[[1]],nodes[[21]]]==1,{ϕ3,ϕ1},WorkingPrecision->10000][[1,2]];

Reduced Nested-7 Graph:

Do[nodes=ReplacePart[nodes,drop->Nothing],{drop,Reverse[Sort[{18,21}]]}]

Braced Tetradecagon:

SRN7=#-nodes[[1]]&/@ nodes;(* Shifted Reduced Nested-7 graph *)
center={{0,0}};
ring4=CirclePoints[{r4,ϕ4},14];
ring5=CirclePoints[{r5,ϕ5},14];
ring6=CirclePoints[{r6,ϕ6},14];
ϕ4=0;r4=1 ;
ϕ5=0;r5=FindRoot[SQD[ring4[[1]],ring5[[2]]]==1,{r5,1},WorkingPrecision->10000][[1,2]];
ϕ6=0;r6=FindRoot[SQD[ring5[[2]],ring6[[1]]]==1,{r6,2},WorkingPrecision->10000][[1,2]];
{r4,r5,r6};
nodes=Join[center,ring4,ring5,ring6,SRN7];
Do[nodes=ReplacePart[nodes,drop->Nothing],{drop,Reverse[Sort[{11,14,12,13,26,27}]]}]
Do[nodes=ReplacePart[nodes,drop->Nothing],{drop,Reverse[Sort[{9,20}]]}]
Do[nodes=ReplacePart[nodes,drop->Nothing],{drop,Reverse[Sort[{1,9,10,19,20,32,33}]]}]

ee=UnitEdges[nodes]

g=Graph[Range[Length[nodes]],ee,VertexCoordinates->nodes]

RecognizeGraph[g]

Exact vertices

ToAlgebraicRoot[#,"MaxDegree"->16,WorkingPrecision->5000,Debug->True]&/@nodes[[8]]//Timing

exactv=Map[ToAlgebraicRoot[#,"MaxDegree"->32,WorkingPrecision->5000]&,nodes,{2}]

g=Graph[Range[Length[exactv]],ee,VertexCoordinates->exactv]

RecognizeGraph[g]

UnitDistanceGraphQ[g]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedTetradecagon",{91,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedTetradecagon",{91,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Properties

Through[{VertexCount,EdgeCount}[g]]

LamanGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]//Timing

nodes[[10]]

GraphData

file=OpenWrite["~/braced-14.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedTetradecagon",{91,1}},
"AlternateStandardNames"->{{"BracedPolygon",{14,{91,1}}}},
"Name"->"91\[Hyphen]rod braced tetradecagon graph 1",
"Information"->"BracedPolygon",
"NotationRules"->{"BracedPolygon"->{14,91}},
"Classes"->{"Braced","Laman","UnitDistance"},
"Skip"->{"Arboricity","DominatingSets","EdgeCovers","HamiltonianWalks","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedTetradecagon", {213, 1}} = Khodulyov linkage construction (213 rods)

Construction

g=KhodulyovBracedPolygonGraph[14]

EdgeCount[g]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedTetradecagon",{213,1}},"Graph"]

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

g=

RecognizeGraph[g]

GraphData

file=OpenWrite["~/braced-14.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedTetradecagon",{213,1}},
"AlternateStandardNames"->{{"BracedPolygon",{14,{213,1}}}},
"Name"->"213\[Hyphen]rod braced tetradecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{14,213}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced pentadecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{15,_},_,_,gn_}:>gn],Dividers->All]

{"BracedPentadecagon", {91, 1}} (from Tam)

Construction

Jeremy Tan
Oct. 28, 2021

Two more braced polygons here: the 15-gon in 91 and the 18-gon in 117. The 18-gon is somewhat similar to Khodulyov's nonagon, with a pair of P-L (Peaucellier-Lipkin) linkages fixing some vectors and equilateral triangles in a rhombic tiling fixing the rest. The 15-gon essentially has Khodulyov's decagon for its core, with two pairs of redundant edges removed; I chanced upon it when trying to derive a bracing from Hamming(5,3) (5 copies of K_3).

cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]

G=Module[{starinds={{13,4},{12,2},{11,10},{15,8},{14,6}},star,Gc=VertexDelete[GraphData[{"BracedDecagon", {55, 1}}],{7,9}],X,ev1,evi1,ee1,ev2,evi2,ee2,ev3,evi3,ee3,ev4,evi4,ee4},star=RootReduce[Map[{1,I}.AnnotationValue[{Gc,#},VertexCoordinates]&,starinds,{2}]];ev1=RootReduce[cu@@@star];evi1=29+Range[5];ee1=Flatten[MapThread[{#1\[UndirectedEdge]#2[[1]],#1\[UndirectedEdge]#2[[2]]}&,{evi1,starinds}]];ev2=RootReduce[MapThread[cu,{#[[2]]&/@RotateRight[star],ev1}]];evi2=34+Range[5];ee2=Flatten[MapThread[{#1\[UndirectedEdge]#2,#1\[UndirectedEdge]#3}&,{evi2,evi1,#[[2]]&/@RotateRight[starinds]}]];ev3=RootReduce[MapThread[cu,{RotateRight[ev1],ev2}]];evi3=39+Range[5];ee3=Flatten[MapThread[{#1\[UndirectedEdge]#2,#1\[UndirectedEdge]#3}&,{evi3,evi2,RotateRight[evi1]}]];ev4=RootReduce[MapThread[cu,{RotateRight[ev2],ev3}]];evi4=44+Range[5];ee4=Flatten[MapThread[{#1\[UndirectedEdge]#2,#1\[UndirectedEdge]#3}&,{evi4,evi3,RotateRight[evi2]}]];X=RootReduce[{1,I}.#&/@AnnotationValue[Gc,VertexCoordinates]];{Join[X,ev1,ev2,ev3,ev4],Join[EdgeList[Gc],ee1,ee2,ee3,ee4]/.{x_Integer:>7/;x==8,x_Integer:>x-2/;x>=10}}];

Length/@G

(*This shows that G is indeed a unit-distance embedding...*)
SubsetQ[UnitEdges[G[[1]]],Sort/@G[[2]]]

(*...containing a regular 15-gon*)
SubsetQ[G[[1]],RootReduce[{1,I}.#&/@CirclePoints[Csc[Pi/15]/2,15]]]

g=Graph[Range[Length[G[[1]]]],Sort[Sort/@G[[2]]],VertexCoordinates->RootReduce[ReIm/@G[[1]]]]

Through[{VertexCount,EdgeCount}[g]]

UnitDistanceGraphEmbeddingQ[g]

LamanGraphQ[g]

FirstOrderRigidGraphQ[g]

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"BracedPentadecagon",{91,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"BracedPentadecagon",{91,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

GraphData

file=OpenWrite["~/braced-15.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedPentadecagon",{91,1}},
"AlternateStandardNames"->{{"BracedPolygon",{15,{91,1}}}},
"Name"->"91\[Hyphen]rod braced pentadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{15,91}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

{"BracedPentadecagon", {231, 1}} = Khodulyov linkage construction (231 rods)

Construction

g=KhodulyovBracedPolygonGraph[15]

EdgeCount[g]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedPentadecagon",{231,1}},"Graph"]

GraphData[{"BracedPentadecagon",{231,1}},"EmbeddingClasses"]

GraphData[{"BracedPentadecagon",{231,1}}]//UnitDistanceGraphEmbeddingQ

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-15.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedPentadecagon",{231,1}},
"AlternateStandardNames"->{{"BracedPolygon",{15,{231,1}}}},
"Name"->"231\[Hyphen]rod braced pentadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{15,231}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced hexadecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{16,_},_,_,gn_}:>gn],Dividers->All]

{"BracedHexadecagon", {109, 1}} = Tan (109 rods)

GraphData[{"BracedHexadecagon",{109,1}}]

LamanGraphQ[GraphData[{"BracedHexadecagon",{109,1}}]]//Timing

UnitDistanceGraphQ[GraphData[{"BracedHexadecagon",{109,1}}]]

GraphEmbedding[GraphData[{"BracedHexadecagon",{109,1}}]]

Properties

GraphData[{"BracedHexadecagon",{109,1}},{"V","E"}]

Laman:

LamanGraphQ[g]//Timing

First-order rigid:

FirstOrderRigidGraphQ[g]

UD:

UnitDistanceGraphEmbeddingQ[g]

RecognizeGraph[g]

Construction

Original from Jeremy Tan, Oct 26, 2021

"No proof notebook is provided since the constraint methods are quite easy to see from the graph itself: six diamonds (like the braced square) and one Peaucellier-Lipkin linkage (like the braced nonagon) in a rhombus tiling (which alone leaves seven degrees of freedom)."

cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]

cu[x_,y_,rx_,ry_]:=Module[{d,ϕ,θ},
{d,ϕ}=ToPolarCoordinates[ReIm[y-x]];θ=ArcCos[(rx^2-ry^2+d^2)/(2d rx)];x+rx Exp[I(ϕ+θ)]]

plcell[a_,b_,c_,d_]:=Module[{z0=b+d-c,z1=a+d-c,y0,y1,m,a0,a1,a2,a3},
y0=cu[z1,c,1,Sqrt[3]];
y1=cu[c,z1,Sqrt[3],1];
m=y0+y1-z1;
a0=cu[y0,c];
a1=cu[c,y0];
a2=cu[y1,c];
a3=cu[c,y1];
{z0,z1,y0,y1,m,a0,a1,a2,a3}]

z=AlgebraicNumber[Exp[I Pi/8],{0,1}];

triples={{1,4,2},{1,5,3},{6,10,4},{7,11,5},{10,11,1},{13,14,11},{12,14,10},{7,15,13},{6,16,12},{9,17,7},{8,18,6},{15,19,17},{16,20,18},{14,21,15},{14,22,16},{23,24,14},{22,25,24},{21,25,23},{26,27,25},{19,27,21},{20,26,22},{9,29,19},{8,30,20},{28,29,27},{28,30,26},{31,33,29},{32,34,30},{33,34,28}};pairs={{4,16},{5,15},{10,18},{11,17},{19,25},{20,25}};

verts=ReIm/@Module[{res={0,1,z^7,1+z,z^7+z^6,1+z+z^2,z^7+z^6+z^5,1+z+z^2+z^3,z^7+z^6+z^5+z^4}},
AppendTo[res,{1,1,-1}.res[[#]]]&/@triples;AppendTo[res,cu@@res[[#]]]&/@pairs;AppendTo[res,cu@@Reverse[res[[#]]]]&/@pairs;Join[res,(plcell@@res[[{7,5,3,1}]])[[3;;]]]];

edges=UnitEdges[verts]

Length/@{verts,edges}

g=Graph[Range[56],ee,VertexCoordinates->verts]

Algebraic root objects

v=GraphEmbedding[GraphData[{"BracedHexadecagon",{109,1}}]]

(exactv=Table[Print[i];ToAlgebraicRoot[#,Debug->True]&/@v[[i]],{i,Length[v]}])//Timing

g=Graph[Range[Length[exactv]],GraphData[{"BracedHexadecagon",{109,1}},"Edges"],VertexCoordinates->exactv]

RecognizeGraph[g]

GraphData

file=OpenWrite["~/braced-16.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHexadecagon",{109,1}},
"AlternateStandardNames"->{{"BracedPolygon",{16,{109,1}}}},
"Name"->"109\[Hyphen]rod braced hexadecagon graph 1",
"Information"->"BracedPolygon",
"NotationRules"->{"BracedPolygon"->{16,109}},
"Classes"->{"Braced","Laman","UnitDistance"},
"Skip"->{"Arboricity","DominatingSets","EdgeCovers","HamiltonianWalks","MinimumVertexColoring","MinimumWeightFractionalEdgeColoring"},
Debug->True,
TimeConstraint->60
]]

Close[file]

{"BracedHexadecagon", {251, 1}} = Khodulyov linkage construction (251 rods)

Construction

g=KhodulyovBracedPolygonGraph[16]

EdgeCount[g]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedPentadecagon",{251,1}},"Graph"]

GraphData[{"BracedPentadecagon",{251,1}},"EmbeddingClasses"]

GraphData[{"BracedPentadecagon",{231,1}}]//UnitDistanceGraphEmbeddingQ

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

g=Graph[Range[Length[vexact]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-16.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHexadecagon",{251,1}},
"AlternateStandardNames"->{{"BracedPolygon",{16,{251,1}}}},
"Name"->"251\[Hyphen]rod braced hexadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{16,251}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced heptadecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{17,_},_,_,gn_}:>gn],Dividers->All]

{"BracedHeptadecagon", {269, 1}} = Khodulyov linkage construction (269 rods)

Construction

g=KhodulyovBracedPolygonGraph[17]

EdgeCount[g]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedHeptadecagon",{269,1}},"Graph"]

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

Graph[Range[Length[v]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-17.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedHeptadecagon",{269,1}},
"AlternateStandardNames"->{{"BracedPolygon",{17,{269,1}}}},
"Name"->"269\[Hyphen]rod braced heptadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{17,231}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced octadecagon

TextGrid[{#,GraphData[#]//StyleGraphs}&/@Cases[BracedPolygons,{{18,_},_,_,gn_}:>gn],Dividers->All]

{"BracedOctadecagon", {117, 1}} (from Tam)

Construction

Jeremy Tan
Oct. 28, 2021

My cyclotomic method, and perhaps any other possible method, is most likely not going to beat the "Khodulyov bound" (the linear upper bound on edge count provided by the equal-angles construction) at n = 17 and higher prime numbers of sides. The n-3 in the expression for the Khodulyov bound has physical significance as the number of degrees of freedom of the unbraced polygon, so any method beating the Khodulyov bound would have to work with a budget of 18 edges per constraint regardless of how big the polygon gets -- an impossible proposition, since the needed vertices just get farther away.

cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]

cu[x_,y_,rx_,ry_]:=Module[{d,ϕ,θ},
{d,ϕ}=ToPolarCoordinates[ReIm[y-x]];θ=ArcCos[(rx^2-ry^2+d^2)/(2d rx)];x+rx Exp[I(ϕ+θ)]]

plcell[a_,b_,c_,d_]:=Module[{z0=b+d-c,z1=a+d-c,y0,y1,m,a0,a1,a2,a3},
y0=cu[z1,c,1,Sqrt[3]];
y1=cu[c,z1,Sqrt[3],1];
m=y0+y1-z1;
a0=cu[y0,c];
a1=cu[c,y0];
a2=cu[y1,c];
a3=cu[c,y1];
{z0,z1,y0,y1,m,a0,a1,a2,a3}]

z=AlgebraicNumber[Exp[I Pi/9],{0,1}];

verts=ReIm/@Module[{res={{0},{z^4,z^-4}},middle},
Do[AppendTo[res,Join[{res[[-1,1]]+z^k},ListConvolve[{1,1},res[[-1]]]-res[[-2]],{res[[-1,-1]]+z^-k}]],{k,3,-3,-1}];res=Append[Flatten[res],ToNumberField[Csc[Pi/18],z]];Join[res,(plcell@@res[[{4,2,1,3}]])[[3;;]],(plcell@@res[[{6,3,1,2}]])[[3;;]]]];edges=DeleteCases[UnitEdges[verts],(x_\[UndirectedEdge]y_)/;AllTrue[{x,y},IntervalMemberQ[Interval[{22,25},{37,45}]]]];

Length/@{verts,edges}

g=Graph[Range[Length[verts]],Sort[Sort/@edges],VertexCoordinates->verts]

Through[{VertexCount,EdgeCount}[g]]

UnitDistanceGraphEmbeddingQ[g]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

Exact algebraic roots

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

Graph[Range[Length[v]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenWrite["~/braced-18.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedOctadecagon",{117,1}},
"AlternateStandardNames"->{{"BracedPolygon",{18,{117,1}}}},
"Name"->"117\[Hyphen]rod braced octadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{18,117}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

{"BracedOctadecagon", {289, 1}} = Khodulyov linkage construction (289 rods)

Construction

g=KhodulyovBracedPolygonGraph[18]

Through[{VertexCount,EdgeCount}[g]]

LamanGraphQ[g]//Timing

FirstOrderRigidGraphQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g]

Algebraic root objects

g=GraphData[{"BracedOctadecagon",{289,1}}]

v=GraphEmbedding[g]

(vexact=Map[ToAlgebraicRoot[#,"MaxDegree"->64,WorkingPrecision->5000,Debug->True]&,v,{2}])//Timing

Graph[Range[Length[v]],EdgeList[g],VertexCoordinates->vexact]

GraphData

file=OpenAppend["~/braced-18.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedOctadecagon",{289,1}},
"AlternateStandardNames"->{{"BracedPolygon",{18,{289,1}}}},
"Name"->"289\[Hyphen]rod braced octadecagon graph 1",
"Information"->"BracedPolygon",
"Classes"->{"BracedPolygon","Laman"},
"NotationRules"->{"BracedPolygon"->{18,289}},
"Skip"->{"Arboricity","AlmostHamiltonian","Arboricity","DominatingSets","HamiltonianWalks","MinimumWeightFractionalColoring","TotalDominatingSets"},
Debug->True,
TimeConstraint->10
]]

Close[file]

Braced Archimedean

TextGrid[{#,FirstOrderRigidGraphQ[GraphData[#,"Graph3D"]]}&/@GraphData["Archimedean"],Dividers->All]

GraphData["CuboctahedralGraph","Graph3D"]

FirstOrderRigidGraphQ[GraphData["CuboctahedralGraph","Graph3D"],Debug->True]

Braced Platonic

TextGrid[Function[g,{g,GraphData[g,"Graph",{"3D","All"}],FirstOrderRigidGraphQ/@GraphData[g,"Graph",{"3D","All"}]}]/@GraphData["Platonic"],Dividers->All]

FirstOrderRigidGraphQ[GraphData["CubicalGraph","Graph3D"],Debug->True]

FirstOrderRigidGraphQ[GraphData["DodecahedralGraph","Graph3D"],Debug->True]