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

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.

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.