9
$\begingroup$

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.

Enter image description here

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"]

Enter image description here

I find 26 crossings by hand.

Enter image description here

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]

Enter image description here

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.

$\endgroup$
2
  • $\begingroup$ What do you mean by "The graph I am considering can exist curves"? Can create curves? Contains curves? Something else? $\endgroup$ Jan 27, 2023 at 15:14
  • $\begingroup$ Thank you for your revision, your comments are good. It should be revised by "Curves are permitted in the layout of my graph". $\endgroup$
    – licheng
    Jan 27, 2023 at 15:31

1 Answer 1

13
$\begingroup$

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]

enter image description here

Tabulate the lists and counts of intersecting edges:

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

enter image description here

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}]]

enter image description here

$\endgroup$
2
  • 3
    $\begingroup$ Nice! In a further step, how do we return the number of times an edge crossed, or which edge it crossed with? $\endgroup$
    – licheng
    Jan 26, 2023 at 13:46
  • 2
    $\begingroup$ @licheng, please see the update. $\endgroup$
    – kglr
    Jan 26, 2023 at 19:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.