17
$\begingroup$

Given a list of lists of integers, all of the same length, I want to regard two elements as equivalent if one is the rotated and/or reflected version of another (that is, if the two lists are the same if they are regarded as beads on a chain). So, for example, given

{{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 2}, 
 {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 2}, 
 {1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 2}, 
 {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}}

I would like to return

{{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, 
 {1, 2, 3, 1, 2, 3}}

or something representing one element from each equivalence class. I haven't written any code that actually does this; the only thing I can think of is something really ugly using a custom function for Tally.

Edit: Set equality is not what I need here, although the example I gave did not show it. For example, if two of the sublists were {1,1,4,2,2} and {1,4,1,2,2}, those are not equivalent as necklaces but TestSetsEqual will say that the two are equivalent.

And, in response to a question in a comment below, yes, {1,2,3,4,5} and {2,1,5,4,3} are equivalent --- if a list can be transformed into another by a sequence of RotateLefts and Reverses, the two are equivalent.

Finally, all of the sublists I'm considering are short, under ten integers, though there may be thousands of sublists in the input.

$\endgroup$
  • $\begingroup$ How long are your real lists? Is this considered to be equal: {1, 2, 3, 4, 5} and Reverse[RotateLeft[{1, 2, 3, 4, 5}, 2]]? $\endgroup$ – halirutan Apr 28 '17 at 1:51
  • 3
    $\begingroup$ Very interesting question, distracted me for most of the day +1 $\endgroup$ – LLlAMnYP Apr 28 '17 at 12:03
16
$\begingroup$

A high-performance solution

Since you are planning to work with thousands of necklaces, it may be much faster to introduce a canonical form.

The main point is to write a necklace canonization function, which for all equivalent necklaces should return exactly the same result (canonical form). You can then apply canonization function to all necklaces in your list and use standard DeleteDuplicates procedure afterwards.

For simplicity we can take First@Sort@equivalentForms[necklace] as a canonical form (here equivalentForms generates all necklaces equivalent to a given one). In this case the full solution can be written as:

equivalentForms[nl_] := Join[NestList[RotateLeft, nl, Length[nl] - 1], NestList[RotateLeft, Reverse[nl], Length[nl] - 1]];
canonicalForm[nl_] := First@Sort@equivalentForms[nl];
myDeleteDuplicateNecklaces[list_] := DeleteDuplicates[Map[canonicalForm,list]]

(thanks to @LLlAMnYP for suggesting a more idiomatic code for equivalentForms)

For your example we get:

smallList = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 2},
{1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 2},
{1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 2},
{2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}};

myDeleteDuplicateNecklaces[smallList]

{{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}}

Benchmarks for large input:

Let's take a list of 5000 necklaces:

largeList = RandomInteger[{1, 3}, {5000, 10}];

and compare calculation times (in seconds)

@kglr's answer

First@AbsoluteTiming[f[largeList];]

158.356

@halirutan's answer

First@RepeatedTiming[deleteNecklaceDuplicates[largeList];]

1.941

This answer:

First@RepeatedTiming[myDeleteDuplicateNecklaces[largeList];]

0.077

As we can see from the benchmarks, for large lists this solution is 10 to 1000 times faster.

Update: compilation and parallel evaluation optimizations

@LLlAMnYP and @halirutan showed that canonization procedure can be significantly optimized using Mathematica's compilation and parallelization capabilities. They provided the following highly-optimized code, which calculates all canonical forms in parallel and gives further speedup:

canonicalFormC = Compile[{{list, _Integer, 1}},
   Module[{l =
      NestList[RotateLeft, list, Length[list] - 1]~Join~
       NestList[RotateLeft, Reverse[list], Length[list] - 1]},
    Compile`GetElement[l, First[Ordering[l]]]
    ],
   RuntimeAttributes -> {Listable},
   Parallelization -> True,
   CompilationTarget -> "C",
   RuntimeOptions -> "Speed"
   ];
myDeleteDuplicateNecklacesC[list_] := DeleteDuplicates[canonicalFormC[list]]

Benchmark of the compiled procedure:

First@RepeatedTiming[myDeleteDuplicateNecklacesC[largeList];]

0.00576

Thus, compilation and parallelization optimizations give additional 10x speedup.

$\endgroup$
  • $\begingroup$ +1 for same thinking. I felt opposed to generating 2n permutations, but I guess procedural code is simply slower in MMA than to simply generate everything. $\endgroup$ – LLlAMnYP Apr 28 '17 at 11:15
  • 1
    $\begingroup$ The equivalent forms are more tersely expressed as NestList[RotateLeft, list, Length[list]]~Join~ NestList[RotateLeft, Reverse[list], Length[list]], the canonical form is then fully compilable. I'll add a benchmark. $\endgroup$ – LLlAMnYP Apr 28 '17 at 11:47
  • 1
    $\begingroup$ @LLlAMnYP God d*** it. I thought for about 10 min if I can calculate a canonical form without creating all possibilities. It never even crossed my mind that doing exactly this would work reasonably fast, I fact extraordinarily fast. Has someone tried to combine my approach of doing everything in parallel with this here? Very good answer +1 $\endgroup$ – halirutan Apr 28 '17 at 12:05
  • $\begingroup$ @halirutan see my update, when compiled, +1 order of magnitude $\endgroup$ – LLlAMnYP Apr 28 '17 at 12:07
  • 1
    $\begingroup$ @hal Also, as I learned, it's impossible to find the canonical form without O(n) time anyway, and my roundabout approach only complicates things to probably O(n logn) $\endgroup$ – LLlAMnYP Apr 28 '17 at 12:12
13
$\begingroup$

Preface

If one could create a function f that calculates a canonical form of a necklace that turns all equivalent necklaces {t1, t2, ...} into one unique form t the solution is simple: Take your input list, create the canonical form of each item and delete all duplicates. If the function f is fast, then this approach should be the way to go.

As shown in Shadowray's answer, the direct way of creating all possible allowed permutations and just take the smallest is incredibly fast, especially if you combine it with a parallel compilation as shown in my answer. Therefore, please go and check out his answer.

Answer

If you want to calculate this on a list with thousands of necklaces of say length 10 you will need a fast approach (if you are not a very patient tea-drinker).

Let us first think how we can decide the equivalence of two lists t1 and t2 in an optimised way. I suggest the following sequence of 3 steps where each step is harder to calculate:

  1. If the Total of the two lists is not equal, they are definitely not in the same equivalence class
  2. If they are identical or identical to the Reverse of the other, they are in the same equivalence class
  3. Assume we have {1,2,3} and {3,1,2}. What we do is we join one with itself {1,2,3,1,2,3} and now we go stepwise through this longer list and compare the current 3 elements. Since we already tested for exact equality, we start at position 2:
    • is {3,1,2} equal to {2,3,1}, no.
    • is {3,1,2} equal to {3,1,2}, yes!

If you do step 3. with both, {1,2,3} and the reversed {3,2,1} you catch all rotated/reflected equivalences. Let us compile this down so that we can parallelised compare one element with the whole list:

pickFunc = Compile[{{t1, _Integer, 1}, {t2, _Integer, 1}},
   Module[{t = {0}, t1Rev = {0}, len = Length[t2], res = True},
    If[Total[t1] != Total[t2], Return[True]];
    If[t1 === t2 || t1 === Reverse[t2], Return[False]];
    t = Join[t2, t2];
    t1Rev = Reverse[t1];
    Do[
     If[t1 === t[[i ;; i + len - 1]] || 
       t1Rev === t[[i ;; i + len - 1]],
      res = False;
      Break[]
      ], {i, 2, Length[t2]}
     ];
    res
    ], RuntimeAttributes -> {Listable}, Parallelization -> True
   ];

Taking your original list we can now test

pickFunc[list[[3]], list]
(* {True, True, False, True, True, True, True, False, True, True, True} *)

At all False positions we have an element that is equivalent to the test item. Why have I made the function return False? Because now I know which elements I have to take out for further processing.

The rest of the algorithm is as follows: We start with the initial list and its first element. We store the first element and pick out all that are not equivalent. This cleaned list is our new starting point and we iterate all over again. On our way, we collect all first items in res until our list to check is empty.

deleteNecklaceDuplicates[list_List] := Module[{l = list, res = {}},
  res = {};
  While[Length[l] > 0,
   res = {res, l[[1]]};
   l = Pick[l, pickFunc[l[[1]], l]]
   ];
  Partition[Flatten[res], Length[First[list]]]
  ]

Sidenote: I don't Append to res because it is slow. Instead, I build a nested result list with res = {res, newitem}. At the end I flatten out res and partition it again.

list = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 
    2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 
    2}, {1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 
    2}, {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}};
deleteNecklaceDuplicates[list]
(* {{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 
  3}, {1, 2, 3, 1, 2, 3}} *)

But here comes the cool part! Using @kglr's implementation in f:

list = RandomInteger[{1, 3}, {500, 10}];

f[list] === deleteNecklaceDuplicates[list]
(* True *)

Let us time this:

AbsoluteTiming[f[list];]
(* {1.74933, Null} *)

and

AbsoluteTiming[deleteNecklaceDuplicates[list];]
(* {0.11883, Null} *)

But how fast are we on a list with thousands? Let's try:

list = RandomInteger[{1, 3}, {5000, 10}];
AbsoluteTiming[deleteNecklaceDuplicates[list];]
(* {3.13899, Null} *)

I hope 3 seconds is fast enough.

$\endgroup$
  • $\begingroup$ The equivalence test is smart (+1), too bad it's slow. $\endgroup$ – LLlAMnYP Apr 28 '17 at 11:40
10
$\begingroup$
ClearAll[f]
f = DeleteDuplicates[#, MemberQ[Join @@ NestList[RotateLeft /@ # &, 
    {#, Reverse @ #}, Length@#], #2] &] &;

list = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 2}, 
   {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 2},
   {1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 2}, 
   {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}};

f@list

{{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}}

Also:

<< Combinatorica`
ClearAll[dihedralL, f2]
dihedralL = ListNecklaces[Length@#, #, Dihedral] &;
f2 = DeleteDuplicates[#, {} =!= Intersection[dihedralL@#, dihedralL@#2] &] &;

f2 @ list == f @list

True

Update: a version that avoids Slots and pure functions (#, #2, &):

ClearAll[f3, necklace, mytestfunction]

necklace[a_] := Join @@ NestList[RotateLeft /@ # &, {a, Reverse@a}, Length@a]

mytestfunction[a_, b_] := MemberQ[necklace[a], b]

f3[input_, testfunction_] := DeleteDuplicates[input, testfunction];

f3[list, mytestfunction]

{{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}}

$\endgroup$
9
$\begingroup$

This problem is simple enough, that halirutan's brute force method is still $O(n)$ complexity for comparing two necklaces of length $n$ (which is optimal). But I would like to offer an intelligent approach, which although not being faster here (in fact it's probably not even $O(n)$) (turns out I was wrong), can be useful in many problems of this sort.

The solution is to define a canonical order for a necklace.

  1. The first element shall be the minimal element.
  2. If there are several minimal elements, we shall choose the one, whose neighbor (to the left or right) is smallest.
  3. If this still doesn't resolve ambiguities, we will continue in the separately chosen for each of the minimal elements direction and check subsequent neighbors.
  4. If all list elements have been considered and no conclusion is reached, prefer to take the sequence where the search went to the right (i.e. do not reverse the list).
  5. And if even that doesn't resolve the issue, I'm almost confident it doesn't matter which of the remaining starting points is picked, the output list will be the same, but let's pick the minimal element with the smallest index as the start of the list in canonical form.

The code below does just that.

toCanonical[list_] := Module[{pos, l = Length@list},
  (* find positions of minimum element *)
  pos = MinimalBy[With[{p = Position[list, Min@list]},
     ArrayFlatten[{{1, p, p + 1}, {-1, p, p - 1}}]], 
    list[[Mod[#[[3]], l, 1] ]] &];
  pos = NestWhile[
     (pos[[;; , 3]] += pos[[;; , 1]]; 
       pos = MinimalBy[pos, 
         list[[ Mod[#[[3]], l, 1] ]] &]) &, pos, 
     Length[#] > 1 &, 1, l - 2] // First;
  If[pos[[1]] == 1, RotateLeft[list, pos[[2]] - 1], 
   RotateLeft[list, pos[[2]]] // Reverse]
  ]

The algorithm is realised by the repeated updating of pos; it is initially a column of 3-tuples.

The first element is the direction of search (+1 or -1). The second element is the starting point of the search -- the index of one of the minimal elements of the list. The third element is the index (mod length list) of the next element to be considered (as described in steps 2 and 3).

MinimalBy with each iteration removes from pos the rows whose third elements point to an element of the list which is not the smallest.

The NestWhile runs a maximum of Length[list] - 2 times, since the preceding code has already checked a minimal element and a neighbor. At the end, the first tuple surviving is selected (picking the first tuple fulfills steps 4 and 5, however I ran this on a large set of random numbers and it doesn't seem to matter, which tuple to apply to put the list into canonical form, the result is the same).

Finally the list is rotated left to put the element indexed by the second element of the tuple at the start of the list, if the search went to the right, or at the end of the list if the search went to the left, in which case the list is then reversed.

DeleteDuplicatesBy[{{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 2},
  {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 2}, {1, 3, 2, 1, 3, 2},
  {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 2}, {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}},
  toCanonical]
{{1, 1, 2, 1, 1, 2}, {1, 2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}}
lists = RandomInteger[3, {40, 4}];
GatherBy[lists, toCanonical] // Grid
{1, 1, 0, 0}
{1, 3, 2, 1}
{1, 2, 0, 2}    {2, 0, 2, 1}
{2, 0, 3, 1}    {3, 1, 2, 0}    {2, 1, 3, 0}    {0, 2, 1, 3}
{2, 0, 1, 3}    {2, 0, 1, 3}    {1, 0, 2, 3}
{2, 3, 2, 3}
{2, 1, 1, 1}
{2, 1, 3, 3}    {3, 3, 1, 2}
{1, 3, 3, 0}    {0, 3, 3, 1}    {3, 3, 0, 1}    {3, 3, 1, 0}
{0, 1, 0, 1}
{3, 2, 2, 1}
{0, 2, 2, 2}    {2, 0, 2, 2}
{0, 2, 0, 1}    {0, 1, 0, 2}
{3, 2, 2, 3}
{3, 3, 2, 3}
{3, 0, 1, 1}
{3, 2, 1, 0}
{1, 2, 1, 2}
{2, 3, 2, 0}    {3, 2, 0, 2}
{0, 0, 0, 2}
{0, 3, 2, 2}
{0, 0, 0, 3}
{2, 1, 0, 0}
{0, 2, 2, 0}
{2, 2, 1, 2}
{1, 1, 0, 1}
{2, 1, 2, 3}

Speed turns out better than halirutan's solution, even after I compiled his pickFunc to C with RuntimeOptions -> "Speed"!

list = RandomInteger[{1, 3}, {5000, 10}];
AbsoluteTiming[DeleteDuplicatesBy[list, toCanonical];]
2.81648
AbsoluteTiming[deleteNecklaceDuplicates[list];]
5.16653

UPDATE

One more update: the 3rd argument of the NestList statements is replaced from Length[a] to Length[a] - 1. Besides the very fast parallelization of a compiled function, this is optimal, since finding the canonical from a list of all equivalent permutations is achievable by an O(n) radix sort.

Since I've been foolish enough to try to implement my own canonical form finder instead of generating all valid permutations and letting MMA sort them (as in the answer by Shadowray), not to mention wasting several hours writing this and letting myself get ninja'd by him :-) I'll throw in a benchmark for his approach and an afterthought.

(* Shadowray's solution *)
myDeleteDuplicateNecklaces[list]; // AbsoluteTiming
(* 0.202244 *)

However this transforms all elements to canonical order as well. If that's not desired then Shadowray's canonicalForm like so:

DeleteDuplicatesBy[list, canonicalForm]; // AbsoluteTiming
(* 0.290911 *)

This can be made much faster by compiling the canonicalForm:

compCanonical = 
  Compile[{{a, _Integer, 1}}, 
    Sort[NestList[RotateLeft, a, Length[a] - 1]~Join~
         NestList[RotateLeft, Reverse[a], Length[a] - 1]
    ] // First, 
    RuntimeAttributes -> {Listable},
    CompilationTarget -> "C", 
    Parallelization -> True,
    RuntimeOptions -> "Speed"]

Note how this leverages the special listability options of Compile'd functions: if I run this on a rank-2 array, it will map at level 1, while a top-level Listable function will map at level 2. So if conserving non-canonical forms is not necessary, one can do

DeleteDuplicates[compCanonical[list]]
(* ...; // AbsoluteTiming -> 0.0217732 *)

which is another order of magnitude faster. And if we want to keep the original forms, then

DeleteDuplicatesBy[list, compCanonical]; // AbsoluteTiming
(* 0.0797666 *)
$\endgroup$
  • 1
    $\begingroup$ Even though I didn't accept this answer, I learned quite a bit from it. Thanks for spending the time. +1. $\endgroup$ – rogerl Apr 29 '17 at 13:35
6
$\begingroup$

Solution #1:

The key idea is to transform a list of the base n digits to an integer.

The advantage of the solution is fast.

In:

ListUnion[xss_] := Module[{base, ZERO, yss},
  rotateLeftList[xs_] := 
   NestList[RotateLeft, xs, Length[xs]] // 
    Map[FromDigits[#, base] &];
  rotateList[xs_] := {xs, Reverse[xs]} // Map[rotateLeftList] // 
    Catenate;

  base = If[Max[xss] < 10, 11, Max[xss] + 2];
  ZERO = (base - 1);
  yss = xss /. 0 -> ZERO // Map[First@*Sort@*rotateList] // Union // 
    IntegerDigits[#, base] & ;
  yss /. ZERO -> 0]

RandomSeed[3];
(*original list *)
xss = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 
   2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 
   2, 2, 2}, {1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 
   2}, {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}}
ListUnion[xss]

(*0 leading list *)
xss = RandomInteger[{0, 1}, {10, 6}]
ListUnion[xss]

(*Multiple digits number list *)
xss = RandomInteger[{10, 11}, {10, 6}]
ListUnion[xss]

Out:

enter image description here

Solution #2

The key idea is to transform a list of number/symbol to a string.

In:

  ListUnion[xss_] := Module[{base, ZERO, yss},
  rotateLeftList[xs_] := 
   NestList[RotateLeft, xs, Length[xs]] // Map[ToString];
  rotateList[xs_] := {xs, Reverse[xs]} // Map[rotateLeftList] // 
    Catenate;
  xss // Map[First@*Sort@*rotateList] // Union // ToExpression
  ]

RandomSeed[3];
(*original list *)
xss = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 
   2, 2, 1, 2, 2}, {1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 
   2, 2, 2}, {1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 
   2}, {2, 2, 2, 1, 3, 1}, {2, 3, 1, 2, 3, 1}}
ListUnion[xss]

(* number list *)
xss = RandomInteger[{-1, 0}, {10, 6}]
ListUnion[xss]

(* symbol list *)
xss = RandomChoice[{a, b}, {10, 6}]
ListUnion[xss]

Out: enter image description here

$\endgroup$
  • 2
    $\begingroup$ I considered this. If there are any leading zeroes or multidigit integers, those will be lost. $\endgroup$ – LLlAMnYP Apr 28 '17 at 13:55
  • $\begingroup$ Thanks. I added a base, so I think it's fine now. $\endgroup$ – UnchartedWorks Apr 28 '17 at 14:05
  • $\begingroup$ Could I know the xss mean what?Why are you presist to use it? :) $\endgroup$ – yode Apr 28 '17 at 14:06
  • $\begingroup$ x is x. xs is a list of x, xss is a list of list of x. ;) $\endgroup$ – UnchartedWorks Apr 28 '17 at 14:10
  • $\begingroup$ @ LLlAMnYP multiple digits natural numbers are handled as well. $\endgroup$ – UnchartedWorks Apr 28 '17 at 14:56

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.