Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I want to select distinct cycles (represented by List).

The cycle {a, b, c, d} must be the same as {b, c, d, a} or {c, d, a, b} or {d, a, b, c}. But is not equal to {a, c, b, d}.

The distinct cycles from this set

{{a, b, c, d}, {a, b, d, c}, {a, c, b, d}, {a, c, d, b}, {a, d, b, c}, 
 {a, d, c, b}, {b, a, c, d}, {b, a, d, c}, {b, c, a, d}, {b, c, d, a}, 
 {b, d, a, c}, {b, d, c, a}, {c, a, b, d}, {c, a, d, b}, {c, b, a, d}, 
 {c, b, d, a}, {c, d, a, b}, {c, d, b, a}, {d, a, b, c}, {d, a, c, b}, 
 {d, b, a, c}, {d, b, c, a}, {d, c, a, b}, {d, c, b, a}}

must be {a,b,c,d},{a,b,d,c},{a,c,b,d},{a,c,d,b},{a,d,c,b},{a,d,b,c}.

I want to know whether any two cycles are the same or not. The cycle I involve has length 14.

For example,

{a1, a2, a5, a6, a7, b1, b2, b3, b4, b5, b6, b7, a3, a4}

{a1, a2, a3, a4, a5, a6, a7, b1, b2, b3, b4, b5, b6, b7}

{b1, b2, b3, b4, b5, b6, b7, a3, a4, a1, a2, a5, a6, a7}

How to code in Mathematica?

share|improve this question
    
Related: (5799) –  Mr.Wizard Feb 6 at 9:50

2 Answers 2

up vote 12 down vote accepted

Assuming that your lists contain no duplicates you can use this:

set = 
{{a, b, c, d}, {a, b, d, c}, {a, c, b, d}, {a, c, d, b}, {a, d, b, c}, 
 {a, d, c, b}, {b, a, c, d}, {b, a, d, c}, {b, c, a, d}, {b, c, d, a}, 
 {b, d, a, c}, {b, d, c, a}, {c, a, b, d}, {c, a, d, b}, {c, b, a, d}, 
 {c, b, d, a}, {c, d, a, b}, {c, d, b, a}, {d, a, b, c}, {d, a, c, b}, 
 {d, b, a, c}, {d, b, c, a}, {d, c, a, b}, {d, c, b, a}};

DeleteDuplicates[
  RotateLeft[#, Ordering[#,1] - 1] & /@ set
]
{{a, b, c, d}, {a, b, d, c}, {a, c, b, d}, {a, c, d, b}, {a, d, b, c}, {a, d, c, b}}

Extension to lists with duplicates

A pairwise comparison with SameTest will always be slower than placing elements into a canonical form and using Union or DeleteDuplicates with the default algorithms. To that end I propose this for lists that may have duplicates:

canonize[a_List] := 
  With[{X = # ~Extract~ Ordering[#, 1] &},
    RotateLeft[a, # - 1] & /@ Position[a, X @ a] // X
  ]

Example:

SeedRandom[1];

set =
  Join[
    Table[RandomSample[{a, b, c, d}, 4], {20}],
    RandomChoice[{a, b, c, d}, {5, 4}]
  ];

Union[canonize /@ set]
{{a, a, a, c}, {a, b, c, d}, {a, b, d, c}, {a, c, a, d},
 {a, c, b, d}, {a, c, d, b}, {a, d, b, b}, {a, d, b, c},
 {a, d, c, b}, {b, c, b, c}}

This is far faster than a pairwise compare:

rotatedQ[{x___}, {y___}] := (* example function provided by whuber *)
  Length[{x}] == Length[{y}] && MatchQ[{y, y}, {___, x, ___}];

big = RandomInteger[4, {5000, 5}];

Union[canonize /@ big] // Length // Timing

Union[big, SameTest -> rotatedQ] // Length // Timing

{0.047, 629}

{5.007, 629}

share|improve this answer
    
If the OP wants a pairwise test, then modify as follows: SameCycleQ[c1_, c2_] := c1 === RotateLeft[c2, First@Position[c2, First[c1]] - 1]. –  Michael E2 Dec 28 '12 at 15:15
    
@Mr Very nice! I understand that your second method selects the lexicographically earliest representative of the class of all rotations of a list and then replaces any list by its representative. Because that is far superior in timing to the (quadratic) pattern-matching solution I posted, I'm deleting that solution. –  whuber Dec 28 '12 at 21:26
    
@whuber Thanks for reviewing my method. That is indeed what I am attempting. I'm sorry to see your method disappear as it is quite elegant, even if not fast. –  Mr.Wizard Dec 28 '12 at 21:30

A solution using the built-in Cycles comparison:

numbering = MapIndexed[#1 -> #2[[1]] &, Sort[set[[1]]]];
DeleteDuplicates[set, Cycles[{#1}] == Cycles[{#2}] /. numbering &]
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.