Solution to the Cheryl Birthday problem (based on Levent Erkok's solution)

Cheryl.hs

-- Search solution in Haskell to the puzzle
--
-- See: http://www.nytimes.com/2015/04/15/science/a-math-problem-from-singapore-goes-viral-when-is-cheryls-birthday.html
--
-- Code modified from Levent Erkok's SBV solution
--
-- https://gist.github.com/LeventErkok/654a86a3ec7d3799b624
--
-- This code (like Levent's) is in the public domain.
--

module Cheryl(puzzle) where

import Control.Monad

-- Represent month and day by 8-bit words; they are small enough to fit.
type Month = Int
type Day   = Int
type Date  = (Month, Day)

-- Months referenced in the problem:
may, june, july, august :: Month
[may, june, july, august] = [5,6,7,8]

months :: [Month]
months = [may, june, july, august]

days :: [Day]
days = [14 .. 19]

-- Check that a given month/day combo is a possible birth-date
valid :: Month -> Day -> Bool
valid month day = (month, day) `elem` candidates
  where candidates :: [Date]
        candidates = [ (   may, 15), (   may, 16), (   may, 19)
                     , (  june, 17), (  june, 18)
                     , (  july, 14), (  july, 16)
                     , (august, 14), (august, 15), (august, 17)
                     ]

-- Assert that the given function holds for one of the possible days
existsDay :: (Day -> Bool) -> Bool
existsDay f = any f days

-- Assert that the given function holds for all of the possible days
forallDay :: (Day -> Bool) -> Bool
forallDay f = all f days

-- Assert that the given function holds for one of the possible months
existsMonth :: (Month -> Bool) -> Bool
existsMonth f = any f months

-- Assert that the given function holds for all of the possible months
forallMonth :: (Month -> Bool) -> Bool
forallMonth f = all f months

unknownMonth :: Day -> Bool
unknownMonth d =
  existsMonth $ \m1 -> existsMonth $ \m2 ->
    m1 /= m2 && valid m1 d && valid m2 d

-- Albert: I do not know
a1 :: Month -> Bool
a1 m = existsDay $ \d1 -> existsDay $ \d2 ->
             d1 /= d2 && valid m d1 && valid m d2

-- Albert: I know that Bernard doesn't know
a2 :: Month -> Bool
a2 m = forallDay $ \d -> not (valid m d) || unknownMonth d

-- Bernard: I did not know
b1 :: Day -> Bool
b1 = unknownMonth

-- Bernard: But now I know
b2 :: Day -> Bool
b2  d = forallMonth $ \m1 -> forallMonth $ \m2 ->
          not (b2p m1 && b2p m2) || (m1 == m2)
  where
  b2p m = valid m d && a1 m && a2 m

-- Albert: Now I know too
a3 :: Month -> Bool
a3 m = forallDay $ \d1 -> forallDay $ \d2 ->
         not (a3p d1 && a3p d2) || (d1 == d2)
  where
  a3p d = valid m d && a1 m && a2 m && b2 d

-- Encode the conversation
puzzle :: [Date]
puzzle = do
  m <- months
  d <- days
  guard (valid m d)
  guard (a1 m) -- Doesn't reduce the space
  guard (a2 m) -- Reduces to Jul, Aug
  guard (b1 d) -- Doesn't reduce the space
  guard (b2 d) -- Reduces to 8/15, 7/16, 8/17
  guard (a3 m) -- Reduces to solution
  return (m,d)