Permutations of lists of fixed even numbers

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

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.


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