Secret Santa - Generating 'valid' permutat

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

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

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 4

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 5

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

Answer 6

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.