The BLINK Problem

Consider N people. Everyone closes their eyes and randomly chooses
someone to look at other than themselves.What is the probability
at least two people are looking at each other?A nice application
is to a Doctor Who episode from 2007,  Blink.

Hyperlink["http://en.wikipedia.org/wiki/Blink_(Doctor_Who)"]

The following command is very useful. It takes an integer n and writes it in base B. It then outputs the digits in a string, padding on the left so that the string has a fixed length. We don't really need to isolate this as a function, but as this is so important for looping on an arbitrary number of variables, it is worth isolating.

stringforloop[number_, base_, totallength_] := IntegerDigits[number,base,totallength]
stringforloop[1341,3,10]
stringforloop[1342,3,10]

The code below solves the Blink problem. I have NOT programmed the efficiencies we discussed, such as 1 is matched with 2, 2 with 3 et cetera. It does give a good idea of how to handle problems such as these.

(* Here is how you create a program in mathematica. You underscore the variable. The {} in Module lists the local variables -- I never really bother making things local. *)
blink[n_] := Module[{},
(* numpossibles is how many possible outcomes we have *)
numpossibles = (n-1)^n;
(* numwork will be how many of these we have where two people are not looking at each other *)
numwork = 0;

(* Below is my favorite part of the code -- it is a REALLY efficient way to loop through the possible values of n random variables -- what makes it so nice is that the number of random variables is itself variable! *)
For[m = 0, m ≤ numpossibles-1, m++, 
{
(* as mentioned above, the IntegerDigits[m,B,pad] takes three inputs. The first, m, is our number; the second, B, is the base; the third, pad tells us how many entries we want in our list. It works as follows. It takes the base B expansion of m and saves that in a list, where each element of the list is a different digit. It then pads the list with zeros in the beginning so that it is a certain length. If m loops from 0 to B^n - 1, then this has {x1,...,xn} loop from {0,...,0} to {B-1,...,B-1}. *)
tempdigits = IntegerDigits[m,n-1,n];(* note here we are using the base as n-1. *)
(* we now want to transfer our list to the digits. we initialize digits to be an empty list *)
digits = {};
(* we now construct our number -- we don't allow i to look at i, so the easiest way to ensure that is to add the number to it modulo n; as the number is at most n-1, this makes sure i doesn't look at i. *)
For[i = 1, i ≤ n, i++, 
{
newi = Mod[i+tempdigits[[i]],n]+1; (* adds b/w 1 and n-1 *);
If[newi == 0, newi  = n];
digits = AppendTo[digits, newi];
}];
(* we sent tempwork to 1; if it stays as 1 we found another thing that works *)
tempwork = 1;
(* this is a simple way to check if anyone is looking at someone looking back *)
For[i = 1, i ≤ n, i++, If[i == digits[[digits[[i]]]], tempwork = 0]];
numwork = numwork + tempwork;
}];
(* this prints out the results *)
Print["n = ", n];
Print["Number of possibles is ", numpossibles];
Print["Number that work is ", numwork];
Print["Percentage that works is ", numwork 1.0 / numpossibles];
Print[" "];
];

(* this prints the results for various n, and tells us how long it took to run *)
Timing[blink[3]]
Timing[blink[4]]
Timing[blink[5]]
Timing[blink[6]]

Timing[blink[7]]

(* stopped the evaluation -- the last took 23 seconds; this will take at least half an hour *)
(* see how important it is to code efficiently! need to incorporate having 1 look at 2 and 2 look at 3 and then 3 looks at... *)
Timing[blink[8]]

randomblink[n_,numiter_] := Module[{},
numwork = 0;
For[i = 1, i ≤ numiter, i++,
{
digits = {};
For[d = 1, d ≤ n, d++,
{
newi = Random[Integer,{0,n-2}];
newi = Mod[d + newi,n]+1;
digits = AppendTo[digits, newi];
}]; (* end of d loop *)
(* we sent tempwork to 1; if it stays as 1 we found another thing that works *)
tempwork = 1;
(* this is a simple way to check if anyone is looking at someone looking back *)
For[d = 1,d ≤ n,d++, If[d == digits[[digits[[d]]]], tempwork = 0]];
numwork = numwork + tempwork;
}]; (* end of i loop *)
Print["n = ", n, " and percentage that works is ", 100. numwork / numiter];
];

randomblink[3,100000]
randomblink[4,100000]
randomblink[5,100000]
randomblink[6,100000]
randomblink[10,100000]

Timing[randomblink[50,100000]]

Timing[randomblink[100,100000]]

Timing[randomblink[1000,10000]]