# Shortest path through more than two points visiting vertices once

FindShortestPath works only with two points.

Is there a function that finds shortest path among more than two vertices in specified order and never visiting any vertex more than once? For example we could have vertices {v1,v2,v3,v4}.

If you think the problem is equivalent to finding shortest paths between consecutive pairs of vertices ({v1,v2},{v2,v3},{v3,v4}) and then combining them (like it seems they assumed it here - How to find the shortest path going through some specified vertices) then I provide you with a counterexample.

Here is edge list of the counterexample graph.

UndirectedEdge@@@{{1,2},{1,3},{2,18},{3,18},{2,5},{3,4},{5,6},{5,7},{6,7},{6,9},{7,9},{9,10},{18,8},{4,8},{8,11},{8,21},{10,15},{15,11},{11,12},{12,13},{12,14},{13,16},{13,17},{16,17},{14,16},{21,17},{13,21},{4,7},{8,19},{19,10},{7,19},{14,17},{16,21},{1,20},{2,20},{3,20},{18,20}}


And here are all shortest paths from 1, through 15, to 21 of length 9.

None of these paths can be created by combining shortest paths between 1 and 15 and between 15 and 21.

Update - Another example:

Edge list:

UndirectedEdge@@@{{2,7},{2,25},{3,4},{3,15},{3,20},{4,13},{4,15},{5,10},{5,15},{7,15},{7,17},{7,25},{7,27},{8,14},{8,19},{8,20},{8,21},{8,22},{9,10},{9,23},{10,25},{13,19},{13,24},{14,21},{17,18},{17,30},{18,24},{19,23},{20,27},{21,26},{22,30},{23,27},{24,26},{25,27},{26,30}}


The unique shortest path from 5, through 17, to 15:

If timing doesn't matter, here's the brute force method:

g = Graph[
UndirectedEdge @@@ {{1, 2}, {1, 3}, {2, 18}, {3, 18}, {2, 5}, {3,
4}, {5, 6}, {5, 7}, {6, 7}, {6, 9}, {7, 9}, {9, 10}, {18,
8}, {4, 8}, {8, 11}, {8, 21}, {10, 15}, {15, 11}, {11, 12}, {12,
13}, {12, 14}, {13, 16}, {13, 17}, {16, 17}, {14, 16}, {21,
17}, {13, 21}, {4, 7}, {8, 19}, {19, 10}, {7, 19}, {14,
17}, {16, 21}, {1, 20}, {2, 20}, {3, 20}, {18, 20}}
, VertexLabels -> Automatic];

v = {1, 15, 21};
subpaths = Partition[v, 2, 1];
minbound =
Total[Length[Most[#]] & /@ FindShortestPath@g @@@ subpaths];

Until[Length[res] > 0,
paths = FindPath[g, v[[1]], v[[-1]], {minbound++}, All];
res = Pick[paths, MatchQ[#, Riffle[v, ___]] & /@ paths];

res


{{1, 3, 4, 7, 19, 10, 15, 11, 8, 21}, {1, 3, 4, 7, 9, 10, 15, 11, 8,
21}, {1, 2, 5, 7, 19, 10, 15, 11, 8, 21}, {1, 2, 5, 7, 9, 10, 15,
11, 8, 21}, {1, 2, 5, 6, 9, 10, 15, 11, 8, 21}}

• Similar, how I found the paths. No need to use MatchQ, more easy is to test whether the path contains v[[2]] - Select[paths, MemberQ[#, v[[2]]] &]. Aug 4, 2022 at 20:29
• Yes, if you have only one in the middle. MatchQ is for general case like more than 4 consecutive points. Aug 5, 2022 at 2:56
• Then Riffle[v, ___] is sufficient instead of Riffle[v, ___, {1, -1, 2}]. Aug 5, 2022 at 8:38
• That's correct. edited Aug 5, 2022 at 15:11