# Permutations of lists of fixed even numbers

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. Commented Mar 21, 2017 at 17:00
• Will there ever be repeated odd numbers? Otherwise you can just count the odd numbers and feed the result to Subfactorial. Commented Mar 21, 2017 at 17:02
• No repeated numbers. but how do I construct these permutations? Commented Mar 21, 2017 at 17:03

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.

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

• Ah nice, I always forget about Combinatorica. Commented Mar 21, 2017 at 17:14
• Nice solution. I would include Needs[ "Combinatorica' " ] to make this explicit.
– gwr
Commented Mar 21, 2017 at 17:49
• @gwr this is really essential, I have added it to the answer, thanks! Commented Mar 22, 2017 at 1:38
• The function Derangements seems to work by simply selecting the derangements from the permutations. PrintDefinitions shows us Derangements[p_ ? PermutationQ] := Select[Permutations @ p, DerangementQ]; Commented Mar 23, 2017 at 9:03
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