Find All Permutations for Multiset

Question

Take a list with repetitions, say {a, a, b, c}, and some permutation thereof, say {c, a, b, a}. I want to know which permutations of the new list return it into the old one, in this case {2, 4, 3, 1} and {4, 2, 3, 1}}. The following code does this, but it is highly non-optimal:

{a, a, b, c}
RandomSample[%]
Permutations[Range[Length[%]]]
Pick[%, %%[[#]] === %%% & /@ %]

Here we are checking for all possible permutations, which scales badly with the size of the list. How can this be improved? Is there a built-in (similar to FindPermutation) that can help us? Perhaps if we first Tally the list?

FWIW, any format for the output is allowed. A list of positions is fine, but also a Cycles object, or any other format that contains the relevant information.

Answer 1

Here's a quick-n-dirty idea, can be much further optimized, will revisit when/if I have time.

f1 = Select[Tuples[PositionIndex[#2] /@ #1], Unequal @@ # &] &;

Takes original list and permuted list as arguments, returns all permutation lists to return latter to former.

A quick test:

l1 = RandomInteger[4, 11]
l2 = RandomSample@l1

r2 = (perms = Permutations[Range[Length[l1]]];
     Pick[perms, l2[[#]] === l1 & /@ perms]); //AbsoluteTiming // First

r1 = f1[l1, l2]; // AbsoluteTiming // First

r1 == r2

{1, 4, 4, 3, 2, 2, 4, 0, 3, 1, 3}

{1, 3, 4, 2, 2, 3, 4, 0, 3, 1, 4}

90.2257

0.0197286

True

As is, it can handle pretty large cases:

l1 = {a, b, c, c, c, c, d, e, e, f, f, f, g, h, i, i, j, j, k, l, m, n, n};
l2 = RandomSample[l1];

Short[f1[l1, l2], 5]

{{5,19,6,8,18,22,4,15,23,7,13,14,16,3,10,21,1,11,17,20,9,2,12},{5,19,6,8,18,22,4,15,23,7,13,14,16,3,10,21,1,11,17,20,9,12,2},<<2301>>,{5,19,22,18,8,6,4,23,15,14,13,7,16,3,21,10,11,1,17,20,9,12,2}}

And a more efficient realization that can be orders of magnitude better in time and RAM:

f2 = Module[{p1 = PositionIndex[#2] /@ #1 &[#1, #2], p2, p3},
    p2 = Union[p1];
    p3 = PositionIndex[p1] /@ p2;
    p1 = {p1};
    
    Do[p1 = 
       Join @@ (With[{t = #}, (ReplacePart[t, 
                Thread[p3[[idx]] -> #]] & /@ 
              Permutations[p2[[idx]]])] & /@ p1);, {idx, Length@p2}];
    p1] &;

Which will handle bigger cases:

l1={a, b, c, c, c, c, d, e, e, f, f, f, g, h, i, i, j, j, k, l, m, n, n,n, o, o, o, o, p, q, r, s, s, s, s, s, t, u, v, w};
l2={u, l, m, o, e, j, f, n, o, s, d, o, a, i, h, c, n, g, v, c, n, p, j,s, w, f, s, c, s, c, r, f, o, s, t, i, e, q, b, k};

res=f2[l1,l2];
Length[res]
RandomSample[res, 3]

19906560

{{13,39,28,16,30,20,11,5,37,26,32,7,18,15,14,36,23,6,40,2,3,8,21,17,12,4,9,33,22,38,31,24,34,10,27,29,35,1,19,25},{13,39,30,28,16,20,11,5,37,32,7,26,18,15,14,36,23,6,40,2,3,8,17,21,33,9,4,12,22,38,31,27,34,10,29,24,35,1,19,25},{13,39,28,16,20,30,11,37,5,26,32,7,18,15,36,14,6,23,40,2,3,21,17,8,12,33,4,9,22,38,31,34,27,29,10,24,35,1,19,25}}

And an even speedier way:

   f3 = Module[{start, pos, dispos, posdispos},
    pos = PositionIndex[#1] /@ #2;
    dispos = Union[pos];
    posdispos = PositionIndex[pos] /@ dispos;
    posdispos[[Ordering[dispos]]] // 
     Flatten[Outer[Join, Sequence @@ (Permutations /@ #), 1], 
        Length[#] - 1][[All, Ordering[Flatten[dispos]]]] &
    ]&;

Answer 2

It is not necessary to produce a lot of invalid permutations.

Consider:

orig = {a, b, a, e, d, e}
samp = RandomSample[orig]

We first determine which symbols occur only once and which several times:

t = Split@Sort[orig];
single = Flatten@Select[t, Length[#] == 1 &];
multi = Union@Flatten@Select[t, Length[#] > 1 &];

Next we determine the positions of the symbols in orig and samp:

posorigs = Flatten[Position[orig, #] & /@ single];
posorigm = Flatten[Position[orig, #] & /@ multi, {3, 1}];
possamps = Flatten[Position[samp, #] & /@ single];
possampm = Flatten[Position[samp, #] & /@ multi, {3, 1}];

We the create a list with permutations. To begin with, there is only one member with the positions of the single symbols. Then we calculate the permutations of the multi symbols in possampm:

perm = Table[0, Length[orig]];
perm[[posorigs]] = possamps;
possampm = Permutations /@ possampm;

Now we add for every multi symbols all its permutations to our permutation vector:

perms = {perm};
MapThread[Function[{p1, p2},
   perms = Flatten[Reap[
       Do[
        (t = perms[[i]]; t[[p1]] = #; Sow[t]) & /@ p2
        , {i, Length[perms]}]
       ][[2]], 1]], {posorigm, possampm}];
perms

In the end we can check:

Equal @@ (samp[[#]] & /@ perms)

And for convenience all in one piece:

orig = {a, b, a, e, d, e}
samp = RandomSample[orig]
t = Split@Sort[orig];
single = Flatten@Select[t, Length[#] == 1 &];
multi = Union@Flatten@Select[t, Length[#] > 1 &];
posorigs = Flatten[Position[orig, #] & /@ single];
posorigm = Flatten[Position[orig, #] & /@ multi, {3, 1}];
possamps = Flatten[Position[samp, #] & /@ single];
possampm = Flatten[Position[samp, #] & /@ multi, {3, 1}];
perm = Table[0, Length[orig]];
perm[[posorigs]] = possamps;
possampm = Permutations /@ possampm;
perms = {perm};
MapThread[Function[{p1, p2},
   perms = Flatten[Reap[
       Do[
        (t = perms[[i]]; t[[p1]] = #; Sow[t]) & /@ p2
        , {i, Length[perms]}]
       ][[2]], 1]], {posorigm, possampm}];
perms
Equal @@ (samp[[#]] & /@ perms)