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

Answer 1

In Mathematica you could do something like

secretSanta[n_] := 
  DeleteCases[Permutations[Range[n]], a_ /; Count[a - Range[n], 0] > 0]

where n is the number of people in the pool. Then for example secretSanta[4] returns

{{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}}

Edit

It looks like the Combinatorica package in Mathematica actually has a Derangements function, so you could also do something like

Needs["Combinatorica`"]
Derangements[Range[n]]

although on my system Derangements[Range[n]] is about a factor 2 slower than the function above.

Answer 2

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 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.

Answer 4

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 5

This does not answer your question about counting the valid derangements, but it gives an algorithm to generate one (which might be what you want) with the following properties:

1. it guaranties that there is a single cycle in Santa's relationship (if you play at 4, you do not end up with 2 Santa couples --> 2 cycles),
2. it works efficiently even with very large number of player,
3. if applied fairly, nobody knows whose who Santa's,
4. it does not need a computer, only some paper.

Here the algorithm:

• Every player writes her/his name on an envelope and puts her/his name in a folded paper in the envelope.
• One trusted player (for property # 3 above) takes all the envelopes and shuffles them looking at their back side (where no name is written).
• Once the envelops are shuffled well enough, always looking at the back side, the trusted player moves the paper in each envelope to the following one.
• After shuffling the envelops again, the envelopes are distributed back to the player whose name is on them, and each player is the Santa of the person whose name is in the envelope.

Answer 6

I came across the built-in Subfactorial function in the documentation and altered one of the examples to produce:

Remove[teleSecretSanta];
teleSecretSanta[dims_Integer] :=
 With[{spec = Range[dims]},
  With[{
    perms = Permutations[spec],
    casesToDelete = DiagonalMatrix[spec] /. {0 -> _}},
   DeleteCases[perms, Alternatives @@ casesToDelete]
   ]
  ]

One can use Subfactorial to check the function.

Length[teleSecretSanta[4]] == Subfactorial[4]

As in Mr.Wizard's answer, I suspect teleSecretSanta can be optimized via SparseArray. However, I'm too drunk at the moment to attempt such shenanigans. (kidding... I'm actually too lazy and stupid.)