How can I detect the number of crossings in a layout of a graph?

Question

This question was inspired by the game Planarity in which a player tries to position the vertices so that no two lines cross. As I move the vertices, the change in the number of crossings is detected in time. It is also necessary for my research in graph drawing.

In Mathematica, we can draw a graph.

Problem 1. How can we detect the number of crossings in the layout of a graph?

For example, we have the following graph with LayeredDigraphEmbedding; how do we detect the number of crossings? The graph I am considering can contain curves.

Graph[{1 \[UndirectedEdge] 16, 1 \[UndirectedEdge] 19,
  2 \[UndirectedEdge] 13, 2 \[UndirectedEdge] 14,
  2 \[UndirectedEdge] 15, 2 \[UndirectedEdge] 16,
  2 \[UndirectedEdge] 19, 3 \[UndirectedEdge] 6,
  3 \[UndirectedEdge] 9, 3 \[UndirectedEdge] 10,
  3 \[UndirectedEdge] 17, 3 \[UndirectedEdge] 20,
  4 \[UndirectedEdge] 7, 4 \[UndirectedEdge] 13,
  4 \[UndirectedEdge] 15, 4 \[UndirectedEdge] 20,
  5 \[UndirectedEdge] 10, 6 \[UndirectedEdge] 16,
  7 \[UndirectedEdge] 8, 7 \[UndirectedEdge] 9,
  7 \[UndirectedEdge] 18, 8 \[UndirectedEdge] 13,
  8 \[UndirectedEdge] 19, 9 \[UndirectedEdge] 15,
  9 \[UndirectedEdge] 17, 11 \[UndirectedEdge] 18,
  12 \[UndirectedEdge] 20, 13 \[UndirectedEdge] 14,
  13 \[UndirectedEdge] 18, 13 \[UndirectedEdge] 19,
  14 \[UndirectedEdge] 17, 15 \[UndirectedEdge] 18,
  15 \[UndirectedEdge] 19, 16 \[UndirectedEdge] 19,
  17 \[UndirectedEdge] 18}, GraphLayout -> "LayeredDigraphEmbedding"]

I find 26 crossings by hand.

Problem 2. Given an edge, how do we determine which edges cross it?

For example:

Graph[{1 \[UndirectedEdge] 16, 1 \[UndirectedEdge] 19,
  2 \[UndirectedEdge] 13, 2 \[UndirectedEdge] 14,
  2 \[UndirectedEdge] 15, 2 \[UndirectedEdge] 16,
  2 \[UndirectedEdge] 19, 3 \[UndirectedEdge] 6,
  3 \[UndirectedEdge] 9, 3 \[UndirectedEdge] 10,
  3 \[UndirectedEdge] 17, 3 \[UndirectedEdge] 20,
  4 \[UndirectedEdge] 7, 4 \[UndirectedEdge] 13,
  4 \[UndirectedEdge] 15, 4 \[UndirectedEdge] 20,
  5 \[UndirectedEdge] 10, 6 \[UndirectedEdge] 16,
  7 \[UndirectedEdge] 8, 7 \[UndirectedEdge] 9,
  7 \[UndirectedEdge] 18, 8 \[UndirectedEdge] 13,
  8 \[UndirectedEdge] 19, 9 \[UndirectedEdge] 15,
  9 \[UndirectedEdge] 17, 11 \[UndirectedEdge] 18,
  12 \[UndirectedEdge] 20, 13 \[UndirectedEdge] 14,
  13 \[UndirectedEdge] 18, 13 \[UndirectedEdge] 19,
  14 \[UndirectedEdge] 17, 15 \[UndirectedEdge] 18,
  15 \[UndirectedEdge] 19, 16 \[UndirectedEdge] 19,
  17 \[UndirectedEdge] 18}, GraphLayout -> "LayeredDigraphEmbedding",
 VertexLabels -> Placed[Automatic, Center], VertexSize -> 0.25]

We can find that the edge $\{4, 13\}$ is crossed $3$ times in total and it was crossed by $\{3,9\}, \{3,17\}, \{8,19\}$, respectively.

It feels like it is involved in computational geometry.

Answer 1

Update: For each edge e find the list of edges that intersect e:

ClearAll[removeArrow, edgesToLines, intersectingQ]

First, a helper function that replaces Arrows with lines or curves:

removeArrow =  ReplaceAll[{Arrow[b_BezierCurve, ___] :> b, 
    Arrow[c_List, ___] :> Line[c]}];

Then, create a new graph g0 with each edge wrapped with a tooltip:

g0 = Graph[Labeled[#, #, Tooltip] & /@ EdgeList[g], Options[g]];

Post-process g0 to construct an association that associates with each edge a curve:

edgesToLines = Association @ Cases[Show @ g0, 
    Tooltip[a_, t_] :> t -> First[removeArrow @ Cases[_Arrow] @ a], All];

Define a function that returns True if the curves associated with the two input edges intersect:

intersectingQ[e1_, e2_] := {} =!=
  Graphics`Mesh`FindIntersections[Graphics[edgesToLines /@ {e1, e2}], 
   Graphics`Mesh`AllPoints -> False]

Use intersectingQ to get, for each edge e in EdgeList[g], the indices of edges that intersect edge e:

adjlists = SparseArray[Boole@Outer[intersectingQ, #, #] & @ 
  EdgeList[g]]["AdjacencyLists"];

intersectingEdges = AssociationThread[EdgeList[g], 
  EdgeList[g][[#]] & /@ adjlists];

Example:

intersectingEdges[3 \[UndirectedEdge] 17]

Tabulate the lists and counts of intersecting edges:

Grid[Prepend[{"edge", "intersecting edges", "count"}] @
   KeyValueMap[{#, #2, Length @ #2} &] @ intersectingEdges,
 Frame -> All]

Original answer:

1. Wrap the graph object g with Show to get a graphics object
2. Replace Arrows with Lines
3. Use the function Graphics`Mesh`FindIntersections with the option Graphics`Mesh`AllPoints -> False

g2 = Show[g] /. {Arrow[b_BezierCurve, _] :> b, Arrow[c_List, _] :> Line[c]};

ints = Graphics`Mesh`FindIntersections[g2,  Graphics`Mesh`AllPoints -> False];

Length @ ints

26

Show[g, Graphics[{Red,  PointSize @ Large, Point @ ints}]]