How to judge whether two groups of sequences are equal in cycles?

Question

There's a set of arrays that I want to remove repeated elements that are equal after rotation:

arr = {{1, 2, 3, 4, 5}, {2, 3, 4, 5, 1}, {5, 1, 2, 3, 4}, {4, 3, 2, 5,1}};

The elements {1, 2, 3, 4, 5}, {2, 3, 4, 5, 1}and {5, 1, 2, 3, 4}are the same after operation RotateLeft. I want to delete the duplicate elements and only get {1, 2, 3, 4, 5} and {4, 3, 2, 5, 1}.

DeleteDuplicates[arr, RotateLeft[#1] == #2 &]

However, the above operation can only delete the elements that are equal after one shift.

Answer 1

Another idea is to make use of the fact that Cycles canonicalizes. For example:

Cycles[{{5,1,2,3,4}}]

Cycles[{{1, 2, 3, 4, 5}}]

So,

DeleteDuplicatesBy[arr, Cycles @* List]

{{1, 2, 3, 4, 5}, {4, 3, 2, 5, 1}}

Answer 2

If we consider the list elements as graph vertices with an edge between each consecutive pair (cyclically), then two lists are equivalent if they can be mapped to graphs with the same edges. In code:

graphs[list_] := <| # -> Sort@Thread[# -> RotateLeft[#]] & /@ list |>

So then:

graphs[arr]

(*
  <| {1,2,3,4,5} -> {1->2, 2->3, 3->4, 4->5, 5->1}
   , {2,3,4,5,1} -> {1->2, 2->3, 3->4, 4->5, 5->1}
   , {5,1,2,3,4} -> {1->2, 2->3, 3->4, 4->5, 5->1}
   , {4,3,2,5,1} -> {1->4, 2->5, 3->2 ,4->3, 5->1}
   |>
*)

And:

DeleteDuplicatesBy[arr, graphs[arr]]

(* {{1,2,3,4,5}, {4,3,2,5,1}} *)

Answer 3

Maybe

DeleteDuplicatesBy[arr, Mod[# - #[[1]], 5] &]

does what you want. It replaces rotation operations by basuc integer arithmetic.

However, this exploits that only the numbers 1--5 appear in the lists. I don't know whether that is your actual use case...

The following would be a more general method:

DeleteDuplicatesBy[arr, RotateLeft[#, Ordering[#, -1][[1]] - 1] &]

It normalizes the entries of arr by determining the smallest entry and rotating it in front.

Answer 4

arr = {{1, 2, 3, 4, 5}, {2, 3, 4, 5, 1}, {5, 1, 2, 3, 4}, {4, 3, 2, 5,1}};
DeleteDuplicatesBy[list, Sort[Table[RotateLeft[#, i], {i, 1, 5}]] &] // Length

2

Answer 5

The simplest and the most solid solution is

DeleteDuplicatesBy[arr, Sort[NestList[RotateLeft, #, Length[#] - 1]] &]

If this solution is too slow for you, you might devise something like

DeleteDuplicatesBy[arr, RotateLeft[#, Last[Ordering[#]]] &]

But the latter works only if you know that there are no repetitions in each group. For example, it does not work for

arr={{1, 2, 2}, {2, 1, 2}};

The former solution always works, but is slower. For example, for

arr = Table[RandomSample[Range[7]], 10^4];

the average evaluation time differs by a factor of 3 (0.062 sec. vs 0.023 sec.).

Answer 6

Define an orbit index using CyclicGroup:

orbitIndex = Association[Join @@ MapIndexed[Thread[# -> #2[[1]]] &] @
      GroupOrbits[CyclicGroup[Length @ First @ #], #, Permute]] &;

DeleteDuplicatesBy[arr, orbitIndex[arr]]

{{1, 2, 3, 4, 5}, {4, 3, 2, 5, 1}}

DeleteDuplicates[arr, orbitIndex[arr][#] == orbitIndex[arr][#2] &]

{{1, 2, 3, 4, 5}, {4, 3, 2, 5, 1}}

An example with repeated elements:

arr2 = arr /. 3 -> 2

{{1, 2, 2, 4, 5}, {2, 2, 4, 5, 1}, {5, 1, 2, 2, 4}, {4, 2, 2, 5, 1}}

DeleteDuplicatesBy[arr2, orbitIndex[arr2]]

{{1, 2, 2, 4, 5}, {4, 2, 2, 5, 1}}

DeleteDuplicates[arr2, orbitIndex[arr2][#] == orbitIndex[arr2][#2] &]

{{1, 2, 2, 4, 5}, {4, 2, 2, 5, 1}}

Symbolic elements:

arr3 = arr /. MapIndexed[#2[[1]] -> # &, {"A", "B", "C", "D", "E"}]

 {{"A", "B", "C", "D", "E"}, {"B", "C", "D", "E", "A"},
  {"E", "A", "B", "C", "D"}, {"D", "C", "B", "E", "A"}}

DeleteDuplicatesBy[arr3, orbitIndex[arr3]]

{{"A", "B", "C", "D", "E"}, {"D", "C", "B", "E", "A"}}

DeleteDuplicates[arr3, orbitIndex[arr3][#] == orbitIndex[arr3][#2] &]

{{"A", "B", "C", "D", "E"}, {"D", "C", "B", "E", "A"}}