1,4

In "Secret Santa", if a person picks their own name, they pick another name and they throw their own name back in. If the last person draws their own name, there's a problem. What is that probability as a function of the number of people participating?

Brian Parsonnet, Table of n, a(n) for n = 1..30

Brian Parsonnet, Probability of Derangements

Sum of H(i, N-2) * X(i, N-2) for i=0..2^(N-3), N is the number of people and H(r,c) = sum of H(T(r),L(r)+j) * M(c-T(r)-1,j) for j = 0..c-L(r)-1 and X(r,c) = product of (3 + k - b(r,k)) for k = 0..(c-2) and M(y,z) = binomial distribution (y,z) when y - 1 > z and (y,z)-1 when (y-1)<=z and b(r,k) = bit k of r in base 2 and T(r) = A053645 and L(r) = A000523.

a(n) = (n-1)!*A102262(n)/A102263(n) for n > 1.

If there is one person, the chance of the last person getting their own name is 100%, or 1 over 0!^2. For 2 people, it is 0 / 1!^2. For 3 people, it is 1 / 2!^2, creating a more interesting case. The possible drawings are {2,1,3}, {2,3,1} and {3,1,2}. All other drawings can't happen because the name is rejected and redrawn. But these 3 outcomes don't have equal probability, rather, they are 25%, 25% and 50% respectively. The first outcome is the only one in which the last person draws their own name. The first person has a 50% chance of drawing a 2 or 3. If 2, the second person has a 50% chance of drawing 1 or 3, for a total outcome probability of 1/4. Similarly with 4 people, the chance is 5/36, followed by 76/576 for 5 people, etc. For the case of 5 people, the above equations boil down to this end calculation: {1,5,2,1} * {12,8,9,6} summed, or 12 + 40 + 18 + 6 = 76.

maxP = 22;

rows = Range[1, 2^(nP = maxP - 3)];

pasc = Table[

Binomial[p + 1, i] - If[i >= p, 1, 0], {p, nP}, {i, 0, p}];

sFreq = Table[0, {maxP - 1}, {2^nP}]; sFreq[[2 ;; maxP - 1, 1]] = 1;

For[p = 1, p <= nP, p++,

For[s = 1, s <= p, s++, rS = Range[2^(s - 1) + 1, 2^s];

sFreq[[p + 2, rS]] = pasc[[p + 1 - s, 1 ;; p + 2 - s]] .

sFreq[[s ;; p + 1, 1 ;; 2^(s - 1)]]]];

sProb = Table[p + 2 - BitGet[rows - 1, p - 1], {p, nP}];

sProb = Table[Product[sProb[[i]], {i, p}], {p, nP}]*

Table[If[r <= 2^p, 1, 0],

{p, nP}, {r, rows}];

rslt = Flatten[

Prepend[Table[sProb[[p]] . sFreq[[p + 2]], {p, nP}], {1, 0, 1}]]

prob = N[rslt/Array[(#1 - 1)!^2 & , maxP]] (* Brian Parsonnet, Feb 22 2011 *)

The sequence frequency table (sFreq) is A136301.

Cf. A000523, A053645, A102262, A102263.

Sequence in context: A364323 A011918 A209095 * A382792 A196689 A196725

Adjacent sequences: A136297 A136298 A136299 * A136301 A136302 A136303

Brian Parsonnet, Mar 22 2008

Corrected and extended to a(19) by Brian Parsonnet, Feb 22 2011

approved