Cheryl's birthday: Difference between revisions
Thundergnat (talk | contribs) m (alphabetize) |
|||
Line 1,199: | Line 1,199: | ||
Cheryl's birthday is July 16 |
Cheryl's birthday is July 16 |
||
</pre> |
</pre> |
||
=={{header|Perl}}== |
|||
<lang perl>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";</lang> |
|||
{{out}} |
|||
<pre>Cheryl's birthday is July 16.</pre> |
|||
=={{header|Perl 6}}== |
|||
<lang perl6>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>}.";</lang> |
|||
{{out}} |
|||
<pre>Cheryl's birthday is July 16.</pre> |
|||
=={{header|Phix}}== |
=={{header|Phix}}== |
||
Line 1,302: | Line 1,375: | ||
# bindPairs |
# bindPairs :: [(Month, Day)] -> ((Dict String [String], Dict String [String]) |
||
# -> [(Month, Day)]) -> [(Month, Day)] |
# -> [(Month, Day)]) -> [(Month, Day)] |
||
def bindPairs(xs: List[Tuple[str, str]]) -> Callable: |
def bindPairs(xs: List[Tuple[str, str]]) -> Callable: |
||
Line 1,345: | Line 1,418: | ||
{{Out}} |
{{Out}} |
||
<pre>[('July', '16')]</pre> |
<pre>[('July', '16')]</pre> |
||
=={{header|Perl}}== |
|||
<lang perl>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";</lang> |
|||
{{out}} |
|||
<pre>Cheryl's birthday is July 16.</pre> |
|||
=={{header|Perl 6}}== |
|||
<lang perl6>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>}.";</lang> |
|||
{{out}} |
|||
<pre>Cheryl's birthday is July 16.</pre> |
|||
=={{header|Sidef}}== |
=={{header|Sidef}}== |
Revision as of 15:42, 1 January 2019
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
- Wikipedia article of the same name.
- Tuple Relational Calculus
- Related task
AppleScript
<lang applescript>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|</lang>
- Output:
"[('july', '16')]"
Common Lisp
<lang lisp>
- 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)) </lang>
F#
<lang fsharp> //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 </lang>
- Output:
[[(July, 16)]]
Go
<lang go>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!") }
}</lang>
- Output:
Cheryl's birthday is July 16
Haskell
<lang haskell>{-# 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)</lang>
- Output:
[("July","16")]
J
Solution: <lang j>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=: (] -.@e. monthsWithUniqueDay)/@getDayMonth NB. mask of dates with a month that doesn't have a unique day
uniqueDayInMonth=: ~.@[ #~ (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=: ~.@] #~ (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</lang> Usage: <lang j> isUniqueMonth keep isUniqueDayInMonth keep isMonthWithoutUniqueDay keep Dates +-------+ |16 July| +-------+</lang>
Alternative Approach
The concepts here are the same, of course, it's just the presentation that's different.
<lang J>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</lang>
This gives us the July 16 result we were expecting
JavaScript
<lang javascript>(() => {
'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();
})();</lang>
- Output:
[["July","16"]]
Kotlin
<lang scala>// 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!")
}</lang>
- Output:
Cheryl's birthday is July 16
Perl
<lang perl>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";</lang>
- Output:
Cheryl's birthday is July 16.
Perl 6
<lang perl6>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>}.";</lang>
- Output:
Cheryl's birthday is July 16.
Phix
<lang Phix>sequence choices = {{5, 15}, {5, 16}, {5, 19}, {6, 17}, {6, 18},
{7, 14}, {7, 16}, {8, 14}, {8, 15}, {8, 17}}
sequence mwud = repeat(false,12) -- months with unique days
for step=1 to 4 do
sequence {months,days} = columnize(choices) bool impossible = false for i=length(choices) to 1 by -1 do integer {m,d} = choices[i] switch step do case 1: if not mwud[m] then -- (logical or) mwud[m] = (sum(sq_eq(days,d))=1) end if case 2: impossible = mwud[m] case 3: impossible = (sum(sq_eq(days,d))!=1) case 4: impossible = (sum(sq_eq(months,m))!=1) end switch if impossible then choices[i..i] = {} end if end for
end for
?choices</lang>
Strictly speaking we only need to columnize(choices) on steps 1 and 3.
Iterating backwards down the choices array simplifies element removal.
The first case needs to consolidate the flags before removing items.
Case 3 is days with unique months, case 4 is unique months.
- Output:
{{7,16}}
Python
Functional
<lang python>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()</lang>
- Output:
[('July', '16')]
Sidef
<lang ruby>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}."</lang>
- Output:
Cheryl's birthday is July 16.
zkl
<lang zkl>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(" "));</lang>
- Output:
Cheryl's birthday is July 16