Sousselier Graph

Author

Eric W. Weisstein
January 17, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/GraphTheory/SousselierGraph.nb.

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

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

Figure

GraphicsGrid[Partition[GraphData["SousselierGraph","Graph","All"]//StyleGraphs,UpTo[4]],Dividers->All]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["SousselierGraph","StandardName"]

GraphData["SousselierGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["SousselierGraph","EdgeList"]]

Default embedding

GraphPlot@RotateGraph[Graph@GraphData["SousselierGraph","Edges"],-Pi/2]

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

RecognizeGraph[g]

GraphPlot@RotateGraph[Graph[GraphData["SousselierGraph","Edges"],GraphLayout->"HighDimensionalEmbedding",VertexLabels->None],-Pi/2]

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

RecognizeGraph[g]

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

RecognizeGraph[g]

gs={,};

Degenerate

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

DegenerateGraphEmbeddingTypes/@GraphData["SousselierGraph","Graph","Degenerate"]

Bilateral

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

Circular

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

Planar

GraphData["SousselierGraph","Planar"]

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

MinimalCrossing

GraphData["SousselierGraph",{"RCN","CN"}]

GraphData["SousselierGraph","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

GraphPlot@RotateGraph[,3Pi/4]

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

RecognizeGraph@g

RectilinearCrossingCount[g]

BilateralGraphEmbeddingQ[g]

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

Table[MinimalCrossingGraph[GraphData["SousselierGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,500}]//Union

GraphPlot@

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["SousselierGraph"],"CrossingNumber"->5],Pi-1.25]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["SousselierGraph","Circulant"]

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

Line graph

GraphData["SousselierGraph","Line"]

LineGraphQ[GraphData["SousselierGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["SousselierGraph"]]

Halin

GraphData["SousselierGraph","Halin"]

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

Rigid

GraphData["SousselierGraph","Rigid"]

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

Flexible

GraphData["SousselierGraph","Flexible"]

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

LCF

GraphData["SousselierGraph","LCF"]

GraphData["SousselierGraph","HamiltonianCycleCount"]

GraphData["SousselierGraph","LCFSignature"]

GraphData["SousselierGraph","LCFNotations"]

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

UnitDistance

GraphData["SousselierGraph","UnitDistance"]

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

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

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

UnitDistance construction NSolve Method->"Homotopy", WorkingPrecision->Infinity

g0=;

Clear[a,b,c,d,e,f,g,h,k,l]

v={{0,z+1},{g,h},{1/2,l},{i,j},{c,d},{-e,f},{a,b},{-1/2,0},{1/2,0},{-a,b},{e,f},{-c,d},{-i,j},{-1/2,l},{-g,h},{0,z}};
eqn=UnitEdgeEquations[v,EdgeList[g0]]//FullSimplify//Union

eqn//Column//TraditionalForm

Graph[Range@Length@v,EdgeList[g0],VertexCoordinates->GraphEmbedding[g0],VertexLabels->Thread[Range[Length@v]->(MatrixForm/@v)],BaseStyle->Directive[14,FontFamily->"Times"]]

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

$Version

(nsoln=NSolve[eqn,var,Reals,Method->"Homotopy",WorkingPrecision->Infinity])//Timing

Some exact roots couldn't be found based on the numeric ones.  Possibly because the approximation is not good enough, but also the root may have multiplicity higher than one. The method for validating system roots works only for simple roots.

Precision/@nsoln[[All,1]]

Length[nsoln]

polys=Subtract@@@eqn;

Max[Abs[polys/.nsoln]]//Quiet

Numerical with WorkingPrecision ->50 + FindSystemRoot

(nsoln=NSolve[eqn,var,Reals,WorkingPrecision->50])//Timing

Length[nsoln]

polys=Subtract@@@eqn;

Max[Abs[polys/.nsoln]]

sols=var/.nsoln;

Length[usols=Union[sols,SameTest->(Norm[#1-#2]<1/10&)]]

This  proves (using interval arithmetic) that the numeric solutions approximate actual solutions, hence there are at least 68 real solutions:

In the below, $Failed means that exact roots couldn't be found based on the numeric ones.  Possibly because the approximation is not good enough, but also the root may have multiplicity higher than one. The method for validating system roots works only for simple roots.

(rts=Reduce`FindSystemRoot[polys,var,#,True,45]&/@usols)//Timing

Cases[rts,$Failed]//Length

Length[goodrts=DeleteCases[rts,$Failed]]

Element[var/.goodrts,Reals]

Precision[goodrts]

Position[DistanceMatrix[N[var/.goodrts,100]],_?(#<1/10&)]

Union[Subtract@@@%]

Max[Abs[N[Subtract@@@eqn/.goodrts,10^3]]]//Timing

degen=Select[MapIndexed[#2[[1]]->Graph[Range[Length@v],EdgeList[g0],VertexCoordinates->(v/.#)]&,goodrts],DegenerateGraphEmbeddingQ[#[[2]],"Type"->"VertexVertex"]&]

Length[degen]

ud=Select[MapIndexed[#2[[1]]->Graph[Range[Length@v],EdgeList[g0],VertexCoordinates->(v/.#)]&,goodrts],UnitDistanceGraphEmbeddingQ[#[[2]]]&]

Length[ud]

ByteCount/@ud

Symbolic:

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

Ran overnight

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["SousselierGraph","VertexList"],GraphData["SousselierGraph","EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData["SousselierGraph"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData["SousselierGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["SousselierGraph","Matchstick"]

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

3D default

Graph3D[GraphData["SousselierGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["SousselierGraph","Polyhedral"]

GraphData

GraphDataClassString

GraphDataClassString["SousselierGraph"]