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]]]] &
]&;
PermutationGroup
. $\endgroup$Permute
with the appropriate groups was pretty slow, so I pursued other means. $\endgroup$