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:

  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}$


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!

Tags:

Permutation

Function Construction

Related

How do I convert an inexact number smaller than $MinMachineNumber to machine-precision? How to add a legend to a graph to depict vertex properties? Speed of a simple operation over a long list NDSolve solves this ordinary differential equation only "half-way" Compute $\int\limits_{x_1}^{x_2} \int\limits_{y_1}^{y_2} \int\limits_{z_1}^{z_2} {1 \over \sqrt{x^2+y^2+z^2}} dx\ dy\ dz$ How can I properly define a custom function to give as a ColorFunction option? Is it possible to take a numerical (integral) average of the dependent variable, within NDSolve, at each iteration? Mathematica notebook autocompletion completely disappears How can I specify aspect ratio in BubbleChart3D so as to keep the bubbles spherical? Collect terms in a polynomial, distributed Area between contours of two surfaces How to obtain the cell-adjacency graph of a mesh?

Recent Posts