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]={{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: "#[] 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. Apr 17 '12 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 Apr 17 '12 at 23:07
• Would you give some examples of "special rules"? Apr 17 '12 at 23:13
• @David Filter only the green ones Apr 18 '12 at 2:06
• @belisarius Yes, I could select the ripest permutations. Apr 18 '12 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 where the first element exceeds the last.

filteredPermutations[4, #[] > #[[-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 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[#[]] &]);]

==> {0.4524058, Null}

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

==> {1.8564238, Null}

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

==> {0.1092014, Null}

r1 == r2 == r3

==> True