Finding all simple paths between two vertices in a graph

Question

There are built-in methods to find a shortest path between two vertices in a graph, and the question on finding all shortest paths between two vertices has gathered quite a bit of attention.

A path is simple if it repeats no vertices. As is with all shortest paths between a pair of vertices, the number of simple paths between two vertices can be huge. What would be a nice and clean method of finding all simple paths between two vertices?

Assume the input graph is undirected, simple, and it may have cycles in it. I am not interested in the number of simple paths between $s$ and $t$, but I want to explicitly enumerate all of them. Furthermore, note that this problem cannot be solved in polynomial time. Even writing the output might take time that is not polynomial in the number of vertices.

One way of listing the simple paths is to use depth-first search. Maybe DepthFirstScan is useful here. The DFS can avoid repeating vertices by marking them as they are visited in the recursion, and then removing the mark just before returning from the recursive call. I learned a backtracking solution might not be that fast.

Answer 1

Disclaimer: OP problem is more specific than the problem solved here. This solution has been posted primarily to draw some attention and to give some ideas. For a possibly more efficient solution of OP problem I would suggest looking into algorithms searching for strongly connected components (e.g. Tarjan's algorithm).

All simple paths in a (directed) graph

Below is an explicit implementation from this paper. Claimed to perform $\mathcal{O}(n^3)$ operations - whatever it means, i.e. I think there is ca. $\sum_{k=2}^n \binom{n}{k} \frac{k!}{2} = \Omega(2^n)$ simple paths to generate in a $n$-clique. Nevertheless, this algorithm looks interesting e.g. for its bit descriptors. There is plenty of room for improvement, including not Mathematica specific improvements (e.g. Section IV remarks on efficient implementation are not implemented).

The algorithm w/ auxiliary functions:

pairs[l1_, l2_] := Transpose[{l1, l2}]
initializePathDescriptorMatrix[g_] := Module[{a, e, m, n},
  a = Normal[System`AdjacencyMatrix[g]];
  e = Position[a, 1];
  (* e == Sort[(EdgeList[g] /. Rule@@@pairs[System`VertexList[g], Range[n]]) /. DirectedEdge -> List] *)
  m = Length[e];
  n = Length[a];
  (a[[#1[[1]], #1[[2]]]] = {{Plus @@ (2^(n - #) & /@ #1), 2^(m - #2)}}) & @@@
    pairs[e,Range[m]];
  a = a /. {0 -> {}};
  a
  ]
generatePathDescriptorMatrix[g_] := Module[{dm, n, j, k, i},
  dm = initializePathDescriptorMatrix[g];
  n = Length[dm]; (* VertexCount[g] *)      
  For[j = 1, j <= n, j++,
   For[i = 1, i <= n, i++,
    For[k = 1, k <= n, k++,
     Function[{v, e},
       Function[{w, f},
         If[BitAnd[v, w] == 2^(n - j),
          dm[[i, k]] = Append[dm[[i, k]], BitOr @@@ {{v, w}, {e, f}}]
         ]
       ] @@@ dm[[j, k]]
     ] @@@ dm[[i, j]]
  ]]];      
  dm
]

And examples w/ some more auxiliary functions:

descriptorToEdgePath[g_, {}] := {}
descriptorToEdgePath[g_, d_] := Part[(* w/ crude solution for edges/vectices reordering *)
   Sort[System`EdgeList[g] /. (Rule @@@ pairs[System`VertexList[g], Range[System`VertexCount[g]]])],
   Flatten[Position[IntegerDigits[d[[2]], 2, System`EdgeCount[g]], 1]]
 ] /. (Rule @@@ pairs[Range[System`VertexCount[g]], System`VertexList[g]])
partg[g_] := Function[{m, v, w}, m[[ VertexIndex[g, v], VertexIndex[g, w]] ]]

(* paper example graph w/ 3 paths from 1 to 5 *)
e = {1 -> 2, 1 -> 3, 1 -> 4, 2 -> 4, 2 -> 5, 4 -> 5} ;
g = System`Graph[e, VertexLabels -> "Name"];
dm = generatePathDescriptorMatrix[g];
(* paths from 1 to 5 *)
(* Note: paths are sorted by vertex (in VertexList order), length, vertex etc. key  *)
descriptorToEdgePath[g, #] & /@ partg[g][dm, 1, 5];
GraphicsRow[HighlightGraph[g, #] & /@ %, ImageSize -> 600]

(* cycle example *)
e = {x -> y, y -> z, z -> x, y -> v};
g = System`Graph[e, VertexLabels -> "Name"];
dm = generatePathDescriptorMatrix[g];
Length[Flatten[dm, 2]] == 9
(* 1 path of length 3 (z -> v) + 4 paths of length 2 (3 within cycle) + 4 edges  *)
(* paths of length 2 *)
descriptorToEdgePath[g, #] & /@
  Cases[Flatten[dm, 2], {_, ed_} /; Length[Position[IntegerDigits[ed, 2], 1]] == 2];
GraphicsGrid[Partition[HighlightGraph[g, #] & /@ %, 2], ImageSize -> 600]

Answer 2

You can use the new FindPath function that comes with Mathematica 10. A simple example:

g = CompleteGraph[4];
FindPath[g, 1, 2, Infinity, All]

(* Output: {{1,2},{1,4,2},{1,3,2},{1,4,3,2},{1,3,4,2}} *)

The function also accepts parameters, so you can find a path (or all paths) of specific length. See the docs for more.

Answer 3

For directed graphs (cyclic or acyclic), here is a simple method that recursively scans the neighbours of a source vertex s until it finds all paths to a target vertex t (either using the graph or its adjacency matrix):

findPaths[a_?MatrixQ, s_Integer, t_Integer] := Module[{child, find},
   child[v_] := Flatten@Position[a[[v]], Except@0, 1, Heads -> False];
   find[v_, list_] := Scan[If[# === t, Sow[Append[list, #]], 
            If[FreeQ[list, #], find[#, Append[list, #]]]] &, child@v];
   If[# =!= {}, First@#, {}]&@Last@Reap@find[s, {s}]
   ];
findPaths[g_Graph, s_, t_] := Module[{nodes = VertexList@g, convert},
   convert = Thread[nodes -> Range@Length@nodes];
   findPaths[Normal@AdjacencyMatrix@g, s /. convert, t /. convert] /. Reverse/@convert
   ];

Test it for a random directed graph:

edges = {2 -> 1, 1 -> 3, 1 -> 4, 5 -> 1, 8 -> 1, 2 -> 6, 2 -> 10,
         4 -> 3, 3 -> 7, 4 -> 9, 6 -> 5, 5 -> 7, 9 -> 5, 7 -> 6, 6 -> 9};
g = Graph[edges, VertexLabels -> "Name"];
paths = findPaths[g, 5, 9]
HighlightGraph[g, Rule @@@ Partition[#, 2, 1], PlotLabel -> #] & /@ paths

{{5, 1, 3, 7, 6, 9}, {5, 1, 4, 3, 7, 6, 9}, {5, 1, 4, 9}, {5, 7, 6, 9}}

For a use case, see this thread.

Answer 4

Here's a little wrapper for the code posted by @trybik. The function abstract away the conversion to an directed graph and back.

FindAllPaths[g_, s_, t_] :=
Module[{copy = DirectedGraph[g]},
dm = generatePathDescriptorMatrix[copy];
Return [Apply[UndirectedEdge,
 descriptorToEdgePath[copy, #] & /@ partg[copy][dm, s, t], {2}]];
];

Usage:

g = Graph[{1 \[UndirectedEdge] 3, 1 \[UndirectedEdge] 4, 
3 \[UndirectedEdge] 5, 3 \[UndirectedEdge] 4, 
4 \[UndirectedEdge] 5, 5 \[UndirectedEdge] 2}, 
VertexLabels -> "Name", ImagePadding -> 20]
FindAllPaths[g, 2, 1];
HighlightGraph[g, #] & /@ %