How to choose the shortest route? (Vehicle routing problem)

There are several problems if to attempt to solve this question with the ordinary methods like FindShortestTour.

Mathematica traditionally annoys first time users with the travelling salesman alike problems. Many authors have therefore published in their introductory books handwritten and so specially adopted and adaptable routine to solve this for their handsome readers. But this is a hard problem for professional measures.

So in literature, it is unusual to use the Mathematica built-in graph data structure and even the edge list and the edge list are seldom. The reason is evident. It is like in this question possible to deviate some the so intrinsic euclidian measure of the real world. That is already indicted in the copied picture the problem is not treatable with a metric like Manhattan distance and else.

The situation looks like this

The problem might be solved in manners like that in house-of-santa-claus. That problem has not weights and the solution is so general in the node, knots it can not be transfered to this question directly.

listpoints = {{0, 0}, {177.9189, 125.972}, {410, 0}, {503.140, 
   83.366}}

Since this is mathematics there is a trick!

I suggest the code from Comparing Algorithms For The Traveling Salesman Problem. There is the need for the exact position for the last node, knot.

And there comes somehow the flaw of the design of the question into range. Only the 75 weight is in need to be satisfied. The 440 can be shortened to fit.

So another path is divide into loops and solve for the loops.

Sort[410, 510, 218, 218, 75, 329, 75, 440, 440, 329, 510, 125, 125, 410]

{75,125,218,329,440,510}

Anneal the weights and discard 440 and 510. Travel along the other egdes covers the graph. This is the main drawback of all Mathematica built-ins for such questions. They cover the graph and use all edges and all knots. That is not needed in general for traveling salesman problems.

Home -> Postoffice -> Bookshop -> Postoffice -> Supermarket -> Home is the minimal length in weight path. No other covers the reach of all nodes/knots.

The last step needs extra effort because the edge Supermarket -> Home can not be considered for the annealing with Mathematica built-ins

gred = Graph[{1 [UndirectedEdge] 2, 1 [UndirectedEdge] 3, 
   3 [UndirectedEdge] 2, 3 [UndirectedEdge] 4, 
   4 [UndirectedEdge] 2}, EdgeWeight -> {218, 510, 329, 440, 75}, 
  VertexLabels -> "Name", EdgeLabels -> "EdgeWeight", 
  VertexCoordinates -> {1 -> {0, 0}, 2 -> {0.2, 1}, 3 -> {1.2, 0.8}, 
    4 -> {0.4, 1.7}}]

FindPostmanTour[gred] // First

{1 [UndirectedEdge] 3, 3 [UndirectedEdge] 4, 4 [UndirectedEdge] 2, 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 2, 2 [UndirectedEdge] 1}

Seems Mathematica uses the loop partioning first and than adds up.

gred = Graph[{1 [UndirectedEdge] 2, 3 [UndirectedEdge] 2, 
   4 [UndirectedEdge] 2}, EdgeWeight -> {218, 329, 75}, 
  VertexLabels -> "Name", EdgeLabels -> "EdgeWeight", 
  VertexCoordinates -> {1 -> {0, 0}, 2 -> {0.2, 1}, 3 -> {1.2, 0.8}, 
    4 -> {0.4, 1.7}}]

FindPostmanTour[gred] // First

{1 [UndirectedEdge] 2, 2 [UndirectedEdge] 4, 4 [UndirectedEdge] 2, 
 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 2, 2 [UndirectedEdge] 1}

Replace the two edges then:

{1 [UndirectedEdge] 2, 2 [UndirectedEdge] 4, 4 [UndirectedEdge] 2, 
 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 1}

Chance has to replace the undirected egdes in this one case into a directed one from 3 to 1 first and than use Mathematica built-ins or solutions from other authors.

There is a difference between tsp with little nodes/knots and larger ones. They are usually treated different. For small numbers of knots it is cheaper to think first and than use Mathematica built-ins than other way round.

The detour, longer path than in real-world present makes this problem special. The question of whether all edges and nodes shall be used is intrinsic to Mathematical built-ins. It saves a lot of programming to anneal first. Most tsp problems allow ordering and annealing. That is the comfortable perspective of such kind of problems.

With such a low number of places ($n=3$) to visit the number of orderings ($n!=6$) is low enough for an exhaustive search. (given distances that are the same in both directions, the number is actually $n!/2=3$).

Of course the possible orderings of the stores can be generated by Mathematica:

Permutations[{Bookstore, PostOffice, Supermarket}]

$longrightarrow$

{{Bookstore, PostOffice, Supermarket}, {Bookstore, Supermarket, 
  PostOffice}, {PostOffice, Bookstore, Supermarket}, {PostOffice, 
  Supermarket, Bookstore}, {Supermarket, Bookstore, 
  PostOffice}, {Supermarket, PostOffice, Bookstore}}

In the present case one can remove routes that are reverse of one another because distances are the same going from A to B or B to A:

DeleteDuplicates[Permutations[{Bookstore, PostOffice, Supermarket}],
                 #1 == Reverse[#2] &]

$longrightarrow$

{{Bookstore, PostOffice, Supermarket}, {Bookstore, Supermarket, 
  PostOffice}, {PostOffice, Bookstore, Supermarket}}

Given an ordering of places to visit, just use shortest paths from one to the next. I will assume the guy returns home:

length[a_, b_, c_] := 
  GraphDistance[g, Home, a] + GraphDistance[g, a, b] + 
  GraphDistance[g, b, c]    + GraphDistance[g, c, Home];
length1 = length[Bookstore, PostOffice, Supermarket]
length2 = length[Bookstore, Supermarket, PostOffice]
length3 = length[PostOffice, Bookstore, Supermarket]

output is 1207, 1244, 1207. Just pick any order with lowest total, say the first. The route is:

FindShortestPath[g, Home, Bookstore]
FindShortestPath[g, Bookstore, PostOffice]
FindShortestPath[g, PostOffice, Supermarket]
FindShortestPath[g, Supermarket, Home]

With output

{Home, PostOffice, Bookstore}
{Bookstore, PostOffice}
{PostOffice, Supermarket}
{Supermarket, Home}

So one optimal tour is:

Home, PostOffice, Bookstore, PostOffice, Supermarket, Home.

This approach will work fine as long as $n!/2$ is not too high, but the graph itself can be quite large as finding shortest paths is usually quite efficient computationally.

In this code below I'm doing a repeated greedy search. This gives a much better route than FindShortestTour which does not allow re-visited nodes.

We start by randomly permuting our list of targets. We then get the first remaining target and find the shortest path from our current node to the target, recording the path as we go. Any other targets we happen to encounter on the way there are removed from the list of targets. We repeat this procedure until no more targets are left, then we walk back home.

The whole thing is repeated starting from scratch for every different permutation of the target list. This should ensure we aren't biasing the greedy search to visit the targets in a particular order.

One thing to note, I've adjusted the graph so that it's simple:

g = Graph[{Home [UndirectedEdge] PostOffice, 
   Home [UndirectedEdge] Supermarket, Home [UndirectedEdge] School, 
   PostOffice [UndirectedEdge] Supermarket, 
   PostOffice [UndirectedEdge] Bookstore, 
   Bookstore [UndirectedEdge] Supermarket, 
   Supermarket [UndirectedEdge] School}, 
  EdgeWeight -> {218, 510, 410, 329, 75, 440, 125}, 
  VertexLabels -> "Name", EdgeLabels -> "EdgeWeight", 
  VertexCoordinates -> {Home -> {0, 0}, School -> {1, 0}, 
    PostOffice -> {0.2, 1}, Supermarket -> {1.2, 0.8}, 
    Bookstore -> {0.4, 1.7}}, PlotTheme -> "Scientific"]

route[g_, targetvtxs_, currentvtx_, paths_] := 
 Module[{sp = Rest[FindShortestPath[g, currentvtx, First[targetvtxs]]], newtgtvtxs},
  newtgtvtxs = Complement[targetvtxs, sp];
  If[newtgtvtxs != {}, 
   sp = Join[sp, route[g, newtgtvtxs, Last[sp], Join[paths, sp]]]];
  Return[sp];
]

pathToEdges[path_] := UndirectedEdge @@@ Partition[path, 2, 1]

edgeLength[g_, edge_] := AnnotationValue[{g, edge}, EdgeWeight]

generateRoute[g_, targets_] := 
 Module[{rt = Prepend[route[g, targets, Home, {}], Home]},
  (* go back home if required *)
  If[Last[rt] =!= Home,
   rt = Join[rt, Rest[FindShortestPath[g, Last[rt], Home]]]
   ];
  (* return the cost of the route and the route *)
  Return[{Total[edgeLength[g, #] & /@ pathToEdges[rt]], rt}]
]


(* find the routes *)
DeleteDuplicates[
  generateRoute[g, #] & /@ Permutations[{PostOffice, Bookstore, Supermarket}]
]
(* results:
  {{1207, {Home, PostOffice, Bookstore, PostOffice, Supermarket, Home}},
   {1207, {Home, Supermarket, PostOffice, Bookstore, PostOffice, Home}}}
*)

Notice that there are two short routes of identical length that it found.

In a larger more complex graph, the problem becomes more intractable. Therefore it would make sense to only try a relatively small number of the target permutations, perhaps using RandomSample, to find a good result.

As I mentioned in the comments, this problem seems to be related to the sparse Travelling Salesman Problem with revisits and while it's not the most common version of the problem which normally has a dense complete graph, it's definitely the most interesting to me.