Find permutations with constraints without using Permutations

Question

EDIT: To clarify, the bottleneck right now is available RAM, so any answer should keep that in mind (I cannot store all T! lists of length T and filter out those that satisfy the condition a posteriori.)

I want to find all permutations of the elements of Range[0,T-1] that satisfy a condition, but where T may be too large for Permutations to be useable: first generating and storing all permutations simply consumes too much RAM. The condition is always such that cond = {c[1],c[2],...,c[T]} means that the first element of the permutation must be larger than or equal to c[1], the second element must be larger than or equal to c[2] etc. The condition is sorted in increasing order, and we can assume that the condition is not so strict that no permutations survive.

I have managed to implement what I want, but in a very procedural way using a recursive function (the details here are not that important):

recuPerm[level_] :=
 If[level == 0,
  res[[1]] = Total[avail];
  Sow[res],
  ((res[[level + 1]] = #; avail[[First[#] + 1]] = 0; 
       recuPerm[level - 1];
       avail[[
         First[#] + 1]] = #) & /@ ({(allow[[level + 1]].avail)} /. 
       Plus -> Sequence));
  ]

and I call it from the wrapper function:

listPerm[T_, cond_] :=
 Block[
  {a, avail, allow, res = ConstantArray[1, T], rip},
  avail = a /@ Range[0, T - 1];
  allow = 
   Table[PadLeft[ConstantArray[1, T - cond[[i]]], T], {i, 
     T}];
  rip = Reap[recuPerm[T - 1]][[2]];
  If[rip == {}, {}, rip[[1]]]
  ]

(The dummy head a is simply there so I can use Total and Dot in order to pick out allowed elements.)

Do you know of an approach that is more functional in nature and/or can better take advantage of the strengths of Mathematica? If it's more memory efficient (or faster) than my (unelegant) attempt then that's of course a bonus!

Answer 1

This is pretty functional:

f = Module[{comps, r = Reverse@Range[#2, #1 - 1]},
    comps[l1_, l2_] := Join @@ Map[Thread[{Sequence @@ #, Complement[l2, #]}] &, l1];
    Reverse /@ Fold[comps, Transpose@{First@r}, Rest@r]] &;

This is about 10-15% faster, very slightly higher memory use (but still far below your current solution):

fz = With[{r = Reverse@Range[#2, #1 - 1]}, 
          Fold[(Join @@ MapThread[Thread[{Sequence @@ #1, #2}] &, 
               {#1, Outer[Complement, {#2}, #1, 1][[1]]}]) &, 
               Transpose@{r[[1]]}, Rest@r][[All, -1 ;; 1 ;; -1]]] &;

Comparing and including djp's interesting solution:

t = 11;
c = cond = {0, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6};

lp = listPerm[t, c]; // Timing // First

Timing[
  possibleElements = Range[cond, Length@cond - 1];
  fn[{{last_}}] := {{last}};
  fn[{most__List, last_List}] := Table[{fn[{most} /. i -> Sequence[]], i}, {i, last}];
  intermediate = fn[possibleElements];
  result = intermediate //. {x : {{__Integer} ..}, i_Integer} :> Sequence @@ (Append[#, i] & /@ x);
  ] // First

fr = f[t, c]; // Timing // First

fzr = fz[t, c]; // Timing // First

(lp /. a[x_] :> x) == result == fr == fzr

(*

8.704856

6.661243

2.839218

2.464816

True

*)

Timings on an old netbook, but ~3X faster. Memory utilization s/b close to optimal: it never grows the intermediate results list to more than the ultimate results list length. Fails gracefully - if restrictions have no results, it returns no permutations (your current code, I'm sure you're aware, goes bonkers ;-} ). This s/b easy to adapt to a staggered restriction range, that is, differing lower and upper bounds for each position, should you so desire.

Neat puzzle, BTW...

Side note: You'll beat these by doing things iteratively... bodging up a function generator that builds such a solution based on parameters was 60% faster than my own fastest on some quick tests...

Answer 2

This is a question of finding a suitable algorithm rather than use of Mathematica. The challenge is to generate only the permutations that will be used, rather than generate all permutations and filter those that satisfy a criterion. Fun problem. Here's my solution:

cond = {0, 0, 1};
possibleElements = Range[cond, Length@cond-1];
(* {{0, 1, 2}, {0, 1, 2}, {1, 2}} *)

So we need to generate all series {a,b,c,...} where each element appears precisely once.

I wrote a recursive function fn to take the last element off the end of the list, and remove it from the preceding elements. That is:

fn[{a,b,c}, {a,b,c}, {b,c}] ->
{
  {fn[{a, c}, {a, c}], b},
  {fn[{a, b}, {a, b}], c}
}

fn[{most__List, last_List}] :=
  Table[{fn[{most} /. i -> Sequence[]], i}, {i, last}]

We also want to terminate the recursion:

fn[{{a}}] -> {{a}}
fn[{{last_}}] := {{last}};

The output of fn looks like this:

intermediate = fn[possibleElements]

(* {{{{{{2}}, 0}, {{{0}}, 2}}, 1}, {{{{{1}}, 0}, {{{0}}, 1}}, 2}} *)

To reduce this, we need to make the transformation, and do so repeatedly.

{ x:{Lists of Integers}, i_Integer } -> {{x1, i}, {x2, i}, ...}
result = intermediate //. {x : {{__Integer} ..}, i_Integer} :> 
    Sequence @@ (Append[#, i] & /@ x)

All together:

cond = {0, 1, 2, 3, 4, 5, 6, 6, 8, 8, 10, 11, 12, 13, 14};
possibleElements = Range[cond, Length@cond-1]
fn[{{last_}}] := {{last}};
fn[{most__List, last_List}] := 
  Table[{fn[{most} /. i -> Sequence[]], i}, {i, last}]

intermediate = fn[possibleElements]
result = intermediate //. {x : {{__Integer} ..}, i_Integer} :> 
   Sequence @@ (Append[#, i] & /@ x)

It isn't a function and doesn't fail gracefully (thanks @rasher), but you can add those if you like. I think @rasher's algorithm is the same as mine.