Secret Santa - Generating 'valid' permutations

Question

My friends invited me home to play the game of Secret Santa, where we are supposed to draw a lot & play the role of 'Santa' for a friend in the group.

So, we write all our names and pick a name randomly. If any of us ends up having their own name picked, then we reshuffle and pick names all over again (the rationale being that one can not be one's own Santa).

There are seven of us while playing so I thought of the final 'Santa-allocation' as a permutation of (1:7) onto itself, with some restrictions.

I would like to invite various ideas about how we could use Mathematica in particular or any programming language or even an algorithm to:

• List/print out ALL the 'valid' Santa-allocations
• Is scalable as the number of friends playing 'Secret Santa' grows

Answer 1

What you're looking for is called a derangement (another lovely Latinate word to know, like exsanguination and defenestration).

The fraction of all permutations which are derangements approaches 1/e = approx 36.8% -- so if you are generating random permutations, just keep generating them, and there's a very high probability that you'll find one within 5 or 10 selections of a random permutation. (10.1% chance of not finding one within 5 random permutations, every additional 5 permutations lowers the chance of not finding a derangement by another factor of 10)

This presentation is pretty down-to-earth and gives a recursive algorithm for generating derangements directly, rather than having to reject permutations that aren't derangements.

Answer 2

I propose this:

f[s_List] := Pick[#, Inner[SameQ, #, s, Nor]] & @ Permutations@s

f @ 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}}

This is significantly faster than Heike's function.

f @ Range @ 9; //Timing
secretSanta[9]; //Timing

{0.483, Null}

{1.482, Null}

Ignoring transparency of code, this can be made several times faster still:

f2[n_Integer] := With[{s = Range@n},
    # ~Extract~ 
       SparseArray[Times@@BitXor[s, #] & /@ #]["NonzeroPositions"] & @ Permutations@s
  ]

f2[9]; //Timing

{0.162, Null}

Answer 3

A permutation that maps no element to itself is a derangement. As n increases, the fraction of derangements approaches the constant 1/e. As such, it takes (on average) e tries to get a derangement, if picking a permutation at random.

The wikipedia article includes expressions for calculating explicit values for small n.