Adding rules to permutations

Question

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: http://mathematica.stackexchange.com/a/3050/121 and http://mathematica.stackexchange.com/a/1922/121 — Mr.Wizard, Apr 17 '12 at 23:07

Andy Ross · Accepted Answer · 2012-04-18T15:03:10.907

6

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

edited Apr 18 '12 at 15:03

answered Apr 18 '12 at 02:34

Andy Ross

19,320
2
61
93

1

What about using NextPermutation, instead? – rcollyer Apr 18 '12 at 02: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 02:40
@rcollyer. I tried it now. Surprisingly my method seems faster. – Andy Ross Apr 18 '12 at 02: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 02:48
@rcollyer probably should give it a bit. I'm sure someone here can come up with something much more efficient than I did in 5 minutes perusing wikipedia :) – Andy Ross Apr 18 '12 at 02:49
@AndyRoss: thank you. It works good for range <10. My problem is that I have to work with range = 64. I have to filter a lot of the possible permutations with a rule like #[[1]] != 6 && #[[1]] != 7 && #[[1]] != 8 && #[[1]] etc. Probably i write the condition in a too complicated way or my problem is not solvable with mathematica. – Raffaele Carlone Apr 18 '12 at 15:51
For 64! possible permutations you are going to probably have to resort to randomly generating them and hope to capture a representative subset of the ones that meet your conditions. I don't think you will find a method that can generate and test them all in a practically finite amount of time. – Andy Ross Apr 18 '12 at 16:13
In fact my idea was to generate only a small subgroup of them and not to select after the generation of the full list of 64! of them. The number of restriction is high because in every slot of the 64 can go only 5 elements. For example the value of #[[1]] can be only 1,2,3,4,5. The same for all the others (with different values). The main task is to invert a very sparse matrix. – Raffaele Carlone Apr 18 '12 at 16:27
You won't win with that suggestion, Andy: if all requisite permutations can be generated in reasonable time, they form an astronomically small subset of all $64!$ permutations, so rejection sampling is out of the question. If rejection sampling has a chance of working, it means that a sizable fraction of all permutations are required, so it is hopeless to try to generate them all by any means. Raffaele, you still have approximately $5^{64}$ such permutations, which is more than you can possibly generate in the lifetime of the universe. – whuber Apr 18 '12 at 18:53
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
Thank you. I simplified my query and after that I need a permutation in block of four elements. For example if range is 8 {1,2,3,4,5,6,7,8} I need to combine only the permutations of {1,2,3,4} and {5,6,7,8}. In this case with range 64 the number of permutation is 4!^(16). Quite an astronomical number but better than 5^64. Any suggestion? – Raffaele Carlone Apr 19 '12 at 08:13

Adding rules to permutations

1 Answers1