4
$\begingroup$

Suppose there are points {ai,bi}; i = 1,....,N, but this is given in some jumbled order such as {{a2,b2}, {a5,b5}, {a1,b1},...,}.

I want to sort this into a sequence {{a1,b1},{a2,b2},.....} so that d(i+1,i) is the smallest possible where d(i,j) is the Euclidean distance between i and j.

I have tried to use Sort command but I seem to be using it incorrectly.

$\endgroup$
  • 1
    $\begingroup$ This looks like a modification of the Traveling Salesman(person) Problem, wherein the distance from last stop back to origin is not considered. $\endgroup$ – Daniel Lichtblau Dec 3 '20 at 15:12
6
$\begingroup$
SeedRandom[1]
list = RandomInteger[100, {20, 2}];

ReplaceRepeated

Pick one of the two farthest apart elements as starting point:

start = First @ First@MaximalBy[EuclideanDistance @@ # &]@Subsets[list, {2}];

Starting with {{start}, DeleteCases[list, start]}, use ReplaceRepeated to replace the pair of lists {list1, list2} with a new pair of lists by (i) appending to list1 the element from list2 nearest to the last element of list1 and (ii) deleting list1 from list2:

sortedlist = First @ Most[{{start}, DeleteCases[list, start]} //. {{a___, b_}, 
      Except[{}, c_List]} :> With[{ x = {a, b, Nearest[c, b, 1][[1]]}},
   {x, DeleteCases[Alternatives @@ x] @ c}]]
{{3, 65}, {0, 67}, {1, 30}, {24, 4}, {48, 25}, {47, 28}, {43, 33}, {68, 26},
 {74, 15}, {80, 14}, {68, 10}, {93, 18}, {100, 23}, {97, 68}, {86, 76}, 
 {83, 70}, {69, 56}, {44, 73}, {44,  86}, {100, 90}}
Graphics[{ Blue, Line @ list, AbsoluteThickness[3], Opacity[.7], Green, 
  Arrowheads[Large], Arrow /@ Partition[#, 2, 1] &@sortedlist, 
  Opacity[1], Black, AbsolutePointSize[7], Point@list, Red,  Point@start}]

enter image description here

NestWhile

Alternatively, we could use NestWhile:

sortedlist2 = First @ Most @ NestWhile[
     With[{dc = DeleteCases[#[[2]], Alternatives @@ #[[1]]]}, 
       If[dc == {}, {#[[1]], {}}, {Join[#[[1]], 
          Nearest[dc, #[[1, -1]], 1]], 
         DeleteCases[dc, Alternatives @@ #[[1]]]}]] &, {{start}, 
      DeleteCases[start]@list}, #[[2]] =!= {} &];

sortedlist2 == sortedlist
 True

FindShortestTour

shortesttour = FindShortestTour[list][[2]];

breakat = Last @ First @ MaximalBy[EuclideanDistance @@ list[[#]] &]@
     Partition[shortesttour, 2, 1];

shortestpath = list[[DeleteDuplicates[Join @@
    Reverse[Split[shortesttour, #2 != breakat &]]]]]
{{44, 86}, {44, 73}, {69, 56}, {83, 70}, {86, 76}, {100, 90}, {97,  68}, 
{100, 23}, {93, 18}, {80, 14}, {74, 15}, {68, 10}, {68, 26}, 
{48, 25}, {47, 28}, {43, 33}, {24, 4}, {1, 30}, {3, 65}, {0,  67}}
Graphics[{ Blue, Line@list, AbsoluteThickness[3], Opacity[.7], Orange,
   Arrowheads[Large], Arrow /@ Partition[#, 2, 1] &@shortestpath, 
  Opacity[1], Black, AbsolutePointSize[7], Point@list,  Red, 
  Point@shortestpath[[1]]}]

enter image description here

FindHamiltonianPath

dm = DistanceMatrix[list, list];

hamiltonianpath = list[[FindHamiltonianPath@WeightedAdjacencyGraph[dm]]]
  {{100, 23}, {93, 18}, {80, 14}, {74, 15}, {68, 10}, {68, 26}, {48, 25}, 
 {47, 28}, {43, 33}, {24, 4}, {1, 30}, {3, 65}, {0, 67}, {44,   86}, 
 {44, 73}, {69, 56}, {83, 70}, {86, 76}, {97, 68}, {100, 90}}
Graphics[{ Blue, Line @ list, AbsoluteThickness[3], Opacity[.7], 
  Magenta, Arrowheads[Large], 
  Arrow /@ Partition[#, 2, 1] & @h amiltonianpath, Opacity[1], Black, 
  AbsolutePointSize[7], Point @ list, Red, Point @ First @ hamiltonianpath}]

enter image description here

$\endgroup$
3
$\begingroup$

This can be done by a number of ways, and the results will be different. You did not specify the way to take.

For example, here is the list of points:

lst = RandomReal[{-10, 10}, {10, 2}]

(*  {{5.89149, -4.3352}, {3.98278, 4.59527}, {9.32045, 
  7.73512}, {0.943589, 7.5915}, {-7.74408, -0.850429}, {-8.69404, -8.49791}, {-5.3345, 0.0408344}, {-3.3804, -2.58724}, {1.25562, 1.97175}, {8.82761,8.23534}}   *)

Let us take the first point and sort the other ones such that the point corresponding to a smaller distance to the very first one comes earlier:

lst2 = SortBy[lst, EuclideanDistance[lst[[1]], #] &]

(*  {{5.89149, -4.3352}, {1.25562, 1.97175}, {3.98278, 
  4.59527}, {-3.3804, -2.58724}, {-5.3345, 0.0408344}, {9.32045, 
  7.73512}, {8.82761, 8.23534}, {0.943589, 7.5915}, {-7.74408, -0.850429}, {-8.69404, -8.49791}}  *)

Let us check building the list of distances:

EuclideanDistance[lst[[1]], #] & /@ lst2

(*  {0., 7.82745, 9.13217, 9.43521, 12.0488, 12.5479, 12.9089, 12.9123, \
14.0738, 15.1679}  *)

Have fun!

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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