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. – Mr.Wizard 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 – Mr.Wizard Apr 17 '12 at 23:07
Would you give some examples of "special rules"? – DavidC Apr 17 '12 at 23:13
@David Filter only the green ones – Dr. belisarius Apr 18 '12 at 2:06
@belisarius Yes, I could select the ripest permutations. – DavidC 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[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? – rcollyer Apr 18 '12 at 2:39
@rcollyer. I didn't even think to look for such a creature ;) That would probably be much more efficient. – Andy Ross Apr 18 '12 at 2:40
@rcollyer. I tried it now. Surprisingly my method seems faster. – Andy Ross Apr 18 '12 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? – rcollyer Apr 18 '12 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. – Andy Ross Apr 18 '12 at 19:26