Generating permutations where no item appears in its original position

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-&gt;MTensor_getDimensions(p_)[0];

mint * const p = libData-&gt;MTensor_getIntegerData(p_);

mint iter = 0;

do
{   
    ++iter;

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

libData-&gt;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}} *)