Cheryl's birthday

gistfile1.mathematica

(*
Procedural answer to the question posted here:
"http://nbviewer.ipython.org/url/norvig.com/ipython/Cheryl.ipynb"

Doing this in other fun mathematica ways is left as an exercise for the reader :)
*)

In[665]:= str  = "    May 15     May 16     May 19
     June 17    June 18
     July 14    July 16
   August 14  August 15  August 17" ;

dates = Partition[StringSplit[str], 2]

Out[666]= {{"May", "15"}, {"May", "16"}, {"May", "19"}, {"June", 
  "17"}, {"June", "18"}, {"July", "14"}, {"July", "16"}, {"August", 
  "14"}, {"August", "15"}, {"August", "17"}}

(* 3. albert didn't know when cheryl's birthday was, but 
knew bernard didn't know either. he has revealed that he's holding a 
month that does not permit bernard to immediately know. bernard would 
only immediately know if the day was unique in the list *)

In[667]:= 

monthsWithUniqueDay = 
 GatherBy[dates, Last] // Select[Length[#] == 1 &] // Catenate // 
  Map[First]

Out[667]= {"May", "June"}

(* 4. bernard reveals his initial day was ambiguous, it 
mapped to multiple months *)

In[668]:= 

ambiguousDays = 
  GatherBy[dates, Last] // Select[Length[#] > 1 &] // Catenate // 
    Map[Last] // Union;

bernardInitial = dates // Select[MemberQ[ambiguousDays, Last[#] ] &]

Out[669]= {{"May", "15"}, {"May", "16"}, {"June", "17"}, {"July", 
  "14"}, {"July", "16"}, {"August", "14"}, {"August", 
  "15"}, {"August", "17"}}

(* 4.3 bernard has incorporated albert's information, 
ruling out any months with unique days *)

In[670]:= 

bernardNoUniqueDays = 
 bernardInitial // Select[! MemberQ[monthsWithUniqueDay, First[#]] &]

Out[670]= {{"July", "14"}, {"July", "16"}, {"August", 
  "14"}, {"August", "15"}, {"August", "17"}}

(* 4.6 bernard says this is good enough to give him the 
answer. so what days are potentially unambiguous for him, that are 
unique day numbers in the set? *)

In[671]:= 

bernardCandidateDays = 
 Tally[bernardNoUniqueDays[[All, 2]]] // Select[Last[#] == 1 &] // 
  Map[First]

Out[671]= {"16", "15", "17"}

(* since these are the unique day numbers bernard has, we 
know the final answer must be one of these month/day combinations *)

In[672]:= 

bernardCandidateAnswers = 
 Select[bernardNoUniqueDays, MemberQ[bernardCandidateDays, Last@#] &]

Out[672]= {{"July", "16"}, {"August", "15"}, {"August", "17"}}

(* 5. albert says this is good enough to give *him* the answer. which 
means albert sees here an unambiguous month. What month is 
unambiguous in this set? because that's our answer *)

Select[
 GatherBy[bernardCandidateAnswers, First], Length[#] == 1 &]

Out[673]= {{{"July", "16"}}}