12
$\begingroup$

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?

$\endgroup$
15
$\begingroup$

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}

$\endgroup$
  • $\begingroup$ If the OP wants a pairwise test, then modify as follows: SameCycleQ[c1_, c2_] := c1 === RotateLeft[c2, First@Position[c2, First[c1]] - 1]. $\endgroup$ – Michael E2 Dec 28 '12 at 15:15
  • $\begingroup$ @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. $\endgroup$ – whuber Dec 28 '12 at 21:26
  • $\begingroup$ @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. $\endgroup$ – Mr.Wizard Dec 28 '12 at 21:30
6
$\begingroup$

A solution using the built-in Cycles comparison:

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

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