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

$\endgroup$
  • 3
    $\begingroup$ Permutations where "every [element] moves to another place" are called derangements. $\endgroup$ – Martin Ender Mar 21 '17 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 Mar 21 '17 at 17:02
  • $\begingroup$ No repeated numbers. but how do I construct these permutations? $\endgroup$ – J42161217 Mar 21 '17 at 17:03
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$
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$
  • $\begingroup$ Ah nice, I always forget about Combinatorica. $\endgroup$ – Martin Ender Mar 21 '17 at 17:14
  • 2
    $\begingroup$ Nice solution. I would include Needs[ "Combinatorica' " ] to make this explicit. $\endgroup$ – gwr Mar 21 '17 at 17:49
  • $\begingroup$ @gwr this is really essential, I have added it to the answer, thanks! $\endgroup$ – vapor Mar 22 '17 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 Mar 23 '17 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$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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