Programming challenge: restricted Permutations

Question

I need to generate the set of all inequivalent permutations for a collection of objects of the form {symbol, integer}.

Here is an example collection from which I would like to the obtain the permutations.

myList = {{a, 1}, {b, 1}, {c, 2}, {d, 2}, {e, 2}, {f, 3}}

Two permutations are equivalent if the order of the positions of second element (integer) are the same in the two permutations. Here are two equivalent permutations (and therefore, only one of them should be included in the final output):

{{a, 1}, {c, 2}, {b, 1}, {d, 2}, {e, 2}, {f, 3}}

{{a, 1}, {e, 2}, {b, 1}, {c, 2}, {d, 2}, {f, 3}}

myList should result in a total of 60 inequivalent permutations.

---

Challenge: I need the most efficient code (ideally in functional form) that does not require constructing all permutations with Permutations[myList] only to eliminate the equivalent one. It needs to be fast for collections as large as 10 objects.

Answer 1

Update

Here is an improved version that should be considerably faster. The main improvements are:

1. Use a compiled function instead of Ordering @* Ordering to compute the ranks. Here's an example of how the compiled function works. For a list like: {{a, 1}, {b, 2}, {c, 1}} I permute {1, 3, 1} instead of {1, 2, 1}. Then, the compiled function changes the second 1 to 2.

2. Create the result by direct part extraction, and use Partition/Flatten so that only a single part extraction is needed.

Here's the code:

perms[list_]:=Module[{indices=list[[All,2]], len=Length[list], reps},
    reps = indices /. DeleteDuplicatesBy[Thread[Sort[indices]->Range@len], First];
    Partition[
        list[[Flatten@fc[Permutations[reps]]]],
        len
    ]
]

fc = Compile[{{v,_Integer,1}},
    Module[{r=v,dup=Table[0,{Length[v]}]},
        Do[
            r[[i]] += dup[[r[[i]]]]++,
            {i,Length[v]}
        ];
        r
    ],
    RuntimeAttributes->{Listable}
];

And, here's a timing comparison:

list = {{a,1},{b,1},{c,2},{d,2},{e,2},{f,3},{g,3},{h,4},{i,5},{j,6},{k,6},{l,8}};

r1 = perms[list]; //AbsoluteTiming
r2 = permit[list]; //AbsoluteTiming

r1 === r2

{20.5043, Null}

{30.4845, Null}

True

(permit is from @ciao's answer) Note that the majority of time is spent constructing the list. The following function just creates the permutations:

p1[list_] := Module[{indices=list[[All,2]], len=Length[list], reps},
    reps = indices /. DeleteDuplicatesBy[Thread[Sort[indices]->Range@len], First];
    fc[Permutations[reps]];
]

The timing for permutation creation is:

p1[list]; //AbsoluteTiming

{2.96846, Null}

So, 17.5 seconds is spent just converting the permutations to the desired output. This is slow because the list is a mixture of symbols and integers. In other words, the output cannot be packed. If the input consisted strictly of integers, than the output could be packed, and the function would be much faster. For example, suppose the input is:

list ={{1,1},{2,1},{3,2},{4,2},{5,2},{6,3},{7,3},{8,4},{9,5},{10,6},{11,6},{12,8}};

Then perms is much faster:

perms[list]; //AbsoluteTiming

{8.00287, Null}

Old answer

How about:

perms[list_]:=With[{p = Permutations[list[[All,2]]]},
    Thread[{
        list[[Ordering @ Ordering @ #, 1]],
        #
    }]& /@ p
]

For your test case:

res = perms[myList];
Column[Row[#, ","]& /@ res] //TeXForm

$\begin{array}{l} \{a,1\},\{b,1\},\{c,2\},\{d,2\},\{e,2\},\{f,3\} \\ \{a,1\},\{b,1\},\{c,2\},\{d,2\},\{f,3\},\{e,2\} \\ \{a,1\},\{b,1\},\{c,2\},\{f,3\},\{d,2\},\{e,2\} \\ \{a,1\},\{b,1\},\{f,3\},\{c,2\},\{d,2\},\{e,2\} \\ \{a,1\},\{c,2\},\{b,1\},\{d,2\},\{e,2\},\{f,3\} \\ \{a,1\},\{c,2\},\{b,1\},\{d,2\},\{f,3\},\{e,2\} \\ \{a,1\},\{c,2\},\{b,1\},\{f,3\},\{d,2\},\{e,2\} \\ \{a,1\},\{c,2\},\{d,2\},\{b,1\},\{e,2\},\{f,3\} \\ \{a,1\},\{c,2\},\{d,2\},\{b,1\},\{f,3\},\{e,2\} \\ \{a,1\},\{c,2\},\{d,2\},\{e,2\},\{b,1\},\{f,3\} \\ \{a,1\},\{c,2\},\{d,2\},\{e,2\},\{f,3\},\{b,1\} \\ \{a,1\},\{c,2\},\{d,2\},\{f,3\},\{b,1\},\{e,2\} \\ \{a,1\},\{c,2\},\{d,2\},\{f,3\},\{e,2\},\{b,1\} \\ \{a,1\},\{c,2\},\{f,3\},\{b,1\},\{d,2\},\{e,2\} \\ \{a,1\},\{c,2\},\{f,3\},\{d,2\},\{b,1\},\{e,2\} \\ \{a,1\},\{c,2\},\{f,3\},\{d,2\},\{e,2\},\{b,1\} \\ \{a,1\},\{f,3\},\{b,1\},\{c,2\},\{d,2\},\{e,2\} \\ \{a,1\},\{f,3\},\{c,2\},\{b,1\},\{d,2\},\{e,2\} \\ \{a,1\},\{f,3\},\{c,2\},\{d,2\},\{b,1\},\{e,2\} \\ \{a,1\},\{f,3\},\{c,2\},\{d,2\},\{e,2\},\{b,1\} \\ \{c,2\},\{a,1\},\{b,1\},\{d,2\},\{e,2\},\{f,3\} \\ \{c,2\},\{a,1\},\{b,1\},\{d,2\},\{f,3\},\{e,2\} \\ \{c,2\},\{a,1\},\{b,1\},\{f,3\},\{d,2\},\{e,2\} \\ \{c,2\},\{a,1\},\{d,2\},\{b,1\},\{e,2\},\{f,3\} \\ \{c,2\},\{a,1\},\{d,2\},\{b,1\},\{f,3\},\{e,2\} \\ \{c,2\},\{a,1\},\{d,2\},\{e,2\},\{b,1\},\{f,3\} \\ \{c,2\},\{a,1\},\{d,2\},\{e,2\},\{f,3\},\{b,1\} \\ \{c,2\},\{a,1\},\{d,2\},\{f,3\},\{b,1\},\{e,2\} \\ \{c,2\},\{a,1\},\{d,2\},\{f,3\},\{e,2\},\{b,1\} \\ \{c,2\},\{a,1\},\{f,3\},\{b,1\},\{d,2\},\{e,2\} \\ \{c,2\},\{a,1\},\{f,3\},\{d,2\},\{b,1\},\{e,2\} \\ \{c,2\},\{a,1\},\{f,3\},\{d,2\},\{e,2\},\{b,1\} \\ \{c,2\},\{d,2\},\{a,1\},\{b,1\},\{e,2\},\{f,3\} \\ \{c,2\},\{d,2\},\{a,1\},\{b,1\},\{f,3\},\{e,2\} \\ \{c,2\},\{d,2\},\{a,1\},\{e,2\},\{b,1\},\{f,3\} \\ \{c,2\},\{d,2\},\{a,1\},\{e,2\},\{f,3\},\{b,1\} \\ \{c,2\},\{d,2\},\{a,1\},\{f,3\},\{b,1\},\{e,2\} \\ \{c,2\},\{d,2\},\{a,1\},\{f,3\},\{e,2\},\{b,1\} \\ \{c,2\},\{d,2\},\{e,2\},\{a,1\},\{b,1\},\{f,3\} \\ \{c,2\},\{d,2\},\{e,2\},\{a,1\},\{f,3\},\{b,1\} \\ \{c,2\},\{d,2\},\{e,2\},\{f,3\},\{a,1\},\{b,1\} \\ \{c,2\},\{d,2\},\{f,3\},\{a,1\},\{b,1\},\{e,2\} \\ \{c,2\},\{d,2\},\{f,3\},\{a,1\},\{e,2\},\{b,1\} \\ \{c,2\},\{d,2\},\{f,3\},\{e,2\},\{a,1\},\{b,1\} \\ \{c,2\},\{f,3\},\{a,1\},\{b,1\},\{d,2\},\{e,2\} \\ \{c,2\},\{f,3\},\{a,1\},\{d,2\},\{b,1\},\{e,2\} \\ \{c,2\},\{f,3\},\{a,1\},\{d,2\},\{e,2\},\{b,1\} \\ \{c,2\},\{f,3\},\{d,2\},\{a,1\},\{b,1\},\{e,2\} \\ \{c,2\},\{f,3\},\{d,2\},\{a,1\},\{e,2\},\{b,1\} \\ \{c,2\},\{f,3\},\{d,2\},\{e,2\},\{a,1\},\{b,1\} \\ \{f,3\},\{a,1\},\{b,1\},\{c,2\},\{d,2\},\{e,2\} \\ \{f,3\},\{a,1\},\{c,2\},\{b,1\},\{d,2\},\{e,2\} \\ \{f,3\},\{a,1\},\{c,2\},\{d,2\},\{b,1\},\{e,2\} \\ \{f,3\},\{a,1\},\{c,2\},\{d,2\},\{e,2\},\{b,1\} \\ \{f,3\},\{c,2\},\{a,1\},\{b,1\},\{d,2\},\{e,2\} \\ \{f,3\},\{c,2\},\{a,1\},\{d,2\},\{b,1\},\{e,2\} \\ \{f,3\},\{c,2\},\{a,1\},\{d,2\},\{e,2\},\{b,1\} \\ \{f,3\},\{c,2\},\{d,2\},\{a,1\},\{b,1\},\{e,2\} \\ \{f,3\},\{c,2\},\{d,2\},\{a,1\},\{e,2\},\{b,1\} \\ \{f,3\},\{c,2\},\{d,2\},\{e,2\},\{a,1\},\{b,1\} \\ \end{array}$

Answer 2

Quick-n-dirty attempt at an interesting problem:

permit[list_] := 
  Module[{sp, tg, idx}, 
   sp = Partition[
      Flatten[##][[Flatten[
         Ordering[Ordering[#]] & /@ 
          Permutations[Flatten[MapIndexed[(idx = #2[[1]]; idx & /@ #1) &, ##]]]]]], Length[Flatten[##]]] &;
   tg = GatherBy[Transpose[{Range@Length@list, list}], #[[2, -1]] &][[All, All, 1]];
   Replace[sp@tg, AssociationThread[Range@Length@list, list], {2}]];

Using this test list with a dozen objects, pretty quick.

listx = {{a, 1}, {b, 1}, {c, 2}, {d, 2}, {e, 2}, {f, 3}, {g, 3}, {h, 4}, {i, 5}, {j, 6}, {k, 6}, {l, 8}};

Answer 3

Let

myList = {{a, 1}, {b, 1}, {c, 2}, {d, 2}, {e, 2}, {f, 3}};

Naïve solution:

naive[list_] := DeleteDuplicatesBy[Permutations[list], Map[Last]]

My non-brute-force approach:

aft[list_] := Module[{sym = First /@ list, int = Last /@ list},
               (
                Permute[sym, #] & /@
                 (
                  Flatten[Last /@ Sort[Normal@PositionIndex[#]]] & /@ Permutations[int]
                 )
                ) /. (list /. {A_, B_} :> Rule[A, {A, B}])
              ]

For comparison, let me denote the solutions by ciao and Carl Woll as

ciao[list_] := ...
woll[list_] := ...

With this,

naive[myList] == aft[myList] == ciao[myList] == woll[myList]
(* True *)

and

naive[myList] // Length // RepeatedTiming
aft[myList] // Length // RepeatedTiming
ciao[myList] // Length // RepeatedTiming
woll[myList] // Length // RepeatedTiming
(* {0.00253, 60}
   {0.00081, 60}
   {0.00026, 60}
   {0.00029, 60} *)

so that the best approach is the one by ciao. This is much more obvious if we introduce a larger list,

myList2 = {{a, 1}, {b, 1}, {c, 2}, {d, 2}, {e, 2}, {f, 3}, {g, 3}, {h,
 4}, {i, 5}, {j, 6}, {k, 6}, {l, 8}};

so that

aft[myList2] == ciao[myList2] == woll[myList2]
(* True *)

and

aft[myList2] // Length // AbsoluteTiming
ciao[myList2] // Length // AbsoluteTiming
woll[myList2] // Length // AbsoluteTiming
(* {274.962, 9979200}
   {26.2701, 9979200}
   {225.609, 9979200} *)

In conclusion: the approach by ciao is the most efficient one. Mine and Carl's are similar efficiency-wise, but his is much more readable. For small input you may use the solution by Carl Woll if you want a readable solution; for larger input, you should go with ciao's.

--

Some comments: first, this looks like graph theory. Although I don't know what you are trying to do exactly, recall that MMA has a lot of built-ins, so perhaps there is a function that does a better job when you consider the big picture. Second, if someone else comes up with a different method, leave a comment below and I'll add your approach to the comparative here. Cheers!