Unit-Distance Graph

Author

Eric W. Weisstein
July 31, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Unit-DistanceGraph.nb.

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

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

Counts

GraphData

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/UnitDistance"]

FileNames["*.m"]

All

A350507

Table[Total[Boole[Get["UnitDistance_0"<>ToString[n]<>".m"]]],{n,9}]

Table[Length@GraphData["UnitDistance",n],{n,9}]

Connected

A059103

Number of simple, connected, unit-distance graphs on n points realizable in the plane with straight edges all of the same length; lines are permitted to cross.

Table[Total[Boole[Get["UnitDistance_0"<>ToString[n]<>".m"][[ConnectedGraphIndices[n]]]]],{n,9}]

Table[Length@GraphData[{"Connected","UnitDistance"},n],{n,9}]

1

GraphData["Connected",1]

GraphData[{"Connected","UnitDistance"},1]

2

GraphData["Connected",2]

GraphData[{"Connected","UnitDistance"},2]

3

GraphData["Connected",3]

GraphData[{"Connected","UnitDistance"},3]

4

GraphData["Connected",4]

GraphData[{"Connected","UnitDistance"},4]

5

GraphData["Connected",5]

GraphData[{"Connected","UnitDistance"},5]

nonu=Complement[%%,%]

Show[GraphData[#],PlotLabel->#]&/@nonu

6

GraphData["Connected",6]

GraphData[{"Connected","UnitDistance"},6]

Length[%]

nonu=Complement[GraphData["Connected",6],GraphData[{"Connected","UnitDistance"},6]]

Show[GraphData[#],PlotLabel->#]&/@nonu

7

GraphData[{"Connected","UnitDistance"},7]

Length[%]

nonu=Complement[GraphData["Connected",7],GraphData[{"Connected","UnitDistance"},7]]

Length[%]

Checks

Monitor[Select[GraphData[{"Connected","UnitDistance"},;;6],(g=GraphData[gname=#,"Graph","UnitDistance"])==={}||DegenerateEmbeddingQ[g=g[[1]]]||UnitDistanceGraphQ[g,WorkingPrecision->100]=!=True&],gname]//Timing

Monitor[Select[GraphData[{"Connected","UnitDistance"},;;7],(g=GraphData[gname=#,"Graph","UnitDistance"])==={}||DegenerateEmbeddingQ[g=g[[1]]]||UnitDistanceGraphQ[g,WorkingPrecision->100]=!=True&],gname]//Timing

Parametrized families

Alkane

seq=Table[GraphData[{"Alkane",n},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]

AlternatingGroupGraph

seq=Table[GraphData[{"AlternatingGroupGraph",n},"UnitDistance"],{n,2,6}]

Andrasfai

seq=Table[GraphData[{"Andrasfai",n},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]

FindGeneratingFunction[seq,x]//FullSimplify

Antelope n×n

seq=Table[GraphData[{"Antelope",{n,n}},"UnitDistance"],{n,20}]

Antiprism

Entity["Graph",{"Antiprism",n}]["UnitDistance"]

seq=Table[GraphData[{"Antiprism",n},"UnitDistance"],{n,3,25}]

Apollonian

seq=Table[GraphData[{"Apollonian",n},"UnitDistance"],{n,5}]

FindSequenceFunction[seq,n]

Barbell

seq=Table[GraphData[{"Barbell",n},"UnitDistance"],{n,3,20}]

FindSequenceFunction[seq,n]

BlackBishop n×n

seq=Table[GraphData[{"BlackBishop",{n,n}},"UnitDistance"],{n,20}]

FullSimplify[FindSequenceFunction[Rest@seq,n-1],n∈Integers]

Bishop n×n

seq=Table[GraphData[{"Bishop",{n,n}},"UnitDistance"],{n,20}]

Book

seq=Table[GraphData[{"Book",n},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]

Bruhat

seq=Table[GraphData[{"Bruhat",n},"UnitDistance"],{n,6}]

FindSequenceFunction[seq,n]

Camel n×n

seq=Table[GraphData[{"Camel",{n,n}},"UnitDistance"],{n,20}]

Centipede

seq=Table[GraphData[{"Centipede",n},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]

CocktailParty

seq=Table[GraphData[{"CocktailParty",n},"UnitDistance"],{n,20}]

Complete

Entity["Graph",{"Complete",n}]["UnitDistance"]

seq=Table[GraphData[{"Complete",n},"UnitDistance"],{n,30}]

FindSequenceFunction[seq,n]

CompleteBipartite m×n

Entity["Graph",{"CompleteBipartite",{m,n}}]["UnitDistance"]

DeleteCases[Flatten[Table[{
{m,n},
GraphData[{"CompleteBipartite",{m,n}},"UnitDistance"],
3Max[m,n]/2
},{n,10},{m,n}],1],{_,x_,x_}]

CompleteBipartite n×n

Entity["Graph",{"CompleteBipartite",{n,n}}]["UnitDistance"]

seq=Table[GraphData[{"CompleteBipartite",{n,n}},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]//FullSimplify

CompleteTripartite k×m×n

Entity["Graph",{"CompleteTripartite",{k,m,n}}]["UnitDistance"]

DeleteCases[Flatten[Table[{
{k,m,n},
GraphData[{"CompleteTripartite",{k,m,n}},"UnitDistance"],
3Max[k,m,n]/2
},{n,10},{m,n},{k,m}],2],{_,x_,x_}]

CompleteTripartite n×n×n

Entity["Graph",{"CompleteTripartite",{n,n,n}}]["UnitDistance"]

seq=Table[GraphData[{"CompleteTripartite",{n,n,n}},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]//FullSimplify

CrossedPrism

seq=Table[GraphData[{"CrossedPrism",2n},"UnitDistance"],{n,2,12}]

FindSequenceFunction[seq,n-1]//Factor

Crown

seq=Table[GraphData[{"Crown",n},"UnitDistance"],{n,20}]

CubeConnectedCycle

Entity["Graph",{"CubeConnectedCycle",n}]["UnitDistance"]

seq=Table[GraphData[{"CubeConnectedCycle",n},"UnitDistance"],{n,3,8}]

Cycle

Entity["Graph",{"Cycle",n}]["UnitDistance"]

seq=Table[GraphData[{"Cycle",n},"UnitDistance"],{n,3,30}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

CycleComplement

seq=Table[GraphData[{"CycleComplement",n},"UnitDistance"],{n,3,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

DiagonalIntersection

seq=Table[GraphData[{"DiagonalIntersection",n},"UnitDistance"],{n,3,14}]

Dipyramid

seq=Table[GraphData[{"Dipyramid",n},"UnitDistance"],{n,3,20}]

DorogovtsevGoltsevMendes

seq=Table[GraphData[{"DorogovtsevGoltsevMendes",n},"UnitDistance"],{n,0,7}]

DoubleCone

seq=Table[GraphData[{"DoubleCone",n},"UnitDistance"],{n,3,20}]

Empty

Entity["Graph",{"Empty",n}]["UnitDistance"]

seq=Table[GraphData[{"Empty",n},"UnitDistance"],{n,30}]

FibonacciCube

seq=Table[GraphData[{"FibonacciCube",n},"UnitDistance"],{n,15}]

FindSequenceFunction[seq,n]//Head//Timing

Fiveleaper n×n

seq=Table[GraphData[{"Fiveleaper",{n,n}},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]//Head//Timing

Flower

seq=Table[GraphData[{"Flower",n},"UnitDistance"],{n,5,20}]

FoldedCube

seq=Table[GraphData[{"FoldedCube",n},"UnitDistance"],{n,2,10}]

FindSequenceFunction[seq,n]

Gear

seq=Table[GraphData[{"Gear",n},"UnitDistance"],{n,3,20}]

FindSequenceFunction[seq,n]

Giraffe n×n

seq=Table[GraphData[{"Giraffe",{n,n}},"UnitDistance"],{n,20}]

Goldberg

seq=Table[GraphData[{"Goldberg",n},"UnitDistance"],{n,3,20}]

Grid m×n

Entity["Graph",{"Grid",{m,n}}]["UnitDistance"]

DeleteCases[Flatten[Table[{
{m,n},
GraphData[{"Grid",{m,n}},"UnitDistance"],
3Max[m,n]/2
},{n,10},{m,n}],1],{_,x_,x_}]

Grid n×n

Entity["Graph",{"Grid",{n,n}}]["UnitDistance"]

seq=Table[GraphData[{"Grid",{n,n}},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]

Grid k×m×n

Entity["Graph",{"Grid",{k,m,n}}]["UnitDistance"]

Sort@Flatten[Table[{
{k,m,n},
GraphData[{"Grid",{k,m,n}},"UnitDistance"],
XXX
},{n,5},{m,n},{k,m}],2]

Tally[GraphData[{"Grid",{2,3,4}},"DistanceMatrix"]//Normal//Flatten]

Grid n×n×n

Entity["Graph",{"Grid",{n,n,n}}]["UnitDistance"]

seq=Table[GraphData[{"Grid",{n,n,n}},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]//FullSimplify

HalvedCube

seq=Table[GraphData[{"HalvedCube",n},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]

gf=x FindGeneratingFunction[seq,x]

SeriesCoefficient[gf,{x,0,n}]

Hanoi

seq=Table[GraphData[{"Hanoi",n},"UnitDistance"],{n,5}]

FindSequenceFunction[seq,n]//Head//Timing

FindSequenceFunction[Rest@seq,n-1]//Head//Timing

Helm

seq=Table[GraphData[{"Helm",n},"UnitDistance"],{n,3,20}]

FindSequenceFunction[seq,n]

Hypercube

Entity["Graph",{"Hypercube",n}]["UnitDistance"]

seq=Table[GraphData[{"Hypercube",n},"UnitDistance"],{n,0,10}]

FindSequenceFunction[seq,n+1]

Keller

Entity["Graph",{"Keller",n}]["UnitDistance"]

seq=Table[GraphData[{"Keller",n},"UnitDistance"],{n,5}]

FindSequenceFunction[seq,n]

King n×n

seq=Table[GraphData[{"King",{n,n}},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]//Factor

Knight m×n

Entity["Graph",{"Knight",{m,n}}]["UnitDistance"]

Knight n×n

Entity["Graph",{"Knight",{n,n}}]["UnitDistance"]

seq=Table[GraphData[{"Knight",{n,n}},"UnitDistance"],{n,20}]

Ladder

Entity["Graph",{"Ladder",n}]["UnitDistance"]

seq=Table[GraphData[{"Ladder",n},"UnitDistance"],{n,20}]

FindSequenceFunction[seq,n]//Factor

LadderRung

seq=Table[GraphData[{"LadderRung",n},"UnitDistance"],{n,20}]

LucasCube

seq=Table[GraphData[{"LucasCube",n},"UnitDistance"],{n,15}]

FindSequenceFunction[seq,n]//Head//Timing

MengerSponge

seq=Table[GraphData[{"MengerSponge",n},"UnitDistance"],{n,3}]

MoebiusLadder

Entity["Graph",{"MoebiusLadder",n}]["UnitDistance"]

seq=Table[GraphData[{"MoebiusLadder",n},"UnitDistance"],{n,3,25}]

Mycielski

Entity["Graph",{"Mycielski",n}]["UnitDistance"]

seq=Table[GraphData[{"Mycielski",n},"UnitDistance"],{n,11}]

Odd

Entity["Graph",{"Odd",n}]["UnitDistance"]

seq=Table[GraphData[{"Odd",n},"UnitDistance"],{n,7}]

FindSequenceFunction[Rest@seq,n-1]//Head//Timing

FindGeneratingFunction[seq,x]//Head//Timing

Pan

seq=Table[GraphData[{"Pan",n},"UnitDistance"],{n,3,20}]

Path

Entity["Graph",{"Path",n}]["UnitDistance"]

seq=Table[GraphData[{"Path",n},"UnitDistance"],{n,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

PathComplement

seq=Table[GraphData[{"PathComplement",n},"UnitDistance"],{n,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

Pell

seq=Table[GraphData[{"Pell",n},"UnitDistance"],{n,9}]

FindSequenceFunction[seq,n]//Head//Timing

Prism

Entity["Graph",{"Prism",n}]["UnitDistance"]

seq=Table[GraphData[{"Prism",n},"UnitDistance"],{n,3,25}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

Queen n×n

seq=Table[GraphData[{"Queen",{n,n}},"UnitDistance"],{n,20}]

FullSimplify[FindSequenceFunction[seq,n],n∈Integers]//Factor

Rook n×n

seq=Table[GraphData[{"Rook",{n,n}},"UnitDistance"],{n,20}]

FullSimplify[FindSequenceFunction[seq,n],n∈Integers]//Factor

RookComplement n×n

seq=Table[GraphData[{"RookComplement",{n,n}},"UnitDistance"],{n,10}]

FindSequenceFunction[Drop[seq,2],n-2]//Factor

SierpinskiCarpet

seq=Table[GraphData[{"SierpinskiCarpet",n},"UnitDistance"],{n,4}]

FindSequenceFunction[seq,n]

SierpinskiGasket

seq=Table[GraphData[{"SierpinskiGasket",n},"UnitDistance"],{n,5}]

FindSequenceFunction[seq,n]

SierpinskiTetrahedron

seq=Table[GraphData[{"SierpinskiTetrahedron",n},"UnitDistance"],{n,6}]

FindSequenceFunction[seq,n]

Spoke n×n

seq=Table[GraphData[{"Spoke",{n,n}},"UnitDistance"],{n,5}]

FindSequenceFunction[seq,n]

StackedBook

seq=Table[GraphData[{"StackedBook",{n,n}},"UnitDistance"],{n,10}]

StackedPrism

seq=Table[GraphData[{"StackedPrism",{n,n}},"UnitDistance"],{n,3,5}]

Star

Entity["Graph",{"Star",n}]["UnitDistance"]

seq=Table[GraphData[{"Star",n},"UnitDistance"],{n,25}]

FindSequenceFunction[seq,n]//Factor

Sun

seq=Table[GraphData[{"Sun",n},"UnitDistance"],{n,3,20}]

FindSequenceFunction[seq,n-2]//Factor

Sunlet

seq=Table[GraphData[{"Sunlet",n},"UnitDistance"],{n,3,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

TorusGrid m×n

DeleteCases[{#,GraphData[#,"UnitDistance"]}&/@GraphData["TorusGrid"],{_,True}]

TorusGrid n×n

Inferred for n > 10:

seq=Table[GraphData[{"TorusGrid",{n,n}},"UnitDistance"],{n,3,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

Transposition

Entity["Graph",{"Transposition",n}]["UnitDistance"]

seq=Table[GraphData[{"Transposition",n},"UnitDistance"],{n,6}]

FindSequenceFunction[Rest@seq,n-1]//FullSimplify

Trapezohedron

Entity["Graph",{"Trapezohedron",n}]["UnitDistance"]

seq=Table[GraphData[{"Trapezohedron",n},"UnitDistance"],{n,3,20}]

FullSimplify[FindSequenceFunction[seq,n-2],n∈Integers]

Triangular

seq=Table[GraphData[{"Triangular",n},"UnitDistance"],{n,2,20}]

FindSequenceFunction[seq,n-1]

TriangularGrid

seq=Table[GraphData[{"TriangularGrid",n},"UnitDistance"],{n,0,10}]

FindSequenceFunction[seq,n+1]//FullSimplify

TriangularHoneycombAcuteKnight

seq=Table[GraphData[{"TriangularHoneycombAcuteKnight",n},"UnitDistance"],{n,20}]

TriangularHoneycombBishop

seq=Table[GraphData[{"TriangularHoneycombBishop",n},"UnitDistance"],{n,9}]

FindSequenceFunction[seq,n]//Factor

TriangularHoneycombObtuseKnight

seq=Table[GraphData[{"TriangularHoneycombObtuseKnight",n},"UnitDistance"],{n,20}]

TriangularHoneycombQueen

seq=Table[GraphData[{"TriangularHoneycombQueen",n},"UnitDistance"],{n,10}]

FindSequenceFunction[seq,n]

TriangularHoneycombRook

seq=Table[GraphData[{"TriangularHoneycombRook",n},"UnitDistance"],{n,20}]

TriangularSnake

seq=Table[GraphData[{"TriangularSnake",n},"UnitDistance"],{n,1,20,2}]

Web

seq=Table[GraphData[{"Web",n},"UnitDistance"],{n,3,20}]

Wheel

Entity["Graph",{"Wheel",n}]["UnitDistance"]

seq=Table[GraphData[{"Wheel",n},"UnitDistance"],{n,4,20}]

FindSequenceFunction[seq,n-3]//FullSimplify

WheelComplement

seq=Table[GraphData[{"WheelComplement",n},"UnitDistance"],{n,4,20}]

FindSequenceFunction[seq,n-3]//FullSimplify

WhiteBishop n×n

seq=Table[GraphData[{"WhiteBishop",{n,n}},"UnitDistance"],{n,2,20}]

FullSimplify[FindSequenceFunction[Rest@seq,n-2],n∈Integers]

Factor[%]

Zebra n×n

seq=Table[GraphData[{"Zebra",{n,n}},"UnitDistance"],{n,20}]

3D with small ChromaticNumber

TextGrid[Take[DeleteCases[ReverseSortBy[GraphData[#,{"ChromaticNumber","V","#"}]&/@Select[GraphData["Connected"],GraphData[#,"Dimension"]==3&],{#[[1]],-#[[2]]}&],{_Missing,__}],10],Dividers->All,Alignment->{{{Decimal},Left}}]

Two-point construction

UnitDistanceoints0[p_,q_]:=Module[{m=(p+q)/2,n,pq=Reverse[p-q]},
n={-1,1}(pq/(Sqrt[pq.pq])) Sqrt[1-(m-q).(m-q)];
{m+n,m-n}
]

(p+q)/2-q//Simplify

Sqrt[((1-(m-q).(m-q))/(pq.pq))]==Sqrt[((1-((p-q)/2).((p-q)/2))/(pq.pq))]==Sqrt[((1-(pq/2).(pq/2))/(pq.pq))]==Sqrt[(1/(pq.pq))-(1/4)]

UnitDistancePoints[p_,q_]:=Module[{m=(p+q)/2,n,pq=Reverse[p-q]},
n={-1,1}pq Sqrt[(1/(pq.pq))-(1/4)];
{m+n,m-n}
]

FullSimplify[UnitDistancePoints0[{a,b},{c,d}]-UnitDistanceoints[{a,b},{c,d}],(a|b|c|d)∈Reals]

UnitDistancePointsEd[{a_,b_},{c_,d_}]:=Module[{frac},frac=((Sqrt[(4-(((a-c))^2)-(((b-d))^2)) ((((a-c))^2)+(((b-d))^2)) ])/((((a-c))^2)+(((b-d))^2)));
{{(1/2) (a+c-(b-d)frac),(1/2) (b+d+(a-c)frac)},{(1/2) (a+c-(d-b)frac),(1/2) (b+d+(c-a)frac)}}];

UnitDistancePointsEd[{1,GoldenRatio},{2,Pi}]//FullSimplify

UnitDistancePoints[{1,GoldenRatio},{2,Pi}]

FullSimplify[UnitDistancePointsEd[{a,b},{c,d}]-UnitDistancePoints[{a,b},{c,d}],(a|b|c|d)∈Reals]

Cartesian product of two unit-distance graphs

Length[sub=Subsets[GraphData[{"Connected","UnitDistance"},2;;],{2}]]

ns=Union[GraphData[#,"V"]&/@GraphData[All]];

Beware of:

bug(425319): CanonicalGraph[10Q3, C5+2C3] hangs starting in V13

$Version

(new=Monitor[Select[
sub,
(
If[res=And[
MemberQ[ns,GraphData[g1=#[[1]],"V"]GraphData[g2=#[[2]],"V"]],(r=RecognizeGraph[GraphProduct[GraphData[g1],GraphData[g2],"Cartesian"],"Cache"->"InternalOnly"])=!={},FreeQ[GraphData[r,"EmbeddingClasses"],"UnitDistance"]
],
Print[{g1,g2}]];
res
)&],{g1,g2}])//Timing

DateString[]

Examples

$Version

GraphData["UnitDistance"]//Length

Nice

nice=SortBy[GraphData[#,"#"]&/@{"BiggsSmithGraph","ClawGraph","C6","CoxeterGraph","CubicalGraph","DesarguesGraph","DiamondGraph","DodecahedralGraph","DominoGraph","DoyleGraph","DyckGraph","Foster026A","Foster056C",{"Fusene",{2,1}},"GolombGraph",{"Grid",{3,4}},{"Hanoi",3},"HarborthGraph","HeawoodGraph" ,{"LadderRung",4},"LeviGraph","MoebiusKantorGraph","MoserSpindle","NauruGraph",{"Path",3},"PappusGraph","PetersenGraph",{"Polyiamond",{5,2}},{"Polyomino",{4,3}},{"Sierpinski",4},"C4","S6","TesseractGraph","ThetaZeroGraph","C3","W7","HirschhornDissectedOctadecagonGraph","ChilakamarriCoreGraph","ExooIsmailescuGraph17","HochbergODonnellFishGraph","HochbergODonnellStarGraph","DecagonMycielskianGraph"},GraphData[#,"V"]&];

Grid[GraphData[#,{"Name","V","E","ChromaticNumber"}]&/@SortBy[nice,GraphData[#,"V"]&],Dividers->All,Alignment->{{Left,Decimal,Decimal,Decimal},Automatic}]//TraditionalForm

Graphic

noembedding=Cases[nice,_?(GraphData[#,"Graph","UnitDistance"]==={}&)]

gs=Show[GraphData[#,"Graph","UnitDistance"][[1]]//StyleGraphs[#,VertexSize->{"Scaled",.05}]&,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->95,TextAlignment->Center],LabelStyle->{FontFamily->"Times",Italic}]&/@DeleteCases[nice,Alternatives@@noembedding];

GraphicsGrid[Partition[gs,UpTo[6]],ImageSize->600,Spacings->{Automatic,70},Alignment->Top]

Biconnected components algorithm

?MyFastSubgraph

https://en.wikipedia.org/wiki/Biconnected_component

A connected graph is unit-distance if and only if each of its biconnected components is unit-distance

BiconnectedComponents0[g_Graph]:=Select[Subgraphs[g],BiconnectedGraphQ[#]&]

GraphData["MothGraph","Graph","Labeled"]

BiconnectedComponents0[GraphData["MothGraph"]]

KVertexConnectedComponents[GraphData["HouseGraph"],2]

MyFastSubgraph[g_System`Graph,v_]:=System`Graph[v,UndirectedEdge@@@Intersection[List@@@EdgeList[g],Subsets[v,{2}]]]

BiconnectedComponents[g_Graph]:=KVertexConnectedComponents[g,2]

BiconnectedComponents[GraphData["MothGraph"]]

BiconnectedComponents[g_Graph]:=MyFastSubgraph[g,Sort[#]]&/@KVertexConnectedComponents[g,2]

BiconnectedComponents[GraphData["MothGraph"]]

BiconnectedComponentNames[g_Graph]:=Union[RecognizeGraph[#,"Cache"->"InternalOnly"]&/@BiconnectedComponents[g]]

BiconnectedComponentNames[GraphData["MothGraph"]]

DeleteCases[{#,GraphData[#,"UnitDistance"],And@@(GraphData[#,"UnitDistance"]&/@BiconnectedComponentNames[GraphData[#]])}&/@GraphData["Connected",;;11],{_,x_,x_}]//Timing

BiconnectedComponents[GraphData["KrackhardtKite"]]

BiconnectedComponentNames[GraphData["KrackhardtKite"]]

UnitDistanceByBiconnectedComponents[g_Graph]:=Module[{bcc=BiconnectedComponentNames[g]},
If[FreeQ[bcc,{}],And@@(GraphData[#,"UnitDistance"]&/@bcc),$Failed]
]

UnitDistanceByBiconnectedComponents[GraphData[{"StackedPrism",{3,3}}]]

Monitor[data={g=#,GraphData[#,"UnitDistance"],UnitDistanceByBiconnectedComponents[GraphData[#]]}&/@Take[GraphData["Connected",10],All],g]

DeleteCases[data,{_,x_,x_}|{_,_,$Failed}]

Monitor[data={g=#,GraphData[#,"UnitDistance"],UnitDistanceByBiconnectedComponents[GraphData[#]]}&/@Take[GraphData["Connected",;;15],All];,g]//Timing

DeleteCases[data,{_,x_,x_}|{_,_,$Failed}]

BiconnectedComponents[GraphData[{"Cubic",{14,21}}]]

RecognizeGraph/@%

GraphData[#,"Graph","UnitDistance"]&/@%

Checks

Listed as UnitDistance but contains a forbidden subgraph

Forbidden graphs are complete up to n==9

UD but no UD embedding given:

Select[GraphData[9],MissingQ[ud=GraphData[#,"UnitDistance"]]||(ud&&FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"])&]

DeleteCases[data7=Monitor[{g=#,GraphData[#,"UnitDistance"],EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]}&/@GraphData[;;7],g],{_,x_,x_}]//Timing

DeleteCases[data8=Monitor[{g=#,GraphData[#,"UnitDistance"],EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]}&/@Complement[GraphData[8],GraphData["Complete"]],g],{_,x_,x_}]//Timing

(data=DeleteCases[Monitor[{
g=#,
GraphData[#,"UnitDistance"],
EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]
}&/@Complement[GraphData["Connected",9],GraphData["Complete"]],g],
{_,x_,x_}])//Timing

UnitDistance disagrees with being forbidden graph-free:

l={#,{0,#3}}&@@@data

MissingFillin[l,"UnitDistance"]

RenameGraphFiles[]

10-node EdgeInducedSubgraphFreeQ based on forbidden subgraphs of size 1-9 (if *not* free, then not unit distance; but if free, don't know if it *is* unit distance)

UD is missing:

Select[GraphData[10],MissingQ[GraphData[#,"UnitDistance"]]&]

UD but no UD embedding given:

Select[GraphData[10],MissingQ[ud=GraphData[#,"UnitDistance"]]||(ud&&FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"])&]

No 10-node forbidden graph (list of such graphs currently unknown) and not listed as UnitDistance:

i=0;
gs=SortBy[Complement[GraphData["Connected",10],GraphData["Complete"]],GraphData[#,"M"]&];
len=Length[gs];
data=Monitor[{
i++;g=#,
GraphData[#,"UnitDistance"],
EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]
}&/@gs,Column[{ProgressIndicator[i,{1,len}],g}]];//Timing

Take[data,10]

Listed as not UD but does not contain forbidden graphs up to 9 nodes (so UD if it does not contain any 10-node forbidden graphs):

Cases[data,{g_,False,True}:>g]

No 10-node forbidden graph (list of such graphs currently unknown) and listed as UnitDistance):

Cases[data,{_,True,True}][[All,1]]

Unit-distance embedding not known for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

No 10-node forbidden graph (list of such graphs currently unknown) and not listed as UnitDistance:

Cases[data,{_,False,True}][[All,1]]

No unit-distance embedding given for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Listed as unit-distance but not free of forbidden subgraphs (so actually is not UD):

Cases[data,{_,True,False}][[All,1]]

11-node EdgeInducedSubgraphFreeQ based on forbidden subgraphs of size 1-9 (if *not* free, then not unit distance; but if free, don't know if it *is* unit distance)

i=0;
gs=SortBy[Complement[GraphData["Connected",11],GraphData["Complete"]],GraphData[#,"M"]&];
len=Length[gs];
data=Monitor[{
i++;g=#,
GraphData[#,"UnitDistance"],
EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]
}&/@gs,Column[{ProgressIndicator[i,{1,len}],g}]];//Timing

No 11-node forbidden graph (list of such graphs currently unknown) and listed as UnitDistance):

Cases[data,{_,True,True}][[All,1]]

Unit-distance embedding not known for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

No 11-node forbidden graph (list of such graphs currently unknown) and not listed as UnitDistance:

Cases[data,{_,False,True}][[All,1]]

No unit-distance embedding given for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Listed as unit-distance but not free of forbidden subgraphs (so actually is not UD):

Cases[data,{_,True,False}][[All,1]]

12-node EdgeInducedSubgraphFreeQ based on forbidden subgraphs of size 1-9 (if *not* free, then not unit distance; but if free, don't know if it *is* unit distance)

gs=SortBy[Complement[GraphData["Connected",12],GraphData["Complete"]],GraphData[#,"M"]&]

Length[gs]

len=Length[gs];
i=0;
data=(res={
#,
GraphData[#,"UnitDistance"],
EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]
}//Timing;
Print[Row[{++i,"/",Length[gs],": ",res}]];
res[[2]]
)&/@Take[gs,All];//Timing

MaxMemoryUsed[]/10.^9 GB

No 12-node forbidden graph (list of such graphs currently unknown) and listed as UnitDistance):

Cases[data,{_,True,True}][[All,1]]

Unit-distance embedding not known for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

No 12-node forbidden graph (list of such graphs currently unknown) and not listed as UnitDistance:

Cases[data,{_,False,True}][[All,1]]

No unit-distance embedding given for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Listed as unit-distance but not free of forbidden subgraphs (so actually is not UD):

Cases[data,{_,True,False}][[All,1]]

13-node EdgeInducedSubgraphFreeQ based on forbidden subgraphs of size 1-9 (if *not* free, then not unit distance; but if free, don't know if it *is* unit distance)

gs=SortBy[Complement[GraphData["Connected",13],GraphData["Complete"]],GraphData[#,"M"]&]

Length[gs]

len=Length[gs];
i=0;
data=(res={
#,
GraphData[#,"UnitDistance"],
EdgeInducedSubgraphFreeQ[GraphData[#],GraphData/@GraphData["UnitDistanceForbidden"]]
}//Timing;
Print[Row[{++i,"/",Length[gs],": ",res}]];
res[[2]]
)&/@Take[gs,All];//Timing

MaxMemoryUsed[]/10.^9 GB

No 13-node forbidden graph (list of such graphs currently unknown) and listed as UnitDistance):

Cases[data,{_,True,True}][[All,1]]

Unit-distance embedding not known for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

No 13-node forbidden graph (list of such graphs currently unknown) and not listed as UnitDistance:

Cases[data,{_,False,True}][[All,1]]

No unit-distance embedding given for above:

Select[%,FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Listed as unit-distance but not free of forbidden subgraphs (so actually is not UD):

Cases[data,{_,True,False}][[All,1]]

Check using UnitDistanceGraphQ

<<MathWorld`Graphs`

DeleteCases[
Monitor[{g=#,UnitDistanceGraphQ[GraphData[#]],GraphData[#,"UnitDistance"]}&/@GraphData[;;11],
g],
{_,x_,x_}]//Timing

DeleteCases[
Monitor[{g=#,UnitDistanceGraphQ[GraphData[#]],GraphData[#,"UnitDistance"]}&/@GraphData[12],
g],
{_,x_,x_}]//Timing

FindSubgraphUnitDistanceEmbedding

Length[GraphsWithUDEmbeddings=Select[GraphData["Connected"],!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]]

Technically only have to check graphs on n≥10 vertices since all forbidden minimal minors are known up to n==9

And probably also only need to check connected

Length[GraphsWithNoUDEmbeddings=SortBy[Select[GraphData[All],FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"V"]&]]

Length[UDGraphsWithNoUDEmbeddings=SortBy[Select[GraphData[{"Cyclic","UnitDistance"}],FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"V"]&]]

noncubic=DeleteCases[UDGraphsWithNoUDEmbeddings,{"Cubic",_}]

Print[{#,FindSubgraphUnitDistanceEmbedding[GraphData[#]]//Timing}]&/@DeleteCases[UDGraphsWithNoUDEmbeddings,{"Cubic",_}];

UD graphs from existing UD by deleting edges

Using combined graph {"UnitDistance", {27, 1}}

GraphData[{"UnitDistance",{27,1}}]

UnitDistanceByDeletingEdges[GraphData[{"UnitDistance",{27,1}}],Debug->2]//Timing

8 uses a lot of memory

Using combined graph {"UnitDistance", {118, 1}}

GraphData[{"UnitDistance",{118,1}}]

UnitDistanceByDeletingEdges[GraphData[{"UnitDistance",{118,1}}],Debug->2]//Timing

Exclude trivial classes or classes covered by others

exclude=Union@@(GraphData/@{"Caveman","Cycle","DutchWindmill","Fusene","Gear","Helm","KayakPaddle","Ladder","Pan","Polyomino","SierpinskiSieve","Sunlet","Tadpole","TriangularSnake"})

8

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},8],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[Monitor[{g=#,FindUnitDistanceEmbedding[#2]}&@@@emb,g],{_,{}}])//Timing

9

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},9],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[Monitor[{g=#,FindUnitDistanceEmbedding[#2]}&@@@emb,g],{_,{}}])//Timing

10

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},10],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[Monitor[{g=#,FindUnitDistanceEmbedding[#2]}&@@@emb,g],{_,{}}])//Timing

11

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},11],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[Monitor[{g=#,FindUnitDistanceEmbedding[#2]}&@@@emb,g],{_,{}}])//Timing

12

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},12],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

13

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},13],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[Monitor[{Print[#];g=#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,g],{_,{}}])//Timing

14

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},14],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

15

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},15],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

16

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},16],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

17

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},17],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

18

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},18],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

19

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},19],exclude],GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

ExooIsmailescuGraph19 uses 33 GB for 10-subsets

20

ud=SortBy[Select[
Complement[GraphData[{"Connected","Cyclic"},20],exclude],
GraphData[#,"UnitDistance"]===True&&!FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&],GraphData[#,"M"]&]

emb=Flatten[MapIndexed[{{#2[[1]],RecognizeGraph[#,"Cache"->"InternalOnly"]},#}&,GraphData[#,"Graph","UnitDistance"]]&/@ud,1]

(new=DeleteCases[{Print[#];#,FindUnitDistanceEmbedding[#2,Debug->2]}&@@@emb,{_,{}}])//Timing

Add to GraphData

todo=Flatten[new[[All,2]],1]

Flatten[new[[All,2]],1]

UnitDistanceGraphEmbeddingQ/@todo[[All,2]]

l={#1,{0,Append[GraphData[#1,"Embeddings"],ToCommonEdges[#2,GraphData[#]]]}}&@@@todo

PropertyReplace[l,"Embeddings","12.2"]

RenameGraphFiles[]

l2={#,{0,Append[GraphData[#,"EmbeddingClasses"],{
If[And@@(IntegerQ/@Flatten[GraphEmbedding[#2]]),"IntegerCoordinates",Sequence@@{}],
If[int=FullSimplify@RootReduce[IntegralEmbeddingQ[#2]],"Integral",Sequence@@{}],
If[(ud=FullSimplify@RootReduce@UnitDistanceGraphEmbeddingQ[#2])&&(pl=(RectilinearCrossingCount[#2]==0)),"Matchstick",Sequence@@{}],
If[pl,"MinimalCrossing",Sequence@@{}],
If[int&&ud,"MinimalIntegral",Sequence@@{}],
If[ud&&pl,"MinimalPlanarIntegral",Sequence@@{}],
If[pl,"MinimalRectilinearCrossing",Sequence@@{}],
If[pl,"Planar",Sequence@@{}],If[ud,"UnitDistance",Sequence@@{}]
}]}}&@@@todo

PropertyReplace[l2,"EmbeddingClasses","12.2"]

RenameGraphFiles[]

l3={#,{0,True}}&@@@todo

MissingFillin[l3,"UnitDistance"]

RenameGraphFiles[]

l4={#,{0,True}}&@@@Select[todo,(RectilinearCrossingCount[#[[2]]]==0)&]

MissingFillin[l4,"Matchstick"]

RenameGraphFiles[]

By girth

χ==4, girth==4

Grid[Sort[GraphData[#,{"V","#"}]&/@Select[GraphData[{"UnitDistance","TriangleFree"}],GraphData[#,"ChromaticNumber"]===4&&GraphData[#,"Girth"]==4&]],Dividers->All,Alignment->Left]

χ==4, girth==5

Grid[Sort[GraphData[#,{"V","#"}]&/@Select[GraphData[{"UnitDistance","TriangleFree"}],GraphData[#,"ChromaticNumber"]===4&&GraphData[#,"Girth"]==5&]],Dividers->All,Alignment->Left]

UD from edge-deletion of triangular grid

Subsets of 6×6×6 Triangular Grid

s=Sqrt[3]/2;
v={{-2,0},{-1,0},{0,0},{1,0},{2,0},{-3/2,s},{-1/2,s},{1/2,s},{3/2,s},{-1,2s},{0,2s},{1,2s},{-1/2,3s},{1/2,3s},{0,4s}};
g0=Graph[Range[Length[v]],UnitEdges[v],VertexCoordinates->v,VertexLabels->Automatic]

ee=EdgeList[g0];

3

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{3}],{{},_}]],First]

GraphData[{"SierpinskiSieve",3},"Graph","UnitDistance"]

4

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{4}],{{},_}]],First]//Timing

5

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{5}],{{},_}]],First]//Timing

6

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{6}],{{},_}]],First]//Timing

Subsets of Triangular Grid

s=Sqrt[3]/2;
v={{-1,0},{0,0},{1,0},{-3/2,s},{-1/2,s},{1/2,s},{3/2,s},{-1,2s},{0,2s},{1,2s},{-1/2,3s},{1/2,3s}};
g0=Graph[Range[Length[v]],UnitEdges[v],VertexCoordinates->v,VertexLabels->Automatic]

ee=EdgeList[g0];

3

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{3}],{{},_}]],First]

4

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{4}],{{},_}]],First]

5

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{5}],{{},_}]],First]

6

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{6}],{{},_}]],First]//Timing

7

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{7}],{{},_}]],First]//Timing

8

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{8}],{{},_}]],First]//Timing

9

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{9}],{{},_}]],First]//Timing

10

{#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[DeleteCases[{RecognizeGraph[g1=EdgeDelete[g0,#]],g1}&/@Subsets[ee,{10}],{{},_}]],First]//Timing

Most cubic graphs are UD

Exceptions: graphs containing (Subscript[K, 4]), (Subscript[K, 3,3]), and (I think) Möbius ladders or crossed prism

GraphData["K4","UD"]

GraphData["K3,3","UD"]

ContainsForbiddenSubgraph={"CrossingNumberGraph2B","CrossingNumberGraph3A","CrossingNumberGraph3B","CrossingNumberGraph3E"};

DeleteCases[
{#,GraphData[#,"UnitDistance"]}&/@Complement[Select[GraphData["Cubic"],FreeQ[GraphData[#,"ConnectedComponents","Name"],"UtilityGraph"]&&(MissingQ[w=GraphData[#,"CliqueNumber"]]||w<4)&],ContainsForbiddenSubgraph],
{_,True}]

Cases[%,{gn_,_Missing}:>gn]

Tan's conjecture

Jeremy Tan, Oct 20, 2021

"Based on this, I conjecture that every cubic graph with girth at least 5 is unit-distance in the plane"

Max[GraphData[#,"Girth"]&/@GraphData["UnitDistanceForbidden"]]

Connected cubic graphs with unknown UD status:

Select[GraphData[{"Connected","Cubic"}],Missing@GraphData[#,"UnitDistance"]&]

data=GraphData[#,{"#","Girth","UnitDistance"}]&/@GraphData[{"Connected","Cubic"}];

There are many connected cubic graphs of girth <5 that are UD:

Cases[data,{_,_?(LessThan[5]),True}][[All,1]]

However, indeed all connected cubic graphs of girth >=5 seem to be UD:

Cases[data,{_,_?(GreaterThan[4]),False|_Missing}]

Non-UD connected cubic graphs:

Select[GraphData[{"Connected","Cubic"}],GraphData[#,"UnitDistance"]===False&]

Sort[GraphData[#,"Girth"]&/@%]//Tally

Embeddings

<<MathWorld`Graphs`

orange means the graph is not UD
pink means a UD embedding is present but it is either not exact or else is not expressed as algebraic root objects
red means the graph is forbidden graph free for graphs on <= 9 nodes and so might be UD
green means a graph is UD but there is currently no nice embedding for it
blue means the graph has not yet been added

e[l__Integer]:=Sequence@@Partition[{l},2,1]

RightAngleEquation[v_,l_]:=Dot@@(Subtract@@@(v[[#]]&/@Partition[Take[l,3],2,1]))==0

RotateTranslate[g_Graph]:=g
RotateTranslate[g_Graph,{i_,j_}]:=TranslateGraph[RotateGraph[g,{i,j}],i]

{"UnitDistance", {9, 1}} == "UnitDistanceGraphT"

GraphData["UnitDistanceGraphT","#"]

https://arxiv.org/pdf/1804.02385.pdf

GraphData["MoserSpindle","Graph","Labeled"]

v=GraphData["MoserSpindle","VertexCoordinates"];

{x,y}/.Solve[SquaredEuclideanDistance[v[[5]],{x,y}]==1&&SquaredEuclideanDistance[v[[6]],{x,y}]==1,{x,y},Reals]//FullSimplify

T=System`Graph[Range[9],Union[GraphData["MoserSpindle","Edges"],{6\[UndirectedEdge]8,5\[UndirectedEdge]8,3\[UndirectedEdge]9,7\[UndirectedEdge]9}],VertexCoordinates->Join[GraphData["MoserSpindle","VertexCoordinates"],{{((Sqrt[(11/3)])/2),0},{((-(Sqrt[(11/3)]))/2),0}}],VertexLabels->"Name"]

RecognizeGraph[T]

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

FindUnitDistanceEmbedding[T]

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

WriteString[file,GraphDataString[T,
"StandardName"->{"UnitDistance",{9,1}},
"Name"->"9\[Hyphen]unit distance graph 1",
"AlternateStandardNames"->{"UnitDistanceGraphT"},
"AlternateNames"->{"unit\[Hyphen]distance graph T"},
Debug->True,
TimeConstraint->60]]

{"UnitDistance", {9, 2}}

GraphData[{"UnitDistance",{9,2}},"StandardName"]

Primary

GraphData[{"UnitDistance",{9,2}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"UnitDistance",{9,2}},"Graph","All"]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{9,2}},"EdgeList"]]

Default embedding

GraphPlot[GraphData[{"UnitDistance",{9,2}},"Edges"],GraphLayout->"LayeredEmbedding"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{9,2}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{9,2}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{9,2}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{9,2}},"Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{9,2}}],All][[All,All,1]]]

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

g=Graph[Range[9],GraphData["H1","Edges"],VertexCoordinates->CirclePoints[9][[Ordering@GraphData["H1","HamiltonianCycles"][[1]]]]]

r=RecognizeGraph[g]

rcn=RectilinearCrossingCount[g]

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

Planar

GraphData[{"UnitDistance",{9,2}},"Planar"]

GraphData[{"UnitDistance",{9,2}},"Graph","Planar"]//StyleGraphs

Tutte embeddings

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData[{"UnitDistance",{9,2}}]]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[GraphData[{"UnitDistance",{9,2}}],"OuterFace"->#]&/@faces

gs=Annotate[#,{VertexLabels->None,ImageSize->Tiny}]&/@{}

RecognizeGraph/@gs

Tutte embedding construction

GraphPlot[RotateGraph[]]

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

RecognizeGraph[g]

MinimalCrossing

GraphData[{"UnitDistance",{9,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{9,2}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

MinimalCrossingGraph[GraphData[{"UnitDistance",{9,2}}]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{9,2}},"Circulant"]

GraphData[{"UnitDistance",{9,2}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{9,2}},"Halin"]

GraphData[{"UnitDistance",{9,2}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{9,2}},"Rigid"]

GraphData[{"UnitDistance",{9,2}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{9,2}},"Flexible"]

GraphData[{"UnitDistance",{9,2}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{9,2}},"LCF"]

GraphData[{"UnitDistance",{9,2}},"HamiltonianCycleCount"]

GraphData[{"UnitDistance",{9,2}},"LCFSignature"]

GraphData[{"UnitDistance",{9,2}},"LCFNotations"]

GraphData[{"UnitDistance",{9,2}},"Graph","LCF"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{9,2}},"Graph","Halin"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{9,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{9,2}}],Debug->True]//Timing

GraphData[{"UnitDistance",{9,2}},"Graph","UnitDistance"]//StyleGraphs

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

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"UnitDistance",{9,2}},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{9,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{9,2}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{9,2}}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

UnitDistance construction

https://tinyurl.com/smallUDcode

soln=;

v={{0,0},{1,0},{2,0},{1/2,Sqrt[3]/2},{3/2,Sqrt[3]/2},{x1,x2},{y1,y2},{z1,z2},{w1,w2}}/.ToRules[(x1==Root[-2+21 #1-192 ((#1)^2)+389 ((#1)^3)-231 ((#1)^4)+42 ((#1)^5)&,1]&&x2==Root[-27+531 ((#1)^2)-3513 ((#1)^4)+7870 ((#1)^6)-483 ((#1)^8)+1764 ((#1)^10)&,2]&&y1==Root[-981+2859 #1-3688 ((#1)^2)+2484 ((#1)^3)-840 ((#1)^4)+112 ((#1)^5)&,1]&&y2==Root[-34992+109593 ((#1)^2)-128088 ((#1)^4)+79920 ((#1)^6)-38976 ((#1)^8)+12544 ((#1)^10)&,1]&&z1==Root[-2749+12978 #1-24420 ((#1)^2)+22928 ((#1)^3)-10752 ((#1)^4)+2016 ((#1)^5)&,1]&&z2==Root[-75843-135684 ((#1)^2)-30384 ((#1)^4)+896128 ((#1)^6)+2838528 ((#1)^8)+4064256 ((#1)^10)&,1]&&w1==Root[-4428+14157 #1-18339 ((#1)^2)+11906 ((#1)^3)-3864 ((#1)^4)+504 ((#1)^5)&,1]&&w2==Root[-432+737001 ((#1)^2)-2318127 ((#1)^4)+3175012 ((#1)^6)-1389024 ((#1)^8)+254016 ((#1)^10)&,2])]

FullSimplify[v]

Length[v]

h1=Graph[Range[9],UndirectedEdge@@@Select[Subsets[Range[9],{2}],N[EuclideanDistance@@v[[#]],20]==1.&],VertexCoordinates->v]

RecognizeGraph[h1]

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

Matchstick

GraphData[{"UnitDistance",{9,2}},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{9,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{9,2}},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

g=Graph@GraphData[{"UnitDistance",{9,2}},"Edges"]

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

RecognizeGraph[g]

MinimalCrossing Construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"UnitDistance",{9,2}}],"CrossingNumber"->-1]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"UnitDistance",{9,2}},"Edges"]]

3D All

GraphData[{"UnitDistance",{9,2}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{9,2}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{9,2}},"Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData[{"UnitDistance",{9,2}},"Polyhedron"]}]

3D Canonical

GraphData[{"UnitDistance",{9,2}},"Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData[{"UnitDistance",{9,2}},"Polyhedron"],Yellow,Sphere[]}]

3D Polyhedron construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData[{"UnitDistance",{9,2}}],1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->20])//Timing

SimplePolyhedronQ[can]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

{"UnitDistance", {9, 3}} (H2)

GraphData[{"UnitDistance",{9,3}},"Graph","All"]

GraphData[{"UnitDistance",{9,3}},"EmbeddingClasses"]

UD

https://arxiv.org/pdf/1905.07829.pdf

https://tinyurl.com/smallUDcode

soln=;

gs=With[{v={{0,0},{Sqrt[3]/2,1/2},{Sqrt[3]/2,-1/2},{Sqrt[3],0},{x1,x2},{y1,y2},{z1+Sqrt[3],z2},{w1+Sqrt[3],w2},{u1,u2}}/.ToRules[#]},Graph[Range[9],UndirectedEdge@@@Select[Subsets[Range[9],{2}],N[EuclideanDistance@@v[[#]],20]==1.&],VertexCoordinates->v]]&/@(List@@soln)

IsomorphicGraphQ@@gs

RecognizeGraph[h2=gs[[1]]]

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

Circular

g=Graph[Range[9],GraphData["H2","Edges"],VertexCoordinates->CirclePoints[9][[Ordering@GraphData["H2","HamiltonianCycles"][[1]]]]]

r=RecognizeGraph[g]

rcn=RectilinearCrossingCount[g]

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

{"UnitDistance", {10, 1}}

Discovered by Eric Weisstein based on UD refinement of {"NoncayleyTransitive", {20, 4}} on Jan 27, 2023

GraphData[{"UnitDistance",{10,1}},"StandardName"]

Primary

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

All

GraphData[{"UnitDistance",{10,1}},"Graph","All"]//StyleGraphs

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{10,1}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{10,1}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{10,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{10,1}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{10,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{10,1}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"UnitDistance",{10,1}},"Planar"]

GraphData[{"UnitDistance",{10,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{10,1}},{"RCN","CN"}]

GraphData[{"UnitDistance",{10,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

GraphPlot@MinimalCrossingGraph[GraphData[{"UnitDistance",{10,1}}],"CrossingNumber"->0]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{10,1}},"Circulant"]

GraphData[{"UnitDistance",{10,1}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{10,1}},"Halin"]

GraphData[{"UnitDistance",{10,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{10,1}},"Rigid"]

GraphData[{"UnitDistance",{10,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{10,1}},"Flexible"]

GraphData[{"UnitDistance",{10,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{10,1}},"LCF"]

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

UnitDistance

GraphData[{"UnitDistance",{10,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{10,1}}],Debug->True]//Timing

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

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

UnitDistance construction

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

g=LabelGraph@IndexGraph@ContractCoincidentVertices@

v=GraphEmbedding[g];

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

g=LabelGraph@Graph[Range[10],UnitEdges[v],VertexCoordinates->v]

RigidGraphEmbeddingQ@g

VertexCount[g]

ee=.

v={{ee,f},{0,0},{-a,b},{gg,h},{c,d},{-ee,f},{-gg,h},{a,b},{-c,d},{0,y}};

eqn=UnitEdgeEquations[v,EdgeList[g]]//FullSimplify//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

(soln=Solve[eqn,var,Reals])//Timing

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/16}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/8}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/4}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/3}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/2-1/16}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs=Select[Graph[Range[10],EdgeList[g],VertexLabels->Automatic,VertexCoordinates->(v/.#)]&/@FullSimplify[Solve[Join[eqn,{c==1/2}],var,Reals]],UnitDistanceGraphEmbeddingQ]

gs={,}

file=OpenAppend["~/ud.m"]

WriteString[file,GraphDataString[,
"StandardName"->{"UnitDistance",{10,1}},
"Name"->"10\[Hyphen]unit distance graph 1",
TimeConstraint->10]]

Close[file]

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{10,1}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{10,1}}];,TimeConstraint->300,"Results"->All]//Timing}

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

gs=RotateGraph@@@Transpose[{{,},{{24,14},{287,13}}}]

Matchstick

GraphData[{"UnitDistance",{10,1}},"Matchstick"]

GraphData[{"UnitDistance",{10,1}},"M"]

GraphData[{"UnitDistance",{10,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{10,1}},"Edges"]]

3D All

GraphData[{"UnitDistance",{10,1}},"Graph",{"3D","All"}]

3D UnitDistance

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

3D Polyhedron

GraphData[{"UnitDistance",{10,1}},"Polyhedral"]

GraphData[{"UnitDistance",{10,1}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {11, 1}}

GraphData[{"UnitDistance",{11,1}},"Graph","MinimalCrossing"]

GraphData[{"UnitDistance",{11,1}},"LCF"]

GraphData[{"UnitDistance",{11,1}},"Graph","Matchstick"]

GraphData[{"UnitDistance",{11,1}},"Graph","UnitDistance"]

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

GraphData[{"UnitDistance",{11,1}},"Graph","All"]

GraphPlot[GraphData[{"UnitDistance",{11,1}},"EdgeList"]]

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

Graph[GraphData[{"UnitDistance",{11,1}},"Edges"]]

gs=Select[{UnitDistanceEmbeddingRefine@%},UnitDistanceGraphEmbeddingQ]

Select[FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{11,1}}],20],UnitDistanceGraphEmbeddingQ]

Cases[GraphData[All],{"UnitDistance",{11,_}}]

Found trying to find UD embedding for {"Johnson", 5}

g0=GraphData[{"JohnsonSkeleton",5},"Graph",{"All","Labeled"}][[2]]

g1=RotateGraph[UnitDistanceEmbeddingRefine[g0,WorkingPrecision->200],-2.45]

g=IndexGraph@VertexDelete[IndexGraph@VertexContract[g1,DeleteCases[GatherBy[MapIndexed[{#2[[1]],#}&,GraphEmbedding[g1]],Last][[All,All,1]],{_Integer}]],{3,11}]

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

eqn={x^2+y^2==2^2,(x-2)^2+y^2==1};
soln=Solve[eqn,{x,y},PositiveReals]

v={{0,0},{1,0},{2,0},{1/2,-s},{3/2,-s},{5/2,-s},{7/4,((Sqrt[15])/4)},(1/2){7/4,((Sqrt[15])/4)}};
v=Join[v,{UnitDistancePoint[Sequence@@v[[{6,7}]],1],UnitDistancePoint[Sequence@@v[[{7,8}]],1]}];
v=Join[v,{v[[1]]+v[[10]]-v[[8]]}];
g=Graph[Range[Length[v]],Complement[UnitEdges[v],UndirectedEdge@@@{{8,11},{2,5}}],VertexCoordinates->v, VertexLabels->Automatic]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

VertexCount[g]

RecognizeGraph[g]

RigidGraphQ[]

RecognizeGraph[g1=]

g=Graph[Range[11],Sort[Sort/@EdgeList[g1]],VertexCoordinates->GraphEmbedding[g1]]

Cases[GraphData[All],{"UnitDistance",{11,_}}]

file=OpenAppend["~/ud.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{11,1}},
"Name"->"11\[Hyphen]unit distance graph 1",
"Information"->"Unit-DistanceGraph",
TimeConstraint->60,
Debug->True]]

Close[file]

{"UnitDistance", {11, 2}}

GraphData[{"UnitDistance",{11,2}},"Graph","MinimalCrossing"]

GraphData[{"UnitDistance",{11,2}},"LCF"]

GraphData[{"UnitDistance",{11,2}},"Graph","Matchstick"]

GraphData[{"UnitDistance",{11,2}},"Graph","UnitDistance"]

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

GraphData[{"UnitDistance",{11,2}},"Graph","All"]

GraphPlot[GraphData[{"UnitDistance",{11,2}},"EdgeList"]]

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

Graph[GraphData[{"UnitDistance",{11,2}},"Edges"]]

gs=Select[{UnitDistanceEmbeddingRefine@%},UnitDistanceGraphEmbeddingQ]

Select[FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{11,2}}],20],UnitDistanceGraphEmbeddingQ]

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

eqn={x^2+y^2==2^2,(x-2)^2+y^2==1};
soln=Solve[eqn,{x,y},PositiveReals]

v={{0,0},{1,0},{2,0},{1/2,-s},{3/2,-s},{5/2,-s},{7/4,((Sqrt[15])/4)},(1/2){7/4,((Sqrt[15])/4)}};
v=Join[v,{UnitDistancePoint[Sequence@@v[[{6,7}]],1],UnitDistancePoint[Sequence@@v[[{7,8}]],1]}];
v=Join[v,{v[[1]]+v[[10]]-v[[8]]}];
g=Graph[Range[Length[v]],UnitEdges[v],VertexCoordinates->v, VertexLabels->Automatic]

file=OpenAppend["~/ud.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{11,2}},
"Name"->"11\[Hyphen]unit distance graph 2",
"Information"->"Unit-DistanceGraph",
TimeConstraint->60,
Debug->True]]

Close[file]

{"UnitDistance", {12, 1}} (contains square; flexible)

Graph

GraphData[{"UnitDistance",{12,1}},"Graph","All"]//StyleGraphs

GraphData[{"UnitDistance",{12,1}},"#"]

LamanGraphQ[GraphData[{"UnitDistance",{12,1}}]]

g=GraphData[{"UnitDistance",{12,1}}]

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

not Laman

LamanGraphQ[GraphData[{"UnitDistance",{12,1}}]]

Flexible

RigidGraphQ[GraphData[{"UnitDistance",{12,1}}]]

Construction

vals={{{-12,-6},{-4,-2}},{{-12,6},{-4,-2}},{{-9,0},{7,-4}},{{-3,0},{-13,-4}},{{-3,0},{-1,0}},{{0,0},{-16,8}},{{0,0},{4,0}},{{3,0},{-13,-4}},{{3,0},{-1,0}},{{9,0},{7,-4}},{{12,-6},{-4,-2}},{{12,6},{-4,-2}},{{-12,-6},{4,-2}},{{-12,6},{4,-2}},{{-9,0},{7,4}},{{-3,0},{13,-4}},{{0,0},{16,8}},{{3,0},{13,-4}},{{9,0},{7,4}},{{12,-6},{4,-2}},{{12,6},{4,-2}}}/12;
points=Map[Function[x,RootReduce[Sign[x.{1,(Sqrt[3])}](Sqrt[Abs[(x).{1,(Sqrt[3])}]])]],vals,{2}];
unitlines=Select[Subsets[points,{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,N[x]]]]==0]];
Graphics[{EdgeForm[{Black}],Line[unitlines],Table[{If[n>12,White,Blue],Tooltip[Disk[points[[n]],.06],vals[[n]]]},{n,1,Length[points]}]},ImageSize->Medium]

UnitDistanceGraphQ[g]

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

smalle=Select[unitlines/.Thread[points->Range[Length[points]]],Max[#]<13&]

pegg12=System`Graph[Range[12],UndirectedEdge@@@smalle,VertexCoordinates->Take[points,12]]

RecognizeGraph[pegg12]

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

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

WriteString[file,GraphDataString[pegg12,
"StandardName"->{"UnitDistance",{12,1}},
"Name"->"12\[Hyphen]unit distance graph 1"
]]

Close[file]

Primary

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

All

GraphData[{"UnitDistance",{12,1}},"Graph","All"]//StyleGraphs

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{12,1}},"EdgeList"]]

Default embedding

GraphPlot[GraphData[{"UnitDistance",{12,1}},"Edges"],GraphLayout->"SpringEmbedding"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{12,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{12,1}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{12,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{12,1}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"UnitDistance",{12,1}},"Planar"]

GraphData[{"UnitDistance",{12,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{12,1}},{"RCN","CN"}]

GraphData[{"UnitDistance",{12,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

Table[MinimalCrossingGraph[GraphData[{"UnitDistance",{12,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

GraphPlot@RotateGraph[,Pi/4]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{12,1}},"Circulant"]

GraphData[{"UnitDistance",{12,1}},"Graph","Circulant"]//StyleGraphs

Circulant construction

CirculantGraph1@@@CirculantIndices[GraphData[{"UnitDistance",{12,1}}]]

gs=CirculantGraph1@@@Cases[GraphData[{"UnitDistance",{12,1}},"StandardNames"],{"Circulant",i_}:>i]

Halin

GraphData[{"UnitDistance",{12,1}},"Halin"]

GraphData[{"UnitDistance",{12,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{12,1}},"Rigid"]

GraphData[{"UnitDistance",{12,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{12,1}},"Flexible"]

GraphData[{"UnitDistance",{12,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{12,1}},"LCF"]

GraphData[{"UnitDistance",{12,1}},"HamiltonianCycleCount"]

GraphData[{"UnitDistance",{12,1}},"LCFSignature"]

GraphData[{"UnitDistance",{12,1}},"LCFNotations"]

GraphData[{"UnitDistance",{12,1}},"Graph","LCF"]//StyleGraphs

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

LCF compute random

ComputeRandomLCFNotation[{"UnitDistance",{12,1}},2,TimeConstraint->120]

LCF compute 10^5

Tally[(lcf=LCF[GraphData[{"UnitDistance",{12,1}}],10^5])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

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

(gs=Flatten[{
(* all LCF's with order >1, sorted by order and with bilateral graphs first *)
Join[DeleteCases[#,{_Missing,_}][[All,1]],Cases[#,{_Missing,_}][[All,2]]]&/@Map[{BilateralLCFEmbedding[#],#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,1}]]}])//Timing

Length[gs]

LCF compute all

Length[FindHamiltonianCycle[GraphData[{"UnitDistance",{12,1}}],All][[All,All,1]]]//Timing

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

Tally[(lcf=ReadProperty["LCFNotations",GraphNameToFileName[{"UnitDistance",{12,1}},".m.gz"]])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

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

(gs=Flatten[{
(* all LCF's with order >1, sorted by order and with bilateral graphs first *)
Join[DeleteCases[#,{_Missing,_}][[All,1]],Cases[#,{_Missing,_}][[All,2]]]&/@Map[{BilateralLCFEmbedding[#],#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,1}]]}])//Timing

Length[gs]

i=0;
gs={};
t0=AbsoluteTime[];
count=Length[order2];
Monitor[
Do[
If[!MissingQ[g=BilateralLCFEmbedding[LCFGraph@@order2[[i]]]],AppendTo[gs,g]],
{i,count}
],
Column[{
ProgressIndicator[i,{1,count}],
Row[{i,"/",count}],
Row[{"estimated time remaining: ",Round[(AbsoluteTime[]-t0) (count/i-1)]," s"}],
Row[{Length[gs]," bilateral graphs"}]
}]
];//Timing

UnitDistance

GraphData[{"UnitDistance",{12,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{12,1}}],Debug->True]//Timing

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

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"UnitDistance",{12,1}},"VertexList"],GraphData[{"UnitDistance",{12,1}},"EdgeList"]]]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData[{"UnitDistance",{12,1}},"Matchstick"]

GraphData[{"UnitDistance",{12,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{12,1}},"Edges"]]

3D All

GraphData[{"UnitDistance",{12,1}},"Graph",{"3D","All"}]

3D UnitDistance

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

3D Polyhedron

GraphData[{"UnitDistance",{12,1}},"Polyhedral"]

GraphData[{"UnitDistance",{12,1}},"Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData[{"UnitDistance",{12,1}},"Polyhedron"]}]

3D Canonical

GraphData[{"UnitDistance",{12,1}},"Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData[{"UnitDistance",{12,1}},"Polyhedron","Canonical"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData[{"UnitDistance",{12,1}}],1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->50000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/10,"PlanarFactor"->1/10,Debug->True])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

g=GraphData[{"UnitDistance",{12,1}},"Graph","Planar"][[1]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->3],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.2v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->20000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/5,"PlanarFactor"->1/5,Debug->True])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

{"UnitDistance", {12, 2}} (rigid)

GraphData[{"UnitDistance",{12,2}},"Graph","All"]

RigidGraphQ/@%

Rigid

RigidGraphQ[GraphData[{"UnitDistance",{12,2}}]]

LamanGraphQ[GraphData[{"UnitDistance",{12,2}}]]

Construction

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

Found by Geoffrey Exoo
Communicated by Ed Pegg, Jr. on July 31, 2019

Smallest UD 4-chromatic graph with no 4-cycles.

ud4=Select[GraphData["UnitDistance",12],GraphData[#,"ChromaticNumber"]==4&]

GraphData[#,"StandardNames"]&/@ud4

GraphData[#,"CycleCount"]&/@ud4

base={{0,-(1/3) (Sqrt[(1/2) (7-(Sqrt[33]))])},{0,-(1/3) (Sqrt[(1/2) (7+(Sqrt[33]))])},{(1/2),-((Sqrt[11])/6)},{-(1/2),-((Sqrt[11])/6)}};
vert=Flatten[Table[RotationMatrix[2 n Pi/3].#&/@base,{n,0,2}],1];
edge=Select[Subsets[Range[12],{2}],EuclideanDistance@@vert[[#]]==1.&]

g=Graph[Range[Length[vert]],UndirectedEdge@@@edge,VertexCoordinates->vert]

UnitDistanceGraphEmbeddingQ[g]

ChromaticNumber[g]

RecognizeGraph@g

RecognizeGraph@GraphComplement@g

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

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

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{12,2}},
"Name"->"12\[Hyphen]unit distance graph 2"
]]

Close[file]

{"UnitDistance", {12, 3}}

Names

GraphData[{"UnitDistance",{12,3}},"StandardName"]

GraphData[{"UnitDistance",{12,3}},"StandardNames"]

Primary

GraphData[{"UnitDistance",{12,3}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"UnitDistance",{12,3}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"UnitDistance",{12,3}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{12,3}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{12,3}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{12,3}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{12,3}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{12,3}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{12,3}},"Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{12,3}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"UnitDistance",{12,3}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

bilat

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

Planar

GraphData[{"UnitDistance",{12,3}},"Planar"]

GraphData[{"UnitDistance",{12,3}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{12,3}},{"RCN","CN"}]

GraphData[{"UnitDistance",{12,3}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"UnitDistance",{12,3}}],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"UnitDistance",{12,3}}],TimeConstraint->10])//AbsoluteTiming

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

Table[MinimalCrossingGraph[GraphData[{"UnitDistance",{12,3}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"UnitDistance",{12,3}}],"CrossingNumber"->5],-.6]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

MinimalLocalCrossing

GraphData[{"UnitDistance",{12,3}},"LocalCrossingNumber"]

GraphData[{"UnitDistance",{12,3}},"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[{"UnitDistance",{12,3}}],TimeConstraint->1])//AbsoluteTiming

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

GraphPlot@RotateGraph[,4Pi/5]

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

RecognizeGraph@g

RectilinearCrossingCount@g

LocalCrossingCount@g

Circulant

GraphData[{"UnitDistance",{12,3}},"Circulant"]

GraphData[{"UnitDistance",{12,3}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{12,3}},"Halin"]

GraphData[{"UnitDistance",{12,3}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{12,3}},"Rigid"]

GraphData[{"UnitDistance",{12,3}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{12,3}},"Flexible"]

GraphData[{"UnitDistance",{12,3}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{12,3}},"LCFSignature"]

GraphData[{"UnitDistance",{12,3}},"Graph","LCF"]//StyleGraphs

UnitDistance

UnitDistanceGraphQ[GraphData[{"UnitDistance",{12,3}}],Debug->True]

GraphData[{"UnitDistance",{12,3}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"UnitDistance",{12,3}},"VertexList"],GraphData[{"UnitDistance",{12,3}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,3}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,3}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

g=RotateGraph[,{9,1}]

UnitDistanceGraphEmbeddingQ@g

RecognizeGraph@g

v={{1/2,0},{c,d},{-a,b},{-ee,f},{0,Sqrt[3]/2},{0,gg},{a,b},{0,z},{-1/2,0},{-c,d},{0,h},{ee,f}};

eqn=UnitEdgeEquations[v,EdgeList[g]]//FullSimplify//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

(soln=Solve[eqn,var,Reals]//FullSimplify)//Timing

Select[Graph[Range[12],EdgeList[g],VertexCoordinates->(v/.#)]&/@soln,UnitDistanceGraphEmbeddingQ]//Union

gs={,,};

RecognizeGraph/@gs

UnitDistance construction

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{12,3}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,3}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"UnitDistance",{12,3}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{12,3}},"Edges"]]

3D All

GraphData[{"UnitDistance",{12,3}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{12,3}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{12,3}},"Polyhedral"]

GraphData[{"UnitDistance",{12,3}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {12, 4}}

Discovered by Eric Weisstein based on UD refinement of {"NoncayleyTransitive", {20, 4}} on Jan 27, 2023

GraphData[{"UnitDistance",{12,4}},"StandardName"]

Primary

GraphData[{"UnitDistance",{12,4}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"UnitDistance",{12,4}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"UnitDistance",{12,4}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{12,4}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{12,4}},"Edges"]

GraphPlot@RotateGraph[GraphicsToGraph@,.5]

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

RecognizeGraph@g

v=CirclePoints[{1,Pi/2},12];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[{1,12},1,4,12],e[5,1,9],e[1,10,2],e[3,7,11],e[7,4,8],e[6,10,7]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{12,4}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{12,4}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{12,4}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{12,4}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"UnitDistance",{12,4}},"Planar"]

GraphData[{"UnitDistance",{12,4}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{12,4}},{"RCN","CN"}]

GraphData[{"UnitDistance",{12,4}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"UnitDistance",{12,4}}],TimeConstraint->1])//AbsoluteTiming

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

Table[MinimalCrossingGraph[GraphData[{"UnitDistance",{12,4}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

GraphPlot@

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{12,4}},"Circulant"]

GraphData[{"UnitDistance",{12,4}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{12,4}},"Halin"]

GraphData[{"UnitDistance",{12,4}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{12,4}},"Rigid"]

GraphData[{"UnitDistance",{12,4}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{12,4}},"Flexible"]

GraphData[{"UnitDistance",{12,4}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{12,4}},"LCF"]

GraphData[{"UnitDistance",{12,4}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{12,4}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{12,4}}],Debug->True]//Timing

GraphData[{"UnitDistance",{12,4}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance Construction

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

g5=LabelGraph@IndexGraph@ContractCoincidentVertices@RotateGraph[,{20,2}]

EdgeAdd[g5,UndirectedEdge[2,11]]

RecognizeGraph@%

Graph[Range[11],UnitEdges[GraphEmbedding[g5]],VertexCoordinates->GraphEmbedding[g5]]

VertexCount[g5]

s=Sqrt[3]/2;
v=Join[Tuples[{-1,1}/2,2],{{1/2+s,0},{-1/2-s,0},{s-1/2,0},{1/2-s,0},{0,1/2+s},{0,-1/2-s},{0,1/2-s},{0,s-1/2}}];
g=Graph[Range[Length[v]],UnitEdges[v],VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

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

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{12,4}},
"Name"->"12\[Hyphen]unit distance graph 4"
]]

Close[file]

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"UnitDistance",{12,4}},"VertexList"],GraphData[{"UnitDistance",{12,4}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,4}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

GraphPlot@

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,4}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{12,4}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{12,4}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"UnitDistance",{12,4}},"Matchstick"]

GraphData[{"UnitDistance",{12,4}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{12,4}},"Edges"]]

3D All

GraphData[{"UnitDistance",{12,4}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{12,4}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{12,4}},"Polyhedral"]

GraphData[{"UnitDistance",{12,4}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {13, 1}}

GraphData[{"UnitDistance",{13,1}},"RCN"]

GraphData[{"UnitDistance",{13,1}},"Graph","MinimalCrossing"]

GraphData[{"UnitDistance",{13,1}},"Graph","LCF"]

GraphData[{"UnitDistance",{13,1}},"Graph","UnitDistance"]

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

GraphData[{"UnitDistance",{13,1}},"Graph","All"]

GraphPlot[GraphData[{"UnitDistance",{13,1}},"Edges"]]

GraphPlot[GraphData[{"UnitDistance",{13,1}},"Edges"],GraphLayout->"TutteEmbedding"]

RotateGraph[LabelGraph@GraphicsToGraph@,{3,8}]

v=CirclePoints[Csc[Pi/7]/2,7];
v=Join[v,{v[[7]]+{0,1/2},v[[1]]+{0,1/2},v[[1]]+{0,1},v[[7]]+{0,1}}];
v=Join[v,{v[[11]]+(v[[10]]-v[[11]])/3,v[[11]]+(v[[10]]-v[[11]])2/3}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{Sequence@@Partition[Range[7],2,1,1],{4,6},{2,4},e[7,8,11,12,4,11],e[1,9,10,4,13,10],{8,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

{"UnitDistance", {13, 2}}

Found trying to find UD embedding for {"Johnson", 5}

GraphData[{"UnitDistance",{13,2}},"StandardName"]

Primary

GraphData[{"UnitDistance",{13,2}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"UnitDistance",{13,2}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"UnitDistance",{13,2}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{13,2}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{13,2}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{13,2}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{13,2}},"Graph","Degenerate"]

Bilateral

GraphData[{"UnitDistance",{13,2}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{13,2}},"Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{13,2}}],All][[All,All,1]]]

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

Planar

GraphData[{"UnitDistance",{13,2}},"Planar"]

GraphData[{"UnitDistance",{13,2}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{13,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{13,2}},"Graph","MinimalCrossing"]//StyleGraphs

GraphPlot@MinimalCrossingGraph[GraphData[{"UnitDistance",{13,2}}]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{13,2}},"Circulant"]

GraphData[{"UnitDistance",{13,2}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{13,2}},"Halin"]

GraphData[{"UnitDistance",{13,2}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{13,2}},"Rigid"]

GraphData[{"UnitDistance",{13,2}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{13,2}},"Flexible"]

GraphData[{"UnitDistance",{13,2}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{13,2}},"LCF"]

GraphData[{"UnitDistance",{13,2}},"HamiltonianCycleCount"]

GraphData[{"UnitDistance",{13,2}},"LCFSignature"]

GraphData[{"UnitDistance",{13,2}},"LCFNotations"]

GraphData[{"UnitDistance",{13,2}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{13,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{13,2}}],Debug->True]//Timing

GraphData[{"UnitDistance",{13,2}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"UnitDistance",{13,2}},"VertexList"],GraphData[{"UnitDistance",{13,2}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{13,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{13,2}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{13,2}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{13,2}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"UnitDistance",{13,2}},"Matchstick"]

GraphData[{"UnitDistance",{13,2}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{13,2}},"Edges"]]

3D All

GraphData[{"UnitDistance",{13,2}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{13,2}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{13,2}},"Polyhedral"]

GraphData[{"UnitDistance",{13,2}},"Graph",{"3D","Polyhedron"}]

Construction from {"JohnsonSkeleton",5}

g0=GraphData[{"JohnsonSkeleton",5},"Graph",{"All","Labeled"}][[3]]

g1=RotateGraph[UnitDistanceEmbeddingRefine[g0,WorkingPrecision->200],.45]

g=IndexGraph@VertexDelete[IndexGraph@VertexContract[g1,DeleteCases[GatherBy[MapIndexed[{#2[[1]],#}&,GraphEmbedding[g1]],Last][[All,All,1]],{_Integer}]],8]

UnitDistanceGraphEmbeddingQ[g]

VertexCount[g]

RecognizeGraph[g]

RigidGraphQ[g]

RecognizeGraph[g=]

UD exact construction

g1=Graph[Range[13],Sort[Sort/@EdgeList[g]],VertexCoordinates->GraphEmbedding[g]]

s=Sqrt[3]/2;
v={{a+1/2,y-s},{a,y},{1,0},{c-1/2,d-s},{c+1/2,d-s},{x,y},{c,d},{a+1/2,y+s},{1/2,s},{x+1,y},{0,0},{x+1/2,y-s},{a+1,y}};
ee=GraphData[{"UnitDistance",{13,2}},"Edges"];
eqn=UnitEdgeEquations[v,ee]//FullSimplify//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

soln=Solve[eqn,var,Reals]

gs=Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

soln=Solve[Append[eqn,c==1/2],var,Reals]

gs=Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

soln=Solve[Append[eqn,x+1==-a],var,Reals]

gs=Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

Manipulate[(
soln=Solve[Append[eqn,x==Rationalize[x0]],var,Reals];
Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]
),{x0,-1,1}]

Manipulate[(
soln=Solve[Append[eqn,x==Rationalize[x0]],var,Reals];
Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]
),{x0,-1,1}]

soln1=Solve[Append[eqn,x==-8/10],var,Reals]

Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln1,UnitDistanceGraphEmbeddingQ]

soln2=Solve[Append[eqn,x==1/4],var,Reals]

Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln2,UnitDistanceGraphEmbeddingQ]

c4=(c4e=FindCycle[GraphData[{"UnitDistance",{13,2}}],{4},All])[[All,All,1]]

squares=RightAngleEquation[v,#]&/@c4

soln3=Flatten[Solve[Append[eqn,#],var,Reals]&/@squares,1]//FullSimplify

Function[sol,Select[Graph[Range[13],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic,ImageSize->Tiny]&/@sol,UnitDistanceGraphEmbeddingQ]]/@{Reverse@soln1,soln2,soln3}

gs=Flatten[{{,},{,,},{,,,,,}}]

GraphDataString

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

WriteString[file,GraphDataString[g1,
"StandardName"->{"UnitDistance",{13,2}},
"AlternateStandardNames"->"13\[Hyphen]unit distance graph 2",
"Information"->"Unit-DistanceGraph",
TimeConstraint->60,
Debug->True]]

Close[file]

{"UnitDistance", {14, 1}} (2-vertex deletion from (Subscript[Q, 4]); contains octagon; 10-vertex deletion from {"BracedOctagon", {56, 1}}; Laman but not Rigid)

Names

GraphData[{"UnitDistance",{14,1}},"StandardName"]

GraphData[{"UnitDistance",{14,1}},"StandardNames"]

Primary

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

All

GraphData[{"UnitDistance",{14,1}},"Graph","All"]//StyleGraphs

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{14,1}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{14,1}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{14,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{14,1}},"Graph","Degenerate"]

Configuration

GraphData[{"UnitDistance",{14,1}},"Configuration"]

GraphData[{"UnitDistance",{14,1}},"Graph","Configuration"]//StyleGraphs

Perspective

GraphData[{"UnitDistance",{14,1}},"Graph","Perspective"]//StyleGraphs

HoneycombToroidal construction

GraphData[{"UnitDistance",{14,1}},"NotationRules","HoneycombToroidal"]

GeneralizedPetersen

GraphData[{"UnitDistance",{14,1}},"Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData[{"UnitDistance",{14,1}},"Graph","IGraph"]//StyleGraphs

Bilateral

GraphData[{"UnitDistance",{14,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{14,1}},"Graph","Circular"]//StyleGraphs

Circular construction

GraphData[{"UnitDistance",{14,1}},"Hamiltonian"]

GraphData[{"UnitDistance",{14,1}},"HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{14,1}}],All][[All,All,1]]]

circ=CircularEmbeddingFromHamiltonianCycle[GraphData[{"UnitDistance",{14,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[{"UnitDistance",{14,1}},"Planar"]

GraphData[{"UnitDistance",{14,1}},"Graph","Planar"]//StyleGraphs

2-vertex deletion from "TesseractGraph" which is Laman but not Rigid

tess=GraphData["TesseractGraph","Graph",{"UnitDistance","Labeled"}][[1]]

RigidGraphQ[tess]

LamanGraphQ[tess]

RecognizeGraph@VertexDelete[tess,{3,4}]

MinimalLocalCrossing

GraphData[{"UnitDistance",{14,1}},"LocalCrossingNumber"]

GraphData[{"UnitDistance",{14,1}},"Graph","MinimalLocalCrossing"]//StyleGraphs

LocalCrossingCount/@%

MinimalLocalCrossing construction

GraphPlot@UnlabelGraph@

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

RecognizeGraph@g

LocalCrossingCount@g

MinimalCrossing

GraphData[{"UnitDistance",{14,1}},{"RCN","CN"}]

GraphData[{"UnitDistance",{14,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

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

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

Table[MinimalCrossingGraph[GraphData[{"UnitDistance",{14,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union//Timing

GraphPlot@RotateGraph[,Pi/4]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

LocalCrossingCount@g

GraphData[{"UnitDistance",{14,1}},"Graphics"]

MinimalCrossingGraph[GraphData[{"UnitDistance",{14,1}}],"CrossingNumber"->2]

CirclePoints[(2/3)Csc[Pi/4]/2,4]

Mean[{-1/2,-1/3}]

v=Join[CirclePoints[Csc[Pi/4]/2,4],CirclePoints[(2/3)Csc[Pi/4]/2,4],CirclePoints[(1/3)Csc[Pi/4]/2,4],{{-1/6,-5/12},{1/6,-5/12}}];

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

r=RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{14,1}},"Circulant"]

GraphData[{"UnitDistance",{14,1}},"Graph","Circulant"]//StyleGraphs

Complement graph

compl=GraphData[{"UnitDistance",{14,1}},"ComplementGraph","Name"]

Line graph

GraphData[{"UnitDistance",{14,1}},"Line"]

LineGraphQ[GraphData[{"UnitDistance",{14,1}}]]//Timing

RootGraph

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

RootGraph[GraphData[{"UnitDistance",{14,1}}]]

RecognizeGraph[%]

Halin

GraphData[{"UnitDistance",{14,1}},"Halin"]

GraphData[{"UnitDistance",{14,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{14,1}},"Rigid"]

GraphData[{"UnitDistance",{14,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{14,1}},"Flexible"]

GraphData[{"UnitDistance",{14,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{14,1}},"LCF"]

GraphData[{"UnitDistance",{14,1}},"HamiltonianCycleCount"]

GraphData[{"UnitDistance",{14,1}},"LCFSignature"]

GraphData[{"UnitDistance",{14,1}},"LCFNotations"]

GraphData[{"UnitDistance",{14,1}},"Graph","LCF"]//StyleGraphs

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

UnitDistance

GraphData[{"UnitDistance",{14,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{14,1}}],Debug->True]//Timing

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

gs={,};

Matchstick

GraphData[{"UnitDistance",{14,1}},"Matchstick"]

GraphData[{"UnitDistance",{14,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{14,1}},"Edges"]]

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

RecognizeGraph@g

3D All

GraphData[{"UnitDistance",{14,1}},"Graph",{"3D","All"}]

3D UnitDistance

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

3D Polyhedron

GraphData[{"UnitDistance",{14,1}},"Polyhedral"]

GraphData[{"UnitDistance",{14,1}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {15, 1}} == "UnitDistanceGraphU"

GraphData

GraphData["UnitDistanceGraphU","#"]

GraphicsRow[GraphData["UnitDistanceGraphU","Graph","All"]/.g_System`Graph:>SetProperty[g,{VertexSize->{"Scaled",.02},System`VertexStyle->Red,System`EdgeStyle->Black}]]

GraphData[gn="UnitDistanceGraphU","Graph","UnitDistance"]

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

Construct

https://arxiv.org/pdf/1804.02385.pdf

v67=GraphEmbedding[T][[{6,7}]]

EuclideanDistance@@%//FullSimplify

Cot[Pi/3]/2

ctr=Mean[v67]-{0,(1/(2 (Sqrt[3])))(1/6) (-3+(Sqrt[33]))}//FullSimplify

Show[T,Graphics[{PointSize[.02],Point[ctr]}]]

vnew=FullSimplify[Flatten[Table[RotationMatrix[2π k/3].(#-ctr)&/@GraphEmbedding[T],{k,0,2}],1]]//Union

Length[vnew]

Graphics[Point[vnew]]

e=Select[Subsets[Range[15],{2}],EuclideanDistance@@vnew[[#]]==1.&]

U=System`Graph[Range[15],UndirectedEdge@@@e,VertexCoordinates->vnew]

RecognizeGraph[U]

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

WriteString[file,GraphDataString[U,
"StandardName"->{"UnitDistance",{15,1}},
"Name"->"15\[Hyphen]unit distance graph 1",
"AlternateStandardNames"->{"UnitDistanceGraphU"},
"AlternateNames"->{"unit\[Hyphen]distance graph U"},
Debug->True,
TimeConstraint->60]]

{"UnitDistance", {16, 1}}

g=GraphData[gn={"UnitDistance",{16,1}}]

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

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

GraphData[gn,"LCF"]

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

Construction

vals={{{0,0},{-6,0}},{{0,0},{6,0}},{{-2,0},{0,0}},{{2,0},{0,0}},{{-66,0},{0,0}},{{66,0},{0,0}},{{0,0},{-22,0}},{{0,0},{22,0}},{{-17,-1},{7,1}},{{-17,1},{7,-1}},{{17,-1},{7,-1}},{{17,1},{7,1}},{{-17,-1},{-7,-1}},{{-17,1},{-7,1}},{{17,-1},{-7,1}},{{17,1},{-7,-1}}}/24;root=(Sqrt[33]);
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]];
Graphics[{EdgeForm[{Black}],Line[unitlines],White,Table[Tooltip[Disk[points[[n]],.06],vals[[n]]],{n,1,Length[points]}]},ImageSize->Medium]

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

VertexCount[pegg16]

RecognizeGraph[pegg16]

<<MathWorld`Graphs`

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

WriteString[file,GraphDataString[pegg16,
"StandardName"->{"UnitDistance",{16,1}},
"Name"->"16\[Hyphen]unit distance graph 1",
"Skip"->{"Cactus"}
]]

Close[file]

{"UnitDistance", {16, 2}}

Found by Eric Weisstein from UD refinement of {"NoncayleyTransitive", {20, 4}} on Jan 27, 2023

Intersection[GraphData["UnitDistance*"],GraphData[16]]

Primary

GraphData[{"UnitDistance",{16,2}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"UnitDistance",{16,2}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"UnitDistance",{16,2}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{16,2}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{16,2}},"Edges"]

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

RecognizeGraph[g]

Bilateral

GraphData[{"UnitDistance",{16,2}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{16,2}},"Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{16,2}}],All][[All,All,1]]]

Length[bilat=Union@DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"UnitDistance",{16,2}}],#]&/@hc]]//Timing

bilat

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

gs=quad

Planar

GraphData[{"UnitDistance",{16,2}},"Planar"]

GraphData[{"UnitDistance",{16,2}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{16,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{16,2}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"UnitDistance",{16,2}}],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"UnitDistance",{16,2}}],TimeConstraint->10])//AbsoluteTiming

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

Table[MinimalCrossingGraph[GraphData[{"UnitDistance",{16,2}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UnitDistance",{16,2}},"Circulant"]

GraphData[{"UnitDistance",{16,2}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{16,2}},"Halin"]

GraphData[{"UnitDistance",{16,2}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{16,2}},"Rigid"]

GraphData[{"UnitDistance",{16,2}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{16,2}},"Flexible"]

GraphData[{"UnitDistance",{16,2}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{16,2}},"LCF"]

GraphData[{"UnitDistance",{16,2}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{16,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{16,2}}],Debug->True]//Timing

GraphData[{"UnitDistance",{16,2}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance construction

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

g2=LabelGraph@IndexGraph@RotateGraph[CenterGraph@ContractCoincidentVertices[],{6,2}]

RecognizeGraph[g2]

UnitDistanceGraphEmbeddingQ@g2

v={{1/2,1/2},{1/2,-1/2},{x,0},{-c,0},{-1/2,1/2},{-1/2,-1/2},{0,c},{0,-h},{a,b},{a,-b},{-a,b},{-a,-b},{0,-c},{0,h},{c,0},{-x,0}};
ee=EdgeList[g2];

eqn=UnitEdgeEquations[v,ee]//FullSimplify//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

soln=Solve[Append[eqn,a>0],var,Reals]

g=Graph[Range[Length[v]],ee,VertexCoordinates->(v/.soln[[1]])]

UnitDistanceGraphEmbeddingQ[%]

g=;

v=GraphEmbedding[g];

Graph[Range[16],UnitEdges[v],VertexCoordinates->v]

RecognizeGraph@%54

g7=IndexGraph@ContractCoincidentVertices@RotateGraph[,{8,4}]

VertexCount[g7]

IsomorphicGraphQ[g2,g7]

GraphData[{"UnitDistance",{16,1}},"Name"]//FullForm

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

WriteString[file,GraphDataString[,
"StandardName"->{"UnitDistance",{16,2}},
"Name"->"16\[Hyphen]unit distance graph 2",
TimeConstraint->10
]]

Close[file]

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"UnitDistance",{16,2}},"VertexList"],GraphData[{"UnitDistance",{16,2}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{16,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{16,2}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{16,2}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{16,2}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"UnitDistance",{16,2}},"Matchstick"]

GraphData[{"UnitDistance",{16,2}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{16,2}},"Edges"]]

3D All

GraphData[{"UnitDistance",{16,2}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{16,2}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{16,2}},"Polyhedral"]

GraphData[{"UnitDistance",{16,2}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {17, 1}} (7-vertex deletion from {"BracedOctagon", {56, 1}}; contains octagon; Laman but not Rigid)

Names

GraphData[{"UnitDistance",{17,1}},"StandardName"]

GraphData[{"UnitDistance",{17,1}},"StandardNames"]

Primary

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

Construction from {"BracedOctagon", {56, 1}}

After discussion with Ed Dec 21, 2020 about how many rods can be deleted to make the graph rigid:

g=IndexGraph@VertexDelete[GraphData[{"BracedOctagon",{56,1}}],{2,3,6,19,20,23,24}]

EdgeCount[g]

All

GraphData[{"UnitDistance",{17,1}},"Graph","All"]//StyleGraphs

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData[{"UnitDistance",{17,1}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UnitDistance",{17,1}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UnitDistance",{17,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"UnitDistance",{17,1}},"Graph","Degenerate"]

Configuration

GraphData[{"UnitDistance",{17,1}},"Configuration"]

GraphData[{"UnitDistance",{17,1}},"Graph","Configuration"]//StyleGraphs

Perspective

GraphData[{"UnitDistance",{17,1}},"Graph","Perspective"]//StyleGraphs

HoneycombToroidal construction

GraphData[{"UnitDistance",{17,1}},"NotationRules","HoneycombToroidal"]

GeneralizedPetersen

GraphData[{"UnitDistance",{17,1}},"Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData[{"UnitDistance",{17,1}},"Graph","IGraph"]//StyleGraphs

Bilateral

GraphData[{"UnitDistance",{17,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UnitDistance",{17,1}},"Graph","Circular"]//StyleGraphs

Circular construction

GraphData[{"UnitDistance",{17,1}},"Hamiltonian"]

GraphData[{"UnitDistance",{17,1}},"HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData[{"UnitDistance",{17,1}}],All][[All,All,1]]]

Planar

GraphData[{"UnitDistance",{17,1}},"Planar"]

GraphData[{"UnitDistance",{17,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{17,1}},{"RCN","CN"}]

GraphData[{"UnitDistance",{17,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

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

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

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

GraphPlot@

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

LocalCrossingCount@g

gs=UnlabelGraph/@{,}

GraphPlot@MinimalCrossingGraph[GraphData[{"UnitDistance",{17,1}}],"CrossingNumber"->4]

GraphPlot@RotateGraph[HighlightGraph[GraphicsToGraph@,{18,19,20,21}],{15,10}]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

MinimalLocalCrossing

GraphData[{"UnitDistance",{17,1}},"LocalCrossingNumber"]

GraphData[{"UnitDistance",{17,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[{"UnitDistance",{17,1}}],TimeConstraint->1])//AbsoluteTiming

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

GraphPlot@

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

Sort[Sort/@EdgeList@g]

RecognizeGraph@g

LocalCrossingCount@g

Circulant

GraphData[{"UnitDistance",{17,1}},"Circulant"]

GraphData[{"UnitDistance",{17,1}},"Graph","Circulant"]//StyleGraphs

Complement graph

compl=GraphData[{"UnitDistance",{17,1}},"ComplementGraph","Name"]

Line graph

GraphData[{"UnitDistance",{17,1}},"Line"]

LineGraphQ[GraphData[{"UnitDistance",{17,1}}]]//Timing

RootGraph

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

RootGraph[GraphData[{"UnitDistance",{17,1}}]]

RecognizeGraph[%]

GraphData[roots[[1]],"Graph","All"]

gs=LineGraph/@%

Halin

GraphData[{"UnitDistance",{17,1}},"Halin"]

GraphData[{"UnitDistance",{17,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"UnitDistance",{17,1}},"Rigid"]

GraphData[{"UnitDistance",{17,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"UnitDistance",{17,1}},"Flexible"]

GraphData[{"UnitDistance",{17,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{17,1}},"LCF"]

GraphData[{"UnitDistance",{17,1}},"HamiltonianCycleCount"]

GraphData[{"UnitDistance",{17,1}},"LCFSignature"]

GraphData[{"UnitDistance",{17,1}},"LCFNotations"]

GraphData[{"UnitDistance",{17,1}},"Graph","LCF"]//StyleGraphs

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

UnitDistance

GraphData[{"UnitDistance",{17,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{17,1}}],Debug->True]//Timing

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData[{"UnitDistance",{17,1}},"Matchstick"]

GraphData[{"UnitDistance",{17,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UnitDistance",{17,1}},"Edges"]]

3D All

GraphData[{"UnitDistance",{17,1}},"Graph",{"3D","All"}]

3D UnitDistance

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

3D Polyhedron

GraphData[{"UnitDistance",{17,1}},"Polyhedral"]

GraphData[{"UnitDistance",{17,1}},"Graph",{"3D","Polyhedron"}]

{"UnitDistance", {21, 1}}  (contains squares)

Graph

g=GraphData[{"UnitDistance",{21,1}}]

RigidGraphQ[g]

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

Construction

vals={{{-12,-6},{-4,-2}},{{-12,6},{-4,-2}},{{-9,0},{7,-4}},{{-3,0},{-13,-4}},{{-3,0},{-1,0}},{{0,0},{-16,8}},{{0,0},{4,0}},{{3,0},{-13,-4}},{{3,0},{-1,0}},{{9,0},{7,-4}},{{12,-6},{-4,-2}},{{12,6},{-4,-2}},{{-12,-6},{4,-2}},{{-12,6},{4,-2}},{{-9,0},{7,4}},{{-3,0},{13,-4}},{{0,0},{16,8}},{{3,0},{13,-4}},{{9,0},{7,4}},{{12,-6},{4,-2}},{{12,6},{4,-2}}}/12;
points=Map[Function[x,RootReduce[Sign[x.{1,(Sqrt[3])}](Sqrt[Abs[(x).{1,(Sqrt[3])}]])]],vals,{2}];
unitlines=Select[Subsets[points,{2}],Function[x,Chop[N[1-Apply[EuclideanDistance,N[x]]]]==0]];
Graphics[{EdgeForm[{Black}],Line[unitlines],Table[{If[n>12,White,Blue],Tooltip[Disk[points[[n]],.06],vals[[n]]]},{n,1,Length[points]}]},ImageSize->Medium]

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

VertexCount[g]

RecognizeGraph[%]

UnitDistanceGraphQ[g]

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

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

WriteString[file,GraphDataString[pegg21,
"StandardName"->{"UnitDistance",{21,1}},
"Name"->"21\[Hyphen]unit distance graph 1"
]]

Close[file]

{"UnitDistance", {24, 1}} Pegg (56 rods) (flexible octagon that cannot be made rigid)

GraphData[{"UnitDistance",{24,1}},{"V","M"}]

g=GraphData[gn={"UnitDistance",{24,1}}]//StyleGraphs

UnitDistanceGraphEmbeddingQ[g]

Flexible

RigidGraphQ[g]

not Laman

LamanGraphQ[g]

Properties

GraphData[gn,"UnitDistance"]

GraphData[gn,"CyclePolynomial"]

GraphData[gn,"Girth"]

GraphData[gn,"ChromaticNumber"]

Search for Laman/rigid subgraphs by removing vertices

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

n=VertexCount[g]

Vertices that are not part of the octagon:

vl=Complement[VertexList[g],{1,5,15,16,8,4,10,9}]

nl=Length[vl]

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

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

Graph

Graphic

Mar 8, 2018

points=Join[GraphData["TesseractGraph","AlternateVertexCoordinates"][[1]],{{(-3-Sqrt[3])/6,-(1/Sqrt[6])},{(-3-Sqrt[3])/6,1/Sqrt[6]},{(3-Sqrt[3])/6,-(1/Sqrt[6])},{(3-Sqrt[3])/6,1/Sqrt[6]},{(-3+Sqrt[3])/6,-(1/Sqrt[6])},{(-3+Sqrt[3])/6,1/Sqrt[6]},{(3+Sqrt[3])/6,-(1/Sqrt[6])},{(3+Sqrt[3])/6,1/Sqrt[6]}}];
unitlines=Select[Subsets[points,{2}],Chop[Quiet@N[1-Quiet@EuclideanDistance@@#]]==0&];
gr=Graphics[{Line/@unitlines,EdgeForm[Black],White,Table[{Disk[points[[n]],.03]},{n,1,Length[points]}]},ImageSize->500]

Construction

ec=Cases[gr,Line[l_]:>l,∞];

Length[v=Flatten[ec,1]//Union]

e=ec/.Thread[v->Range[24]]

g=System`Graph[Range[24],UndirectedEdge@@@e,VertexCoordinates->v]

EdgeCount[g]

VertexCount[g]

RecognizeGraph[g]

UnitDistanceEmbeddingGraphQ[g,WorkingPrecision->∞]

FindVertexColoring[g,Method->"Brelaz"]//Timing

FindVertexColoring[g,Method->"Combinatorica"]//Timing

GraphData

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

WriteString[file,GraphDataString[g,
"StandardName"->{"BracedOctagon",{56,1}},
"Name"->"56\[Hyphen]rod braced octagon 1",
"Skip"->{"Arboricity","Cactus","EdgeChromaticNumber","GridIndices","HamiltonianPaths","HamiltonianWalks","IrredundantSets","MinimumWeightFractionalEdgeColoring","OddChordlessCycles","Skewness"}
]]

Close[file]

{"UnitDistance", {27, 1}} (G27)

GraphData[{"UnitDistance",{27,1}}]

https://arxiv.org/abs/1905.07829

From Globus and Parshall (2020)

We use nauty to generate the set of all 7123 biconnected graphs on 8 vertices. SageMath computes that only 366 of these graphs are (Subscript[ℱ, ≤8])-free. Moreover, each of these 366 are subgraphs of the embedded unit-distance graph G27 portrayed in Figure 4 with coordinates given in Table 1 in Appendix B. We constructed G27 as follows. First, we explicitly computed coordinates for several of the 366 graphs that we were attempting to embed. Next, we focused on those graphs with a vertex of degree 2 that had not yet been embedded. When we could successfully embed the subgraph without this degree-2 vertex into our set of already computed coordinates, we attempted to solve for new coordinates for this degree-2 vertex.  If we succeeded, we added this new vertex to our set of coordinates. Iterating this procedure yielded a unit-distance graph which contained as a subgraph each of the 366 graphs being considered. We finally produced G27 by eliminating several unnecessary vertices.

A00221 (Number of unlabeled nonseparable graphs (or blocks) with n nodes.)

1, 1, 1, 3, 10, 56, 468, 7123, 194066,

Length[g8=Graphs[8]]

Length[bc8=Select[g8,VertexConnectivity[#]>1&]]//Timing

udforbidden=GraphData["UnitDistanceForbidden",;;8]

udforbiddengraphs=GraphData/@udforbidden;

F8FreeGraphQ[g_Graph]:=AllTrue[udforbiddengraphs,IsomorphicSubgraphQ[#,g]===False&]

Length[G27Graphs=Select[bc8,F8FreeGraphQ]]//Timing

G27Graphs

G27Graphs={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};

rg=RecognizeGraph[#,"Cache"->"InternalOnly"]&/@G27Graphs;

In GraphData:

DeleteCases[rg,{}]

Length[%]

Not in GraphData:

Count[rg,{}]

UnitDistanceGraphEmbeddingQ[GraphData[{"UnitDistance",{27,1}}]]

GraphData[{"UnitDistance",{27,1}},"Graph","All"]

GraphData[{"UnitDistance",{27,1}},"EmbeddingClasses"]

GraphData[{"UnitDistance",{27,1}},"Hamiltonian"]

https://tinyurl.com/smallUDcode

soln=;

Length[G27coords={{0,0},{-1/2,1/2 Sqrt[3]},{1/2,1/2 Sqrt[3]},{1,0},{1/2,-1/2 Sqrt[3]},{-1/2,-1/2 Sqrt[3]},{-1,0},{1/12 Sqrt[33]+1/12,-1/12 Sqrt[11]+1/12 Sqrt[3]},{1/12 Sqrt[33]+11/12,1/12 Sqrt[11]+1/12 Sqrt[3]},{1/6 Sqrt[33]+1/2,-1/3 Sqrt[3]},{1/6 Sqrt[33],1/6 Sqrt[3]},{3/2,1/2 Sqrt[3]},{1/12 Sqrt[33]+1/4,1/4 Sqrt[11]-5/12 Sqrt[3]},{1/6 Sqrt[33]+1,1/6 Sqrt[3]},{1/12 Sqrt[33]-5/12,-1/12 Sqrt[11]-5/12 Sqrt[3]},{2,0},{5/6,1/6 Sqrt[11]},{11/6,1/6 Sqrt[11]},{-1/60 Sqrt[385]+17/12,-7/60 Sqrt[35]+1/12 Sqrt[11]},{1/60 Sqrt[385]+17/12,7/60 Sqrt[35]+1/12 Sqrt[11]},{5/2,1/2 Sqrt[3]},{1/12 Sqrt[11] Sqrt[3]+13/12,-1/12 Sqrt[11]+1/12 Sqrt[3]},{1/12 Sqrt[11] Sqrt[3]+5/12,1/12 Sqrt[11]-5/12 Sqrt[3]},{3/2,-1/2 Sqrt[3]},{12/7,1/7 Sqrt[3]},{11/14,5/14 Sqrt[3]},{4/3,1/6 Sqrt[11]+1/2 Sqrt[3]}}]

ByteCount[G27coords]

Transpose[{G27coords,FullSimplify[G27coords]}]//TraditionalForm

G27edges=With[{v=G27coords},Select[Subsets[Range[Length[v]],{2}],EuclideanDistance@@v[[#]]==1.&]]

G27=Graph[Range[Length[G27coords]],UndirectedEdge@@@G27edges,VertexCoordinates->G27coords]

Through[{VertexCount,EdgeCount}[G27]]

UnitDistanceGraphQ[G27]

RecognizeGraph[G27]

{"UnitDistance", {28, 1}}

GraphData[{"UnitDistance",{28,1}},"UnitDistance"]

GraphData[{"UnitDistance",{28,1}},{"TriangleCount","SquareCount"}]

GraphData[{"UnitDistance",{28,1}},"Graph","UnitDistance"]

GraphData[{"UnitDistance",{28,1}},"Graph","All"]

gcontr=ContractCoincidentVertices[GraphData[{"TorusGrid",{7,7}},"Graph","All"][[3]],Debug->True]

RecognizeGraph[gcontr]

{"UnitDistance", {30, 1}} [supergraph of "Icosidodecahedral" UD embedding]

GraphData[{"UnitDistance",{30,1}},"Graph","UnitDistance"]

GraphData[{"UnitDistance",{30,1}},"Graph","All"]

GraphData[{"UnitDistance",{30,1}},"CN"]

{"UnitDIstance", {30, 2}} [supergraph of "Icosidodecahedral" UD embedding]

GraphData[{"UnitDistance",{30,2}},"StandardName"]

All

GraphData[{"UnitDistance",{30,2}},"Graph","All"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{30,2}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{30,2}},"LCFSignature"]

GraphData[{"UnitDistance",{30,2}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{30,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{30,2}}],Debug->True]//Timing

GraphData[{"UnitDistance",{30,2}},"Graph","UnitDistance"]//StyleGraphs

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

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"UnitDistance",{30,2}},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{30,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{30,2}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{30,2}}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

Matchstick

GraphData[{"UnitDistance",{30,2}},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{30,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{30,2}},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"UnitDistance",{30,2}},"Edges"]

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

RecognizeGraph[g]

Planar construction

GraphPlot[RotateGraph[PlanarGraph[GraphData[{"UnitDistance",{30,2}}],VertexLabels->None],{25,23}]]

v=CirclePoints[5];
v=Join[v,Table[v[[4]]+(v[[2]]-v[[4]])i/3,{i,2}]];
s=EuclideanDistance@@v[[{6,7}]]//FullSimplify//Quiet;
v=Join[v,{{x,y}=v[[6]]-{0,s},v[[7]]-{0,s}}];
v=Join[v,
{x+# s/5,y}&/@{2,3},
{x+# s/5,y+s/6}&/@{2,3,4},
{x+# s/5,y+2s/6}&/@{-1,0,1,2,3},
{x+# s/5,y+3s/6}&/@{2,3,4,5,6},
{x+# s/5,y+4s/6}&/@{3},
{x+# s/5,y+5s/6}&/@{0,2,3,5},
{{0,-1/2}}
];g=Graph[Range[Length[v]],Sort[Sort/@UndirectedEdge@@@{e[5,1,2,3,4,5,15,26,6,3,7,6,27,26],e[5,30,1,24,2],e[4,15,16,17,18],e[15,8,10,11,9,24,23,22,21,20],{2,7},e[8,16,26],e[27,28,29,7,28],e[11,30,10,12,18,20,27],e[8,12,13,14,9,23,29],e[26,17,20],e[27,25,20],e[28,25,21],e[29,22,19,14],e[12,11,14,22],e[18,13,19,21],{1,9},{4,6}}],VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"UnitDistance",{30,2}}],"CrossingNumber"->-1]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"UnitDistance",{30,2}},"Edges"]]

3D All

GraphData[{"UnitDistance",{30,2}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UnitDistance",{30,2}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UnitDistance",{30,2}},"Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData[{"UnitDistance",{30,2}},"Polyhedron"]}]

3D Canonical

GraphData[{"UnitDistance",{30,2}},"Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData[{"UnitDistance",{30,2}},"Polyhedron"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData[{"UnitDistance",{30,2}}],-1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->20])//Timing

SimplePolyhedronQ[can]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

{"UnitDistance", {31, 1}} == "UnitDistanceGraphJ"

GraphData[{"UnitDistance",{31,1}},"StandardName"]

All

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

Construction

https://arxiv.org/pdf/1804.02385.pdf

v=Prepend[CirclePoints[6],{0,0}]

GraphData["W7","VertexCoordinates"]

GraphData["W7","Graph","Labeled"]

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

Graphics[Point[Hv=Union@@Append[Table[((Sqrt[3])Through[{Cos,Sin}[2Pi( k+1/2)/6]]+#)&/@v,{k,0,5}],v]]]

Length[Hv]

e=Select[Subsets[Range[31],{2}],EuclideanDistance@@Hv[[#]]==1.&]

J=System`Graph[Range[31],UndirectedEdge@@@e,VertexCoordinates->Hv,VertexLabels->"Name"]

Through[{VertexCount,EdgeCount}[J]]

RecognizeGraph[J]

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

Halin

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

LCF

GraphData[{"UnitDistance",{31,1}},"LCFSignature"]

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

UnitDistance

GraphData[{"UnitDistance",{31,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{31,1}}],Debug->True]//Timing

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

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

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

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

Matchstick

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

MinimalCrossing

GraphData[{"UnitDistance",{31,1}},{"RCN","CN"}]

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

Default embedding

GraphPlot@GraphData[{"UnitDistance",{31,1}},"Edges"]

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

RecognizeGraph[g]

MinimalCrossing construction

g=RotateGraph[MinimalCrossingGraph[GraphData[{"UnitDistance",{31,1}}]],{10,23}]

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"UnitDistance",{31,1}},"Edges"]]

3D All

GraphData[{"UnitDistance",{31,1}},"Graph",{"3D","All"}]

3D UnitDistance

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

3D Polyhedron

GraphData[{"UnitDistance",{31,1}},"Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData[{"UnitDistance",{31,1}},"Polyhedron"]}]

3D Canonical

GraphData[{"UnitDistance",{31,1}},"Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData[{"UnitDistance",{31,1}},"Polyhedron"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData[{"UnitDistance",{31,1}}],-1,GraphLayout->"HighDimensionalEmbedding"]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->20])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

g=GraphData[{"UnitDistance",{31,1}},"Graph","Planar"][[1]]

g=GraphData[{"UnitDistance",{31,1}},"Graph","Planar"][[2]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->3.],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.3v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->1000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/20,"PlanarFactor"->1/20,Debug->True])//Timing

Graphics3D[can=Polyhedron[]]

(can=FindCanonicalPolyhedron[can,WorkingPrecision->50,MaxIterations->100000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/1000,"PlanarFactor"->1/1000,Debug->True])//Timing

SimplePolyhedronQ[can=Polyhedron[]]

Graphics3D[can]

(can=FindCanonicalPolyhedron[can,WorkingPrecision->50,MaxIterations->100000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/10000,"PlanarFactor"->1/10000,Debug->True])//Timing

Graphics3D[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

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

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

GraphData

WriteString[file,GraphDataString[J,
"StandardName"->{"UnitDistance",{31,1}},
"Name"->"31\[Hyphen]unit distance graph 1",
"AlternateStandardNames"->{"UnitDistanceGraphJ"},
"AlternateNames"->{"unit\[Hyphen]distance graph J"},
"Classes"->{"Matchstick","Polyiamond","UnitDistance"},
"EmbeddingClasses"->{{"Integral","Matchstick","MinimalCrossing","MinimalIntegral","MinimalRectilinearCrossing","Planar","Primary","UnitDistance"}},
Debug->True,
TimeConstraint->10]]

{"UnitDistance", {31, 2}} == "UnitDistanceGraphV"

GraphData[{"UnitDistance",{31,2}},"StandardName"]

All

GraphData[{"UnitDistance",{31,2}},"Graph","All"]//StyleGraphs

Halin

GraphData[{"UnitDistance",{31,2}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"UnitDistance",{31,2}},"LCFSignature"]

GraphData[{"UnitDistance",{31,2}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UnitDistance",{31,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UnitDistance",{31,2}}],Debug->True]//Timing

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

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

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"UnitDistance",{31,2}},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"UnitDistance",{31,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"UnitDistance",{31,2}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"UnitDistance",{31,2}}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

Matchstick

GraphData[{"UnitDistance",{31,2}},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"UnitDistance",{31,2}},{"RCN","CN"}]

GraphData[{"UnitDistance",{31,2}},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"UnitDistance",{31,2}},"Edges"]

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

RecognizeGraph[g]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"UnitDistance",{31,2}}],"CrossingNumber"->-1]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Construction

GraphicsRow[GraphData["UnitDistanceGraphV","Graph","All"]/.g_System`Graph:>SetProperty[g,{VertexSize->{"Scaled",.02},System`VertexStyle->Red,System`EdgeStyle->Black}]]

GraphData[gn="UnitDistanceGraphV","Graph","UnitDistance"]

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

Figure

https://arxiv.org/pdf/1804.02385.pdf

GraphData["GolombMoser*"]

Attempting to rotate Golomb-Moser

g=GraphData["MoserSpindle","Graph","Labeled"]

v=GraphData["MoserSpindle","VertexCoordinates"]

Subtract@@v[[{1,4}]]

ArcTan@@%

Pi/2-ArcTan[(Sqrt[11])]//FullSimplify

N[%]

Vv=Union@FullSimplify[Flatten[Table[RotationMatrix[(1/2) (π-2 ArcTan[(Sqrt[11])])k].(#-v[[4]])&/@v,{k,-1,1}],1]]

Length[Vv]

Graphics[Point[Vv]]

e=Select[Subsets[Range[16],{2}],EuclideanDistance@@Vv[[#]]==1.&]

VV1=System`Graph[Range[16],UndirectedEdge@@@e,VertexCoordinates->Vv,VertexLabels->"Name"]

VertexDegree[VV1]

Rotation

rot[0]:=0
rot[i_]:=ArcCos[((2i-1)/(2i))]

rot/@{1,3}

Graphics[Point[v=Prepend[Flatten[CirclePoints[{1,rot[1]+# rot[3]},6]&/@Range[-1,1,1/2],1],{0,0}]]]

Length[v]

e=Select[Subsets[Range[31],{2}],EuclideanDistance@@v[[#]]==1.&]

V31=System`Graph[Range[31],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[V31]

EdgeCount[V31]

(wrong on twiki)

GraphDataString

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

WriteString[file,GraphDataString[V31,
"StandardName"->{"UnitDistance",{31,2}},
"Name"->"31\[Hyphen]unit distance graph 2",
"AlternateStandardNames"->{"UnitDistanceGraphV"},
"AlternateNames"->{"unit\[Hyphen]distance graph V"},
Debug->True,
TimeConstraint->60]]

Close[file]

{"UnitDistance", {40, 1}} (disconnected; from Ed, contains a pentagon but is flexible)

Triangle-free and contains a pentagon.  Claimed by Ed 2021-01-03 to be rigid but isn't

From Ed Pegg, Jen 3, 2021

The pentagon can be braced with 40 nodes, 80-edges.  Here are some points. This is basically 4 copies on the unit-distance Petersen Graph.   William's program nicely verifies rigidity. [not for me]
Any vertex can be deleted and it remains rigid.

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

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

g=GraphData[{"UnitDistance",{40,1}},"Graph","Labeled"]

Connected components

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

RigidGraphQ/@cc

IsomorphicGraphQ@@cc

cc1=IndexGraph@cc[[1]]

pents=GraphRegularPolygons[cc1,5]

CyclePolynomial[cc1,x]

HighlightGraphRegularPolygons[cc1,5]

not Laman

LamanGraphQ[g]

UnitDistance

UnitDistanceGraphEmbeddingQ[g]

Flexible

RigidGraphQ[g]

Attempt to make Rigid

VertexCount[g]

Length[cyc=FindCycle[g,{5},All]]//Timing

HighlightGraph[g,cyc[[4]]]

Symmetrically distinct vertices that are not part of the square:

vl=Complement[VertexList[g],{25,37,24,38,26}]

nl=Length[vl]

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

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

Construction

<<MathWorld`Graphs`

v=ToRadicals@Union[RootReduce[ReIm/@Flatten[x/.Solve[#==0]&/@{1-5 x^2+5 x^4,1+5 x^2+5 x^4,1-5 x+10 x^2-10 x^3+5 x^4,1-5 x^3+5 x^4,1+5 x^3+5 x^4,1+5 x+10 x^2+10 x^3+5 x^4,1+5 x^2+10 x^4+25 x^8,1+10 x^4+25 x^6+25 x^8}]]]

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

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

FindCycle[g,{3}]

Through[{VertexCount,EdgeCount}[g]]

GraphData

file=OpenWrite["~/unit-distance-40.m"]

WriteString[file,GraphDataString[g,
"StandardName"->{"UnitDistance",{40,1}},
"Name"->"40\[Hyphen]unit distance graph 1",
"Information"->"Unit-DistanceGraph",
"Skip"->{"Arboricity","ConnectedInducedSubgraphPolynomial","DominatingSets","Skewness"}
]]

Close[file]

{"UnitDistance", {61, 1}} == "UnitDistanceGraphK"

GraphData["UnitDistanceGraphK","#"]

https://arxiv.org/pdf/1804.02385.pdf

Graphics[Point[Kv=Join[Hv,RotationMatrix[π/6].#&/@Hv]]]

Length[Kv]

e=Select[Subsets[Range[62],{2}],EuclideanDistance@@Kv[[#]]==1.&]

K=System`Graph[Range[62],UndirectedEdge@@@e,VertexCoordinates->Kv,VertexLabels->"Name"]

Hv[[24]]

RotationMatrix[a].Hv[[27]]

FullSimplify[SquaredEuclideanDistance[{1,(Sqrt[3])},{2 Cos[a],2 Sin[a]}],a>0]

Solve[-4 (-2+Cos[a]+(Sqrt[3]) Sin[a])==1,a,Reals]//FullSimplify

π/6.

Table[-2 ArcTan[(1/11) (Sqrt[3]) (-4+(Sqrt[5]))]+2.π k,{k,-2,0}]

-2 ArcTan[(1/11) (Sqrt[3]) (-4+(Sqrt[5]))]//N

Graphics[Point[Kv=ToRadicals@FullSimplify@TrigExpand@FullSimplify@Union[Hv,RotationMatrix[-2 ArcTan[(1/11) (Sqrt[3]) (-4+(Sqrt[5]))]].#&/@Hv]]]

Kv

Length[Kv]

e=Select[Subsets[Range[61],{2}],EuclideanDistance@@Kv[[#]]==1.&]

K=System`Graph[Range[61],UndirectedEdge@@@e,VertexCoordinates->Kv,VertexLabels->"Name"]

Through[{VertexCount,EdgeCount}[K]]

RecognizeGraph[K]

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

WriteString[file,GraphDataString[K,
"StandardName"->{"UnitDistance",{61,1}},
"Name"->"61\[Hyphen]unit distance graph 1",
"AlternateStandardNames"->{"UnitDistanceGraphK"},
"AlternateNames"->{"unit\[Hyphen]distance graph K"},
"Classes"->{"UnitDistance"},
"EmbeddingClasses"->{{"Integral","MinimalIntegral","Primary","UnitDistance"}},
Debug->True,
TimeConstraint->10]]

{"UnitDistance", {63, 1}}

From Ed Pegg?

GraphData[{"UnitDistance",{63,1}},"Graph","All"]

GraphData[{"UnitDistance",{63,1}},"EmbeddingClasses"]

GraphData[{"UnitDistance",{63,1}},"Graph","UnitDistance"]

g=GraphData[{"UnitDistance",{63,1}},"Graph","UnitDistance"][[1]]

N[EdgeLengths[g]-1,100]//Union

EdgeLengths[g]^2//RootReduce//Union//Timing

Redo construction

basepts = {{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,1]},{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,5]},{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,4]}};

pts = Flatten[Table[Table[RootReduce[basepts[[k]].RotationMatrix[2 n Pi/21]],{n,0,20}],{k,1,3}],1]

baselines = {{1,1,3},{2,2,6},{3,3,9},{1,2,7},{1,2,14},{1,3,7},{1,3,14}, {2,3,7},{2,3,14}};

lines = Flatten[Table[Table[{21(baselines[[n,1]]-1) + k,21(baselines[[n,2]]-1)+ Mod[k+baselines[[n,3]],21,1]},{k,1,21}],{n,9}],1]

g=Graph[Range[63],UndirectedEdge@@@lines,VertexCoordinates->pts]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

N[EdgeLengths[g]-1,100]//Union

RootReduce[EdgeLengths[g]^2]//Timing

Original construction

basepts = {{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,1]},{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,5]},{0,Root[-1+7 ((#1)^2)-14 ((#1)^4)+7 ((#1)^6)&,4]}};

pts = Flatten[Table[Table[RootReduce[basepts[[k]].RotationMatrix[2 n Pi/21]],{n,0,20}],{k,1,3}],1];

baselines = {{1,1,3},{2,2,6},{3,3,9},{1,2,7},{1,2,14},{1,3,7},{1,3,14}, {2,3,7},{2,3,14}};

lines = Flatten[Table[Table[{21(baselines[[n,1]]-1) + k,21(baselines[[n,2]]-1)+ Mod[k+baselines[[n,3]],21,1]},{k,1,21}],{n,1,9}],1];

Graphics[{Black,Table[Line[pts[[#]]&/@lines[[nn]]],{nn,1,189}],AbsolutePointSize[6],Red,Point/@pts},ImageSize->200]

g=Graph[List/@lines,List/@pts]

RecognizeGraph[g]

GraphPlot[g,Method->None,ImageSize->200]

UnitDistanceGraphQ[g_]:=Module[{v=Vertices[g]},
Equal[1,Sequence@@(Norm/@(Subtract@@@(Edges[g]/.n_Integer:>v[[n]])))]
]

UnitDistanceGraphQ[g]//N

UnitDistanceGraphQ[g]//FullSimplify//Timing

{"UnitDistance", {118, 1}}

https://arxiv.org/abs/1905.07829

From Globus and Parshall (2020)

We use nauty to generate the set of all 194,066 biconnected graphs on 9 vertices. SageMath computes that only 2984 of these graphs are (Subscript[ℱ, ≤9])-free, and all but 275 of these are subgraphs of the unit-distance graph G27 that we constructed for the proof of Theorem 9. For some of these remaining 275 graphs, we explicitly compute several coordinates. We proceed to add new vertices to G27 using the same procedure described in the proof of Theorem 9 that we used to construct G27. In total, we add 91 vertices to G27 to construct an embedded unit-distance graph G118, and we report these additional vertices in Table 2. SageMath verifies that there are exactly two  (Subscript[ℱ, ≤9])-free biconnected graphs on 9 vertices, which we label H1 and H2 and depict in Figure 5, that are not subgraphs of G118. We were unable to produce exact coordinates for H1 and H2 using SageMath. However, using the implementation of cylindrical algebraic decomposition [3] within Mathematica, we found exact coordinates for these graphs and report them in Tables 3 and 4.

A00221 (Number of unlabeled nonseparable graphs (or blocks) with n nodes.)

1, 1, 1, 3, 10, 56, 468, 7123, 194066,

Length[g9=Graphs[9]]//AbsoluteTiming

Length[bc9=Select[g9,VertexConnectivity[#]>1&]]//Timing

udforbidden=GraphData["UnitDistanceForbidden",;;9]

udforbiddengraphs=GraphData/@udforbidden;

F9FreeGraphQ[g_Graph]:=AllTrue[udforbiddengraphs,IsomorphicSubgraphQ[#,g]===False&]

Length[F9FreeGraphGraphs=Select[bc9,F9FreeGraphQ]]//Timing

G27FreeGraphQ[g_Graph]:=IsomorphicSubgraphQ[g,GraphData["G27"]]===False

Length[G27FreeF9FreeGraphGraphs=Select[F9FreeGraphGraphs,G27FreeGraphQ]]//Timing

G27FreeF9FreeGraphGraphs

G27FreeF9FreeGraphGraphs={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};

rg=RecognizeGraph[#,"Cache"->"InternalOnly"]&/@G27FreeF9FreeGraphGraphs;

DeleteCases[rg,{}]

Count[rg,{}]

UnitDistanceGraphEmbeddingQ[GraphData[{"UnitDistance",{118,1}}]]

GraphData[{"UnitDistance",{118,1}},"Graph","All"]

GraphData[{"UnitDistance",{118,1}},"Graph","UnitDistance"]

g=GraphData[{"UnitDistance",{118,1}}];

N[EdgeLengths[g]-1,100]//Chop//Union

RootReduce[EdgeLengths[g]]//Union//Timing

Fix bad coordinate

g=GraphData[{"UnitDistance",{118,1}}];

ps=Position[N[EdgeLengths[g]-1,100]//Chop,_?(#≠0&)]//Flatten

EdgeList[g][[ps]]

v=GraphEmbedding[g];

v[[100]]

N[%]

eqn=SquaredEuclideanDistance[v[[#]],{x,y}]==1&/@{5,38,103}/.Abs:>Identity

NSolve[eqn,{x,y},Reals]

soln=Solve[Take[eqn,2],{x,y},Reals]//FullSimplify

goodsoln={x,y}/.soln[[1]]

goodsoln={(1/444) (37-(Sqrt[37 (-275+344 (Sqrt[33]))])),-(1/6) (Sqrt[(1/74) (341+50 (Sqrt[33])+5 (Sqrt[4477+1628 (Sqrt[33])]))])}

N[%]

g=SetProperty[GraphData[r={"UnitDistance",{118,1}}],VertexCoordinates->ReplacePart[GraphData[r,"Embeddings"][[1]],100->goodsoln]]

UnitDistanceGraphEmbeddingQ@g

N[EdgeLengths[g]-1,100]//Union

RootReduce[EdgeLengths[g]]//Union//Timing

BiconnectedComponentGraphs

BiconnectedComponentGraphs[GraphData[{"UnitDistance",{118,1}}]]

RecognizeGraph/@%

GraphPlot[]

Rotate[,-π/2]

GraphData[{"QuasiCubic",{9,14}},"Graph","All"]

Original scrape

GraphData[{"UnitDistance",{118,1}},"EmbeddingClasses"]

https://tinyurl.com/smallUDcode

soln=;

str=;

Length[pos=StringPosition[str,"sqrt("][[All,1]]]

ChangeParens[c_,p_]:=Module[{o=1,i=p+4},
While[o>0,
Switch[c[[++i]],"(",o++,")",o--,_,Null];
];
ReplacePart[c,{p->"S",p+4->"[",i->"]"}]
]

char=Characters[str];
Do[char=ChangeParens[char,p],{p,Take[pos,All]}];

str2="{{"<>StringTake[StringReplace[StringJoin[char],"), ("->"}, {"],{3,-3}]<>"}}";

G118coords=ToExpression[str2]

ByteCount[G118coords=]

ByteCount[G118coordsSimp=FullSimplify[G118coords]]//Timing

G118coordsSimp=;

G118edges=With[{v=G118coordsSimp},Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==1.&]]//Quiet

Length[G118edges]

G118=With[{v=G118coordsSimp},Graph[Range[Length[v]],UndirectedEdge@@@G118edges,VertexCoordinates->v]]

Through[{VertexCount,EdgeCount}[G118]]

UnitDistanceGraphQ[G118,WorkingPrecision->20]

UnitDistanceGraphQ[G118,WorkingPrecision->∞]//RootReduce//Timing

RecognizeGraph[G118]

{"UnitDistance", {126, 1}}

GraphData[{"UnitDistance",{126,1}},"Graph","MinimalCrossing"]

GraphData[{"UnitDistance",{126,1}},"Graph","Circular"]

GraphData[{"UnitDistance",{126,1}},"Graph","UnitDistance"]

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

GraphData[{"UnitDistance",{126,1}},"Graph","All"]

UnitDistanceGraphEmbeddingQ[,Debug->True]

EdgeLengths[%[[1]]]//FullSimplify//Union

GraphData["DeGreyGraph","EmbeddingClasses"]

Construction

edge length-1 subgraph of "DeGreyGraph126"

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/126"];

Length[v=ToExpression/@Import["g126.vtx","Lines"]]

Length[e=UnitEdges[v]]//Quiet//Timing

(G126=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

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

WriteString[file,GraphDataString[G126,
"StandardName"->{"UnitDistance",{126,1}},
"Name"->"126\[Hyphen]unit distance graph 1",
"Information"->"Unit-DistanceGraph",
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

{"UnitDistance", {210, 1}}

From Ed Pegg?

The big order 30 graph with 7 interconnected layers may have chromatic number 5.

This seems to be the largest Incestuous Unit Star Polygon, based on my analysis out to order 200.

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

GraphData[{"UnitDistance",{210,1}},"Graph","All"]

GraphData[{"UnitDistance",{210,1}},"Graph","UnitDistance"]

g=GraphData[{"UnitDistance",{210,1}},"Graph","UnitDistance"][[1]]

UnitDistanceGraphEmbeddingQ[g]

EdgeLengths[g]^2//FullSimplify//Union//Timing

Redo construction

210/30

Graphics[Point[GraphData[{"UnitDistance",{210,1}},"VertexCoordinates"]],Axes->True]

Sort[Norm/@GraphData[{"UnitDistance",{210,1}},"VertexCoordinates"]]

SortBy[1/Norm[{Sin[0 Pi/30],Cos[0 Pi/30]}-{Sin[#[[1,2]] Pi/30],Cos[#[[1,2]] Pi/30]}]&/@{{{0,4},{4,4}},{{0,4},{3,6}},{{0,6},{6,6}},{{0,6},{6,10}},{{0,6},{3,16}},{{0,6},{0,18}},{{0,8},{8,8}},{{0,8},{9,18}},{{0,10},{10,10}},{{0,10},{12,18}},{{0,16},{16,16}},{{0,18},{21,28}},{{0,28},{28,28}}}//FullSimplify//Union,N]

N[%]

SortBy[1/Norm[{Sin[0 Pi/30],Cos[0 Pi/30]}-{Sin[#[[2,2]] Pi/30],Cos[#[[2,2]] Pi/30]}]&/@{{{0,4},{4,4}},{{0,4},{3,6}},{{0,6},{6,6}},{{0,6},{6,10}},{{0,6},{3,16}},{{0,6},{0,18}},{{0,8},{8,8}},{{0,8},{9,18}},{{0,10},{10,10}},{{0,10},{12,18}},{{0,16},{16,16}},{{0,18},{21,28}},{{0,28},{28,28}}}//FullSimplify//Union,N]

N[%]

{Graphics[{Red,PointSize[.025],Point[newv=Join[
CirclePoints[{(1/2) Sec[(π/30)],π/2},30],
CirclePoints[(1/GoldenRatio),30],
CirclePoints[{(1/(Sqrt[2 (1+Sin[(π/30)])])),π/2},30],
CirclePoints[1,30],
CirclePoints[{(1/((Sqrt[2]) (Cos[((7 π)/60)]-Sin[((7 π)/60)]))),π/2},30],
CirclePoints[GoldenRatio,30],
CirclePoints[{(1/2) Csc[(π/15)],π/2},30]]]},Axes->True],Graphics[{Green,Point[GraphData[{"UnitDistance",{210,1}},"VertexCoordinates"]]},Axes->True]}

Show@%

e=Select[Subsets[Range[210],{2}],Abs[EuclideanDistance@@newv[[#]]-1]<1*^-5&]//Quiet;

Length[e]

GraphData[{"UnitDistance",{210,1}},"M"]

g=Graph[Range[210],UndirectedEdge@@@e,VertexCoordinates->newv]

g=;

r=RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

N[EdgeLengths[g]-1,100]//Chop//Union

EdgeLengths[g]//RootReduce//Union//Timing

r=RecognizeGraph[g];
origv=ToCommonEdges[g,GraphData[r]]

Original construction

g2=LinesToGraph[,.1,10^8.];

V[g2]

Graphics[Point[Vertices[g2]]]

Norm/@(Subtract@@@(Edges[g2]/.n_Integer:>Vertices[g2][[n]]))

RootReduce[Norm[{Sin[#[[1,1]] Pi/30],Cos[#[[1,1]] Pi/30]}/Norm[{Sin[0 Pi/30],Cos[0 Pi/30]}-{Sin[#[[1,2]] Pi/30],Cos[#[[1,2]] Pi/30]}]-{Sin[#[[2,1]] Pi/30],Cos[#[[2,1]] Pi/30]}/Norm[{Sin[0 Pi/30],Cos[0 Pi/30]}-{Sin[#[[2,2]] Pi/30],Cos[#[[2,2]] Pi/30]}]]&/@{{{0,4},{4,4}},{{0,4},{3,6}},{{0,6},{6,6}},{{0,6},{6,10}},{{0,6},{3,16}},{{0,6},{0,18}},{{0,8},{8,8}},{{0,8},{9,18}},{{0,10},{10,10}},{{0,10},{12,18}},{{0,16},{16,16}},{{0,18},{21,28}},{{0,28},{28,28}}}]

{"UnitDistance", {391, 1}}

From Ed Pegg?

GraphData[{"UnitDistance",{391,1}},"Graph","All"]

GraphData[{"UnitDistance",{391,1}},"Graph","UnitDistance"]

GraphData[{"UnitDistance",{391,1}},"EmbeddingClasses"]

g=GraphData[{"UnitDistance",{391,1}}];

N[EdgeLengths[g]-1,100]//Chop//Union

EdgeLengths[g]^2//RootReduce//Union//Timing

Redo

basepts={{0,1},{0,(1/2) ((Sqrt[5])-1)},{0,(1/2) ((Sqrt[5])+1)},{((Sqrt[3])/2),((Sqrt[5])/2)},{((Sqrt[3])/2),-((Sqrt[5])/2)},{Root[1-7 ((#1)^2)+14 ((#1)^4)-8 ((#1)^6)+((#1)^8)&,5],0},{Root[1-7 ((#1)^2)+14 ((#1)^4)-8 ((#1)^6)+((#1)^8)&,6],0},{Root[1-7 ((#1)^2)+14 ((#1)^4)-8 ((#1)^6)+((#1)^8)&,7],0},{Root[1-7 ((#1)^2)+14 ((#1)^4)-8 ((#1)^6)+((#1)^8)&,8],0},{Root[1-8 ((#1)^2)+14 ((#1)^4)-7 ((#1)^6)+((#1)^8)&,5],0},{Root[1-8 ((#1)^2)+14 ((#1)^4)-7 ((#1)^6)+((#1)^8)&,6],0},{Root[1-8 ((#1)^2)+14 ((#1)^4)-7 ((#1)^6)+((#1)^8)&,7],0},{Root[1-8 ((#1)^2)+14 ((#1)^4)-7 ((#1)^6)+((#1)^8)&,8],0}};

pts = Append[Flatten[Table[Print[k];Table[RootReduce[basepts[[k]].RotationMatrix[n Pi/15]],{n,0,29}],{k,13}],1],{0,0}];//Timing

baselines = {{1,1,5},{2,2,9},{3,3,3},{6,6,14},{7,7,8},{8,8,4},{9,9,2},{1,2,6},{1,2,24},{1,3,3},{1,3,27},{1,10,16},{1,10,29},{1,11,17},{1,11,28},{1,12,19},{1,12,26},{1,13,22},{1,13,23},{2,3,0},{2,4,0},{2,5,15},{2,6,3},{2,6,12},{2,8,18},{2,8,27},{2,10,5},{2,10,10},{2,12,20},{2,12,25},{3,4,0},{3,5,15},{3,7,21},{3,7,24},{3,9,21},{3,9,24},{3,11,20},{3,11,25},{3,13,20},{3,13,25},{4,6,28},{4,7,29},{4,8,22},{4,9,26},{4,10,26},{4,11,22},{4,12,29},{4,13,28},{5,6,2},{5,7,1},{5,8,8},{5,9,4},{5,10,4},{5,11,8},{5,12,1},{5,13,2},{6,11,8},{6,11,22},{6,12,1},{6,12,29},{7,10,11},{7,10,19},{7,11,7},{7,11,23},{8,10,4},{8,10,26},{8,13,2},{8,13,28},{9,12,1},{9,12,29},{9,13,2},{9,13,28}};

lines = Flatten[{Flatten[Table[Table[{30(baselines[[n,1]]-1) + k,30(baselines[[n,2]]-1)+ Mod[k+baselines[[n,3]],30,1]},{k,30}],{n,72}],1],Table[{b,391},{b,30}]},1];

g=Graph[Range[391],UndirectedEdge@@@lines,VertexCoordinates->pts]

r=RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

N[EdgeLengths[g]-1,100]//Union

Original construction

basepts ={{0, 1}, {0, (Sqrt[5] - 1)/2}, {0, (Sqrt[5] + 1)/2}, {Sqrt[3]/2, Sqrt[5]/2}, {Sqrt[3]/2, -Sqrt[5]/2},
{Root[1 - 7*#1^2 + 14*#1^4 - 8*#1^6 + #1^8 & , 5], 0}, {Root[1 - 7*#1^2 + 14*#1^4 - 8*#1^6 + #1^8 & , 6], 0}, 
{Root[1 - 7*#1^2 + 14*#1^4 - 8*#1^6 + #1^8 & , 7], 0}, {Root[1 - 7*#1^2 + 14*#1^4 - 8*#1^6 + #1^8 & , 8], 0}, 
{Root[1 - 8*#1^2 + 14*#1^4 - 7*#1^6 + #1^8 & , 5], 0}, {Root[1 - 8*#1^2 + 14*#1^4 - 7*#1^6 + #1^8 & , 6], 0}, 
{Root[1 - 8*#1^2 + 14*#1^4 - 7*#1^6 + #1^8 & , 7], 0}, {Root[1 - 8*#1^2 + 14*#1^4 - 7*#1^6 + #1^8 & , 8], 0}};

pts = Append[Flatten[Table[Table[RootReduce[basepts[[k]].RotationMatrix[n Pi/15]],{n,0,29}],{k,1,13}],1],{0,0}];

baselines = {{1,1,5},{2,2,9},{3,3,3},{6,6,14},{7,7,8},{8,8,4},{9,9,2},{1,2,6},{1,2,24},{1,3,3},{1,3,27},{1,10,16},{1,10,29},{1,11,17},{1,11,28},{1,12,19},{1,12,26},{1,13,22},{1,13,23},{2,3,0},{2,4,0},{2,5,15},{2,6,3},{2,6,12},{2,8,18},{2,8,27},{2,10,5},{2,10,10},{2,12,20},{2,12,25},{3,4,0},{3,5,15},{3,7,21},{3,7,24},{3,9,21},{3,9,24},{3,11,20},{3,11,25},{3,13,20},{3,13,25},{4,6,28},{4,7,29},{4,8,22},{4,9,26},{4,10,26},{4,11,22},{4,12,29},{4,13,28},{5,6,2},{5,7,1},{5,8,8},{5,9,4},{5,10,4},{5,11,8},{5,12,1},{5,13,2},{6,11,8},{6,11,22},{6,12,1},{6,12,29},{7,10,11},{7,10,19},{7,11,7},{7,11,23},{8,10,4},{8,10,26},{8,13,2},{8,13,28},{9,12,1},{9,12,29},{9,13,2},{9,13,28}};

lines = Flatten[{Flatten[Table[Table[{30(baselines[[n,1]]-1) + k,30(baselines[[n,2]]-1)+ Mod[k+baselines[[n,3]],30,1]},{k,1,30}],{n,1,72}],1],Table[{b,391},{b,1,30}]},1];

All vertices have a valence of 10 or higher.

g=Graphics[{Table[Line[pts[[#]]&/@lines[[nn]]],{nn,1,2190}],Red,Point/@pts}]

e=Cases[g,_Line,{1,∞}][[All,1]]/.Thread[pts->Range[Length[pts]]];

g=Graph[List/@e,List/@pts]

GraphPlot[g,Method->None]

Degrees[g]//Union

v=Vertices[g];

Norm/@(Subtract@@@(Edges[g]/.n_Integer:>v[[n]]))//N//Union

Norm/@(Subtract@@@(Edges[g]/.n_Integer:>v[[n]]))//FullSimplify//Union//Timing

FullSimplify[(Cases[g,_Line,{1,∞}]/.Line[x_]:>Norm[Subtract@@x])]//Union//Timing

Ed: This graph actually has Chromatic Number 3.  The unique coloring was tricky to find.

Doubled polygon edges

Code

DoubledEdgeUnitGraphVertices[n_,x_]:=Module[{
v=CirclePoints[(Sqrt[1-(x^2)])Sec[Pi/n],n],
v1=CirclePoints[{x+(Sqrt[1-(x^2)]),2π/n-π/2},n],
v2=CirclePoints[{-x+(Sqrt[1-(x^2)]),2π/n-π/2},n]
},
Join[v,v1,v2]/EuclideanDistance[v[[1]],v1[[1]]]]

DoubledEdgeUnitGraph[n_,x_]:=Module[{v=DoubledEdgeUnitGraphVertices[n,x],
e
},
e=Join[
Transpose[{Range[n],Range[n+1,2n]}],
Transpose[{Range[n],Range[2n+1,3n]}],
Transpose[{RotateLeft@Range[n],Range[n+1,2n]}],
Transpose[{RotateLeft@Range[n],Range[2n+1,3n]}]
];
System`Graph[Range[3n],UndirectedEdge@@@e,VertexCoordinates->FullSimplify[v],VertexLabels->"Name"]
]

Manipulate[DoubledEdgeUnitGraph[n,x],{{n,3},3,8,1},{{x,1/2},0,1}]

3

GraphData[{"EdgeTransitive",{9,14}},"Graph","All"]

GraphData[{"EdgeTransitive",{9,14}},"Graph","UnitDistance"]

GraphData[{"EdgeTransitive",{9,14}},"Graph","Matchstick"]

DoubledEdgeUnitGraph[3,#]&/@{1/2,.86}

RecognizeGraph/@%

GetGraphData[%[[1]],"File"]

GraphData[{"EdgeTransitive",{9,14}},"Graph","All"]

GraphData[{"EdgeTransitive",{9,14}},"EmbeddingClasses"]

g=DoubledEdgeUnitGraph[3,1/2]

<<MathWorld`Graphs`

UnitDistanceGraphQ[g,WorkingPrecision->∞]

gname=RecognizeGraph[g]

v=DoubledEdgeUnitGraphVertices[3,x];

FullSimplify[Dot[v[[1]]-v[[7]],v[[2]]-v[[7]]],0<x<1]

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

g=DoubledEdgeUnitGraph[3,((Sqrt[3])/2)]

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

gname=RecognizeGraph[g]

GraphData[gname,"Graph","All"]

4

GraphData[{"EdgeTransitive",{12,3}},"Graph","All"]

GraphData[{"EdgeTransitive",{12,3}},"Graph","UnitDistance"]

GraphData[{"EdgeTransitive",{12,3}},"Graph","Matchstick"]

DoubledEdgeUnitGraph[4,1/2]

DoubledEdgeUnitGraph[4,#]&/@{1/2,2/(Sqrt[5]),((Sqrt[2+(Sqrt[2])])/2)}

RecognizeGraph/@%

c/.x->1/2

Solve[Norm[v[[10]],2]==Norm[v[[8]],2],x]

N[%]

5

GraphData[{"EdgeTransitive",{15,5}},"Graph","All"]

GraphData[{"EdgeTransitive",{15,5}},"Graph","UnitDistance"]

GraphData[{"EdgeTransitive",{15,5}},"Graph","Matchstick"]

DoubledEdgeUnitGraph[5,1/2]

RecognizeGraph[%]

v=DoubledEdgeUnitGraphVertices[5,x];

Solve[v[[8,2]]==v[[3,2]],x]//FullSimplify

N[%]

g1=DoubledEdgeUnitGraph[5,(Sqrt[(5/58) (7-2 (Sqrt[5]))])]

g=System`Graph[VertexList[g1],EdgeList[g1],VertexCoordinates->({1,-1}#&/@GraphEmbedding[g1])]

gname=RecognizeGraph[g]

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

v=FullSimplify[DoubledEdgeUnitGraphVertices[5,x],0<x<1];

Solve[SquaredEuclideanDistance@@v[[{7,12}]]==1,x]//FullSimplify

g=DoubledEdgeUnitGraph[5,(Sqrt[(1/22) (10-3 (Sqrt[5]))])]

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

gname=RecognizeGraph[g]

6

GraphData[{"EdgeTransitive",{18,3}},"Graph","All"]

GraphData[{"EdgeTransitive",{18,3}},"Graph","UnitDistance"]

GraphData[{"EdgeTransitive",{18,3}},"Graph","Matchstick"]

DoubledEdgeUnitGraph[6,.3]

DoubledEdgeUnitGraph[6,#]&/@{.3,1/2,.896,.902}

RecognizeGraph[%]

v=DoubledEdgeUnitGraphVertices[6,x];

Solve[SquaredEuclideanDistance@@v[[{9,15}]]==1,x]

N[%]

g=DoubledEdgeUnitGraph[6,(1/(Sqrt[10]))]

gname=RecognizeGraph[g]

UnitDistanceGraphQ[g]

Solve[SquaredEuclideanDistance@@v[[{9,15}]]==SquaredEuclideanDistance@@v[[{3,4}]],x]

g=DoubledEdgeUnitGraph[6,1/2]

gname=RecognizeGraph[g]

UnitDistanceGraphQ[g]

Solve[v[[4,2]]==v[[18,2]],x]

g=DoubledEdgeUnitGraph[6,(2/(Sqrt[5]))]

gname=RecognizeGraph[g]

Solve[Norm[v[[4]],2]==Norm[v[[18]],2],x]

g=DoubledEdgeUnitGraph[6,(Sqrt[(11/26)+((3 (Sqrt[3]))/13)])]

gname=RecognizeGraph[g]

7

DoubledEdgeUnitGraph[7,.5]

RecognizeGraph[%]

8

DoubledEdgeUnitGraph[8,.5]

RecognizeGraph[%]

3D UD embeddings

By chromatic number

A 6-Chromatic Unit Distance Graph in Space
Lee, Thomas; Li, Stephanie

https://abstracts.societyforscience.org/Home/PrintPdf/9066

By rotating and transforming Nechushtan’s basic unit-distance graph with chromatic number 5, we construct an explicit unit-distance graph in 3 dimensions with chromatic number 6 that has only 79 vertices and 250 edges

(ud=Monitor[Select[GraphData["Connected"],!FreeQ[GraphData[g=#,"EmbeddingClasses3D"],"UnitDistance"]&],g])//Timing

TextGrid[{#[[1,1]],#[[All,2]]}&/@SplitBy[SortBy[GraphData[#,{"ChromaticNumber","#"}]&/@ud,First],First],Dividers->All]

3D UD embeddings of graphs that are  either not ot not known to be (2D) UD graphs via AdjacencyGraph

todo=SortBy[Select[GraphData[All],GraphData[#,"UnitDistance"]=!=True&&GraphData[#,"EmbeddingClasses3D"]==={}&],GraphData[#,"V"]&]

Length[todo]

This will skip (large) graphs with no embedding specified (so those must be run separately):

data=Monitor[
{g=#,SelectFirst[
UnitDistanceEmbeddingRefine/@Flatten[{GraphData[#,"Graph","3D"]}],
UnitDistanceGraphEmbeddingQ
]}&/@Take[todo,All],g];//Quiet//Timing

Length[ud3dgraphs=Cases[data,{_,_Graph}]]

ud3dgraphs[[All,1]]

TextGrid[ud3dgraphs,Dividers->All]

l={#,{0,{ToCommonEdges[#2,GraphData[#]]}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l,"Embeddings3D","13.1"]

RenameGraphFiles[]

l2={#,{0,{{"Integral","MinimalIntegral","Primary","UnitDistance"}}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l2,"EmbeddingClasses3D","13.1"]

RenameGraphFiles[]

3D UD embeddings of graphs that are  either not ot not known to be (2D) UD graphs via Graph[edge list] (5s)

todo=SortBy[Select[GraphData[All],GraphData[#,"UnitDistance"]=!=True&&GraphData[#,"EmbeddingClasses3D"]==={}&],GraphData[#,"V"]&]

Length[todo]

data=Monitor[
{g=#,
SelectFirst[
{TimeConstrained[UnitDistanceEmbeddingRefine[Graph3D[GraphData[#,"Edges"]]],5]},
UnitDistanceGraphEmbeddingQ
]}&/@Take[todo,All],
g];//Quiet//Timing

Length[ud3dgraphs=Cases[data,{_,_Graph}]]

ud3dgraphs[[All,1]]

TextGrid[ud3dgraphs,Dividers->All]

l={#,{0,{ToCommonEdges[#2,GraphData[#]]}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l,"Embeddings3D","13.1"]

RenameGraphFiles[]

l2={#,{0,{{"Integral","MinimalIntegral","Primary","UnitDistance"}}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l2,"EmbeddingClasses3D","13.1"]

RenameGraphFiles[]

3D UD embeddings of graphs that are  either not ot not known to be (2D) UD graphs via Graph[edge list] (60 s)

todo=SortBy[Select[GraphData[All],GraphData[#,"UnitDistance"]=!=True&&GraphData[#,"EmbeddingClasses3D"]==={}&],GraphData[#,"V"]&]

Length[todo]

data=Monitor[
{g=#,
SelectFirst[
{TimeConstrained[UnitDistanceEmbeddingRefine[Graph3D[GraphData[#,"Edges"]]],60]},
UnitDistanceGraphEmbeddingQ
]}&/@Take[todo,All],
g];//Quiet//Timing

Length[ud3dgraphs=Cases[data,{_,_Graph}]]

ud3dgraphs[[All,1]]

TextGrid[ud3dgraphs,Dividers->All]

l={#,{0,{ToCommonEdges[#2,GraphData[#]]}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l,"Embeddings3D","13.1"]

RenameGraphFiles[]

l2={#,{0,{{"Integral","MinimalIntegral","Primary","UnitDistance"}}}}&@@@Take[ud3dgraphs,All];

PropertyReplace[l2,"EmbeddingClasses3D","13.1"]

RenameGraphFiles[]

Tests

Embedding claimed to be UD but isn't

Monitor[Select[GraphData[{"Connected","UnitDistance"},;;10],(ud=GraphData[g=#,"Graph","UnitDistance"])=!={}&&UnitDistanceGraphQ[ud[[1]]]=!=True&],g]

UD but no UD embedding (connected non-tree)

udbutnoembedding=Select[Complement[GraphData["Connected"],GraphData["Tree"]],GraphData[#,"UnitDistance"]===True&&FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Length[udbutnoembedding]

(#->GraphData[#])&/@udbutnoembedding

UD but no UD embedding (all)

udbutnoembedding=Select[GraphData[All],GraphData[#,"UnitDistance"]===True&&FreeQ[GraphData[#,"EmbeddingClasses"],"UnitDistance"]&]

Length[udbutnoembedding]

(#->GraphData[#])&/@udbutnoembedding

Chromatic number > 7 but UD =!= False

Select[GraphData[All],IntegerQ[chi=GraphData[#,"ChromaticNumber"]]&&chi>7&&GraphData[#,"UnitDistance"]=!=False&]

Contains a forbidden subgraph but UD =!= False

Monitor[Select[GraphData[;;8],!EdgeInducedSubgraphFreeQ[GraphData[g=#],ForbiddenGraphs]===True&&GraphData[#,"UnitDistance"]=!=False&],g]//Timing

Monitor[Select[GraphData[9],!EdgeInducedSubgraphFreeQ[GraphData[g=#],ForbiddenGraphs]===True&&GraphData[#,"UnitDistance"]=!=False&],g]//Timing

Dimension unknown

Needs to include the forbidden graphs on n nodes that are non-minimal (by adding edges to other forbidden graphs with same vertex count)

(nodim=SortBy[Monitor[Select[GraphData["Connected",;;12],Head[GraphData[#,"Dimension"]]===Missing&&GraphData[#,"ChromaticNumber"]<8&&VertexInducedSubgraphFreeQ[GraphData[g=#],ForbiddenGraphs]&],g],GraphData[#,"V"]&])//Timing

Slow:

(nodim=SortBy[Monitor[Select[GraphData["Connected",;;12],Head[GraphData[#,"Dimension"]]===Missing&&GraphData[#,"ChromaticNumber"]<8&&EdgeInducedSubgraphFreeQ[GraphData[g=#],ForbiddenGraphs]&],g],GraphData[#,"V"]&])//Timing

Length[nodim]

(#->If[!PlanarGraphQ[g=GraphData[#]]||DegenerateEmbeddingQ[p=PlanarGraph[g]],g,Column[{g,p},Dividers->All]])&/@nodim