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

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.

• This looks like a modification of the Traveling Salesman(person) Problem, wherein the distance from last stop back to origin is not considered. – Daniel Lichtblau Dec 3 '20 at 15:12

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


  {{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],
Arrow /@ Partition[#, 2, 1] & @h amiltonianpath, Opacity[1], Black,
AbsolutePointSize[7], Point @ list, Red, Point @ First @ hamiltonianpath}]


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!