Cheryl's Birthday

From Rosetta Code
Cheryl's Birthday is a draft programming task. It is not yet considered ready to be promoted as a complete task, for reasons that should be found in its talk page.

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.

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

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

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


Task

Write a program in your language to deduce, by successive elimination, Cheryl's birthday.

Referrences
Related task



AppleScript[edit]

use AppleScript version "2.4"
use framework "Foundation"
use scripting additions
 
property M : 1 -- Month
property D : 2 -- Day
 
on run
-- The MONTH with only one remaining day
-- among the DAYs with unique months,
-- EXCLUDING months with unique days,
-- in Cheryl's list:
 
showList(uniquePairing(M, ¬
uniquePairing(D, ¬
monthsWithUniqueDays(false, ¬
map(composeList({tupleFromList, |words|, toLower}), ¬
splitOn(", ", ¬
"May 15, May 16, May 19, June 17, June 18, " & ¬
"July 14, July 16, Aug 14, Aug 15, Aug 17"))))))
 
--> "[('july', '16')]"
end run
 
 
-- QUERY FUNCTIONS ----------------------------------------
 
-- monthsWithUniqueDays :: Bool -> [(Month, Day)] -> [(Month, Day)]
on monthsWithUniqueDays(blnInclude, xs)
set _months to map(my fst, uniquePairing(D, xs))
script uniqueDay
on |λ|(md)
set bln to elem(fst(md), _months)
if blnInclude then
bln
else
not bln
end if
end |λ|
end script
filter(uniqueDay, xs)
end monthsWithUniqueDays
 
 
-- uniquePairing :: DatePart -> [(M, D)] -> [(M, D)]
on uniquePairing(dp, xs)
script go
property f : my mReturn(item dp of {my fst, my snd})
on |λ|(md)
 
set dct to f's |λ|(md)
script unique
on |λ|(k)
set mb to lookupDict(k, dct)
if Nothing of mb then
false
else
1 = length of (Just of mb)
end if
end |λ|
end script
set uniques to filter(unique, keys(dct))
 
script found
on |λ|(tpl)
elem(f's |λ|(tpl), uniques)
end |λ|
end script
filter(found, xs)
end |λ|
end script
bindPairs(xs, go)
end uniquePairing
 
 
-- bindPairs :: [(M, D)] -> ((Dict Text [Text], Dict Text [Text])
-- -> [(M, D)]) -> [(M, D)]
on bindPairs(xs, f)
tell mReturn(f)
|λ|(Tuple(dictFromPairs(xs), ¬
dictFromPairs(map(my swap, xs))))
end tell
end bindPairs
 
-- dictFromPairs :: [(M, D)] -> Dict Text [Text]
on dictFromPairs(mds)
set gps to groupBy(|on|(my eq, my fst), ¬
sortBy(comparing(my fst), mds))
script kv
on |λ|(gp)
Tuple(fst(item 1 of gp), map(my snd, gp))
end |λ|
end script
mapFromList(map(kv, gps))
end dictFromPairs
 
 
-- LIBRARY GENERICS ---------------------------------------
 
-- comparing :: (a -> b) -> (a -> a -> Ordering)
on comparing(f)
script
on |λ|(a, b)
tell mReturn(f)
set fa to |λ|(a)
set fb to |λ|(b)
if fa < fb then
-1
else if fa > fb then
1
else
0
end if
end tell
end |λ|
end script
end comparing
 
-- composeList :: [(a -> a)] -> (a -> a)
on composeList(fs)
script
on |λ|(x)
script
on |λ|(f, a)
mReturn(f)'s |λ|(a)
end |λ|
end script
 
foldr(result, x, fs)
end |λ|
end script
end composeList
 
-- drop :: Int -> [a] -> [a]
-- drop :: Int -> String -> String
on drop(n, xs)
set c to class of xs
if c is not script then
if c is not string then
if n < length of xs then
items (1 + n) thru -1 of xs
else
{}
end if
else
if n < length of xs then
text (1 + n) thru -1 of xs
else
""
end if
end if
else
take(n, xs) -- consumed
return xs
end if
end drop
 
-- dropAround :: (a -> Bool) -> [a] -> [a]
-- dropAround :: (Char -> Bool) -> String -> String
on dropAround(p, xs)
dropWhile(p, dropWhileEnd(p, xs))
end dropAround
 
-- dropWhile :: (a -> Bool) -> [a] -> [a]
-- dropWhile :: (Char -> Bool) -> String -> String
on dropWhile(p, xs)
set lng to length of xs
set i to 1
tell mReturn(p)
repeat while i ≤ lng and |λ|(item i of xs)
set i to i + 1
end repeat
end tell
drop(i - 1, xs)
end dropWhile
 
-- dropWhileEnd :: (a -> Bool) -> [a] -> [a]
-- dropWhileEnd :: (Char -> Bool) -> String -> String
on dropWhileEnd(p, xs)
set i to length of xs
tell mReturn(p)
repeat while i > 0 and |λ|(item i of xs)
set i to i - 1
end repeat
end tell
take(i, xs)
end dropWhileEnd
 
-- elem :: Eq a => a -> [a] -> Bool
on elem(x, xs)
considering case
xs contains x
end considering
end elem
 
-- enumFromToInt :: Int -> Int -> [Int]
on enumFromToInt(M, n)
if M ≤ n then
set lst to {}
repeat with i from M to n
set end of lst to i
end repeat
return lst
else
return {}
end if
end enumFromToInt
 
-- eq (==) :: Eq a => a -> a -> Bool
on eq(a, b)
a = b
end eq
 
-- filter :: (a -> Bool) -> [a] -> [a]
on filter(f, xs)
tell mReturn(f)
set lst to {}
set lng to length of xs
repeat with i from 1 to lng
set v to item i of xs
if |λ|(v, i, xs) then set end of lst to v
end repeat
return lst
end tell
end filter
 
-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
tell mReturn(f)
set v to startValue
set lng to length of xs
repeat with i from 1 to lng
set v to |λ|(v, item i of xs, i, xs)
end repeat
return v
end tell
end foldl
 
-- foldr :: (a -> b -> b) -> b -> [a] -> b
on foldr(f, startValue, xs)
tell mReturn(f)
set v to startValue
set lng to length of xs
repeat with i from lng to 1 by -1
set v to |λ|(item i of xs, v, i, xs)
end repeat
return v
end tell
end foldr
 
-- fst :: (a, b) -> a
on fst(tpl)
if class of tpl is record then
|1| of tpl
else
item 1 of tpl
end if
end fst
 
-- Typical usage: groupBy(on(eq, f), xs)
-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
on groupBy(f, xs)
set mf to mReturn(f)
 
script enGroup
on |λ|(a, x)
if length of (active of a) > 0 then
set h to item 1 of active of a
else
set h to missing value
end if
 
if h is not missing value and mf's |λ|(h, x) then
{active:(active of a) & {x}, sofar:sofar of a}
else
{active:{x}, sofar:(sofar of a) & {active of a}}
end if
end |λ|
end script
 
if length of xs > 0 then
set dct to foldl(enGroup, {active:{item 1 of xs}, sofar:{}}, rest of xs)
if length of (active of dct) > 0 then
sofar of dct & {active of dct}
else
sofar of dct
end if
else
{}
end if
end groupBy
 
-- insertMap :: Dict -> String -> a -> Dict
on insertMap(rec, k, v)
tell (current application's NSMutableDictionary's ¬
dictionaryWithDictionary:rec)
its setValue:v forKey:(k as string)
return it as record
end tell
end insertMap
 
-- intercalateS :: String -> [String] -> String
on intercalateS(sep, xs)
set {dlm, my text item delimiters} to {my text item delimiters, sep}
set s to xs as text
set my text item delimiters to dlm
return s
end intercalateS
 
-- Just :: a -> Maybe a
on Just(x)
{type:"Maybe", Nothing:false, Just:x}
end Just
 
-- keys :: Dict -> [String]
on keys(rec)
(current application's NSDictionary's dictionaryWithDictionary:rec)'s allKeys() as list
end keys
 
-- lookupDict :: a -> Dict -> Maybe b
on lookupDict(k, dct)
set ca to current application
set v to (ca's NSDictionary's dictionaryWithDictionary:dct)'s objectForKey:k
if v ≠ missing value then
Just(item 1 of ((ca's NSArray's arrayWithObject:v) as list))
else
Nothing()
end if
end lookupDict
 
-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
if class of f is script then
f
else
script
property |λ| : f
end script
end if
end mReturn
 
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
tell mReturn(f)
set lng to length of xs
set lst to {}
repeat with i from 1 to lng
set end of lst to |λ|(item i of xs, i, xs)
end repeat
return lst
end tell
end map
 
-- mapFromList :: [(k, v)] -> Dict
on mapFromList(kvs)
set tpl to unzip(kvs)
script
on |λ|(x)
x as string
end |λ|
end script
(current application's NSDictionary's ¬
dictionaryWithObjects:(|2| of tpl) ¬
forKeys:map(result, |1| of tpl)) as record
end mapFromList
 
-- min :: Ord a => a -> a -> a
on min(x, y)
if y < x then
y
else
x
end if
end min
 
-- Nothing :: Maybe a
on Nothing()
{type:"Maybe", Nothing:true}
end Nothing
 
-- e.g. sortBy(|on|(compare, |length|), ["epsilon", "mu", "gamma", "beta"])
-- on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
on |on|(f, g)
script
on |λ|(a, b)
tell mReturn(g) to set {va, vb} to {|λ|(a), |λ|(b)}
tell mReturn(f) to |λ|(va, vb)
end |λ|
end script
end |on|
 
-- partition :: predicate -> List -> (Matches, nonMatches)
-- partition :: (a -> Bool) -> [a] -> ([a], [a])
on partition(f, xs)
tell mReturn(f)
set ys to {}
set zs to {}
repeat with x in xs
set v to contents of x
if |λ|(v) then
set end of ys to v
else
set end of zs to v
end if
end repeat
end tell
Tuple(ys, zs)
end partition
 
-- show :: a -> String
on show(e)
set c to class of e
if c = list then
showList(e)
else if c = record then
set mb to lookupDict("type", e)
if Nothing of mb then
showDict(e)
else
script
on |λ|(t)
if "Either" = t then
set f to my showLR
else if "Maybe" = t then
set f to my showMaybe
else if "Ordering" = t then
set f to my showOrdering
else if "Ratio" = t then
set f to my showRatio
else if class of t is text and t begins with "Tuple" then
set f to my showTuple
else
set f to my showDict
end if
tell mReturn(f) to |λ|(e)
end |λ|
end script
tell result to |λ|(Just of mb)
end if
else if c = date then
"\"" & showDate(e) & "\""
else if c = text then
"'" & e & "'"
else if (c = integer or c = real) then
e as text
else if c = class then
"null"
else
try
e as text
on error
("«" & c as text) & "»"
end try
end if
end show
 
-- showList :: [a] -> String
on showList(xs)
"[" & intercalateS(", ", map(my show, xs)) & "]"
end showList
 
-- showTuple :: Tuple -> String
on showTuple(tpl)
set ca to current application
script
on |λ|(n)
set v to (ca's NSDictionary's dictionaryWithDictionary:tpl)'s objectForKey:(n as string)
if v ≠ missing value then
unQuoted(show(item 1 of ((ca's NSArray's arrayWithObject:v) as list)))
else
missing value
end if
end |λ|
end script
"(" & intercalateS(", ", map(result, enumFromToInt(1, length of tpl))) & ")"
end showTuple
 
-- snd :: (a, b) -> b
on snd(tpl)
if class of tpl is record then
|2| of tpl
else
item 2 of tpl
end if
end snd
 
-- Enough for small scale sorts.
-- Use instead sortOn :: Ord b => (a -> b) -> [a] -> [a]
-- which is equivalent to the more flexible sortBy(comparing(f), xs)
-- and uses a much faster ObjC NSArray sort method
-- sortBy :: (a -> a -> Ordering) -> [a] -> [a]
on sortBy(f, xs)
if length of xs > 1 then
set h to item 1 of xs
set f to mReturn(f)
script
on |λ|(x)
f's |λ|(x, h)0
end |λ|
end script
set lessMore to partition(result, rest of xs)
sortBy(f, |1| of lessMore) & {h} & ¬
sortBy(f, |2| of lessMore)
else
xs
end if
end sortBy
 
-- splitOn :: String -> String -> [String]
on splitOn(pat, src)
set {dlm, my text item delimiters} to ¬
{my text item delimiters, pat}
set xs to text items of src
set my text item delimiters to dlm
return xs
end splitOn
 
-- swap :: (a, b) -> (b, a)
on swap(ab)
if class of ab is record then
Tuple(|2| of ab, |1| of ab)
else
{item 2 of ab, item 1 of ab}
end if
end swap
 
-- take :: Int -> [a] -> [a]
-- take :: Int -> String -> String
on take(n, xs)
set c to class of xs
if list is c then
if 0 < n then
items 1 thru min(n, length of xs) of xs
else
{}
end if
else if string is c then
if 0 < n then
text 1 thru min(n, length of xs) of xs
else
""
end if
else if script is c then
set ys to {}
repeat with i from 1 to n
set v to xs's |λ|()
if missing value is v then
return ys
else
set end of ys to v
end if
end repeat
return ys
else
missing value
end if
end take
 
-- toLower :: String -> String
on toLower(str)
set ca to current application
((ca's NSString's stringWithString:(str))'s ¬
lowercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toLower
 
-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
{type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple
 
-- tupleFromList :: [a] -> (a, a ...)
on tupleFromList(xs)
set lng to length of xs
if 1 < lng then
if 2 < lng then
set strSuffix to lng as string
else
set strSuffix to ""
end if
script kv
on |λ|(a, x, i)
insertMap(a, (i as string), x)
end |λ|
end script
foldl(kv, {type:"Tuple" & strSuffix}, xs) & {length:lng}
else
missing value
end if
end tupleFromList
 
-- unQuoted :: String -> String
on unQuoted(s)
script p
on |λ|(x)
--{34, 39} contains id of x
34 = id of x
end |λ|
end script
dropAround(p, s)
end unQuoted
 
-- unzip :: [(a,b)] -> ([a],[b])
on unzip(xys)
set xs to {}
set ys to {}
repeat with xy in xys
set end of xs to |1| of xy
set end of ys to |2| of xy
end repeat
return Tuple(xs, ys)
end unzip
 
-- words :: String -> [String]
on |words|(s)
set ca to current application
(((ca's NSString's stringWithString:(s))'s ¬
componentsSeparatedByCharactersInSet:(ca's ¬
NSCharacterSet's whitespaceAndNewlineCharacterSet()))'s ¬
filteredArrayUsingPredicate:(ca's ¬
NSPredicate's predicateWithFormat:"0 < length")) as list
end |words|
Output:
"[('july', '16')]"

Common Lisp[edit]

 
;; Author: Amir Teymuri, Saturday 20.10.2018
 
(defparameter *possible-dates*
'((15 . may) (16 . may) (19 . may)
(17 . june) (18 . june)
(14 . july) (16 . july)
(14 . august) (15 . august) (17 . august)))
 
(defun unique-date-parts (possible-dates &key (alist-look-at #'car) (alist-r-assoc #'assoc))
(let* ((date-parts (mapcar alist-look-at possible-dates))
(unique-date-parts (remove-if #'(lambda (part) (> (count part date-parts) 1)) date-parts)))
(mapcar #'(lambda (part) (funcall alist-r-assoc part possible-dates))
unique-date-parts)))
 
(defun person (person possible-dates)
"Who's turn is it to think?"
(case person
('albert (unique-date-parts possible-dates :alist-look-at #'cdr :alist-r-assoc #'rassoc))
('bernard (unique-date-parts possible-dates :alist-look-at #'car :alist-r-assoc #'assoc))))
 
(defun cheryls-birthday (possible-dates)
(person 'albert
(person 'bernard
(set-difference
possible-dates
(person 'bernard possible-dates)
:key #'cdr))))
 
(cheryls-birthday *possible-dates*) ;; => ((16 . JULY))
 

F#[edit]

 
//Find Cheryl's Birthday. Nigel Galloway: October 23rd., 2018
type Month = |May |June |July |August
let fN n= n |> List.filter(fun (_,n)->(List.length n) < 2) |> List.unzip
let dates = [(May,15);(May,16);(May,19);(June,17);(June,18);(July,14);(July,16);(August,14);(August,15);(August,17)]
let _,n = dates |> List.groupBy snd |> fN
let i = n |> List.concat |> List.map fst |> Set.ofList
let _,g = dates |> List.filter(fun (n,_)->not (Set.contains n i)) |> List.groupBy snd |> fN
let _,e = List.concat g |> List.groupBy fst |> fN
printfn "%A" e
 
Output:
[[(July, 16)]]

Go[edit]

package main
 
import (
"fmt"
"time"
)
 
type birthday struct{ month, day int }
 
func (b birthday) String() string {
return fmt.Sprintf("%s %d", time.Month(b.month), b.day)
}
 
func (b birthday) monthUniqueIn(bds []birthday) bool {
count := 0
for _, bd := range bds {
if bd.month == b.month {
count++
}
}
if count == 1 {
return true
}
return false
}
 
func (b birthday) dayUniqueIn(bds []birthday) bool {
count := 0
for _, bd := range bds {
if bd.day == b.day {
count++
}
}
if count == 1 {
return true
}
return false
}
 
func (b birthday) monthWithUniqueDayIn(bds []birthday) bool {
for _, bd := range bds {
if bd.month == b.month && bd.dayUniqueIn(bds) {
return true
}
}
return false
}
 
func main() {
choices := []birthday{
{5, 15}, {5, 16}, {5, 19}, {6, 17}, {6, 18},
{7, 14}, {7, 16}, {8, 14}, {8, 15}, {8, 17},
}
 
// Albert knows the month but doesn't know the day.
// So the month can't be unique within the choices.
var filtered []birthday
for _, bd := range choices {
if !bd.monthUniqueIn(choices) {
filtered = append(filtered, bd)
}
}
 
// Albert also knows that Bernard doesn't know the answer.
// So the month can't have a unique day.
var filtered2 []birthday
for _, bd := range filtered {
if !bd.monthWithUniqueDayIn(filtered) {
filtered2 = append(filtered2, bd)
}
}
 
// Bernard now knows the answer.
// So the day must be unique within the remaining choices.
var filtered3 []birthday
for _, bd := range filtered2 {
if bd.dayUniqueIn(filtered2) {
filtered3 = append(filtered3, bd)
}
}
 
// Albert now knows the answer too.
// So the month must be unique within the remaining choices.
var filtered4 []birthday
for _, bd := range filtered3 {
if bd.monthUniqueIn(filtered3) {
filtered4 = append(filtered4, bd)
}
}
 
if len(filtered4) == 1 {
fmt.Println("Cheryl's birthday is", filtered4[0])
} else {
fmt.Println("Something went wrong!")
}
}
Output:
Cheryl's birthday is July 16

Haskell[edit]

{-# LANGUAGE OverloadedStrings #-}
 
import Data.List as L (filter, groupBy, head, length, sortBy)
import Data.Map.Strict as M (Map, fromList, keys, lookup)
import Data.Text as T (Text, splitOn, words)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Data.Function (on)
import Data.Tuple (swap)
 
data DatePart
= Month
| Day
 
type M = Text
 
type D = Text
 
main :: IO ()
main =
print $
-- The month with only one remaining day,
--
-- (A's month contains only one remaining day)
-- (3 :: A "Then I also know")
uniquePairing Month $
 
-- among the days with unique months,
--
-- (B's day is paired with only one remaining month)
-- (2 :: B "I know now")
uniquePairing Day $
 
-- excluding months with unique days,
--
-- (A's month is not among those with unique days)
-- (1 :: A "I know that Bernard does not know")
monthsWithUniqueDays False $
 
-- from the given month-day pairs:
--
-- (0 :: Cheryl's list)
(\(x:y:_) -> (x, y)) . T.words <$>
splitOn
", "
"May 15, May 16, May 19, June 17, June 18, \
\July 14, July 16, Aug 14, Aug 15, Aug 17"

 
-- QUERY FUNCTIONS ---------------------------------------------
monthsWithUniqueDays :: Bool -> [(M, D)] -> [(M, D)]
monthsWithUniqueDays bln xs =
let months = fst <$> uniquePairing Day xs
in L.filter
(\(m, _) ->
(if bln
then id
else not)
(m `elem` months))
xs
 
uniquePairing :: DatePart -> [(M, D)] -> [(M, D)]
uniquePairing dp xs =
let f =
case dp of
Month -> fst
_ -> snd
in bindPairs
xs
(\md ->
let dct :: M.Map Text [Text]
dct = f md
uniques =
L.filter
((1 ==) . L.length . fromJust . flip M.lookup dct)
(keys dct)
in L.filter ((`elem` uniques) . f) xs)
 
bindPairs :: [(M, D)]
-> ((M.Map Text [Text], M.Map Text [Text]) -> [(M, D)])
-> [(M, D)]
bindPairs xs f = f (mapFromPairs xs, mapFromPairs (swap <$> xs))
 
mapFromPairs :: [(M, D)] -> Map Text [Text]
mapFromPairs xs =
M.fromList $
((,) . fst . L.head) <*> fmap snd <$>
L.groupBy (on (==) fst) (L.sortBy (comparing fst) xs)
Output:
[("July","16")]

J[edit]

Solution:

Dates=: <;._2 noun define
15 May
16 May
19 May
17 June
18 June
14 July
16 July
14 August
15 August
17 August
)
 
getDayMonth=: |:@:(' '&splitstring&>) NB. retrieve lists of days and months from dates
keep=: adverb def '] #~ u' NB. apply mask to filter dates
 
monthsWithUniqueDay=: {./. #~ (1=#)/. NB. list months that have a unique day
isMonthWithoutUniqueDay=: (] [email protected] monthsWithUniqueDay)/@getDayMonth NB. mask of dates with a month that doesn't have a unique day
 
uniqueDayInMonth=: [email protected][ #~ (1=#)/. NB. list of days that are unique to 1 month
isUniqueDayInMonth=: ([ e. uniqueDayInMonth)/@getDayMonth NB. mask of dates with a day that is unique to 1 month
 
uniqueMonth=: [email protected]] #~ (1=#)/.~ NB. list of months with 1 unique day
isUniqueMonth=: (] e. uniqueMonth)/@getDayMonth NB. mask of dates with a month that has 1 unique day

Usage:

   isUniqueMonth keep isUniqueDayInMonth keep isMonthWithoutUniqueDay keep Dates
+-------+
|16 July|
+-------+

Alternative Approach[edit]

The concepts here are the same, of course, it's just the presentation that's different.

possible=: cut;._2 'May 15, May 16, May 19, June 17, June 18, July 14, July 16, August 14, August 15, August 17,'
 
Albert=: {."1 NB. Albert knows month
Bernard=: {:"1 NB. Bernard knows day
 
NB. Bernard's understanding of Albert's first pass
days=: {:"1 possible
invaliddays=: (1=#/.~ days)#~.days
months=: {."1 possible
validmonths=: months -. (days e. invaliddays)#months
possibleA=. (months e. validmonths)# possible
 
NB. Albert's understanding of Bernard's pass
days=: {:"1 possibleA
invaliddays=: (1<#/.~ days)#~.days
possibleB=. (days e. days-.invaliddays)# possibleA
 
NB. our understanding of Albert's second pass
months=: {."1 possibleB
invalidmonths=: (1<#/.~months)#~.months
echo ;:inv (months e. months -. invalidmonths)#possibleB

This gives us the July 16 result we were expecting

JavaScript[edit]

(() => {
'use strict';
 
// main :: IO ()
const main = () => {
const
month = fst,
day = snd;
showLog(
map(x => Array.from(x), (
 
// The month with only one remaining day,
 
// (A's month contains only one remaining day)
// (3 :: A "Then I also know")
uniquePairing(month)(
 
// among the days with unique months,
 
// (B's day is paired with only one remaining month)
// (2 :: B "I know now")
uniquePairing(day)(
 
// excluding months with unique days,
 
// (A's month is not among those with unique days)
// (1 :: A "I know that Bernard does not know")
monthsWithUniqueDays(false)(
 
// from the given month-day pairs:
 
// (0 :: Cheryl's list)
map(x => tupleFromList(words(strip(x))),
splitOn(/,\s+/,
`May 15, May 16, May 19,
June 17, June 18, July 14, July 16,
Aug 14, Aug 15, Aug 17`
)
)
)
)
)
))
);
};
 
// monthsWithUniqueDays :: Bool -> [(Month, Day)] -> [(Month, Day)]
const monthsWithUniqueDays = blnInclude => xs => {
const months = map(fst, uniquePairing(snd)(xs));
return filter(
md => (blnInclude ? id : not)(
elem(fst(md), months)
),
xs
);
};
 
// uniquePairing :: ((a, a) -> a) ->
// -> [(Month, Day)] -> [(Month, Day)]
const uniquePairing = f => xs =>
bindPairs(xs,
md => {
const
dct = f(md),
matches = filter(
k => 1 === length(dct[k]),
Object.keys(dct)
);
return filter(tpl => elem(f(tpl), matches), xs);
}
);
 
// bindPairs :: [(Month, Day)] -> (Dict, Dict) -> [(Month, Day)]
const bindPairs = (xs, f) => f(
Tuple(
dictFromPairs(fst)(snd)(xs),
dictFromPairs(snd)(fst)(xs)
)
);
 
// dictFromPairs :: ((a, a) -> a) -> ((a, a) -> a) -> [(a, a)] -> Dict
const dictFromPairs = f => g => xs =>
foldl((a, tpl) => Object.assign(
a, {
[f(tpl)]: (a[f(tpl)] || []).concat(g(tpl).toString())
}
), {}, xs);
 
 
// GENERIC ABSTRACTIONS -------------------------------
 
// Tuple (,) :: a -> b -> (a, b)
const Tuple = (a, b) => ({
type: 'Tuple',
'0': a,
'1': b,
length: 2
});
 
// elem :: Eq a => a -> [a] -> Bool
const elem = (x, xs) => xs.includes(x);
 
// filter :: (a -> Bool) -> [a] -> [a]
const filter = (f, xs) => xs.filter(f);
 
// foldl :: (a -> b -> a) -> a -> [b] -> a
const foldl = (f, a, xs) => xs.reduce(f, a);
 
// fst :: (a, b) -> a
const fst = tpl => tpl[0];
 
// id :: a -> a
const id = x => x;
 
// intersect :: (Eq a) => [a] -> [a] -> [a]
const intersect = (xs, ys) =>
xs.filter(x => -1 !== ys.indexOf(x));
 
// Returns Infinity over objects without finite length
// this enables zip and zipWith to choose the shorter
// argument when one is non-finite, like cycle, repeat etc
 
// length :: [a] -> Int
const length = xs =>
(Array.isArray(xs) || 'string' === typeof xs) ? (
xs.length
) : Infinity;
 
// map :: (a -> b) -> [a] -> [b]
const map = (f, xs) => xs.map(f);
 
// not :: Bool -> Bool
const not = b => !b;
 
// showLog :: a -> IO ()
const showLog = (...args) =>
console.log(
args
.map(JSON.stringify)
.join(' -> ')
);
 
// snd :: (a, b) -> b
const snd = tpl => tpl[1];
 
// splitOn :: String -> String -> [String]
const splitOn = (pat, src) =>
src.split(pat);
 
// strip :: String -> String
const strip = s => s.trim();
 
// tupleFromList :: [a] -> (a, a ...)
const tupleFromList = xs =>
TupleN.apply(null, xs);
 
// TupleN :: a -> b ... -> (a, b ... )
function TupleN() {
const
args = Array.from(arguments),
lng = args.length;
return lng > 1 ? Object.assign(
args.reduce((a, x, i) => Object.assign(a, {
[i]: x
}), {
type: 'Tuple' + (2 < lng ? lng.toString() : ''),
length: lng
})
) : args[0];
};
 
// words :: String -> [String]
const words = s => s.split(/\s+/);
 
// MAIN ---
return main();
})();
Output:
[["July","16"]]

Kotlin[edit]

Translation of: Go
// Version 1.2.71
 
val months = listOf(
"January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December"
)
 
class Birthday(val month: Int, val day: Int) {
public override fun toString() = "${months[month - 1]} $day"
 
public fun monthUniqueIn(bds: List<Birthday>): Boolean {
return bds.count { this.month == it.month } == 1
}
 
public fun dayUniqueIn(bds: List<Birthday>): Boolean {
return bds.count { this.day == it.day } == 1
}
 
public fun monthWithUniqueDayIn(bds: List<Birthday>): Boolean {
return bds.any { (this.month == it.month) && it.dayUniqueIn(bds) }
}
}
 
fun main(args: Array<String>) {
val choices = listOf(
Birthday(5, 15), Birthday(5, 16), Birthday(5, 19), Birthday(6, 17),
Birthday(6, 18), Birthday(7, 14), Birthday(7, 16), Birthday(8, 14),
Birthday(8, 15), Birthday(8, 17)
)
 
// Albert knows the month but doesn't know the day.
// So the month can't be unique within the choices.
var filtered = choices.filterNot { it.monthUniqueIn(choices) }
 
// Albert also knows that Bernard doesn't know the answer.
// So the month can't have a unique day.
filtered = filtered.filterNot { it.monthWithUniqueDayIn(filtered) }
 
// Bernard now knows the answer.
// So the day must be unique within the remaining choices.
filtered = filtered.filter { it.dayUniqueIn(filtered) }
 
// Albert now knows the answer too.
// So the month must be unique within the remaining choices.
filtered = filtered.filter { it.monthUniqueIn(filtered) }
 
if (filtered.size == 1)
println("Cheryl's birthday is ${filtered[0]}")
else
println("Something went wrong!")
}
Output:
Cheryl's birthday is July 16

Python[edit]

Functional[edit]

from typing import Callable, Dict, List, Tuple, Union
from itertools import (groupby)
from operator import not_
from re import (split)
 
 
# main :: IO ()
def main() -> None:
(month, day) = (0, 1)
print(
# (A's month contains only one remaining day)
# (3 :: A "Then I also know")
uniquePairing(month)(
# (B's day is paired with only one remaining month)
# (2 :: B "I know now")
uniquePairing(day)(
# (A's month is not among those with unique days)
# (1 :: A "I know that Bernard does not know")
monthsWithUniqueDays(False)(
# 0 :: Cheryl's list:
list(map(
lambda x: tuple(x.split()),
split(
', ',
'May 15, May 16, May 19, ' +
'June 17, June 18, ' +
'July 14, July 16, ' +
'Aug 14, Aug 15, Aug 17'
)
))
)
)
)
)
 
 
# QUERY FUNCTIONS ----------------------------------------
 
# monthsWithUniqueDays :: Bool -> [(Month, Day)] -> [(Month, Day)]
def monthsWithUniqueDays(blnInclude: bool) -> Callable:
def go(xs):
(month, day) = (0, 1)
months = list(map(fst, uniquePairing(day)(xs)))
return list(filter(
lambda md: (
md if blnInclude else not_
)(md[month] in months),
xs
))
return lambda xs: go(xs)
 
 
# uniquePairing :: DatePart -> [(Month, Day)] -> [(Month, Day)]
def uniquePairing(i: int) -> Callable:
def go(xs):
def inner(md):
dct = md[i]
uniques = list(filter(
lambda k: 1 == len(dct[k]),
dct.keys()
))
return filter(lambda tpl: tpl[i] in uniques, xs)
return inner
return lambda xs: bindPairs(xs)(go(xs))
 
 
# bindPairs :: [(Month, Day)] -> ((Dict String [String], Dict String [String])
# -> [(Month, Day)]) -> [(Month, Day)]
def bindPairs(xs: List[Tuple[str, str]]) -> Callable:
return lambda f: list(f(
(dictFromPairs(xs), dictFromPairs(map(swap, xs)))
))
 
 
# dictFromPairs :: [(Month, Day)] -> Dict Text [Text]
def dictFromPairs(
xs: Union[map, List[Tuple[str, str]]]
) -> Dict[str, List[str]]:
return dict(
(k, list(map(snd, m))) for k, m in groupby(
sorted(xs, key=fst), key=fst
)
)
 
 
# GENERIC -------------------------------------------------
 
# fst :: (a, b) -> a
def fst(tpl: Tuple[str, str]) -> str:
"Return first element of tpl"
return tpl[0]
 
 
# snd :: (a, b) -> b
def snd(tpl: Tuple[str, str]) -> str:
"Return second element of tpl"
return tpl[1]
 
 
# swap :: (a, b) -> (b, a)
def swap(tpl: Tuple[str, str]) -> Tuple[str, str]:
"Swap and return first and second elements of tpl"
return (tpl[1], tpl[0])
 
 
if __name__ == '__main__':
main()
Output:
[('July', '16')]

Perl[edit]

sub filter {
my($test,@dates) = @_;
my(%M,%D,@filtered);
 
# analysis of potential birthdays, keyed by month and by day
for my $date (@dates) {
my($mon,$day) = split '-', $date;
$M{$mon}{cnt}++;
$D{$day}{cnt}++;
push @{$M{$mon}{day}}, $day;
push @{$D{$day}{mon}}, $mon;
push @{$M{$mon}{bday}}, "$mon-$day";
push @{$D{$day}{bday}}, "$mon-$day";
}
 
# eliminates May/Jun dates based on 18th and 19th being singletons
if ($test eq 'singleton') {
my %skip;
for my $day (grep { $D{$_}{cnt} == 1 } keys %D) { $skip{ @{$D{$day}{mon}}[0] }++ }
for my $mon (grep { ! $skip{$_} } keys %M) { push @filtered, @{$M{$mon}{bday}} }
 
# eliminates Jul/Aug 14th because day count > 1 across months
} elsif ($test eq 'duplicate') {
for my $day (grep { $D{$_}{cnt} == 1 } keys %D) { push @filtered, @{$D{$day}{bday}} }
 
# eliminates Aug 15th/17th because day count > 1, within month
} elsif ($test eq 'multiple') {
for my $day (grep { $M{$_}{cnt} == 1 } keys %M) { push @filtered, @{$M{$day}{bday}} }
}
return @filtered;
}
 
# doesn't matter what order singleton/duplicate tests are run, but 'multiple' must be last;
my @dates = qw<5-15 5-16 5-19 6-17 6-18 7-14 7-16 8-14 8-15 8-17>;
@dates = filter($_, @dates) for qw<singleton duplicate multiple>;
 
my @months = qw<_ January February March April May June July August September October November December>;
 
my ($m, $d) = split '-', $dates[0];
print "Cheryl's birthday is $months[$m] $d.\n";
Output:
Cheryl's birthday is July 16.

Perl 6[edit]

my @dates =
{ :15day, :5month },
{ :16day, :5month },
{ :19day, :5month },
{ :17day, :6month },
{ :18day, :6month },
{ :14day, :7month },
{ :16day, :7month },
{ :14day, :8month },
{ :15day, :8month },
{ :17day, :8month }
;
 
# Month can't have a unique day
my @filtered = @dates.grep(*.<month> != one(@dates.grep(*.<day> == one(@dates».<day>))».<month>));
 
# Day must be unique and unambiguous in remaining months
my $birthday = @filtered.grep(*.<day> == one(@filtered».<day>)).classify({.<month>})\
.first(*.value.elems == 1).value[0];
 
# convenience array
my @months = <'' January February March April May June July August September October November December>;
 
say "Cheryl's birthday is { @months[$birthday<month>] } {$birthday<day>}.";
Output:
Cheryl's birthday is July 16.

Sidef[edit]

Translation of: Perl 6
struct Date(day, month)
 
var dates = [
Date(15, "May"),
Date(16, "May"),
Date(19, "May"),
Date(17, "June"),
Date(18, "June"),
Date(14, "July"),
Date(16, "July"),
Date(14, "August"),
Date(15, "August"),
Date(17, "August")
]
 
var filtered = dates.grep {
dates.grep {
dates.map{ .day }.count(.day) == 1
}.map{ .month }.count(.month) != 1
}
 
var birthday = filtered.grep {
filtered.map{ .day }.count(.day) == 1
}.group_by{ .month }.values.first_by { .len == 1 }[0]
 
say "Cheryl's birthday is #{birthday.month} #{birthday.day}."
Output:
Cheryl's birthday is July 16.

zkl[edit]

dates:=T(T("May",   15), T("May",   16), T("May",   19),
T("June", 17), T("June", 18),
T("July", 14), T("July", 16),
T("August",14), T("August",15), T("August",17) );
mDs:=dates.pump(Dictionary().appendKV); // "June":(15,16,19), ...
dMs:=dates.pump(Dictionary().appendKV,"reverse"); // 15:"May", 16:"May", 19:"May", ...
 
// remove unique days (18,19) --> "July":(14,16),"August":(14,15,17)
dMs.values.apply2('wrap(ms){ if(ms.len()==1) mDs.del(ms[0]) });
 
// find intersection of above days --> (14)
fcn intersection(l1,l2){ l1.pump(List,l2.holds,'==(True),Void.Filter) }
badDs:=mDs.values.reduce(intersection);
 
// --> July:(16),August:(15,17) --> ( ("July",(16)) )
theDay:=mDs.filter('wrap([(m,ds)]){ ds.removeEach(badDs).len()==1 });
 
// print birthday such that muliples are shown, if any
println("Cheryl's birthday is ",theDay.flatten().flatten().concat(" "));
Output:
Cheryl's birthday is July 16