14
$\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}.

Improve this question
$\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$ Commented Mar 16, 2015 at 23:07
  • $\begingroup$ This may be useful: (6884708) $\endgroup$ Commented 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$ Commented Mar 17, 2015 at 1:10
  • $\begingroup$ Okay, how about: (14212030) $\endgroup$ Commented 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$ Commented Mar 17, 2015 at 1:19

2 Answers 2

Reset to default
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.

Improve this answer
$\endgroup$
19
  • $\begingroup$ Cute. Gets tragically slow on large problems, and should check for invalid permutation number. +1 nonetheless. $\endgroup$ Commented 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$ Commented 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$ Commented 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$ Commented 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$ Commented 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}} *)
Improve this answer
$\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$ Commented Mar 17, 2015 at 0:40
  • $\begingroup$ No, it handles them fine. Use a range of 120... $\endgroup$ Commented 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$ Commented 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$ Commented 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$ Commented Mar 17, 2015 at 1:05

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.