13
$\begingroup$

What is the fastest way to write a function nthPermutation[xs_List, n_Integer] which is equivalent to Permutations[xs][[n]] but does not explicitly compute all the permutations of xs? This feature seems conspicuously absent from Mathematica.

I have a basic implementation below which almost does what I want, but does not preserve the original ordering of xs (it is instead equivalent to Permutations[Sort[xs]][[n]]), does not check that n is in bounds, and is almost certainly not the fastest method.

nthPermutation[{}, 1] = {};

nthPermutation[xs_List, n_Integer] := Block[{u = Union[xs], p, i = 1},
   p = Accumulate[numPermutations[DeleteCases[xs, #, {1}, 1]] & /@ u];
   While[n > p[[i]], i++];
   Prepend[nthPermutation[DeleteCases[xs, u[[i]], {1}, 1],
     If[i == 1, n, n - p[[i - 1]]]], u[[i]]]];

Edit: I should clarify that, if possible, nthPermutation[xs, n] should be equivalent to Permutations[xs][[n]] whenever it is defined, even with repeated and out-of-order elements in xs. For example, we should have that Permutations[{1, 3, 1, 2, 3}][[20]] === nthPermutation[{1, 3, 1, 2, 3}, 20] === {3, 2, 1, 3, 1}.

$\endgroup$
5
  • $\begingroup$ If you have $n$ arbitrary permutations, you must step through each before you have the final state. You can break this up in a number of ways (tracing the sequence of positions of each individual element, for instance), but you must still step through all in the arbitrary case. If, however, there are cycles or identity permutations or other non-random permutations, you can speed up the calculation. Then of course there are ways to parallelize the computation. $\endgroup$ Mar 16, 2015 at 23:07
  • $\begingroup$ This may be useful: (6884708) $\endgroup$
    – Mr.Wizard
    Mar 17, 2015 at 0:49
  • $\begingroup$ @Mr.Wizard I think the StackExchange question you linked concerns the ranking of permutations on $n$ distinct symbols. Ranking permutations on $n$ symbols, possibly with duplicates, is a rather different problem. $\endgroup$ Mar 17, 2015 at 1:10
  • $\begingroup$ Okay, how about: (14212030) $\endgroup$
    – Mr.Wizard
    Mar 17, 2015 at 1:14
  • $\begingroup$ @Mr.Wizard If I understand the accepted answer correctly, that (un)ranking function is precisely the one I've implemented in the nthPermutation code above. The problem is, that ranking function gives the permutations in lexicographic order, while the ranking function Mathematica uses internally is decidedly not lexicographic--examine the output of Permutations[{1, 3, 1, 2, 3}] and you'll see what I mean. $\endgroup$ Mar 17, 2015 at 1:19

2 Answers 2

12
$\begingroup$

A simple recursive function I've used many times:

permutation[{e_}, _] := {e}
permutation[l_, n_] := 
 With[{m = (Length[l] - 1)!}, 
  permutation[Delete[l, Ceiling[n/m]], Mod[n, m, 1]]~Prepend~
   l[[Ceiling[n/m]]]]

Note that this function assumes that n is a valid permutation number and that all elements are unique.

Update

Here is a solution that meets your criteria. It's not pretty, but it works on the examples I tested.

permutation[l_List, n_Integer] := Module[
  {i = n, remaining = l, tally = Tally[l], m = 1, len, perm = {}},
  If[Multinomial @@ Last /@ tally >= n > 0,
   While[Length[remaining] > 0,
    tally[[m, 2]]--;
    len = Multinomial @@ Last /@ tally;
    If[len >= i,
     AppendTo[perm, tally[[m, 1]]];
     remaining = DeleteCases[remaining, tally[[m, 1]], {1}, 1];
     tally = Tally[remaining];
     m = 1,
     i -= len;
     tally[[m, 2]]++;
     m++;
     ]
    ];
   perm,
   {}
   ]
  ]

Note that it's iterative, not recursive. This lets it handle very large cases, e.g. permutation[RandomInteger[100, 10000], 100!] (only takes around seven seconds on my computer). I think it's worst-case time is $\mathrm{O}(n^2)$ in the number of elements.

$\endgroup$
19
  • $\begingroup$ Cute. Gets tragically slow on large problems, and should check for invalid permutation number. +1 nonetheless. $\endgroup$
    – ciao
    Mar 17, 2015 at 0:14
  • $\begingroup$ @rasher Slow, really? For me, event at the recursion limit (Length[l] == 1022) it's pretty fast, less than 30ms on my computer. I know manipulating lists with large, non-numeric elements is slow, maybe just try permuting the indices and then selecting from your list? $\endgroup$ Mar 17, 2015 at 0:33
  • 1
    $\begingroup$ @2012rcampion: Try yours on a target with say 10k elements... it rapidly degrades in performance (and eats memory like Oprah at an all-you-can-eat) once target lists get larger... still a neat and clean piece of code, no slight intended. $\endgroup$
    – ciao
    Mar 17, 2015 at 0:53
  • 1
    $\begingroup$ Wow, I'm impressed with your new solution! It seems to do everything I hoped for, and is more than fast enough for my needs. $\endgroup$ Mar 17, 2015 at 1:46
  • 2
    $\begingroup$ I failed to make any meaningful improvement to this. I am going to edit your answer to use ++ and -- instead of += 1 and -= 1, then leave it be for now. If you dislike the edit feel free to revert it. $\endgroup$
    – Mr.Wizard
    Mar 17, 2015 at 8:05
5
$\begingroup$
factNum[n_] := 
  Module[{cnt = 1}, 
   Reverse@NestWhileList[
      QuotientRemainder[#[[1]], cnt++] &, {n, 1}, #[[1]] != 0 &][[2 ;;,2]]];

pickPerm[fn_] := Module[{p = Range@Length@fn, fnx = fn + 1},
   Reap[Scan[(Sow[p[[#]]]; p = Drop[p, {#}]) &, fnx]][[2, 1]]];

permN[target_, n_] := 
  If[n > Length[target]!, {}, 
   target[[pickPerm[PadLeft[factNum[n - 1], Length@target]]]]];

Gives permutations in lexicographic order, 1 being identity, empty list for invalid partition number.

v = Permutations[Range@5];
pn = permN[Range@5, #] & /@ Range[120];
pn == v

(* True *)

permN[{1, 2, 3, 3, 2, 1, 4, 4}, #] & /@ {1, 100, 1000}

(* {{1, 2, 3, 3, 2, 1, 4, 4}, {1, 2, 3, 4, 3, 1, 4, 2}, {1, 3, 2, 3, 4, 1, 4, 2}} *)
$\endgroup$
5
  • $\begingroup$ This doesn't seem to handle repeated elements correctly. Try permN[{1, 3, 1, 2, 3}, #] & /@ Range[30]--you'll only get 18 distinct permutations, of which there should be 30. $\endgroup$ Mar 17, 2015 at 0:40
  • $\begingroup$ No, it handles them fine. Use a range of 120... $\endgroup$
    – ciao
    Mar 17, 2015 at 0:52
  • $\begingroup$ But that's exactly the point, if you have to use 120 it clearly doesn't account for repeated elements. The function I'm looking for ought to return the nth distinct permutation (in the order Mathematica does). $\endgroup$ Mar 17, 2015 at 0:56
  • $\begingroup$ @DavidZhang: Not going to spend more time on this, it does precisely what title asked for. Probably might want to change your title to reflect your needs. $\endgroup$
    – ciao
    Mar 17, 2015 at 1:03
  • 1
    $\begingroup$ To be fair, the question body quite clearly states what I'm looking for. Still, changing the title is a good idea. $\endgroup$ Mar 17, 2015 at 1:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.