Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
2  
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
6  
Would you give some examples of "special rules"? –  David Carraher Apr 17 '12 at 23:13
    
@David Filter only the green ones –  belisarius Apr 18 '12 at 2:06
    
@belisarius Yes, I could select the ripest permutations. –  David Carraher Apr 18 '12 at 2:12

1 Answer 1

up vote 5 down vote accepted

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 = Internal`Bag[{-1}], lstk, l = 1, 
     lbag = Internal`Bag[{-1}]},
    While[k < n,
     If[lst[[k]] < lst[[k + 1]], Internal`StuffBag[kbag, k]];
     k++
     ];
    k = Max[Internal`BagPart[kbag, All]];
    If[k == -1,
     lst
     ,
     lstk = lst[[k]];
     While[l <= n,
      If[lstk < lst[[l]], Internal`StuffBag[lbag, l]];
      l++
      ];
     l = Max[Internal`BagPart[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
share|improve this answer
1  
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
1  
@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

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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