Rearranging a List

Question

I am trying to rearrange/sort a list i.e.

 {{1,2},{10,140},{43,10},{1,140},{43,2}}

into

 {{1,2},{2,43},{43,10},{10,140},{140,1}} 

or any cyclic permutation of it. The numbers don't repeat more than twice. It needs to be rather efficient since I am applying to large lists, in a large sets of lists.

I have a quick code that seems to do the job, but I don't like all those appends.

Myarrangemnt[list_] := 
 Module[{x = list, len = Length[list], finalarragment = {First@list},tt},
 x = Drop[x, {1}];
 While[Length[finalarragment] < len,
 tt = First@
  Cases[x, 
   y_ /; Equal[Last@Last@finalarragment, y[[1]]] ||
   Equal[Last@Last@finalarragment, y[[2]]]];
 If[First[tt] == Last@Last@finalarragment,
    finalarragment = Append[finalarragment, tt],
    finalarragment = Append[finalarragment, Reverse@tt]
   ];
 x = Drop[x, First@Position[x, tt]];
 ];
 Return[finalarragment];
 ];

Here is a random test list

test = RandomSample /@ (RandomSample@
Partition[RandomInteger[{1, 1000}, 100], 2, 1, -1])

Is there a more efficient way to achieve this ? Maybe with Reap and Sow and/or SortyBy ?

Answer 1

In your particular case, the following does the job:

lst = {{1, 2}, {10, 140}, {43, 10}, {1, 140}, {43, 2}};
List @@@ If[# === {}, {}, First[#]] &[FindHamiltonianCycle[Graph[UndirectedEdge @@@ lst]]]

(* {{1, 2}, {2, 43}, {43, 10}, {10, 140}, {140, 1}} *)

To work for your larger test, it should be generated by a variation of your code:

test = RandomSample /@ (RandomSample@Partition[RandomSample[Range[1000], 100], 2, 1, -1]);

so that each number is indeed repeated exactly two times.

Answer 2

Using Mathematica 7:

Needs["Combinatorica`"]
Partition[Flatten@ExtractCycles@FromUnorderedPairs@list, 2, 1]

=>

{{140, 1}, {1, 2}, {2, 43}, {43, 10}, {10, 140}}

Edit

testLalmei = 
  RandomSample /@ (RandomSample@
     Partition[RandomInteger[{1, 1000}, 100], 2, 1, -1]);

ExtractCycles@FromUnorderedPairs@testLalmei

=>

{

{643, 115, 518, 238, 469, 250, 484, 455, 314, 445, 436, 174, 950,
981, 905, 855, 531, 948, 735, 987, 380, 282, 643},

{922, 70, 780,
971, 619, 895, 237, 227, 493, 315, 516, 366, 902, 635, 882, 290,
584, 735, 273, 229, 686, 761, 940, 922},

{389, 29, 329, 614, 897,
789, 547, 383, 697, 832, 971, 482, 991, 581, 652, 328, 479, 834,
404, 646, 543, 414, 860, 280, 982, 376, 933, 992, 928, 89, 559, 500,
861, 389},

{928, 10, 523, 291, 88, 727, 319, 405, 748, 550, 526,
940, 662, 457, 881, 399, 917, 330, 975, 928},

{360, 405, 89, 360}

}

testLeonid = 
  RandomSample /@ (RandomSample@
     Partition[RandomSample[Range[1000], 100], 2, 1, -1]);

ExtractCycles@FromUnorderedPairs@testLeonid

{

{588, 15, 268, 797, 746, 111, 341, 490, 527, 743, 163, 402, 800, 798, 652, 299, 210, 854, 355, 793, 98, 109, 466, 203, 693, 694, 575,
539, 223, 344, 549, 347, 470, 76, 594, 380, 441, 698, 875, 293, 394,
285, 300, 129, 556, 457, 240, 79, 855, 520, 950, 584, 897, 872,
638, 16, 637, 763, 602, 595, 459, 176, 89, 752, 839, 864, 494, 579,
577, 310, 169, 935, 508, 184, 22, 871, 631, 128, 995, 114, 881, 389,
885, 412, 296, 116, 932, 255, 489, 208, 900, 521, 814, 325, 974,
159, 809, 162, 690, 992, 588}

}

Edit 2. Just for fun

GraphPlot[#, DirectedEdges -> True, 
   VertexLabeling -> True] & /@ (Rule @@@ Partition[#, 2, 1] & /@ 
   ExtractCycles@FromUnorderedPairs@testLalmei)

Answer 3

FindCycle

cyclesF = List @@@ # &/@ FindCycle[UndirectedEdge @@@ #, Infinity, All]&;

cyclesF @{{1, 2}, {10, 140}, {43, 10}, {1, 140}, {43, 2}}

{{1, 2}, {2, 43}, {43, 10}, {10, 140}, {140, 1}}