Generating permutations where no item appears in its original position [duplicate]

Question

Given a Range[n] list, I need an algorithm that takes a permutation and output the next permutation. These permutations have the property that every item is different from its position. Here are the outputs using Range[4]:

{{2,1,4,3},{2,3,4,1},{2,4,1,3},{3,1,4,2},{3,4,1,2},{3,4,2,1},{4,1,2,3},{4,3,1,2},{4,3,2,1}}

and using Range[5]:

{{2,1,4,5,3},{2,1,5,3,4},{2,3,1,5,4},{2,3,4,5,1},{2,3,5,1,4},{2,4,1,5,3},{2,4,5,1,3},{2,4,5,3,1},{2,5,1,3,4},{2,5,4,1,3},{2,5,4,3,1},{3,1,2,5,4},{3,1,4,5,2},{3,1,5,2,4},{3,4,1,5,2},{3,4,2,5,1},{3,4,5,1,2},{3,4,5,2,1},{3,5,1,2,4},{3,5,2,1,4},{3,5,4,1,2},{3,5,4,2,1},{4,1,2,5,3},{4,1,5,2,3},{4,1,5,3,2},{4,3,1,5,2},{4,3,2,5,1},{4,3,5,1,2},{4,3,5,2,1},{4,5,1,2,3},{4,5,1,3,2},{4,5,2,1,3},{4,5,2,3,1},{5,1,2,3,4},{5,1,4,2,3},{5,1,4,3,2},{5,3,1,2,4},{5,3,2,1,4},{5,3,4,1,2},{5,3,4,2,1},{5,4,1,2,3},{5,4,1,3,2},{5,4,2,1,3},{5,4,2,3,1}}

The starting permutation is given switching items in couples for even lengths and left rotating the last three items for odd lengths. Range[4] and Range[5] are obviously examples. I need a general algorithm.

Answer 1

Clear["Global`*"];
f[n_ /; n ∈ PositiveIntegers] := Module[{
    rule = Alternatives @@ (DiagonalMatrix@Range@n /. 0 -> Blank[])
    },
   DeleteCases[Permutations[Range[n]], rule]
   ];

f /@ Range[4] // Column

---

Result:

Answer 2

This LibraryLink function calls the function std::next_permutation from your system's C++ standard library to sieve through permutations until it finds the first derangement. There are certainly more efficient methods: Sometimes many permutations have to be skipped. However, the larger the permuted set gets, the rarer non-derangements become (I guess). So this should not be awfully bad.

Needs["CCompilerDriver`"]

Quiet[LibraryFunctionUnload[cNextDerangement]];
ClearAll[cNextDerangement];

cNextDerangement::usage = 
  "cNextDerangement[p] finds the next derangement of the permutation \
p of the list {1,2,3,...,Length[p]}. The permutation is changed \
in-place. The returned integer shows the number of next_permutation \
calls that were necessary to find this derangement.";

cNextDerangement = Module[{name, code, lib},
   name = "cNextDerangement";
   code = StringJoin["
#include \"WolframLibrary.h\"

#include <algorithm>

bool IsDerangement( mint * p, mint n )
{
    for( mint i = 0; i < n; ++i )
    {
        if( p[i] == i+1 )
        {       
            return false;
        }
    }
    return true;
}


EXTERN_C DLLEXPORT int ", name, 
     "(WolframLibraryData libData, mint Argc, MArgument *Args, \
MArgument Res)
{
    MTensor p_ = MArgument_getMTensor(Args[0]);

    const mint n = libData->MTensor_getDimensions(p_)[0];

    mint * const p = libData->MTensor_getIntegerData(p_);
   
    mint iter = 0;

    do
    {   
        ++iter;
 
        std::next_permutation( p, p+n );
    }
    while( !IsDerangement(p, n) );

    libData->MTensor_disown(p_);

    MArgument_setInteger(Res, iter);

    return LIBRARY_NO_ERROR;
}"];
   lib = CreateLibrary[code, name,
     "Language" -> "C++",
     "ShellOutputFunction" -> Print
     (*,"ShellOutputFunction"\[Rule]Print,*)];
   LibraryFunctionLoad[lib, name, {{Integer, 1, "Shared"}}, Integer]
   ];

?cNextDerangement

cNextDerangement[p] finds the next derangement of the permutation p
of the list {1,2,3,...,Length[p]}. The permutation is changed
in-place. The returned integer shows the number of next_permutation
calls that were necessary to find this derangement.

Example: Start with the identity permutation:

n = 12;
p = Range[1, n];

Calling the function:

iter = cNextDerangement[p]
p

3669867

{2, 1, 4, 3, 6, 5, 8, 7, 10, 11, 9}

Calling the function another time

iter = cNextDerangement[p]
p

1

{2, 1, 4, 3, 6, 5, 8, 7, 11, 9, 10}

You probably know already how to find the first derangement. At least one can guess it quite well from the output. So you can speed up the search by initializing p with the first derangement.

But later there will be of course some other derangement for which many next_permutation calls will be necessary.

Answer 3

Not as fast as other methods, but possibly acceptable timings up to, say, Range[9].

Assuming what is required is the next derangement, starting from a valid permutation.

NestWhile[ResourceFunction["NextPermutation"][#] &, 
 ResourceFunction["NextPermutation"][#], 
   Length@PermutationSupport@# =!= Length@# &] &[{1, 2, 3, 4}]

(* {2, 1, 4, 3} *) 

As a function:

nextDerangement[lst_List /; PermutationListQ[lst]] := NestWhile[
  ResourceFunction["NextPermutation"][#] &, 
  ResourceFunction["NextPermutation"][lst], 
  Length@PermutationSupport@# =!= Length@# &]

Usage

   NestList[nextDerangement, {1, 2, 3, 4}, 5]

   (* {{1, 2, 3, 4}, {2, 1, 4, 3}, {2, 3, 4, 1}, {2, 4, 1, 3}, {3, 1, 4, 2}, 
       {3, 4, 1, 2}} *)

{#, nextDerangement /@ #} &[Rest@Range@Range[9]] // Transpose

(* {
    {{1, 2}, {2, 1}}, 
    {{1, 2, 3}, {2, 3, 1}}, 
    {{1, 2, 3, 4}, {2, 1, 4, 3}}, 
    {{1, 2, 3, 4, 5}, {2, 1, 4, 5, 3}}, 
    {{1, 2, 3, 4, 5, 6}, {2, 1, 4, 3, 6, 5}}, 
    {{1, 2, 3, 4, 5, 6, 7}, {2, 1, 4, 3, 6, 7, 5}}, 
    {{1, 2, 3, 4, 5, 6, 7, 8}, {2, 1, 4, 3, 6, 5, 8, 7}}, 
    {{1, 2, 3, 4, 5, 6, 7, 8, 9}, {2, 1, 4, 3, 6, 5, 8, 9, 7}}
   } *) 

nextDerangement[Range[10]] // Timing
(* {87.3555, {2, 1, 4, 3, 6, 5, 8, 7, 10, 9}} *) 

Wolfram MathWorld function for all derangements

Adapting the function for derangements given by Wolfram MathWorld, all derangements may be obtained:

Pick[#, Length /@ PermutationSupport /@ #, 4] &@Permutations[Range[4]]

(* {{2, 1, 4, 3}, {2, 3, 4, 1}, {2, 4, 1, 3}, {3, 1, 4, 2}, {3, 4, 1, 2}, 
    {3, 4, 2, 1}, {4, 1, 2, 3}, {4, 3, 1, 2}, {4, 3, 2, 1}} *)