Solve the “Cheryl's birthday” puzzle using mathematica

Question

The "Cheryl's birthday" puzzle has been circulating around, the backstory is available via wikipedia. The puzzle itself is reproduced here:

Albert and Bernard just became friends with Cheryl, and they want to know when her birthday is. Cheryl gave them a list of 10 possible dates:

    May 15     May 16     May 19
   June 17    June 18
   July 14    July 16
 August 14  August 15  August 17

Cheryl then tells Albert and Bernard separately the month and the day of the birthday respectively.

Albert: I don't know when Cheryl's birthday is, but I know that Bernard does not know too.

Bernard: At first I don't know when Cheryl's birthday is, but I know now.

Albert: Then I also know when Cheryl's birthday is.

So when is Cheryl's birthday?

An iterative iPython solution was posted here: http://nbviewer.ipython.org/url/norvig.com/ipython/Cheryl.ipynb

I played around with it and posted my own procedural solution for mathematica here: https://gist.github.com/lburton/241a8083c5d764708010

Since I very seldom use the "math" part of mathematica, I'm really curious to learn how a more sophisticated user would approach the solution. I guess I'd award the answer to the most up-voted.

Of course I'm interested to know more about this general class of problem, so I can identify instances of it that appear in my real work :)

Answer 1

Here is a webpage I set up which solves Cheryl's Birthday-like problems in full generality (i.e. you can specify any set of possible dates) using Mathematica CDF.

http://cherylsbirthdaysolver.com

Answer 2

The following is not particularly inspiring. However,

cand = {{"May", 15}, {"May", 16}, {"May", 19}, {"June", 17}, {"June", 
    18}, {"July", 14}, {"July", 16}, {"August", 14}, {"August", 
    15}, {"August", 17}};
c1[n_] := 
 With[{rem = Cases[Tally[n[[All, 2]]], {x_, _?(# == 1 &)} :> x]}, 
  DeleteCases[
   n, {Alternatives @@ (Cases[n, {_, Alternatives @@ rem}][[All, 
        1]]), _}]]
c2[n_] := 
 With[{rem = Cases[Tally[n[[All, 2]]], {x_, _?(# == 1 &)} :> x]}, 
  Cases[n, {_, Alternatives @@ rem}]]
c3[n_] := 
 With[{rem = Cases[Tally[n[[All, 1]]], {x_, _?(# == 1 &)} :> x]}, 
  Cases[n, {Alternatives @@ rem, _}]]
Composition[
  Row[{"Cheryl's Birthday is "}~Join~#, Spacer[2]] &, #[[1]] &, c3, c2,
   c1][cand]

• cand is candidate birthdays
• c1 to c3 are the clues from the three statements:(i) rule out months that have unique day (ii) rule out birthdays without unique days (iii) find remaining birthday which has unique month
• the rest is for "prettiness"

Run for answer, if not known.