11

I have this graph:

g=Graph[{1, 2, 3, 4, 5, 6, 7, 8, 9, 
  10}, {SparseArray[Automatic, {10, 10}, 
   0, {1, {{0, 2, 5, 7, 9, 11, 13, 15, 16, 18, 
      20}, {{3}, {4}, {1}, {6}, {8}, {5}, {9}, {2}, {9}, {2}, {6}, 
{3}, {5}, {7}, {8}, {4}, 
           {1}, {8}, {1}, {3}}}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 
     1, 1, 1, 1, 1, 1, 1, 1}}], Null}, {VertexLabels -> {"Name"}}]

I want to find a longest path, which contains as many vertices as this path $7\to8\to4\to9\to1\to3\to5\to2\to6$ found by visual inspection. But how do I find it with Mathematica?

yode
  • 26,686
  • 4
  • 62
  • 167

2 Answers2

15

You can just find all the paths by brute force, and use MaximalBy

allPaths = 
  FindPath[g, #2, #1, Infinity, All] & @@@ 
    Subsets[VertexList[g], {2}] // Apply[Join];
MaximalBy[allPaths, Length@Union@# &]
(* {{10, 1, 3, 9, 8, 4, 2, 6, 5}, {7, 8, 4, 9, 1, 3, 5, 2, 6}} *)
Jason B.
  • 68,381
  • 3
  • 139
  • 286
  • Thanks very much.I'd like to know that non-force method still. :) – yode Jan 26 '17 at 16:59
  • 1
    I'm still curious if I interpret your question correctly. The target you give has a loop at vertex 2. – Jason B. Jan 26 '17 at 17:01
  • I'm sorry,that is a typo.I have adjusted that. – yode Jan 26 '17 at 17:07
  • 1
    From what I read here, it's a hard problem. There is apparently a neat solution for acyclic graphs, but that doesn't apply here. – Jason B. Jan 26 '17 at 17:17
  • I would prune the search in a graph of $n$ vertexes by first seeking paths of length $n$, then $n-1$, then $n-2$... Do this by starting with the unique vertex set containing $n$ vertexes, then the $n$ vertex sets containing $n-1$ vertexes, then the ${n \choose 2}$ sets containing $n-2$ vertexes, and so on. – David G. Stork Jan 26 '17 at 17:30
  • It's seem the Subsets should be changed into Tuples in general case. – yode Feb 01 '17 at 05:35
  • @yode - you're right, forgot I was dealing with a directed graph. – Jason B. Feb 01 '17 at 15:09
5

The pruned approach, in which long lists of vertices are tried first and the process terminated once such a path is found:

endptlist = Subsets[Range[10], {2}];
    Catch[
    Do[
       If[(currentlist = DeleteCases[(FindPath[g, #1, #2, {i}] & @@@ 
         endptlist), {}]) != {}, 
       Throw[currentlist]], 
    {i, 10, 1, -1}]]

(* {{{1, 3, 9, 8, 4, 2, 6, 5}}, {{2, 8, 4, 9, 1, 3, 5, 6}}, {{5, 6, 3, 9, 1, 4, 2, 8}}, {{6, 3, 5, 2, 1, 4, 9, 8}}} *)

David G. Stork
  • 41,180
  • 3
  • 34
  • 96
  • 1
    All path you find just contain eight vertices?Acrually the longest path contain nine vertices as I know. – yode Jan 27 '17 at 07:17
  • Is there a resolution to why the above algorithm doesn't reproduce the length-9 path in the other answer? – Semiclassical Aug 01 '17 at 01:24