Derangements

Sunday, December 8, 2024

Derangements, also sometimes known as deranged permutations, are described as:

In combinatorial mathematics, a derangement is a permutation of the elements of a set in which no element appears in its original position. In other words, a derangement is a permutation that has no fixed points.

There is a fun online derangements generator tool that you can use to play with computing the derangements of a sequence as well as calculating the number of derangements for a given sequence size.

As an example, we can use the math.combinatorics vocabulary, to generate all the permutations of the sequence { 0 1 2 }:

IN: scratchpad { 0 1 2 } all-permutations .
{
    { 0 1 2 }
    { 0 2 1 }
    { 1 0 2 }
    { 1 2 0 }
    { 2 0 1 }
    { 2 1 0 }
}

Since a derangement is a permutation that requires each element to be in a different slot, we could write a word to check the permuted indices to see if that is true:

: derangement? ( indices -- ? )
    dup length <iota> [ = ] 2any? not ;

These would be the two derangements of the indices { 0 1 2 }:

IN: scratchpad { 0 1 2 } all-permutations [ derangement? ] filter .
{
    { 1 2 0 }
    { 2 0 1 }
}

The number of derangements is the subfactorial of the length of the sequence:

: subfactorial ( n -- ? )
    [ 1 ] [ factorial 1 + e /i ] if-zero ;

We can build a <derangement-iota> that is a sequence as long as that number:

: <derangement-iota> ( seq -- <iota> )
    length subfactorial <iota> ; inline

And we can build a next-derangement word that calculates the next permutation that is a derangement:

: next-derangement ( seq -- seq )
    [ dup derangement? ] [ next-permutation ] do until ;

We can then build upon some of the code for iterating permutations, designing an internal derangements-quot word that is similar in form to the existing permutations-quot word:

: derangements-quot ( seq quot -- seq quot' )
    [ [ <derangement-iota> ] [ length <iota> >array ] [ ] tri ] dip
    '[ drop _ next-derangement _ nths-unsafe @ ] ; inline

And then use it to build a series of words that can provide iteration across derangements:

: each-derangement ( ... seq quot: ( ... elt -- ... ) -- ... )
    derangements-quot each ; inline

: map-derangements ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
    derangements-quot map ; inline

: filter-derangements ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
    selector [ each-derangement ] dip ; inline

: all-derangements ( seq -- seq' )
    [ ] map-derangements ;

: all-derangements? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
    derangements-quot all? ; inline

: find-derangement ( ... seq quot: ( ... elt -- ... ? ) -- ... elt/f )
    '[ _ keep and ] derangements-quot map-find drop ; inline

: reduce-derangements ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
    swapd each-derangement ; inline

And, now we can use this to find the nine derangements for "ABCD":

IN: scratchpad "ABCD" all-derangements .
{
    "BADC"
    "BCDA"
    "BDAC"
    "CADB"
    "CDAB"
    "CDBA"
    "DABC"
    "DCAB"
    "DCBA"
}

This is available on my GitHub.