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$
  • $\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$ – David G. Stork Mar 16 '15 at 23:07
  • $\begingroup$ This may be useful: (6884708) $\endgroup$ – Mr.Wizard Mar 17 '15 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$ – David Zhang Mar 17 '15 at 1:10
  • $\begingroup$ Okay, how about: (14212030) $\endgroup$ – Mr.Wizard Mar 17 '15 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$ – David Zhang Mar 17 '15 at 1:19
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$
  • $\begingroup$ Cute. Gets tragically slow on large problems, and should check for invalid permutation number. +1 nonetheless. $\endgroup$ – ciao Mar 17 '15 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$ – 2012rcampion Mar 17 '15 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 '15 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$ – David Zhang Mar 17 '15 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 '15 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$
  • $\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$ – David Zhang Mar 17 '15 at 0:40
  • $\begingroup$ No, it handles them fine. Use a range of 120... $\endgroup$ – ciao Mar 17 '15 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$ – David Zhang Mar 17 '15 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 '15 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$ – David Zhang Mar 17 '15 at 1:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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