10
$\begingroup$

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

Improve this question
$\endgroup$
3
  • 3
    $\begingroup$ Permutations where "every [element] moves to another place" are called derangements. $\endgroup$
    – Martin Ender
    Commented Mar 21, 2017 at 17:00
  • $\begingroup$ Will there ever be repeated odd numbers? Otherwise you can just count the odd numbers and feed the result to Subfactorial. $\endgroup$
    – Martin Ender
    Commented Mar 21, 2017 at 17:02
  • $\begingroup$ No repeated numbers. but how do I construct these permutations? $\endgroup$
    – ZaMoC
    Commented Mar 21, 2017 at 17:03

3 Answers 3

Reset to default
14
$\begingroup$

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.

Improve this answer
$\endgroup$
0
14
$\begingroup$

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

Improve this answer
$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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