# How to represent a list as a cycle

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?

-
Related: (5799) – Mr.Wizard Feb 6 '14 at 9:50

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}

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

-