11
$\begingroup$

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 ?

$\endgroup$
  • $\begingroup$ Your code for generation of the test list violates your condition on number repetition, in general. $\endgroup$ – Leonid Shifrin Feb 13 '14 at 13:13
  • $\begingroup$ @LeonidShifrin yes, that condition is not really necessary. In my case the data is not random numbers so I know for a fact they won't repeat so if there is a efficient way that requires that, for me would be fine. $\endgroup$ – lalmei Feb 13 '14 at 13:16
  • $\begingroup$ Brother of this question $\endgroup$ – Rorschach Feb 28 '14 at 7:28
  • $\begingroup$ I tried this module and found that using it a second time it falls in mistakes like to have hanged in a infinite recursion or alike... can it be a problem of me or this module has a problem? $\endgroup$ – Anxon Pués Jan 13 '18 at 10:19
9
$\begingroup$

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.

$\endgroup$
8
$\begingroup$

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)

enter image description here

$\endgroup$
1
$\begingroup$

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

$\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.