How do I sort points {ai,bi}; i = 1,2,…,N so that immediate successors are closest?

Question

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.

Answer 1

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}]

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]]}]

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}]

Answer 2

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!