Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I'd like to find the shortest distance between some points (every point must be visited), such as between these 3 points:

 points = { {-0.9, -0.89}, {.99, .97}, {0.1, .0}}

I am sure there must be a built-in way of doing this automatically (or using Combinatorica), rather than calculating all the combinations manually. I had a quick play with:

FindShortestTour[points]

which returned:

{5.30686, {1, 2, 3}}

whereas the shortest path would be {1, 3, 2} and the Euclidean distance would be about 2, so I am clearly missing something basic ... probably related to graphs and how to set them up when the points are not on a grid??

In brief: is there an easy automated way to find the shortest distance between a set of given points?


UPDATE

Since there doesn't seem to be a built-in form, I just had a quick go at doing one manually ... I only need it for small list size $n$, so I'm not too worried about checking all permutations etc.

 PolygonPathMinDistance[points_] :=  Module[{orderings, pointorderings, pathsToCheck},
       orderings = Union[Permutations[Range[Length[points]]], 
                    SameTest -> (#1 == Reverse[#2] &)];
  pointorderings = Map[points[[#]] &, orderings];
  pathsToCheck  = Map[Partition[#, 2, 1] &, pointorderings];
  Min[Map[Total[Map[EuclideanDistance @@ # &, #1]] &, pathsToCheck]]
 ]

Examples:

 points = {{x1, y1}, {x2, y2}, {x3, y3}};
 PolygonPathMinDistance[points]

 points = {{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}};
 PolygonPathMinDistance[points]

Just comparing with the solution posted by ssch below, we have agreement for the 3 case:

points = {{-0.9, -0.89}, {.99, .97}, {0.1, .0}};
PolygonPathMinDistance[points]

2.65513

... and we have agreement for a 4 part list:

points = {{-0.9, -0.89}, {.99, .97}, {0.1, .0}, {.7, -.1}}
PolygonPathMinDistance[points]

3.05557

and ssch gets (adding magicpoint is necessary):

 mpoints = {{-0.9, -0.89}, {.99, .97}, {0.1, .0}, {.7, -.1}, magicPoint}
 FindShortestTour[mpoints, DistanceFunction -> d]

{3.05557, {1, 3, 4, 2, 5}}

Cool - time for bed ... will follow up tomorrow. Many thanks! On the plus side, I am sure the ssch solution will be much faster ... but I assume it will be numeric (rather than symbolic).

share|improve this question
    
Related, but no answer –  ssch Nov 17 '13 at 17:00
2  
There's a reason why it's called tour. It's a roundtrip, so what you get is the total distance including the trip to back the starting point. With only three points, order doesn't matter. –  Sjoerd C. de Vries Nov 17 '13 at 17:23
    
Combinatorica has TravelingSalesman, but that seems to do a whole tour too. –  Sjoerd C. de Vries Nov 17 '13 at 17:48
    
Well, I also tried FindShortestPath - but that just beeped at my input, which probably is not in graph format. I've got the Pemmaraju/Skiena Combinatorica book ... am looking at it now. –  wolfies Nov 17 '13 at 17:48
    
FindShortestPath needs a Graph plus start and end points. –  Sjoerd C. de Vries Nov 17 '13 at 17:49

1 Answer 1

up vote 4 down vote accepted

Assuming there is a Method other than "AllTours" that doesn't break if one point doesn't obey the triangle inequality, introduce a special point that has a distance 0 to all other points:

points = {{-0.9, -0.89}, {.99, .97}, {0.1, .0}, magicPoint};
d[args__] /; FreeQ[{args}, magicPoint] := EuclideanDistance[args]
d[__] = 0;
FindShortestTour[points, DistanceFunction -> d]
(* {2.65513, {1, 3, 2, 4}} *)

To know in which cases this holds one would have to know more about the different methods than I do.

Wrapping it up into usable form:

shortestPolygonPath[points_, opts : OptionsPattern[FindShortestTour]] :=
 Module[{
   distanceFunction = 
    If[# === Automatic, EuclideanDistance, #] &[OptionValue[DistanceFunction]],
   magicPoint, d
   },
  d[args__] /; FreeQ[{args}, magicPoint] := distanceFunction[args];
  d[__] = 0;
  FindShortestTour[
    Append[points, magicPoint],
    DistanceFunction -> d,
    opts
    ] /. {
      l : {__Integer} :> 
      Most@RotateLeft[l, Position[l, 1 + Length@points, 1, 1][[1, 1]]]
      }

  ]
shortestPolygonPath[{{-0.9, -0.89}, {.99, .97}, {0.1, .0}, {.7, -.1}}]
(* {3.05557, {1, 3, 4, 2}} *)
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.