Haugstrup Graphs

Author

Eric W. Weisstein
January 6, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/GroupTheory/HaugstrupGraphs.nb.

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

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

Figures

TextGrid[Sort@DeleteCases[{
GraphData[#,"V"],
#,
Cases[
GraphData[#,"StandardNames"],
_String?(StringMatchQ[___~~"Haugstrup"~~___])
]
}&/@GraphData[All],{__,{}}],
Dividers->All]

GraphicsRow[Table[With[{lab=ToString[n]},Annotate[StyleGraphs@GraphData["HaugstrupGraph"<>lab,"Graph",If[MatchQ[n,47|48],"3D",Sequence@@{}]],PlotLabel->"Haugstrup graph "<>lab]],{n,{21,31,47,48}}],
BaseStyle->InsetBoxOptions->{BaseStyle->Directive[LightDarkSwitched@Black,14,Italic,FontFamily->"Times"]},
Dividers->All,
Alignment->Top
]

Subgraphs

{"UnitDistance", {126, 1}}]

FindIsomorphicSubgraph[GraphData[{"UnitDistance",{126,1}}],GraphData["HaugstrupGraph31"]]//StyleGraphs

Embeddings

<<MathWorld`Graphs`

"HaugstrupGraph21" == "DecagonMycielskianGraph"

Names

GraphData["HaugstrupGraph21","StandardName"]

GraphData["HaugstrupGraph21","StandardNames"]

"HaugstrupGraph31"

Names

GraphData["HaugstrupGraph31","StandardName"]

GraphData["HaugstrupGraph31","StandardNames"]

HouseOfGraphs

hogid=GraphData["HaugstrupGraph31","NotationRules","HouseOfGraphs"]

HouseOfGraphsLookup[hogid]

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

Primary

GraphData["HaugstrupGraph31"]//StyleGraphs[#,ImageSize->Small]&

All

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

CurvedEdge

GraphData["HaugstrupGraph31","Graph","CurvedEdge"]//StyleGraphs

Inexact

Select[GraphData["HaugstrupGraph31","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Degenerate

GraphData["HaugstrupGraph31","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["HaugstrupGraph31","Graph","Degenerate"]//Column

Embeddings

GraphDataEmbeddings[GraphData["HaugstrupGraph31"]]

Default embedding

GraphPlot[Graph[GraphData["HaugstrupGraph31","VertexList"],GraphData["HaugstrupGraph31","Edges"]]]

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

g=FindCorrespondingGraph[,v]

RecognizeGraph@g

GeneralizedPetersen

GraphData["HaugstrupGraph31","Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData["HaugstrupGraph31","Graph","IGraph"]//StyleGraphs

Bipartite embedding

GraphData["HaugstrupGraph31","Bipartite"]

g=Graph[GraphData["HaugstrupGraph31","VertexList"],GraphData["HaugstrupGraph31","Edges"],GraphLayout->"BipartiteEmbedding"]

Bilateral

GraphData["HaugstrupGraph31","Graph","Bilateral"]//StyleGraphs

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

Circular

GraphData["HaugstrupGraph31","Graph","Circular"]//StyleGraphs

Circular construction 10^3 [8 s]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph31"],10^3][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph31"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction 10^4 [83 s]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph31"],10^4][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph31"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction 10^5 [802 s]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph31"],10^5][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph31"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction 10^6 [4637 + 34032 s; 30 GB]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph31"],10^6][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph31"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

MaxMemoryUsed[]/10^9. GB

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction All

GraphData["HaugstrupGraph31","Hamiltonian"]

GraphData["HaugstrupGraph31","LCF"]

GraphData["HaugstrupGraph31","HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph31"],All][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph31"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Planar

GraphData["HaugstrupGraph31","Planar"]

GraphData["HaugstrupGraph31","Graph","Planar"]//StyleGraphs

MinimalCrossingNumber crossings.uos.de [failed]

CrossingNumber[GraphData["HaugstrupGraph31"],Method->"WebCompute"]//AbsoluteTiming

DateString[]

MinimalCrossingNumber: "EmbeddingScheme" -> 1

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->1,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 2

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->2,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 3

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],"EmbeddingScheme"->3,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossing

GraphData["HaugstrupGraph31","CN"]

(gs=GraphData["HaugstrupGraph31","Graph","MinimalCrossing"])//StyleGraphs

GraphCrossingCount/@gs

GraphCrossingDiagram/@gs

MinimalRectilinearCrossing

GraphData["HaugstrupGraph31","RCN"]

GraphData["HaugstrupGraph31","Graph","MinimalRectilinearCrossing"]//StyleGraphs

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["HaugstrupGraph31"],Automatic,All,"Size"->Automatic,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

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

Take[gs,UpTo[100]]

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["HaugstrupGraph31"],Automatic,All,"Size"->XXX,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

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

Take[gs,UpTo[100]]

MinimalCrossing construction Tutte

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],TimeConstraint->1])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["HaugstrupGraph31"],"CrossingNumber"->cn])//PolyhedralGraphQ//AbsoluteTiming

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

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

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

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

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

Select[SymmetricEmbeddingsWithOperations[[All,1]],Count[OuterFace[#],_?(GreaterThan[GraphData["HaugstrupGraph31","V"]])]==0&]

MinimalCrossing construction Random 1000

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["HaugstrupGraph31"],"CrossingNumber"->cn,RandomSeed->n],{n,1000}]//Union);//Timing

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

Small numbers of crossing points on the boundary:

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

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

Symmetric embeddings:

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

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

MinimalCrossing construction Random 20000

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["HaugstrupGraph31"],"CrossingNumber"->cn,RandomSeed->n],{n,20000}]//Union);//Timing

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

Small numbers of crossing points on the boundary:

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

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

Symmetric embeddings:

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

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

MinimalLocalCrossing

GraphData["HaugstrupGraph31",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["HaugstrupGraph31","Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData["HaugstrupGraph31",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["HaugstrupGraph31","Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction 1000

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

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],TimeConstraint->10])//AbsoluteTiming

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

MinimaRectilinearlLocalCrossing construction 20000

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

(cn=CrossingNumber[GraphData["HaugstrupGraph31"],TimeConstraint->10])//AbsoluteTiming

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

Circulant

GraphData["HaugstrupGraph31","Circulant"]

GraphData["HaugstrupGraph31","Graph","Circulant"]//StyleGraphs

Circulant construction

GraphData["HaugstrupGraph31","NotationRules","Circulant"]

(ci=CirculantIndices[GraphData["HaugstrupGraph31"]])//Timing

CirculantGraph1@@@ci

Cases[GraphData["HaugstrupGraph31","StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData["HaugstrupGraph31","ComplementGraph","Name"]

Line graph

GraphData["HaugstrupGraph31","Line"]

LineGraphQ[GraphData["HaugstrupGraph31"]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]==="HaugstrupGraph31"&]

RootGraph[GraphData["HaugstrupGraph31"]]

Halin

GraphData["HaugstrupGraph31","Halin"]

GraphData["HaugstrupGraph31","Graph","Halin"]//StyleGraphs

Rigid

GraphData["HaugstrupGraph31","Rigid"]

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

Flexible

GraphData["HaugstrupGraph31","Flexible"]

GraphData["HaugstrupGraph31","Graph","Flexible"]//StyleGraphs

LCF

GraphData["HaugstrupGraph31","LCF"]

GraphData["HaugstrupGraph31","HamiltonianCycleCount"]

GraphData["HaugstrupGraph31","LCFSignature"]

GraphData["HaugstrupGraph31","LCFNotations"]

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

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

UnitDistance

GraphData["HaugstrupGraph31","UnitDistance"]

UnitDistanceGraphQ[GraphData["HaugstrupGraph31"],Debug->True]//Timing

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

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

UnitDistance by refinement of default embeddings

Graph[edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["HaugstrupGraph31","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

Graph[vertex list, edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["HaugstrupGraph31","VertexList"],GraphData["HaugstrupGraph31","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

UnitDistance by refinement of existing embeddings

gs=UnitDistanceEmbeddingRefine[#,MaxIterations->500]&/@Complement@@(GraphData["HaugstrupGraph31","Graph",#]&/@{"All","UnitDistance"})

TextGrid[
gdata=SortBy[
{#,DegenerateGraphEmbeddingQ[#],GraphSymmetryGroup[#],Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
],
Dividers->All
]

Cases[gdata,{__,0.}]

Symmetric:

gs=Cases[
gdata,
{g_,_,sym:Except[TransformationGroup[{}]],diff_}:>{
HighlightGraph[g1=BilateralGraph[CenterGraph[g],"ReturnNonbilateralGraph"->True],Flatten[FindCoincidentVertices[g1]]],
sym,
diff
}]

UnitDistance by FindUnitDistanceEmbedding  (random embeddings returning on messages)

gs=FindUnitDistanceEmbedding[GraphData["HaugstrupGraph31"],50,"ReturnWithMessage"->True];//Quiet//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

SymmetricEmebddings=Select[gdata,GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]&]

UnitDistance by FindUnitDistanceEmbedding  (random embedding waiting until UD is found)

FindUnitDistanceEmbedding[GraphData["HaugstrupGraph31"],"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{$Version,DateString[]}

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

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

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

Matchstick

GraphData["HaugstrupGraph31","Matchstick"]

GraphData["HaugstrupGraph31","Graph","Matchstick"]//StyleGraphs

3D default

g=Graph3D[GraphData["HaugstrupGraph31","Edges"]]

EdgeLengths[g]

3D construction

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

RecognizeGraph[g]

3D All

GraphData["HaugstrupGraph31","Graph",{"3D","All"}]

3D UnitDistance construction Random

GraphData["HaugstrupGraph31","Dimension"]

(g=UnitDistanceEmbeddingRefine[
Graph3D[
GraphData["HaugstrupGraph31","VertexList"],
GraphData["HaugstrupGraph31","EdgeList"]
],
WorkingPrecision->25])//Timing

Abs[EdgeLengths[g]-1]//Max

UnitDistanceGraphEmbeddingQ[g]

3D UnitDistance

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

3D Polyhedron

GraphData["HaugstrupGraph31","Polyhedral"]

GraphData["HaugstrupGraph31","Graph",{"3D","Polyhedron"}]

"HaugstrupGraph32"

Names

GraphData["HaugstrupGraph32","StandardName"]

GraphData["HaugstrupGraph32","StandardNames"]

"HaugstrupGraph47" == "DeGreyHaugstrupGraph47"

Names

GraphData["HaugstrupGraph47","StandardName"]

GraphData["HaugstrupGraph47","StandardNames"]

"HaugstrupGraph48"

Names

GraphData["HaugstrupGraph48","StandardName"]

GraphData["HaugstrupGraph48","StandardNames"]

HouseOfGraphs

hogid=GraphData["HaugstrupGraph48","NotationRules","HouseOfGraphs"]

HouseOfGraphsLookup[hogid]

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

Wikidata

GraphData["HaugstrupGraph48","WikidataID"]

GraphData["HaugstrupGraph48","WikidataURL"]

Primary

GraphData["HaugstrupGraph48"]//StyleGraphs[#,ImageSize->Small]&

All

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

CurvedEdge

GraphData["HaugstrupGraph48","Graph","CurvedEdge"]//StyleGraphs

Inexact

Select[GraphData["HaugstrupGraph48","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Degenerate

GraphData["HaugstrupGraph48","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["HaugstrupGraph48","Graph","Degenerate"]//Column

Embeddings

GraphDataEmbeddings[GraphData["HaugstrupGraph48"]]

Default embedding

g0=GraphPlot[Graph[GraphData["HaugstrupGraph48","VertexList"],GraphData["HaugstrupGraph48","Edges"]]]

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

g=FindCorrespondingGraph[,v]

RecognizeGraph@g

GeneralizedPetersen

GraphData["HaugstrupGraph48","Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData["HaugstrupGraph48","Graph","IGraph"]//StyleGraphs

CompleteKPartite

GraphData["HaugstrupGraph48","Graph","CompleteKPartite"]//StyleGraphs

Bipartite

GraphData["HaugstrupGraph48","Bipartite"]

GraphData["HaugstrupGraph48","Graph","Bipartite"]

Bilateral

GraphData["HaugstrupGraph48","Graph","Bilateral"]//StyleGraphs

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

Circular

GraphData["HaugstrupGraph48","Graph","Circular"]//StyleGraphs

Circular construction 10^3

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph48"],10^3][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph48"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction 10^4 [161 s]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph48"],10^4][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph48"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Circular construction 10^5 [78 + 1620 s; 8.5 GB]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph48"],10^5][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph48"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

MaxMemoryUsed[]/10^9.GB

Circular construction 10^6 []

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph48"],10^6][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph48"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

MaxMemoryUsed[]/10^9.GB

Quit

Circular construction All

GraphData["HaugstrupGraph48","Hamiltonian"]

GraphData["HaugstrupGraph48","LCF"]

GraphData["HaugstrupGraph48","HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData["HaugstrupGraph48"],All][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["HaugstrupGraph48"],#]&/@hc);//Timing

GraphWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[GraphWithSymmetryGroups[[All,-1]]]//Column

(BilateralOrRotationalGraphs={BilateralGraph[#,"ReturnNonbilateralGraph"->True],#2}&@@@SortBy[
DeleteCases[GraphWithSymmetryGroups,{_,TransformationGroup[{}]}],
{MatchQ[#[[2]],TransformationGroup[{_Rotation,r_Reflection}|{r_Reflection|_Rotation}]],FirstCase[#[[2]],Rotation[{0,0},r_]:>N[r/π],{},{0,∞}]}&
])//Timing

Length[SymmetricGraphs=DeleteDuplicatesBy[BilateralOrRotationalGraphs,CircularCanonicalGraphEmbedding[#[[1]]]&]]//Timing

SymmetricGraphs

Length[BilateralGraphs=Select[SymmetricGraphs,!FreeQ[#,Reflection]&][[All,1]]]

BilateralGraphs

Length[BilateralAndRotationalGraphs=Select[SymmetricGraphs,And[!FreeQ[#,Rotation],!FreeQ[#,Reflection]]&][[All,1]]]

BilateralAndRotationalGraphs

Planar

GraphData["HaugstrupGraph48","Planar"]

GraphData["HaugstrupGraph48","Graph","Planar"]//StyleGraphs

MinimalCrossingNumber crossings.uos.de

CrossingNumber[GraphData["HaugstrupGraph48"],Method->"WebCompute"]//AbsoluteTiming

DateString[]

MinimalCrossingNumber: "EmbeddingScheme" -> 1

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->1,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 2

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->2,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 3

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],"EmbeddingScheme"->3,TimeConstraint->86400])//AbsoluteTiming

Quit

MinimalCrossing

GraphData["HaugstrupGraph48","CN"]

(gs=GraphData["HaugstrupGraph48","Graph","MinimalCrossing"])//StyleGraphs

GraphCrossingCount/@gs

GraphCrossingDiagram/@gs

MinimalRectilinearCrossing

GraphData["HaugstrupGraph48","RCN"]

GraphData["HaugstrupGraph48","Graph","MinimalRectilinearCrossing"]//StyleGraphs

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["HaugstrupGraph48"],Automatic,All,"Size"->Automatic,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

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

Take[gs,UpTo[100]]

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["HaugstrupGraph48"],Automatic,All,"Size"->XXX,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

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

Take[gs,UpTo[100]]

MinimalCrossing construction Tutte

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],TimeConstraint->1])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["HaugstrupGraph48"],"CrossingNumber"->cn])//PolyhedralGraphQ//AbsoluteTiming

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

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

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

LocalCrossingNumberWithEmbeddings=
{1+Max[Length/@DeleteCases[
Drop[AdjacencyList[#],GraphData["HaugstrupGraph48","V"]],
_Integer?(LessEqualThan[GraphData["HaugstrupGraph48","V"]]),
{2}
]],#}&/@TutteGraphs

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

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

Select[SymmetricEmbeddingsWithOrientations[[All,1]],Count[OuterFace[#],_?(GreaterThan[GraphData["HaugstrupGraph48","V"]])]==0&]

MinimalCrossing construction Random 1k

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["HaugstrupGraph48"],"CrossingNumber"->cn,RandomSeed->n],{n,1000}]//Union);//Timing

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

Small numbers of crossing points on the boundary:

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

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

Symmetric embeddings:

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

MaxMemoryUsed[]/10^9.GB

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

MinimalCrossing construction Random 20k

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["HaugstrupGraph48"],"CrossingNumber"->cn,RandomSeed->n],{n,20000}]//Union);//Timing

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

Small numbers of crossing points on the boundary:

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

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

Symmetric embeddings:

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

MaxMemoryUsed[]/10^9.GB

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

MinimalLocalCrossing

GraphData["HaugstrupGraph48",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["HaugstrupGraph48","Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData["HaugstrupGraph48",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["HaugstrupGraph48","Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction 1000

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

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],TimeConstraint->10])//AbsoluteTiming

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

MinimaRectilinearlLocalCrossing construction 20000

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

(cn=CrossingNumber[GraphData["HaugstrupGraph48"],TimeConstraint->10])//AbsoluteTiming

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

Circulant

GraphData["HaugstrupGraph48","Circulant"]

GraphData["HaugstrupGraph48","Graph","Circulant"]//StyleGraphs

Circulant construction

GraphData["HaugstrupGraph48","NotationRules","Circulant"]

(ci=CirculantIndices[GraphData["HaugstrupGraph48"]])//Timing

CirculantGraph1@@@ci

Cases[GraphData["HaugstrupGraph48","StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData["HaugstrupGraph48","ComplementGraph","Name"]

Line graph

GraphData["HaugstrupGraph48","Line"]

LineGraphQ[GraphData["HaugstrupGraph48"]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]==="HaugstrupGraph48"&]

RootGraph[GraphData["HaugstrupGraph48"]]

Halin

GraphData["HaugstrupGraph48","Halin"]

GraphData["HaugstrupGraph48","Graph","Halin"]//StyleGraphs

Rigid

GraphData["HaugstrupGraph48","Rigid"]

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

Flexible

GraphData["HaugstrupGraph48","Flexible"]

GraphData["HaugstrupGraph48","Graph","Flexible"]//StyleGraphs

LCF

GraphData["HaugstrupGraph48","LCF"]

GraphData["HaugstrupGraph48","HamiltonianCycleCount"]

GraphData["HaugstrupGraph48","LCFSignature"]

GraphData["HaugstrupGraph48","LCFNotations"]

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

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

UnitDistance

GraphData["HaugstrupGraph48","UnitDistance"]

UnitDistanceGraphQ[GraphData["HaugstrupGraph48"],Debug->True]//Timing

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

UnitDistance by refinement of default embeddings

Graph[edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["HaugstrupGraph48","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

Graph[vertex list, edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["HaugstrupGraph48","VertexList"],GraphData["HaugstrupGraph48","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

UnitDistance by refinement of existing embeddings

gs=UnitDistanceEmbeddingRefine[#,MaxIterations->500]&/@Complement@@(GraphData["HaugstrupGraph48","Graph",#]&/@{"All","UnitDistance"})

TextGrid[
gdata=SortBy[
{#,DegenerateGraphEmbeddingQ[#],GraphSymmetryGroup[#],Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
],
Dividers->All
]

Cases[gdata,{__,0.}]

Symmetric:

gs=Cases[
gdata,
{g_,_,sym:Except[TransformationGroup[{}]],diff_}:>{
HighlightGraph[g1=BilateralGraph[CenterGraph[g],"ReturnNonbilateralGraph"->True],Flatten[FindCoincidentVertices[g1]]],
sym,
diff
}]

UnitDistance by refinement of stored LCF embeddings

FileByteCount[file="/Volumes/GraphProperties/Properties/LCFNotations/"<>GraphNameToFileName["HaugstrupGraph48"]<>".gz"]

Tally[(lcf=Import[file])[[All,-1]]]//Timing//AbsoluteTiming

lcf=LCFNotation/@nicelcfgs;

gs=UnitDistanceEmbeddingRefine[LCFGraph@@#,MaxIterations->500]&/@lcf;//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

NondegenerateSymmetricGraphs=Select[
gdata,
And[
DegenerateGraphEmbeddingQ[#[[1]]]===False,
GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]
]&
]/.g_Graph:>CenterGraph[g]

UnitDistance by FindUnitDistanceEmbedding  (random embeddings returning on messages)

gs=FindUnitDistanceEmbedding[GraphData["HaugstrupGraph48"],50,"ReturnWithMessage"->True];//Quiet//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

SymmetricEmebddings=Select[gdata,GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]&]

UnitDistance by FindUnitDistanceEmbedding  (random embedding waiting until UD is found)

FindUnitDistanceEmbedding[GraphData["HaugstrupGraph48"],"ReturnWithMessage"->False]//Quiet//Timing

Matchstick

GraphData["HaugstrupGraph48","Matchstick"]

GraphData["HaugstrupGraph48","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["HaugstrupGraph48","Edges"]]

3D construction

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

RecognizeGraph[g]

3D All

GraphData["HaugstrupGraph48","Graph",{"3D","All"}]

3D UnitDistance construction Random

GraphData["HaugstrupGraph48","Dimension"]

(g=UnitDistanceEmbeddingRefine[
Graph3D[
GraphData["HaugstrupGraph48","VertexList"],
GraphData["HaugstrupGraph48","EdgeList"]
],
WorkingPrecision->25])//Timing

EdgeLengths[g]

UnitDistanceGraphEmbeddingQ[g]

3D UnitDistance

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

3D Polyhedron

GraphData["HaugstrupGraph48","Polyhedral"]

GraphData["HaugstrupGraph48","Graph",{"3D","Polyhedron"}]

"HaugstrupGraph21217" [too big to add]

Haugstrup, A.  ``A Tetrahedron-Free 6-Chromatic Unit-Distance Graph in Three-Dimensional Space.''  {\it Geombinatorics} {\bf 35}, 2026.

Construction

"HaugstrupGraph21" == "DecagonMycielskianGraph"

Haugstrup, A.  ``A Tetrahedron-Free 6-Chromatic Unit-Distance Graph in Three-Dimensional Space.''  {\it Geombinatorics} {\bf 35}, 2026.

RotateGraph[GraphData["DecagonMycielskianGraph"],Pi/10]//StyleGraphs

"HaugstrupGraph31"

Haugstrup, A.  ``A Tetrahedron-Free 6-Chromatic Unit-Distance Graph in Three-Dimensional Space.''  {\it Geombinatorics} {\bf 35}, 2026.

None of these:

G31s=GraphData[{"Connected","UnitDistance","Cyclic"},31]

GraphData[#,"Graph","UnitDistance"][[1]]&/@G31s

g0=RotateGraph[GraphData["DecagonMycielskianGraph"],Pi/10]//StyleGraphs

v=Join[FullSimplify[GraphEmbedding[g0]],CirclePoints[{1/GoldenRatio,Pi/2},10]];
G31=Graph[Range@Length@v,UnitEdges[v],VertexCoordinates->v]

UnitDistanceGraphEmbeddingQ[G31]

RecognizeGraph@G31

"HaugstrupGraph32"

Haugstrup, A.  ``A Tetrahedron-Free 6-Chromatic Unit-Distance Graph in Three-Dimensional Space.''  {\it Geombinatorics} {\bf 35}, 2026.

G32=Select[GraphData["Connected",32],GraphData[#,"Dimension"]==3&]

"HaugstrupGraph47" == "DeGreyHaugstrupGraph47"

G47=Select[GraphData[47],GraphData[#,"Dimension"]==3&]

GraphData["DeGreyHaugstrupGraph47","Graph","3D"]

"HaugstrupGraph48"

Email

From: Asger Haugstrup <asghau@outlook.dk>
 Subject: Graph48 with corrections and more exact coordinates
 Date: 2 January 2026 at 01:23:09 GMT-8
 To: Aubrey de Grey <aubrey@levf.org>

 (*48-vertex 6-chromatic unit distance graph in R^3*)
 coords = {
    (*Coordinates for the 21-vertex scaffold graph*)
    {0, 0, 0},
    {-(5*Sqrt[2001])/261, 40*Sqrt[87]/261, 0},
    {(5*Sqrt[2001])/261, 40*Sqrt[87]/261, 0},
    {0, Sqrt[87]/6, 1/2},
    {0, Sqrt[87]/6, -1/2},
    {-Sqrt[2001]/87, 13/(2 Sqrt[87]), 1/2},
    {-Sqrt[2001]/87, 13/(2 Sqrt[87]), -1/2},
    {Sqrt[2001]/87, 13/(2 Sqrt[87]), 1/2},
    {Sqrt[2001]/87, 13/(2 Sqrt[87]), -1/2},
    {Sqrt[2001]/58, 163/(16*Sqrt[87]), 15/16},
    {Sqrt[23/87]/2, 35/(16 Sqrt[87]), 15/16},
    {-(3 Sqrt[2] + Sqrt[23])/(2 Sqrt[87]), (61/8 - (3 Sqrt[23/2])/8)/
      Sqrt[87], -1/8 - Sqrt[23/2]/8},
    {Sqrt[3/58] - Sqrt[23/87]/2, (61/8 + (3 Sqrt[23/2])/8)/Sqrt[87],
     Sqrt[23/2]/8 - 1/8},
    {-(3 Sqrt[2] + Sqrt[23])/(2 Sqrt[87]), (61/8 - (3 Sqrt[23/2])/8)/
      Sqrt[87], 1/8 + Sqrt[23/2]/8},
    {Sqrt[3/58] - Sqrt[23/87]/2, (61/8 + (3 Sqrt[23/2])/8)/Sqrt[87],
     1/8 - Sqrt[23/2]/8},
    {(1/174) (Sqrt[2001] - 3 Sqrt[174]), (61/8 + (3 Sqrt[23/2])/8)/
      Sqrt[87], Sqrt[23/2]/8 - 1/8},
    {Sqrt[3/58] + Sqrt[23/87]/2, (61/8 - (3 Sqrt[23/2])/8)/
      Sqrt[87], -1/8 - Sqrt[23/2]/8},
    {(1/174) (Sqrt[2001] - 3 Sqrt[174]), (61/8 + (3 Sqrt[23/2])/8)/
      Sqrt[87], 1/8 - Sqrt[23/2]/8},
    {Sqrt[3/58] + Sqrt[23/87]/2, (61/8 - (3 Sqrt[23/2])/8)/Sqrt[87],
     1/8 + Sqrt[23/2]/8},
    {(7 Sqrt[23/87])/8 - (15 Sqrt[3/58])/
       8, (419/64 + (45 Sqrt[23/2])/64)/Sqrt[87],
     15/64 + Sqrt[23/2]/64},
    {(15 Sqrt[3/58])/8 + (7 Sqrt[23/87])/
       8, (419/64 - (45 Sqrt[23/2])/64)/Sqrt[87],
     15/64 - Sqrt[23/2]/64},
    
    
    (*Coordinates for the clamps: 9x3=27 vertices:*)
    (*First clamp. Connects to possible monochromatic 1,2 and 3*)
    {-1517/(60 Sqrt[2001]),
     5617/(480 Sqrt[87]), -Sqrt[520679/23]/160},
    {-0.115709, 1.623928, -0.127024},
    {0.432970, 1.295007, -0.895634},
    {0.223418, 0.871171, 0.437201},
    {0.772096, 0.542250, -0.331409},
    {-0.633702, 0.770583, -0.067999},
    {0.236721, 0.794139, -0.559738},
    {-0.091274, 0.990765, -0.100270},
    {-0.031368, 0.409496, -0.911773},
    
    (*Second clamp. Connects to possible monochromatic 1,10 and 5*)
    {-0.714925, 1.492670, 0.196457},
    {-0.211846, 1.252181, 1.026563},
    {0.279611, 1.593046, 0.225139},
    {0.217109, 0.356578, 0.908689},
    {0.708566, 0.697444, 0.107265},
    {-0.676744, 0.540559, 0.499814},
    {0.141866, 0.981134, 0.131341},
    {-0.151923, 0.777367, 0.610426},
    {-0.137226, 0.914758, -0.379982},
    
    (*Third clamp. Connects to possible monochromatic 3,7 and 11*)
    {0.747094, -0.222094, 0.194944},
    {-0.161880, 0.185213, 0.283644},
    {0.239898, 0.051558, -0.622287},
    {-0.095969, 1.176159, 0.166677},
    {0.305809, 1.042504, -0.739254},
    {0.497404, 0.569659, -0.362535},
    {0.641163, 0.676227, 0.621323},
    {0.257224, 0.649557, 0.179023},
    {1.082232, 0.529501, -0.373200}
    
    };

 edges = {
    4 <-> 5, 2 <-> 4, 2 <-> 5, 3 <-> 4, 3 <-> 5, 4 <-> 6, 4 <-> 8,
    5 <-> 7, 5 <-> 9, 6 <-> 7, 8 <-> 9, 1 <-> 6, 1 <-> 7, 1 <-> 8,
    1 <-> 9, 10 <-> 3, 10 <-> 4, 10 <-> 11, 11 <-> 6, 11 <-> 1,
    12 <-> 13, 12 <-> 1, 12 <-> 2, 12 <-> 5, 12 <-> 9, 13 <-> 1,
    13 <-> 2, 13 <-> 5, 13 <-> 9, 14 <-> 15, 14 <-> 1, 14 <-> 2,
    14 <-> 4, 14 <-> 8, 15 <-> 1, 15 <-> 2, 15 <-> 4, 15 <-> 8,
    16 <-> 17, 16 <-> 1, 16 <-> 3, 16 <-> 5, 16 <-> 7, 17 <-> 1,
    17 <-> 3, 17 <-> 5, 17 <-> 7, 18 <-> 19, 18 <-> 1, 18 <-> 3,
    18 <-> 4, 18 <-> 6, 19 <-> 1, 19 <-> 3, 19 <-> 4, 19 <-> 6,
    20 <-> 21, 20 <-> 1, 20 <-> 3, 20 <-> 10, 20 <-> 11, 21 <-> 1,
    21 <-> 3, 21 <-> 10, 21 <-> 11, 2 <-> 22, 22 <-> 23, 23 <-> 24,
    22 <-> 24, 3 <-> 23, 3 <-> 24, 23 <-> 25, 24 <-> 26, 25 <-> 26,
    1 <-> 25, 1 <-> 26, 1 <-> 27, 22 <-> 27, 23 <-> 27, 25 <-> 27,
    27 <-> 28, 1 <-> 28, 22 <-> 28, 23 <-> 28, 25 <-> 28, 29 <-> 30,
    29 <-> 1, 29 <-> 24, 29 <-> 26, 29 <-> 22, 30 <-> 1, 30 <-> 24,
    30 <-> 26, 30 <-> 22, 31 <-> 5, 31 <-> 32, 32 <-> 33, 31 <-> 33,
    32 <-> 10, 33 <-> 10, 32 <-> 34, 34 <-> 35, 35 <-> 33, 1 <-> 34,
    1 <-> 35, 36 <-> 1, 36 <-> 32, 36 <-> 34, 36 <-> 31, 36 <-> 37,
    37 <-> 1, 37 <-> 32, 37 <-> 34, 37 <-> 31, 38 <-> 39, 38 <-> 31,
    38 <-> 33, 38 <-> 35, 38 <-> 1, 39 <-> 31, 39 <-> 33, 39 <-> 35,
    39 <-> 1, 11 <-> 40, 40 <-> 41, 41 <-> 42, 40 <-> 42, 41 <-> 7,
    42 <-> 7, 41 <-> 43, 43 <-> 44, 44 <-> 42, 43 <-> 3, 44 <-> 3,
    45 <-> 40, 45 <-> 41, 45 <-> 43, 45 <-> 3, 45 <-> 46, 46 <-> 40,
    46 <-> 41, 46 <-> 43, 46 <-> 3, 47 <-> 3, 47 <-> 42, 47 <-> 44,
    47 <-> 40, 48 <-> 47, 48 <-> 3, 48 <-> 42, 48 <-> 44, 48 <-> 40
    };

 (*A possible 6-coloring*)
 colors = {
    Green, Blue, Brown, Green, Red, Yellow, Brown, Red, Blue, Red,
    Brown, Yellow, Brown, Brown, Yellow, Blue, Yellow, Red, Blue,
    Yellow, Blue, Yellow, Red, Green, Yellow, Brown, Blue, Brown, Red,
    Blue, Green, Brown, Yellow, Yellow, Red, Red, Blue, Brown, Blue,
    Yellow, Red, Green, Yellow, Blue, Blue, Green, Red, Purple
    };

 (*Create the 3D graph*)
 graph = Graph3D[Range[Length[coords]], edges,
    VertexCoordinates -> coords,
    VertexStyle -> Thread[Range[Length[coords]] -> colors]];


 (*Display the graph*)
 Show[graph]

 (*Create the graph with vertex labels*)
 graphWithLabels =
   Graph3D[Range[Length[coords]], edges, VertexCoordinates -> coords,
    VertexStyle -> Thread[Range[Length[coords]] -> colors],
    VertexLabels -> "Name"];

 (*Display the graph with vertex labels*)
 Show[graphWithLabels]

 EdgeCount[graph]
 VertexCount[graph]



 edgePairs = List @@@ edges;

 edgeDistances =
   N[EuclideanDistance[coords[[#1]], coords[[#2]]]] & @@@ edgePairs;

 Thread[edgePairs -> edgeDistances]

(*48-vertex 6-chromatic unit distance graph in R^3*)
coords={
(*Coordinates for the 21-vertex scaffold graph*)
{0,0,0},{-(5*Sqrt[2001])/261,40*Sqrt[87]/261,0},{(5*Sqrt[2001])/261,40*Sqrt[87]/261,0},{0,Sqrt[87]/6,1/2},{0,Sqrt[87]/6,-1/2},{-Sqrt[2001]/87,13/(2 Sqrt[87]),1/2},{-Sqrt[2001]/87,13/(2 Sqrt[87]),-1/2},{Sqrt[2001]/87,13/(2 Sqrt[87]),1/2},{Sqrt[2001]/87,13/(2 Sqrt[87]),-1/2},{Sqrt[2001]/58,163/(16*Sqrt[87]),15/16},{Sqrt[23/87]/2,35/(16 Sqrt[87]),15/16},{-(3 Sqrt[2]+Sqrt[23])/(2 Sqrt[87]),(61/8-(3 Sqrt[23/2])/8)/Sqrt[87],-1/8-Sqrt[23/2]/8},{Sqrt[3/58]-Sqrt[23/87]/2,(61/8+(3 Sqrt[23/2])/8)/Sqrt[87],Sqrt[23/2]/8-1/8},{-(3 Sqrt[2]+Sqrt[23])/(2 Sqrt[87]),(61/8-(3 Sqrt[23/2])/8)/Sqrt[87],1/8+Sqrt[23/2]/8},{Sqrt[3/58]-Sqrt[23/87]/2,(61/8+(3 Sqrt[23/2])/8)/Sqrt[87],1/8-Sqrt[23/2]/8},{(1/174) (Sqrt[2001]-3 Sqrt[174]),(61/8+(3 Sqrt[23/2])/8)/Sqrt[87],Sqrt[23/2]/8-1/8},{Sqrt[3/58]+Sqrt[23/87]/2,(61/8-(3 Sqrt[23/2])/8)/Sqrt[87],-1/8-Sqrt[23/2]/8},{(1/174) (Sqrt[2001]-3 Sqrt[174]),(61/8+(3 Sqrt[23/2])/8)/Sqrt[87],1/8-Sqrt[23/2]/8},{Sqrt[3/58]+Sqrt[23/87]/2,(61/8-(3 Sqrt[23/2])/8)/Sqrt[87],1/8+Sqrt[23/2]/8},{(7 Sqrt[23/87])/8-(15 Sqrt[3/58])/8,(419/64+(45 Sqrt[23/2])/64)/Sqrt[87],15/64+Sqrt[23/2]/64},{(15 Sqrt[3/58])/8+(7 Sqrt[23/87])/8,(419/64-(45 Sqrt[23/2])/64)/Sqrt[87],15/64-Sqrt[23/2]/64},

(*Coordinates for the clamps:9x3=27 vertices:*)
(*First clamp.Connects to possible monochromatic 1,2 and 3*)
{-1517/(60 Sqrt[2001]),5617/(480 Sqrt[87]),-Sqrt[520679/23]/160},{-0.115709,1.623928,-0.127024},{0.432970,1.295007,-0.895634},{0.223418,0.871171,0.437201},{0.772096,0.542250,-0.331409},{-0.633702,0.770583,-0.067999},{0.236721,0.794139,-0.559738},{-0.091274,0.990765,-0.100270},{-0.031368,0.409496,-0.911773},
(*Second clamp.Connects to possible monochromatic 1,10 and 5*)
{-0.714925,1.492670,0.196457},{-0.211846,1.252181,1.026563},{0.279611,1.593046,0.225139},{0.217109,0.356578,0.908689},{0.708566,0.697444,0.107265},{-0.676744,0.540559,0.499814},{0.141866,0.981134,0.131341},{-0.151923,0.777367,0.610426},{-0.137226,0.914758,-0.379982},
(*Third clamp.Connects to possible monochromatic 3,7 and 11*)
{0.747094,-0.222094,0.194944},{-0.161880,0.185213,0.283644},{0.239898,0.051558,-0.622287},{-0.095969,1.176159,0.166677},{0.305809,1.042504,-0.739254},{0.497404,0.569659,-0.362535},{0.641163,0.676227,0.621323},{0.257224,0.649557,0.179023},{1.082232,0.529501,-0.373200}
};

Length[coords]

Length[ee=List@@@UnitEdges[coords]]

Length[edges=Sort[Sort/@{{4,5},{2,4},{2,5},{3,4},{3,5},{4,6},{4,8},{5,7},{5,9},{6,7},{8,9},{1,6},{1,7},{1,8},{1,9},{10,3},{10,4},{10,11},{11,6},{11,1},{12,13},{12,1},{12,2},{12,5},{12,9},{13,1},{13,2},{13,5},{13,9},{14,15},{14,1},{14,2},{14,4},{14,8},{15,1},{15,2},{15,4},{15,8},{16,17},{16,1},{16,3},{16,5},{16,7},{17,1},{17,3},{17,5},{17,7},{18,19},{18,1},{18,3},{18,4},{18,6},{19,1},{19,3},{19,4},{19,6},{20,21},{20,1},{20,3},{20,10},{20,11},{21,1},{21,3},{21,10},{21,11},{2,22},{22,23},{23,24},{22,24},{3,23},{3,24},{23,25},{24,26},{25,26},{1,25},{1,26},{1,27},{22,27},{23,27},{25,27},{27,28},{1,28},{22,28},{23,28},{25,28},{29,30},{29,1},{29,24},{29,26},{29,22},{30,1},{30,24},{30,26},{30,22},{31,5},{31,32},{32,33},{31,33},{32,10},{33,10},{32,34},{34,35},{35,33},{1,34},{1,35},{36,1},{36,32},{36,34},{36,31},{36,37},{37,1},{37,32},{37,34},{37,31},{38,39},{38,31},{38,33},{38,35},{38,1},{39,31},{39,33},{39,35},{39,1},{11,40},{40,41},{41,42},{40,42},{41,7},{42,7},{41,43},{43,44},{44,42},{43,3},{44,3},{45,40},{45,41},{45,43},{45,3},{45,46},{46,40},{46,41},{46,43},{46,3},{47,3},{47,42},{47,44},{47,40},{48,47},{48,3},{48,42},{48,44},{48,40}}]]

Complement[ee,edges]

Complement[edges,ee]

Abs[EuclideanDistance@@coords[[{25,26}]]-1]

g0=Graph[Range@Length@coords,UndirectedEdge@@@edges,VertexCoordinates->coords]

Max[Abs[N[EdgeLengths[g0],20]-1]]

VertexChromaticNumber[g0]

RecognizeGraph@g0

Vertex-minimal

<<IGraphM`

Select[Range[48],VertexChromaticNumber[VertexDelete[g0,#]]==6&]//Timing

Select[Range[48],IGChromaticNumber[VertexDelete[g0,#]]==6&]//Timing

Edge-minimal

Select[edges,VertexChromaticNumber[EdgeDelete[g0,UndirectedEdge@@#]]==6&]//Timing

Select[edges,IGChromaticNumber[EdgeDelete[g0,UndirectedEdge@@#]]==6&]//Timing

g1=EdgeDelete[g0,UndirectedEdge@@@{{23,24},{32,33},{41,42}}]

VertexChromaticNumber[g1]

IGChromaticNumber[g1]

UnitDistanceGraphEmbeddingQ[g1]

Refined

(g2=UnitDistanceEmbeddingRefine[g1])//Timing

UnitDistanceGraphEmbeddingQ[g2]

High-precision refined

(g3=UnitDistanceEmbeddingRefine[g2,WorkingPrecision->20000])//Quiet//Timing

Exactified

v=GraphEmbedding[g3];

Do[Print[{i,ToAlgebraicRoot[#,WorkingPrecision->2000,"MaxDegree"->32]&/@v[[i]]//Timing}],{i,35}];

Do[Print[{i,(ToAlgebraicRoot[#,WorkingPrecision->5000,"MaxDegree"->32]/.n_?InexactNumberQ:>N[n])&/@v[[i]]//Timing}],{i,36,48}];

eminimal={{1,6},{1,7},{1,8},{1,9},{1,11},{1,12},{1,13},{1,14},{1,15},{1,16},{1,17},{1,18},{1,19},{1,20},{1,21},{1,25},{1,26},{1,27},{1,28},{1,29},{1,30},{1,34},{1,35},{1,36},{1,37},{1,38},{1,39},{2,4},{2,5},{2,12},{2,13},{2,14},{2,15},{2,22},{3,4},{3,5},{3,10},{3,16},{3,17},{3,18},{3,19},{3,20},{3,21},{3,23},{3,24},{3,43},{3,44},{3,45},{3,46},{3,47},{3,48},{4,5},{4,6},{4,8},{4,10},{4,14},{4,15},{4,18},{4,19},{5,7},{5,9},{5,12},{5,13},{5,16},{5,17},{5,31},{6,7},{6,11},{6,18},{6,19},{7,16},{7,17},{7,41},{7,42},{8,9},{8,14},{8,15},{9,12},{9,13},{10,11},{10,20},{10,21},{10,32},{10,33},{11,20},{11,21},{11,40},{12,13},{14,15},{16,17},{18,19},{20,21},{22,23},{22,24},{22,27},{22,28},{22,29},{22,30},{23,25},{23,27},{23,28},{24,26},{24,29},{24,30},{25,26},{25,27},{25,28},{26,29},{26,30},{27,28},{29,30},{31,32},{31,33},{31,36},{31,37},{31,38},{31,39},{32,34},{32,36},{32,37},{33,35},{33,38},{33,39},{34,35},{34,36},{34,37},{35,38},{35,39},{36,37},{38,39},{40,41},{40,42},{40,45},{40,46},{40,47},{40,48},{41,43},{41,45},{41,46},{42,44},{42,47},{42,48},{43,44},{43,45},{43,46},{44,47},{44,48},{45,46},{47,48}};

vexact={{0,0,0},{-((5 (Sqrt[(23/87)]))/3),(40/(3 (Sqrt[87]))),0},{((5 (Sqrt[(23/87)]))/3),(40/(3 (Sqrt[87]))),0},{0,((Sqrt[(29/3)])/2),(1/2)},{0,((Sqrt[(29/3)])/2),-(1/2)},{-(Sqrt[(23/87)]),(13/(2 (Sqrt[87]))),(1/2)},{-(Sqrt[(23/87)]),(13/(2 (Sqrt[87]))),-(1/2)},{(Sqrt[(23/87)]),(13/(2 (Sqrt[87]))),(1/2)},{(Sqrt[(23/87)]),(13/(2 (Sqrt[87]))),-(1/2)},{((Sqrt[(69/29)])/2),(163/(16 (Sqrt[87]))),(15/16)},{((Sqrt[(23/87)])/2),(35/(16 (Sqrt[87]))),(15/16)},{,,(1/16) (-2-(Sqrt[46]))},{,,(1/16) (-2+(Sqrt[46]))},{,,(1/16) (2+(Sqrt[46]))},{,,(1/16) (2-(Sqrt[46]))},{,,(1/16) (-2+(Sqrt[46]))},{,,(1/16) (-2-(Sqrt[46]))},{,,(1/16) (2-(Sqrt[46]))},{,,(1/16) (2+(Sqrt[46]))},{,,(1/128) (30+(Sqrt[46]))},{,,(1/128) (30-(Sqrt[46]))},{-(1517/(60 (Sqrt[2001]))),(5617/(480 (Sqrt[87]))),-((Sqrt[(520679/23)])/160)},{,,((226279-87 (Sqrt[11975617]))/588800)},{,,((-226279-87 (Sqrt[11975617]))/588800)},{,,((226279+9 (Sqrt[11975617]))/588800)},{,,((-226279+9 (Sqrt[11975617]))/588800)},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,},{,,}};

g=Graph[Range[48],UndirectedEdge@@@eminimal,VertexCoordinates->vexact]

Through[{VertexCount,EdgeCount}[g]]

VertexChromaticNumber[g]

IGChromaticNumber[g]

UnitDistanceGraphEmbeddingQ[g]

Max[Abs[N[EdgeLengths[g],10^4]-1]]//Timing

Max[Abs[N[EdgeLengths[g],10^5]-1]]//Timing

HaugstrupGraph48=;

GraphData

GraphDataClassString

GraphDataClassString[Intersection@@(GraphData[#,"Classes"]&/@GraphData["*Haugstrup*"])]

GraphDataString

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

Close[file]