Re: Factor

I had a lot of fun writing code to compute derangements recently. I thought I was done with that topic until I bumped into a question on StackOverflow asking how to generate a random derangement of a list. Being nerd sniped is a real thing, and so I started looking at solutions.

There’s a paper called “An analysis of a simple algorithm for random derangements” that has an, ahem, simple algorithm. The basic idea is to generate a random permutation of indices, breaking early if the random permutation is obviously not a derangement.

One way to take a random permutation would be to use our permutations virtual sequence:

IN: scratchpad "ABCDEF" <permutations> random .
"FCEBDA" ! is a derangement

IN: scratchpad "ABCDEF" <permutations> random .
"DFBCEA" ! is NOT a derangement

And so you could loop until a derangement of indices is found:

: random-derangement-indices ( n -- seq )
    f swap <iota> <permutations>
    '[ drop _ random dup derangement? not ] loop ;

But, since only 36% or so of permutations are derangements, perhaps it would be faster and better to implement the algorithm from that paper – making our own random permutation of indices and breaking early if obviously not a derangement:

:: random-derangement-indices ( n -- indices )
    n <iota> >array :> seq
    f [
        dup :> v
        n 1 (a..b] [| j |
            j 1 + random :> p
            p v nth j = [ t ] [ j p v exchange f ] if
        ] any? v first zero? or
    ] [ drop seq clone ] do while ;

We can use that to build a random-derangement word:

: random-derangement ( seq -- seq' )
    [ length random-derangement-indices ] [ nths ] bi ;

And then, for example, get a random derangement of the alphabet – of which there are one hundred and forty-eight septillion derangements, give or take – in under a millisecond:

IN: scratchpad "ABCDEFGHIJKLMNOPQRSTUVWXYZ" random-derangement .
"CZFABMSUXRQDEHGYJLTPVOIKWN"

We could check to make sure that we generate all derangments with equal possibility using a simple test case:

IN: scratchpad 1,000,000 [
                   "ABCD" random-derangement
               ] replicate histogram sort-keys .
{
    { "BADC" 111639 }
    { "BCDA" 110734 }
    { "BDAC" 110682 }
    { "CADB" 111123 }
    { "CDAB" 111447 }
    { "CDBA" 111147 }
    { "DABC" 111215 }
    { "DCAB" 111114 }
    { "DCBA" 110899 }
}

Looks good to me!