How to represent a list as a cycle

Question

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?

Answer 1

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}

Answer 2

A solution using the built-in Cycles comparison:

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

Answer 3

If someone needs efficient way of cyclic-sorting of packed arrays, then here's compiled function that does it:

cyclicSortInt = Compile[{{list, _Integer, 1}},
  Module[
    {
      min = Compile`GetElement[list, 1],
      next = Range[Length@list + 1],
      prevIndex = 1,
      currIndex, curr, i, iMin, prevIndexRef
    },
    next[[-1]] = -1;
    (* Remove non-minimal elements from linked list of minimum candidates. *)
    Do[
      curr = Compile`GetElement[list, currIndex];
      If[curr < min,
        next[[1]] = currIndex;
        min = curr;
        prevIndex = currIndex
      (* else *),
        (* Remove element if it's greater than minimal or if previous element is also minimal.
           Removing of consecutive minimal elements, except first in sequence, doesn't change results,
           but significantly increasses speed. *)
        If[curr > min || Compile`GetElement[list, currIndex - 1] == min,
          next[[prevIndex + 1]] = Compile`GetElement[next, currIndex + 1]
        (* else *),
          prevIndex = currIndex
        ]
      ]
      ,
      {currIndex, 2, Length@list}
    ];
    i = 1;
    While[Compile`GetElement[next, Compile`GetElement[next, 1] + 1] != -1 && i <= Length@list - 1,
      (* Remove minimum candidates with non-minimal element `i` elements away from them. *)
      prevIndex = prevIndexRef = Compile`GetElement[next, 1];
      currIndex = Compile`GetElement[next, prevIndex + 1];
      iMin = Compile`GetElement[list, Mod[prevIndex + i, Length@list, 1]];
      While[currIndex != -1,
        curr = Compile`GetElement[list, Mod[currIndex + i, Length@list, 1]];
        If[curr < iMin,
          next[[1]] = currIndex;
          iMin = curr;
          prevIndex = prevIndexRef = currIndex
        (* else *),
          If[curr > iMin,
            next[[prevIndex + 1]] = Compile`GetElement[next, currIndex + 1]
          (* else *),
            (* If current minimum candidate is `i` elements from previous candidate with same `i` elements after,
               then remove current candidate since it can't be better than previous.
               This doesn't change results, but significantly increasses speed
               in case of multiple repeated sequences containing minimal element e.g. {1,2,1,2,...} *)
            If[currIndex - prevIndexRef == i,
              next[[prevIndex + 1]] = Compile`GetElement[next, currIndex + 1];
              prevIndexRef = currIndex;
            (* else *),
              prevIndex = currIndex
            ]
          ]
        ];
        currIndex = Compile`GetElement[next, currIndex + 1]
      ];
      ++i
    ];
    RotateLeft[list, Compile`GetElement[next, 1] - 1]
  ],
  CompilationTarget -> "C", RuntimeOptions -> "Speed",
  RuntimeAttributes -> {Listable}, Parallelization -> True
]

Tests

Let's check that it gives same results as Mr. Wizard's canonize for all representative lists of up to 8 elements:

Permutations[Join @@ MapIndexed[ConstantArray[First@#2, #1] &, #]] & /@ Permutations[#] & /@ IntegerPartitions[#] & /@ Range@8 //
  Flatten[#, 3] & //
  Map[With[{pred = cyclicSortInt@# === canonize@#}, If[pred =!= True, Print@#]; pred] &] //
  Apply@And //
  AbsoluteTiming
(* {8.93922, True} *)

Benchmarks

Its advantage over canonize grows with number of repetitions of minimal element in a list:

(* No repetitions: *)
tmp = Range@(10^4);
(res1 = canonize@tmp) // MaxMemoryUsed // RepeatedTiming
(res2 = cyclicSortInt@tmp) // MaxMemoryUsed // RepeatedTiming
res1 === res2
(* {0.00064,   243632} *)
(* {0.0000356, 320600} *)
(* True *)

(* Around 2% out of 10^4 are minimal elements: *)
SeedRandom@0
tmp = RandomInteger[50, 10^4];
(res1 = canonize@tmp) // MaxMemoryUsed // RepeatedTiming
(res2 = cyclicSortInt@tmp) // MaxMemoryUsed // RepeatedTiming
res1 === res2
(* {0.0068,  27468488} *)
(* {0.0000403, 320600} *)
(* True *)

(* Only minimal elements: *)
tmp = ConstantArray[1, 10^4];
(res1 = canonize@tmp) // MaxMemoryUsed // RepeatedTiming
(res2 = cyclicSortInt@tmp) // MaxMemoryUsed // RepeatedTiming
res1 === res2
(* {0.760, 1601303688} *)
(* {0.0000415, 320600} *)
(* True *)

If we want to "sort" multiple lists we can take advantage of listability (and paralelization) by simply acting with cyclicSortInt on list of lists instead of mapping it:

SeedRandom@0
tmp = RandomInteger[4, {10^4, 5}];
(res1 = Union[canonize /@ tmp]) // Length // RepeatedTiming
(res2 = Union@cyclicSortInt@tmp) // Length // RepeatedTiming
res1 === res2
(* {0.12,   629} *)
(* {0.0032, 629} *)
(* True *)