Programming challenge: restricted Permutations
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}};
Update
Here is an improved version that should be considerably faster. The main improvements are:
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 second1
to2
.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}$
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!