Rectilinear Crossing Number

Author

Eric W. Weisstein
June 11, 2021

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

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

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

Counts

FillinZeros[l_]:=Module[{s=l[[All,1]]},
Union[l,{#,0}&/@Complement[Range@@MinMax[s],s]]
]

All

Exoo contains wrong values of RCN=CN=2 for 9 connected graphs on 9 nodes which actually have RCN=CN=1

Select[GraphData[;;4],FreeQ[GraphData[#,"EmbeddingClasses"],"MinimalRectilinearCrossing"]&]

Select[GraphData[5],FreeQ[GraphData[#,"EmbeddingClasses"],"MinimalRectilinearCrossing"]&]

Table[Sort[Tally[CrossingNumber[GraphData[#,"Graph","MinimalRectilinearCrossing"][[1]]]&/@GraphData[n]]],{n,4}]//Column

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/RectilinearCrossingNumber"];
(tallies=Tally[Sort[Get[#]]]&/@FileNames["*.m"])//Column

(cnts=FillinZeros/@tallies)//Column

A298445

cnts[[All,All,2]]//Column

Flatten[cnts[[All,All,2]]]

Connected

Exoo contains wrong values of RCN=CN=2 for 9 connected graphs on 9 nodes which actually have RCN=CN=1

Select[GraphData["Connected",;;4],FreeQ[GraphData[#,"EmbeddingClasses"],"MinimalRectilinearCrossing"]&]

Select[GraphData["Connected",5],FreeQ[GraphData[#,"EmbeddingClasses"],"MinimalRectilinearCrossing"]&]

Table[Sort[Tally[CrossingNumber[GraphData[#,"Graph","MinimalRectilinearCrossing"][[1]]]&/@GraphData["Connected",n]]],{n,4}]//Column

StringTake[StringCases[FileNames["*"],NumberString][[1]],{2,-2}]

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/RectilinearCrossingNumber"];
(tallies=Tally[Sort[Get[#][[ConnectedGraphIndices[FromDigits[StringTake[StringCases[#,NumberString][[1]],{2,-2}]]]]]]]&/@FileNames["*.m"])//Column

(cnts=FillinZeros/@tallies)//Column

A298446

cnts[[All,All,2]]//Column

Flatten[cnts[[All,All,2]]]

Parametrized families

GraphDataCountTable["RectilinearCrossingNumber",{"Complete"->014540}]

Andrasfai

seq=Table[GraphData[{"Andrasfai",n},"RectilinearCrossingNumber"],{n,10}]

Antiprism

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

seq=Table[GraphData[{"Antiprism",n},"RectilinearCrossingNumber"],{n,3,20}]

Apollonian

seq=Table[GraphData[{"Apollonian",n},"RectilinearCrossingNumber"],{n,6}]

BananaTree

Block[{m,n},DeleteCases[{#,{m,n}="BananaTree"/.GraphData[#,"NotationRules"];0,GraphData[#,"RectilinearCrossingNumber"]}&/@GraphData["BananaTree"],{_,x_,x_}]]

Bishop n×n

seq=Table[GraphData[{"Bishop",{n,n}},"RectilinearCrossingNumber"],{n,10}]

BlackBishop n×n

seq=Table[GraphData[{"BlackBishop",{n,n}},"RectilinearCrossingNumber"],{n,2,10}]

Complete

A014540

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

seq=Table[GraphData[{"Complete",n},"RectilinearCrossingNumber"],{n,20}]

seq={0,0,0,0,1,3,9,19,36,62,102,153,229,324,447,603,798,1029,1318,1657,2055,2528,3077,3699,4430,5250,6180};

CompleteBipartite m×n

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

seq=Table[GraphData[{"CompleteBipartite",{m,n}},"RectilinearCrossingNumber"],{n,20},{m,n}]//Column//TraditionalForm

CompleteBipartite n×n

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

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

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

CompleteTripartite k×m×n

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

seq=Table[{GraphData[{"CompleteTripartite",{k,m,n}},"RectilinearCrossingNumber"]},{n,10},{m,n},{k,m}]

CompleteTripartite n×n×n

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

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

CrossedPrism

seq=Table[GraphData[{"CrossedPrism",2n},"RectilinearCrossingNumber"],{n,2,10}]

Table[GraphData[{"CrossedPrism",2n}],{n,2,5}]

Crown

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

CubeConnectedCycle

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

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

Cycle

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

seq=Table[GraphData[{"Cycle",n},"RectilinearCrossingNumber"],{n,3,20}]

Empty

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

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

FibonacciCube

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

Table[GraphData[{"FibonacciCube",n},"Planar"],{n,15}]

FoldedCube

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

Grid m×n

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

Table[GraphData[{"Grid",{m,n}},"RectilinearCrossingNumber"],{n,10},{m,n}]//Column

Grid n×n

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

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

Grid k×m×n

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

seq=Table[GraphData[{"Grid",{n,n,n}},"RectilinearCrossingNumber"],{n,10},{m,n},{k,m}]//TraditionalForm

Grid n×n×n

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

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

HalvedCube

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

Hanoi

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

Hypercube

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

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

Keller

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

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

King m×n

Table[GraphData[{"King",{m,n}},"RectilinearCrossingNumber"],{n,10},{m,n}]//Column//TraditionalForm

King n×n

seq=Table[GraphData[{"King",{n,n}},"RectilinearCrossingNumber"],{n,10}]

Knight m×n

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

seq=Table[GraphData[{"Knight",{m,n}},"RectilinearCrossingNumber"],{n,10},{m,n}]//Column//TraditionalForm

Knight n×n

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

seq=Table[GraphData[{"Knight",{n,n}},"RectilinearCrossingNumber"],{n,10}]

Ladder

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

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

LadderRung

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

MengerSponge

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

MoebiusLadder

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

seq=Table[GraphData[{"MoebiusLadder",n},"RectilinearCrossingNumber"],{n,3,20}]

Mycielski

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

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

Odd

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

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

Path

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

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

Prism

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

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

Queen n×n

seq=Table[GraphData[{"Queen",{n,n}},"RectilinearCrossingNumber"],{n,10}]

Rook n×n

seq=Table[GraphData[{"Rook",{n,n}},"RectilinearCrossingNumber"],{n,10}]

RookComplement n×n

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

SierpinskiCarpet

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

SierpinskiSieve

seq=Table[GraphData[{"SierpinskiSieve",n},"RectilinearCrossingNumber"],{n,5}]

SierpinskiTetrahedron

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

Star

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

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

Tetrahedral

seq=Table[GraphData[{"Tetrahedral",n},"RectilinearCrossingNumber"],{n,6,10}]

TorusGrid m×n

Table[GraphData[{"TorusGrid",{m,n}},"RectilinearCrossingNumber"],{n,3,10},{m,3,n}]//Column//TraditionalForm

TorusGrid n×n

seq=Table[GraphData[{"TorusGrid",{n,n}},"RectilinearCrossingNumber"],{n,3,10}]

Triangular

seq=Table[GraphData[{"Triangular",n},"RectilinearCrossingNumber"],{n,2,10}]

TriangularGrid

TriangularHoneycombQueen

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

TriangularHoneycombRook

(∑_k^n)rcn(k)

seq=Table[GraphData[{"TriangularHoneycombRook",n},"RectilinearCrossingNumber"],{n,10}]

Transposition

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

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

Wheel

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

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

WhiteBishop n×n

seq=Table[GraphData[{"WhiteBishop",{n,n}},"RectilinearCrossingNumber"],{n,2,10}]

Famous (cubic) graphs

Rectilinear Drawings of Famous Graphs

PetersenGraph

proved

GraphData[g="PetersenGraph","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

HeawoodGraph

proved

GraphData[g="HeawoodGraph","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

McGeeGraph

conjectured?

GraphData[g="McGeeGraph","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

CoxeterGraph

https://arxiv.org/pdf/1804.10336.pdf
says "It is known that the Coxeter graph [2] on 28 vertices has crossing number 11,"

GraphData[g="CoxeterGraph","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

SetDirectory["/Users/eww/Downloads/quickcross"]

RecognizeGraph[g=Import["coxeter_graph6.txt","Graph6"]]

VertexList[g]

e=EdgeList[g]

e===UndirectedEdge@@@Import["coxeter_edgelist.txt","Table"]

v=Import["coxeter_coords.txt","Table"]

SetProperty[g,VertexCoordinates->v]

RectilinearCrossingNumber[%]

SetDirectory["eww"]

Export["coxeter.g6",StringReplace[ExportString[GraphData["CoxeterGraph"],"Graph6"],">>graph6<<"->""],"String"]

GraphData["CoxeterGraph","Graph","MinimalRectilinearCrossing"]

Export["coxeter_coords.txt",GraphEmbedding@GraphData["CoxeterGraph","Graph","MinimalRectilinearCrossing"][[1]],"Table","FieldSeparators"->" "]

QC crashes on this

GraphData["CoxeterGraph","Graph"]

Export["coxeter_coords_circ.txt",GraphEmbedding@GraphData["CoxeterGraph","Graph"],"Table","FieldSeparators"->" "]

QC incorrectly gives CR : 3 for this

LeviGraph

https://arxiv.org/pdf/1804.10336.pdf
says "It is known that ... the Levi graph [9] on 30 vertices has crossing number 13."

GraphData["Tutte8Cage","#"]

GraphData[g="LeviGraph","RectilinearCrossingNumber"]

GraphData[g="LeviGraph","CrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

RobertsonGraph

conjectured?

GraphData[{"Cage",{4,5}},"#"]

GraphData[g="RobertsonGraph","RectilinearCrossingNumber"]

GraphData[g,"V"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

img=;

ImageDimensions[img]

Length[lines=ImageLines[img,.5,.03,MaxFeatures->19,Method->{"Segmented"->True}]]

HighlightImage[img,lines]

DominantColors[img]

img2=ColorReplace[img,{Red->White,Black->White}]

Length[lines=ImageLines[img2,0,.03,MaxFeatures->19,Method->{"Segmented"->True}]]

HighlightImage[img2,lines]

ClebschGraph

conjectured?

GraphData[{"Cage",{4,5}},"#"]

GraphData[g="ClebschGraph","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

Tutte12Cage

conjectured?

GraphData[g="Tutte12Cage","RectilinearCrossingNumber"]

GraphData[g,"Graph","MinimalRectilinearCrossing"]

RectilinearCrossingNumber/@%

Exoo

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Exoo"]

files=FileNames["*.txt"]

Utility Functions

FromUR[l_]:=Module[{n=(1/2) (1+(Sqrt[1+8 StringLength[l]])),i,m,d=ToExpression[Characters[l]]},
m=Append[Table[Join[Table[0,{n-i}],d[[-((i+1)i/2);;-(i(i-1)/2+1)]]],{i,n-1,1,-1}],Table[0,{n}]];
AdjacencyGraph[m+Transpose[m]]
]
ToUR[l_]:=Module[{n=Length[l],i},Table[Take[l[[i]],-(n-i)],{i,8}]]

Read Data in Exoo format/order

6-crossing

(new6=Monitor[
DeleteCases[
{g=RecognizeGraph[FromUR[#]],
GraphData[g,"RectilinearCrossingNumber"],
FromDigits[#2]
}&@@@(StringSplit/@Import["gconn6.txt","Lines"]),
{_,x_,x_}],
g])//Timing

7-crossing

(new7=Monitor[DeleteCases[
{g=RecognizeGraph[FromUR[#]],
GraphData[g,"RectilinearCrossingNumber"],
FromDigits[#2]
}&@@@(StringSplit/@Import["gconn7.txt","Lines"]),
{_,x_,x_}],
g])//Timing

new7

8-crossing

(new8=Monitor[DeleteCases[Quiet[
{
g=RecognizeGraph[FromUR[#]],
GraphData[g,"RectilinearCrossingNumber"],
FromDigits[#2]
}&@@@(StringSplit/@Import["gconn8.txt","Lines"])],
{_,x_,x_}|{_,_GraphData,_}],g])//Timing

DeleteCases[new8,{_,_Missing,_}]

Exoo gives RCN == 5 but QC finds only CN == 6:

Select[GraphData[;;9],GraphData[#,"RCN"]<GraphData[#,"CN"]&]

With[{gn={"KTree",{4,{8,4}}}},
Lookup[With[{n=GraphData[gn,"V"]},MapIndexed[({n,#2[[1]]}->#)&,Get[FileNameJoin[{$GraphDataDirectory,"Nodes","RectilinearCrossingNumber","RectilinearCrossingNumber_0"<>ToString[n]<>".m"}]]]],
Key@GraphIndex[GraphData[gn]]]]

(cn=CrossingNumber[GraphData[{"KTree",{4,{8,4}}}],TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"KTree",{4,{8,4}}}],TimeConstraint->5 3600])//AbsoluteTiming

With[{gn={"KTree",{4,{8,4}}}},
Lookup[With[{n=GraphData[gn,"V"]},MapIndexed[({n,#2[[1]]}->#)&,Get[FileNameJoin[{$GraphDataDirectory,"Nodes","RectilinearCrossingNumber","RectilinearCrossingNumber_0"<>ToString[n]<>".m"}]]]],
Key@GraphIndex[GraphData[gn]]]]

GraphData[{"KTree",{4,{8,4}}},{"RCN","CN"}]

GraphData[{"KTree",{4,{8,4}}},"Graph","MinimalCrossing"]//StyleGraphs

(cn=CrossingNumber[GraphData[{"KTree",{4,{8,4}}}],TimeConstraint->5 3600])//AbsoluteTiming

started May 25 @ 4:55 pm; ended May 28, 7:00 am

qc -g "G~~vUo" -z 9999999 -r 1
New best found: 6, at seed: 1
CR : 6
Current best soln: 6, at seed: 1, current seed: 9999999 
...
Current best soln: 6, at seed: 1, current seed: 949999905

CrossingNumber[GraphData[{"KTree",{4,{8,4}}}],Method->"Sage"]//AbsoluteTiming

http://crossings.uos.de gives interal_error but seems to imply cr = 5

8-crossing singlecross

All 8-vertex singlecross graphs are correct:

Length[lines=StringSplit/@Import["gconn8.txt","Lines"]]

(singlecross=With[{g=FromUR[#]},{sc=SinglecrossGraphQ[g],If[sc,GraphIndex[g][[2]],0],FromDigits[#2]}]&@@@lines)//Timing

Sort[Cases[singlecross,{True,i_,cn:Except[1,_Integer]}:>{i,cn}]]

9-crossing

Exoo contains wrong values of RCN=CN=2 for 9 connected graphs on 9 nodes which actually have RCN=CN=1

i=0;
imax=SimpleGraphCount[9];
(new9=Monitor[DeleteCases[Quiet[
{
i++;
g=RecognizeGraph[FromUR[#]],
GraphData[g,"RectilinearCrossingNumber"],
FromDigits[#2]
}&@@@(StringSplit/@Import["gconn9.txt","Lines"])],
{_,x_,x_}|{_,_GraphData,_}],Column[{ProgressIndicator[i,{1,imax}],Row[{i,"/",imax," = ",Round[10^4i/imax]/10.^2,"%"}]}]])//Timing

DeleteCases[new9,{_,_Missing,_}]

<<MathWorld`Graphs`

Length[lines=StringSplit/@Import["gconn9.txt","Lines"]]

(singlecross=With[{g=FromUR[#]},{sc=SinglecrossGraphQ[g],If[sc,GraphIndex[g][[2]],0],FromDigits[#2]}]&@@@lines)//Timing

Sort[Cases[singlecross,{True,i_,cn:Except[1,_Integer]}:>{i,cn}]]

%[[All,1]]

Get[FileNameJoin[{$GraphDataDirectory,"Nodes","RectilinearCrossingNumber","RectilinearCrossingNumber_09.m"}]][[{92864,103306,120476,120525,181934,182299,190917,192858,232115}]]

So in RectilinearCrossingNumber_09.m, those and any graphs that contain those as connected components have a CN that is 1 too large.

Create CrossingNumber files

<<MathWorld`Graphs`

(cnrules=Association[Rule@@@Union[
{GraphIndex[GraphData[#]],GraphData[#,"RectilinearCrossingNumber"]}&/@GraphData["Connected",;;5],
Flatten[Sort[{
GraphIndex[FromUR[#]],
FromDigits[#2]
}&@@@(StringSplit/@Import[#,"Lines"])]&/@files,1]
]])//Timing

Table[Cases[Normal@cnrules,({n,i_}->_):>i]==ConnectedGraphIndices[n],{n,9}]

1-7 (GraphData is complete)

Do[
Put[
GraphData[RecognizeGraph[#],"CrossingNumber"]&/@Graphs[n],FileNameJoin[{$GraphDataDirectory,"Nodes","CrossingNumber","CrossingNumber_0"<>ToString[n]<>".m"}
]],{n,7}]

All

Total[(GraphIndex/@ConnectedGraphComponents[#])/.cnrules]&/@Graphs[5]

GraphData["Nonplanar",5]

Total[(GraphIndex/@ConnectedGraphComponents[#])/.cnrules]&/@Graphs[6]

Length[DeleteCases[%,0]]

GraphData["Nonplanar",6]//Length

Monitor[Do[
i=0;
cnt=SimpleGraphCount[n];
Put[
Total[i++;(GraphIndex/@ConnectedGraphComponents[#])/.cnrules]&/@Graphs[n],FileNameJoin[{$GraphDataDirectory,"Nodes","RectilinearCrossingNumber","RectilinearCrossingNumber_0"<>ToString[n]<>".m"}
]],
{n,9}],{n,Row[{i,"/",cnt}]}]//Timing

Smallest graphs for which rcn > cn

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

cn=Get/@FileNames["*.m"];

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

rcn=Get/@FileNames["*.m","/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/RectilinearCrossingNumber"];

cn=Get/@FileNames["*.m","/Users/eww/Documents/Mathematica/Paclets/GraphData/Nodes/CrossingNumber"];

Table[cn[[n]]===rcn[[n]],{n,9}]

d8=DeleteCases[MapIndexed[Prepend[#,#2[[1]]]&,Transpose[{cn[[8]],rcn[[8]]}]],{_,x_,x_}]

TextGrid[Select[Prepend[#,GraphData[{8,#[[1]]},"#"]]&/@d8,FreeQ[GraphDataXX]]//Quiet,Dividers->All]

d9=DeleteCases[MapIndexed[Prepend[#,#2[[1]]]&,Transpose[{cn[[9]],rcn[[9]]}]],{_,x_,x_}]

Select[(#->GraphData[{9,#[[1]]},"#"])&/@d9,FreeQ[GraphData]]//Quiet

GraphData[#,{"#","CN","RCN"}]&/@%[[All,2]]

CN > RCN, which is impossible, so Exoo's RCN data is wrong:

bad1=Select[d9,#[[2]]>#[[3]]&]

GraphData[{9,#},"#"]&/@bad1[[All,1]]/._GraphData:>None//Quiet

CN < 4 and CN≠RCN, which is impossible, so Exoo's RCN data is wrong.

bad2=Select[d9,#[[2]]<4&&#[[2]]≠#[[3]]&]

GraphData[{9,#},"#"]&/@bad2[[All,1]]/._GraphData:>None//Quiet

RCN > CN

Grid[
Sort[Select[DeleteCases[GraphData[#,{"V","#","RectilinearCrossingNumber","CrossingNumber"}]&/@GraphData[All],{_,_,x_,x_}],FreeQ[Missing]
]],Dividers->All,Alignment->{{Decimal,Left,{Decimal}}}]

"SixteenCellGraph"

Dear Eric Weisstein,

we have successfully computed the crossing number of your graph (16-cell graph).
The graph has a crossing number of 6.

Please visit this link for detailed results: http://crossings.uos.de/job/hE7tvF144X7QoemHSfSs3A

pp={{0,0},{8,0},{2,1},{5,1},{4,2},{3,2},{4,6},{3,4}};
ee=GraphData["SixteenCellGraph","EdgeIndices"];
Row[{Graph[Range[8],ee,VertexCoordinates->pp,ImageSize->300],Graphics[{Disk[#,.1]&/@pp,Line[pp[[#]]]&/@Complement[ee,{{2,8}}],BSplineCurve[{{8,0},{4,10},{3,4}}]},PlotRange->{-0.2,6.3},ImageSize->300]}]

{"Complete", 8}

[Computation timed out!]

Dear Eric Weisstein,

we are sorry to report that the requested computation (K_8) failed.
Please contact Markus Chimani (http://www-lehre.informatik.uni-osnabrueck.de/theoinf/index/staff/chimani)
if you really need to compute the crossing number of this graph.

Please visit this link for detailed results: http://crossings.uos.de/job/QLXyZ_fGapuJHrS_66YyQA

{"DoubleToroidal", {8, 8}}

Dear Eric Weisstein,

we have successfully computed the crossing number of your graph (8,8-double tor.).
The graph has a crossing number of 9.

Please visit this link for detailed results: http://crossings.uos.de/job/UJ3aAJ-0n9remVnW95aRew

{"Turan", {8, 5}}

Dear Eric Weisstein,

we have successfully computed the crossing number of your graph (8,5-Turan).
The graph has a crossing number of 9.

Please visit this link for detailed results: http://crossings.uos.de/job/93bCwNq4nCLcj6jfZQ6mhg

{"Turan", {9, 5}}

[Computation timed out!]

Dear Eric Weisstein,

we are sorry to report that the requested computation (9,5-Turan) failed.
Please contact Markus Chimani (http://www-lehre.informatik.uni-osnabrueck.de/theoinf/index/staff/chimani)
if you really need to compute the crossing number of this graph.

Please visit this link for detailed results: http://crossings.uos.de/job/VXVHEpv-0DtcD6uxMasdvA

{"Turan", {9, 7}}

[Computation timed out!]

Dear Eric Weisstein,

we are sorry to report that the requested computation (9,7-Turan) failed.
Please contact Markus Chimani (http://www-lehre.informatik.uni-osnabrueck.de/theoinf/index/staff/chimani)
if you really need to compute the crossing number of this graph.

Please visit this link for detailed results: http://crossings.uos.de/job/eL1rWaiStRP1kuiNBgewWw

{"Turan", {9, 8}}

[Computation timed out!]

Dear Eric Weisstein,

we are sorry to report that the requested computation (9,8-Turan) failed.
Please contact Markus Chimani (http://www-lehre.informatik.uni-osnabrueck.de/theoinf/index/staff/chimani)
if you really need to compute the crossing number of this graph.

Please visit this link for detailed results: http://crossings.uos.de/job/QMJALgs9p6wk1iM8YYa9rw

Complete graph

GraphicsGrid[Partition[Table[Show[GraphData[{"Complete",n},"Graph","MinimalRectilinearCrossing"][[1]]/.g_System`Graph:>SetProperty[g,{VertexSize->If[n==1,.015,{"Scaled",.05}],System`VertexStyle->Red,System`EdgeStyle->Black}],PlotLabel->Style[Subscript[K,n],FontFamily->"Times"]],{n,3,19}],UpTo[5]]]

A014540

Do[Print[{n,RectilinearCrossingNumber[GraphData[{"Complete",n},"Graph","MinimalRectilinearCrossing"][[1]]]}//Timing],{n,19}]

Wilson and Read embeddings

(Subscript[K, 5])

k5=Graphics[{Line[{{4147,-1944.5},{137,-8893.5}}],Line[{{8157,-8893.5},{4147,-1944.5}}],Line[{{137,-8893.5},{8157,-8893.5}}],Line[{{137,-8893.5},{2563,-6856.5}}],Line[{{2563,-6856.5},{4147,-1944.5}}],Line[{{4147,-1944.5},{5730,-6856.5}}],Line[{{5730,-6856.5},{8157,-8893.5}}],Line[{{137,-8893.5},{5730,-6856.5}}],Line[{{5730,-6856.5},{2563,-6856.5}}],Line[{{2563,-6856.5},{8157,-8893.5}}]}];

g=LinesToGraph[%,10]

RecognizeGraph[g]

RectilinearCrossingNumber[g]

(Subscript[K, 6])

k6=Show[Graphics[{Line[{{16177,-1944.5},{12167,-8893.5}}],Line[{{20186,-8893.5},{16177,-1944.5}}],Line[{{12167,-8893.5},{20186,-8893.5}}],Line[{{14709,-7425.5},{17644,-7425.5}}],Line[{{17644,-7425.5},{16177,-4881.5}}],Line[{{16177,-4881.5},{14709,-7425.5}}],Line[{{12167,-8893.5},{17644,-7425.5}}],Line[{{17644,-7425.5},{16177,-1944.5}}],Line[{{16177,-1944.5},{14709,-7425.5}}],Line[{{14709,-7425.5},{20186,-8893.5}}],Line[{{20186,-8893.5},{16177,-4881.5}}],Line[{{16177,-4881.5},{12167,-8893.5}}],Line[{{12167,-8893.5},{14709,-7425.5}}],Line[{{20186,-8893.5},{17644,-7425.5}}],Line[{{16177,-4881.5},{16177,-1944.5}}]}],AspectRatio->Automatic];

g=LinesToGraph[%,10]

RecognizeGraph[g]

RectilinearCrossingNumber[g]

(Subscript[K, 7])

k7=Show[Graphics[{Line[{{28206,-1944.5},{24196,-8893.5}}],Line[{{32216,-8893.5},{28206,-1944.5}}],Line[{{24196,-8893.5},{32216,-8893.5}}],Line[{{27551,-8180.5},{27146,-5208.5}}],Line[{{27146,-5208.5},{29921,-6343.5}}],Line[{{29921,-6343.5},{27551,-8180.5}}],Line[{{24196,-8893.5},{27146,-5208.5}}],Line[{{27551,-8180.5},{24196,-8893.5}}],Line[{{24196,-8893.5},{29921,-6343.5}}],Line[{{24196,-8893.5},{28206,-6577.5}}],Line[{{32216,-8893.5},{28206,-6577.5}}],Line[{{32216,-8893.5},{27146,-5208.5}}],Line[{{29921,-6343.5},{32216,-8893.5}}],Line[{{32216,-8893.5},{27551,-8180.5}}],Line[{{28206,-1944.5},{28206,-6577.5}}],Line[{{28206,-1944.5},{27551,-8180.5}}],Line[{{27146,-5208.5},{28206,-1944.5}}],Line[{{28206,-1944.5},{29921,-6343.5}}],Line[{{28206,-6577.5},{27146,-5208.5}}],Line[{{28206,-6577.5},{27551,-8180.5}}],Line[{{28206,-6577.5},{29921,-6343.5}}]}],AspectRatio->Automatic];

g=LinesToGraph[k7,10]

RecognizeGraph[g]

RectilinearCrossingNumber[g]

(not minimal)

(Subscript[K, 8])

k8=Show[Graphics[{Line[{{137,-20929.5},{8157,-20929.5}}],Line[{{8157,-20929.5},{4147,-13980.5}}],Line[{{4147,-13980.5},{137,-20929.5}}],Line[{{4147,-15449.5},{4147,-13980.5}}],Line[{{8157,-20929.5},{5614,-19461.5}}],Line[{{137,-20929.5},{2679,-19461.5}}],Line[{{4147,-15449.5},{137,-20929.5}}],Line[{{8157,-20929.5},{4147,-15449.5}}],Line[{{2679,-19461.5},{8157,-20929.5}}],Line[{{4147,-13980.5},{2679,-19461.5}}],Line[{{5614,-19461.5},{4147,-13980.5}}],Line[{{137,-20929.5},{5614,-19461.5}}],Line[{{4147,-15449.5},{2679,-19461.5}}],Line[{{5614,-19461.5},{4147,-15449.5}}],Line[{{2679,-19461.5},{5614,-19461.5}}],Line[{{6065,-15379.5},{6066,-15379.5}}],Line[{{6549,-20224.5},{8157,-20929.5}}],Line[{{6549,-20224.5},{5614,-19461.5}}],Line[{{6549,-20224.5},{4147,-13980.5}}],Line[{{4147,-15449.5},{6549,-20224.5}}],Line[{{6549,-20224.5},{137,-20929.5}}],Line[{{5614,-19461.5},{5615,-19461.5}}],Line[{{1744,-20224.5},{137,-20929.5}}],Line[{{1744,-20224.5},{8157,-20929.5}}],Line[{{1744,-20224.5},{2679,-19461.5}}],Line[{{4147,-15449.5},{1744,-20224.5}}],Line[{{1744,-20224.5},{4147,-13980.5}}],Line[{{6549,-20224.5},{1744,-20224.5}}]}],AspectRatio->Automatic];

g=LinesToGraph[%,10]

RecognizeGraph[g]

Not (Subscript[K, 8])

(Subscript[K, 9])

k9=Show[Graphics[{Line[{{12167,-20929.5},{12168,-20929.5}}],Line[{{16177,-13980.5},{12167,-20929.5}}],Line[{{20186,-20929.5},{16177,-13980.5}}],Line[{{12167,-20929.5},{20186,-20929.5}}],Line[{{20186,-20929.5},{17644,-19461.5}}],Line[{{12167,-20929.5},{14709,-19461.5}}],Line[{{16177,-16917.5},{12167,-20929.5}}],Line[{{20186,-20929.5},{16177,-16917.5}}],Line[{{14709,-19461.5},{20186,-20929.5}}],Line[{{16177,-13980.5},{14709,-19461.5}}],Line[{{17644,-19461.5},{16177,-13980.5}}],Line[{{12167,-20929.5},{17644,-19461.5}}],Line[{{16177,-16917.5},{14709,-19461.5}}],Line[{{17644,-19461.5},{16177,-16917.5}}],Line[{{14709,-19461.5},{17644,-19461.5}}],Line[{{16177,-16917.5},{16177,-13980.5}}],Line[{{15810,-16084.5},{16177,-16917.5}}],Line[{{15810,-16084.5},{16177,-13980.5}}],Line[{{15810,-16084.5},{14709,-19461.5}}],Line[{{15810,-16084.5},{12167,-20929.5}}],Line[{{15810,-16084.5},{17644,-19461.5}}],Line[{{15810,-16084.5},{20186,-20929.5}}],Line[{{14172,-20195.5},{16177,-13980.5}}],Line[{{14172,-20195.5},{16177,-16917.5}}],Line[{{14172,-20195.5},{20186,-20929.5}}],Line[{{14172,-20195.5},{17644,-19461.5}}],Line[{{14172,-20195.5},{12167,-20929.5}}],Line[{{14172,-20195.5},{14709,-19461.5}}],Line[{{18548,-19559.5},{12167,-20929.5}}],Line[{{18548,-19559.5},{14709,-19461.5}}],Line[{{18548,-19559.5},{16177,-13980.5}}],Line[{{18548,-19559.5},{16177,-16917.5}}],Line[{{18548,-19559.5},{20186,-20929.5}}],Line[{{18548,-19559.5},{17644,-19461.5}}],Line[{{14172,-20195.5},{18548,-19559.5}}],Line[{{18548,-19559.5},{15810,-16084.5}}],Line[{{15810,-16084.5},{14172,-20195.5}}]}],AspectRatio->Automatic];

g=LinesToGraph[%,10]

RecognizeGraph[g]

RectilinearCrossingNumber[g]

Aichholzer

Based on data from http://www.ist.tugraz.at/staff/aichholzer/crossings.html .
Project BOINC is searching for K18. K19 is solved. http://dist.ist.tugraz.at/cape5/

rectilinears ={{{7429,35158},{48899,31728},{9642,18293},{31658,32967}},{{62602,52103},{6265,40210},{48840,1396},{58255,42112},{37080,22863}},{{41308,63354},{9395,41096},{22592,37554},{58413,1730},{36833,49913},{43772,29554}},{{20169,36199},{45349,10721},{14502,44220},{9288,63788},{17647,28622},{9347,31493},{54245,4503}},{{61828,62586},{23204,28426},{30239,46282},{33314,47208},{22188,2874},{9800,58956},{6573,65422},{18966,18286}},{{42951,55648},{49665,51914},{30072,35296},{45348,49100},{59971,46451},{42259,47111},{27023,65200},{57241,47881},{30838,62419}},{{44780,7836},{39296,29146},{59670,63674},{42383,19796},{42111,52299},{27573,46716},{33288,48189},{14091,59244},{40523,46935},{19779,54726}},{{60602,9908},{49054,33611},{23838,38787},{34275,40520},{49880,60046},{13473,35162},{43666,45764},{54277,18627},{47405,55118},{50012,62838},{64698,1573}},{{15830,37373},{47773,30671},{12757,18405},{8834,6546},{2540,56125},{16239,40542},{4854,53054},{18951,23730},{31715,29347},{55040,30821},{26987,32728},{11324,13452}},{{17872,58906},{14875,11008},{11415,63964},{33384,54529},{17316,20590},{56834,50547},{30879,55125},{16780,16606},{64474,49446},{19853,53377},{13671,62419},{19549,57401},{42734,52486}},{{34967,2072},{26426,33385},{42649,34463},{34017,9610},{35674,6531},{57613,38073},{40424,25950},{21249,32771},{20033,34906},{35210,4317},{12980,46193},{65311,43282},{7226,52446},{49787,36687}},{{34383,42746},{19786,43912},{40023,30267},{4575,45721},{52847,14165},{30089,39423},{46466,22664},{47401,21225},{26218,43368},{47741,60083},{43407,50992},{13889,44388},{40740,43952},{42179,49053},{42357,28324}},{{41049,37511},{54629,18611},{31896,18540},{24412,10395},{65366,11875},{36493,60882},{39379,22329},{50449,22578},{37754,50273},{40531,38976},{37190,55987},{45548,21924},{18651,2953},{60109,15352},{29685,17798},{38795,33186}},{{24527,21143},{7845,9397},{29613,42618},{6451,7682},{31434,19508},{25236,32928},{45934,11075},{4270,5561},{32601,52959},{36355,64796},{61450,126},{19714,19510},{30605,23582},{30660,46911},{15191,18456},{30843,47922},{49382,8787}}};

Table[{n,GraphData[{"Complete",n},"RectilinearCrossingNumber"]},{n,20}]

(pos=Table[Flatten[Position[
CrossingNumber[ChangeVertices[Graph[{"Complete",n}],#]]&/@GraphData[{"Complete",n},"Embeddings"],GraphData[{"Complete",n},"RectilinearCrossingNumber"]]],{n,19}])//Timing

l=Table[{n,GraphData[{"Complete",n},"RectilinearCrossingNumber"],If[pos[[n]]==={},{},ShowGraph[ChangeVertices[Graph[{"Complete",n}],GraphData[{"Complete",n},"Embeddings"][[pos[[n]][[1]]]]]]]},{n,19}]

gs=Function[n,ChangeVertices[Graph[{"Complete",n}],Rest[Import["http://www.ist.tugraz.at/staff/aichholzer/research/rp/triangulations/crossing/data/best0"<>If[n<10,"0",""]<>ToString[n]<>".asc","Table"]]]]/@{7,8,10,11,12,Sequence@@Range[13,19]}

GraphPlot[#,Method->None]&/@gs

CrossingNumber/@gs

Print[{V[#],Append[GraphData[{"Complete",V[#]},"Embeddings"],Vertices[#]]}]&/@gs

Algorithms

Region`Mesh`FindSegmentIntersections count multiple crossings at a single point once

g=Graph[Range[6],UndirectedEdge@@@{{1,4},{1,5},{1,6},{2,4},{2,5},{2,6},{3,4},{3,5},{3,6}},VertexCoordinates->{{-2,0},{2,0},{0,2 (Sqrt[3])},{0,0},{-1,(Sqrt[3])},{1,(Sqrt[3])}},VertexLabels->"Name"]

g1=Show[SetProperty[g,{VertexShapeFunction->None,EdgeShapeFunction->"Line"}]]

edges=MeshPrimitives[DiscretizeGraphics[g1],1]

res=Region`Mesh`FindSegmentIntersections[edges]

res[[2,3,2,1]]

V12.1

$Version

RegionMember[#,res[[1,4]]]&/@edges

Counts[RegionMember[#,res[[1,4]]]&/@edges][True]

V12.2

$Version

RegionMember[#,res[[1,4]]]&/@edges

Counts[RegionMember[#,res[[1,4]]]&/@edges][True]

Total[Boole[RegionMember[#,res[[1,4]]]&/@edges]]

Comparison

?RectilinearCrossingCount

Method -> "FindSegmentIntersections" counts multiple crossings only once and so returns e.g., 7 for GraphData[{7, 328}] instead of 9.

data=Monitor[{g=#,Timing@RectilinearCrossingCount[GraphData[#],Method->"FindSegmentIntersections"],Timing@RectilinearCrossingCount[GraphData[#],Method->"RegionIntersection"]}&/@GraphData[;;8],g];//Timing

DeleteCases[data,{_,{_,x_},{_,x_}}]

Total[data[[All,#,1]]]&/@{2,3}

RectilinearCrossingCount

g=RandomGraph[{10,20}]

RectilinearCrossingCount[g]

FindSegmentIntersections

From Charles 2020-08-15

Region`Mesh`FindSegmentIntersections returns a set of intersecting points and overlapping segments. The first element contains a list of points. The second element contains the type of intersection and the indices of the points associated with that intersection.

Requires EdgeShapeFunction->"Line" in V12.2 (Jaebum 2020-10-09)

Connected

g=RandomGraph[{10,20},VertexShapeFunction->None,EdgeShapeFunction->"Line"]

edges=MeshPrimitives[DiscretizeGraphics[Show[g]],1]

res=Region`Mesh`FindSegmentIntersections[edges]

Length[res[[2,3,2,1]]]

Show[g,Graphics[{Red,Point[res[[1]][[res[[2,3,2,1]]]]]}]]

Disconnected {5,10}

g=SetProperty[GraphData[{5,10}],{VertexShapeFunction->None,EdgeShapeFunction->"Line"}]

edges=MeshPrimitives[DiscretizeGraphics[Show[g]],1]

res=Region`Mesh`FindSegmentIntersections[edges]

Length[res[[2,3,2,1]]]

Disconnected "TwoCubes"

g=SetProperty[GraphData["TwoCubes"],{VertexShapeFunction->None,EdgeShapeFunction->"Line"}]

edges=MeshPrimitives[DiscretizeGraphics[Show[g]],1]

res=Region`Mesh`FindSegmentIntersections[edges]

Length[res[[2,3,2,1]]]

StackExchange (doesn't work in V12.2)

https://mathematica.stackexchange.com/questions/223842/detect-if-any-edges-cross-in-a-graph-with-a-specified-layout

symbols=Table[Unique[],8];
v=Flatten[MapAt[Reverse,Table[{a,s},{s,symbols},{a,{-3,3}}],{;;;;2}],1];
e=BlockMap[Apply@UndirectedEdge,v,2,1]~Drop~{Length@symbols};
curv=GraphElementData[{"CurvedArc","Curvature"->(#[[1]][[2]]-#[[2]][[2]])/#[[2]][[1]]}]&;
g[order_]:=With[{rules=Thread[symbols->order]},Graph[e,VertexCoordinates->Thread[v->(v/.rules)],EdgeShapeFunction->Thread[e->(curv/@e/.rules)]]]

{g1=g[{8,3,2,1,5,4,6,7}],g2=g[{8,6,5,1,7,3,2,4}]}

Graphics`Mesh`MeshInit[]

EdgeIntersections[g_System`Graph]:=Complement[Graphics`Mesh`FindIntersections[Show@g],N@GraphEmbedding[g]]&;

EdgeIntersections[g1]