How can I calculate only those permutations of Range[n], that satisfy certain rules?

I don't want to filter the result after calculating all the permutations but adding some rules during the calculation of the permutations.

I will explain better.

Permutations[Range[4]]={{1, 2, 3, 4}, {1, 2, 4, 3}, {1, 3, 2, 4}, {1, 3, 4, 2},
{1, 4, 2, 3}, {1, 4, 3, 2}, {2, 1, 3, 4}, {2, 1, 4, 3}, {2, 3, 1, 4}, {2, 3, 4,
1}, {2, 4, 1, 3}, {2, 4, 3, 1}, {3, 1, 2, 4}, {3, 1, 4, 2}, {3,
2, 1, 4}, {3, 2, 4, 1}, {3, 4, 1, 2}, {3, 4, 2, 1}, {4, 1, 2,
3}, {4, 1, 3, 2}, {4, 2, 1, 3}, {4, 2, 3, 1}, {4, 3, 1, 2}, {4, 3,
2, 1}}


I want to wash out permutations where at the second position is 2 for example, but not after the calculation of all the permutations but during. I want all the permutations with some particular rules. I need that because I have to filter permutations with an high rank in principle.

The rules I need are of the following kind: "#[[1]] not equal to 4".

The code below is very slow for range=10. I need to arrive to range 64.

• This is typically done with recursion, but you will need to be much more specific about your problem if you want specific answers. Commented Apr 17, 2012 at 23:05
• Here are a couple of examples of related algorithms: mathematica.stackexchange.com/a/3050/121 and mathematica.stackexchange.com/a/1922/121 Commented Apr 17, 2012 at 23:07
• Would you give some examples of "special rules"? Commented Apr 17, 2012 at 23:13
• @David Filter only the green ones Commented Apr 18, 2012 at 2:06
• @belisarius Yes, I could select the ripest permutations. Commented Apr 18, 2012 at 2:12

Having no idea what sort of rules you might want to try. Here is a potential solution that generates the next permutation in lexicographic order and determines if it fits a particular criterion crit.

Generate next permutation where lst is the current permutation of Range[n], rng is the original range.

nextP[lst_, rng_] :=
Block[{k, l},
k = Pick[Most@rng, Thread[Most[lst] < Rest[lst]]];
If[k === {}, Return[{}]];
k = Last[k];
l = Pick[rng, Thread[lst[[k]] < lst]][[-1]];
Flatten[{#1[[1 ;; k]], Reverse[#1[[k + 1 ;; -1]]]}] &[
ReplacePart[lst, {k -> lst[[l]], l -> lst[[k]]}]]
]


This takes a positive integer n and and a function crit.

filteredPermutations[n_Integer?Positive, crit_] :=
Block[{res, rng},
res = rng = Range[n];
Reap[While[True, res = nextP[res, rng]; If[res === {}, Break[]];
If[crit[res], Sow[res]]]][[2, 1]]
]


For example, the permutations of Range[4] where the first element exceeds the last.

filteredPermutations[4, #[[1]] > #[[-1]] &]

==> {{2, 3, 4, 1}, {2, 4, 3, 1}, {3, 1, 4, 2}, {3, 2, 4, 1}, {3,4, 1, 2},
{3, 4, 2, 1}, {4, 1, 2, 3}, {4, 1, 3, 2}, {4, 2, 1, 3}, {4, 2, 3, 1},
{4, 3, 1, 2}, {4, 3, 2, 1}}


Note: This is going to be pretty slow for even moderate n.

Edit: This can be made quite a bit faster by using a compiled version of nextP.

nextPC = Compile[{{lst, _Integer, 1}, {rng, _Integer, 1}},
Block[{out = lst, k = 1, n = Length[rng],
kbag = InternalBag[{-1}], lstk, l = 1,
lbag = InternalBag[{-1}]},
While[k < n,
If[lst[[k]] < lst[[k + 1]], InternalStuffBag[kbag, k]];
k++
];
k = Max[InternalBagPart[kbag, All]];
If[k == -1,
lst
,
lstk = lst[[k]];
While[l <= n,
If[lstk < lst[[l]], InternalStuffBag[lbag, l]];
l++
];
l = Max[InternalBagPart[lbag, All]];
out[[k]] = lst[[l]];
out[[l]] = lst[[k]];
Join[out[[1 ;; k]], Reverse[out[[k + 1 ;; -1]]]]
]
]
];


This one returns the last permutation rather than an empty list so we need a slightly modified version of filteredPermutations as well.

filteredPermutations2[n_Integer?Positive, crit_] :=
Block[{res, rng, rev}, res = rng = Range[n];
rev = Reverse[rng];
Reap[While[True, res = nextPC[res, rng];
If[res === rev, If[crit[res], Sow[res]]; Break[]];
If[crit[res], Sow[res]]]][[2, 1]]]


Now to test it. Here I'm looking for all permutations of Range[8] such that the last element is 1 and the second is even. Note that direct computation is much faster so if its possible to store all of the permutations in memory at once, that will be the way to go.

AbsoluteTiming[(r1 = filteredPermutations2[8, #[[-1]] == 1 && EvenQ[#[[2]]] &]);]

==> {0.4524058, Null}

AbsoluteTiming[(r2 = filteredPermutations[8, #[[-1]] == 1 && EvenQ[#[[2]]] &]);]

==> {1.8564238, Null}

AbsoluteTiming[(r3 = Select[Permutations[Range[8]], (#[[-1]] == 1 && EvenQ[#[[2]]]) &]);]

==> {0.1092014, Null}

r1 == r2 == r3

==> True

• What about using NextPermutation, instead? Commented Apr 18, 2012 at 2:39
• @rcollyer. I didn't even think to look for such a creature ;) That would probably be much more efficient. Commented Apr 18, 2012 at 2:40
• @rcollyer. I tried it now. Surprisingly my method seems faster. Commented Apr 18, 2012 at 2:44
• Well, Combinatorica is older code, so it may have just needed a fresh perspective. So, when is nextP being folded into the kernel, like the rest of the Combinatorica functionality? Commented Apr 18, 2012 at 2:48
• @whuber I completely agree. I made that comment under the assumption that there would be high probability of generating a permutation that meets the criteria but that it wasn't feasible to store them all. Recent comments and edits would have led me to say exactly what you have. Commented Apr 18, 2012 at 19:26