SeedRandom[1]
list = RandomInteger[100, {20, 2}];
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}]

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

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