Permutations of lists of fixed even numbers

Question

Let's say we have this list

list={3,6,5,21,23,76,1,28,96,54,77}

I would like to know the number of permutations when every even number stays where it is and every odd number moves to another place. All odd numbers must move from their original places.

i.e. {5,6,21,3,1,76,77,28,96,54,1} is acceptable

AND also to find these permutations

Permutations where "every [element] moves to another place" are called derangements. — Martin Ender, Mar 21 '17 at 17:00
Will there ever be repeated odd numbers? Otherwise you can just count the odd numbers and feed the result to Subfactorial. — Martin Ender, Mar 21 '17 at 17:02
No repeated numbers. but how do I construct these permutations? — ZaMoC, Mar 21 '17 at 17:03

score 14 · Answer 1 · edited Mar 22 '17 at 02:28

14

The permutation you described is called "derangement". There is a function Derangement in Combinatoricapackage.

Needs["Combinatorica`"]
dearr = Select[list, OddQ][[#]] & /@ Derangements[Range[6]];
pos = Flatten@Position[list, _?OddQ];
res = ReplacePart[list, Thread[pos -> #]] & /@ dearr
res
(*{{5, 6, 3, 23, 21, 76, 77, 28, 96, 54, 1}, 
   {5, 6, 3, 23, 1, 76, 77, 28, 96, 54, 21},
   ...
   {77, 6, 1, 23, 21, 76, 5, 28, 96, 54, 3}}*)
(*only the ordering of those permutation is different from Martin's*)
res//Length
(*265*)

Perhaps a little cleaner:

pos = Join @@ Position[list, _?OddQ]
der = pos[[#]] & /@ Derangements @ Length @ pos;
res = ReplacePart[list, Thread[ pos -> list[[#]] ]] & /@ der

edited Mar 22 '17 at 02:28

Mr.Wizard

271,378
34
587
1,371

answered Mar 21 '17 at 17:12

vapor

7,911
2
22
55

Ah nice, I always forget about Combinatorica. – Martin Ender Mar 21 '17 at 17:14
2

Nice solution. I would include Needs[ "Combinatorica' " ] to make this explicit. – gwr Mar 21 '17 at 17:49
@gwr this is really essential, I have added it to the answer, thanks! – vapor Mar 22 '17 at 01:38
3

The function Derangements seems to work by simply selecting the derangements from the permutations. PrintDefinitions shows us Derangements[p_ ? PermutationQ] := Select[Permutations @ p, DerangementQ]; – Jacob Akkerboom Mar 23 '17 at 09:03

score 14 · Accepted Answer · edited Apr 13 '17 at 12:55

Permutations where no element remains in its original place are called derangements. Counting them is easy enough: the number of derangements of a set of size $n$ is $!n$, or the subfactorial of $n$. Of course, that's a built-in in Mathematica:

list = {3,6,5,21,23,76,1,28,96,54,77};
Subfactorial @ Count[list, _?OddQ]
(* 265 *)

Generating them is a bit trickier. I'm just presenting the easiest way here: generate all permutations of the odd numbers and then filter them. Of course, when you get to larger lists this will generate a lot of permutations that you don't want, but for lists like your example it won't matter.

odd = Sort@Select[list, OddQ];
derangements = Select[Permutations[odd], FreeQ[odd - #, 0] &];
list /. Thread[odd -> #] & /@ derangements
(* {{1, 6, 21, 5, 77, 76, 3, 28, 96, 54, 23}, 
    {1, 6, 21, 23, 77, 76, 3, 28, 96, 54, 5},
    ...,
    {23, 6, 21, 5, 1, 76, 77, 28, 96, 54, 3}, 
    {23, 6, 21, 5, 3, 76, 77, 28, 96, 54, 1}} *)

Length @ %
(* 265 *)

The idea is to generate the permutations of the odd values separately, and then to reinsert them into the full list with a replacement rule.

This turns out to be faster than the Combinatorica built-in, but for even more efficient solutions see this question.

score 3 · Answer 3 · edited Apr 13 '17 at 12:55

3

len = Length[list];
even = Flatten[Position[list, _?EvenQ]];
odd = Complement[Range[len], even];
Select[Permute[list, GroupStabilizer[SymmetricGroup[len], even]], 
     !Inner[Equal, #[[odd]], list[[odd]], Or] &]

Will give a same result with happy fish

edited Apr 13 '17 at 12:55

Community

1

answered Mar 21 '17 at 18:00

yode

26,686
4
62
167

Permutations of lists of fixed even numbers

3 Answers3

Linked