Cheryl's birthday: Difference between revisions

From Rosetta Code
Content added Content deleted
(→‎{{header|JavaScript}}: Generalised the first test a little (in terms of the uniquePairing function))
(Added Perl example)
Line 362: Line 362:
{{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";
}

if ($test eq 'singleton') { # eliminates May/Jun dates based on 18th and 19th being singletons
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}};
}

} elsif ($test eq 'duplicate') { # eliminates Jul/Aug 14th because day count > 1 across months
for my $day (grep { $D{$_}{cnt} == 1 } keys %D) {
push @filtered, @{$D{$day}{bday}};
}

} elsif ($test eq 'multiple') { # eliminates Aug 15th/17th because day count > 1, within month
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];
say my $result = "Cheryl's birthday is $months[$m] $d.";</lang>
{{out}}
<pre>Cheryl's birthday is July 16.</pre>


=={{header|Perl 6}}==
=={{header|Perl 6}}==

Revision as of 20:02, 23 October 2018

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.

See the Wikipedia article of the same name.

Related task



Common Lisp

<lang lisp> (defparameter *possible-dates* 

 '((15 . may) (16 . may) (19 . may)
   (17 . june) (18 . june)
   (14 . july) (16 . july)
   (14 . august) (15 . august) (17 . august)))

(defun count-items (list) 

 "returns a list of (item how-many-of-it)"
 (mapcar #'(lambda (item) (list item (count item list :test #'equal)))

(remove-duplicates list :test #'equal)))

(defun filter-dates (possible-dates &key (alist-look-at #'car) (alist-r-assoc #'assoc)) 

 (let ((unique-date-parts (remove-if-not #'(lambda (part) (= (cadr part) 1))

(count-items (mapcar alist-look-at possible-dates))))) 

   (mapcar #'(lambda (part) (funcall alist-r-assoc part possible-dates))
   	    (mapcar #'first unique-date-parts))))

(defun person (person possible-dates) 

 "Who's turn is it to think?"
 (case person
   ('albert (filter-dates possible-dates :alist-look-at #'cdr :alist-r-assoc #'rassoc))
   ('bernard (filter-dates possible-dates :alist-look-at #'car :alist-r-assoc #'assoc))))

(defun cheryls-birthday (possible-dates) 

 (person 'albert			;And this is the final search Albert does in stage 3) and finds the birthday

(person 'bernard ;This is the search Bernard does in stage 2) (set-difference possible-dates (person 'bernard possible-dates) ;This is the search Albert does at first on behalf of Bernard in stage 1) :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(fun (_,n)-> n) |> fN let i = n |> List.concat |> List.map(fun (n,_)->n) |> Set.ofList let _,g = dates |> List.filter(fun (n,_)->not (Set.contains n i)) |> List.groupBy(fun (_,n)-> n)|> fN let _,e = List.concat g |> List.groupBy(fun (n,_)->n) |> 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

JavaScript

<lang javascript>(() => { 

   'use strict';

   // main :: IO ()
   const main = () =>
       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(true)(fst)(

                   // among the days with unique months,

                   // (B's day is paired with only one remaining month)
                   // (2 :: B "I know now")
                   uniquePairing(true)(snd)(

                       // 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(true)(snd)(xs));
       return filter(
           md => (blnInclude ? id : not)(
               elem(fst(md), months)
           ),
           xs
       );
   };

   // uniquePairing :: Bool -> ((a, a) -> a) ->
   //      -> [(Month, Day)] -> [(Month, Day)]
   const uniquePairing = blnInc => f => xs =>
       bindPairs(xs,
           md => {
               const
                   dct = f(md),
                   matches = filter(
                       k => (blnInc ? id : not)(
                           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"]]

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";
   }

   if ($test eq 'singleton') {       # eliminates May/Jun dates based on 18th and 19th being singletons
       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}};
       }

   } elsif ($test eq 'duplicate') {  # eliminates Jul/Aug 14th because day count > 1 across months
       for my $day (grep { $D{$_}{cnt} == 1 } keys %D) {
           push @filtered, @{$D{$day}{bday}};
       }

   } elsif ($test eq 'multiple') {   # eliminates Aug 15th/17th because day count > 1, within month
       for my $day (grep { $M{$_}{cnt} == 1 } keys %M) {
           push @filtered, @{$M{$day}{bday}};
       }
   }
   return @filtered;

}

  1. 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]; say my $result = "Cheryl's birthday is $months[$m] $d.";</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 }
  1. Month can't have a unique day

my @filtered = @dates.grep(*.<month> != one(@dates.grep(*.<day> == one(@dates».<day>))».<month>));

  1. 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];
  1. convenience hash

my %months = < January February March April May June July 

     August September October November December>.kv.pairup;

say "Cheryl's birthday is { %months{$birthday<month>} } {$birthday<day>}.";</lang> 

Cheryl's birthday is July 16.

zkl

<lang zkl>var D=Time.Date, 

 bDays=T(T(D.May,   15), T(D.May,   16), T(D.May,   19),
         T(D.June,  17), T(D.June,  18),

T(D.July, 14), T(D.July, 16), T(D.August,14), T(D.August,15), T(D.August,17) ), 

 pDates=bDays.pump(Dictionary().appendKV);  // "5":(15,16,19), "6":(17,18) ...

dayCnt:=bDays.pump(Dictionary().incV,T("get",1)); // 15:2, 14:2, 19:1, 18:1 .. udays :=dayCnt.keys.filter('wrap(d){ dayCnt[d]==1 }).apply("toInt"); # (19,18) days  :=pDates.keys.apply2('wrap(m) // remove months that have a unique day 

  { if(interset(pDates[m],udays)) pDates.del(m) }); // 7:(14,16), 8:(14,15,17)

days  :=pDates.values.reduce(intersection); // (16), len>1 --> ambiguous result mons  :=pDates.filter(fcn([(m,ds)],d,ms){ // find months that hold day 

       ms.holds(m) and ds.holds(d) }.fp1(days[0],pDates.keys)); # ((7,(14,16)))

if(days.len()>1 or mons.len()>1) throw(Exception.BadDay); // can't reduce

println("Cheryl's birthday is ",D.monthNames[mons[0][0]]," ",days[0]);

fcn interset(l1,l2){ foreach i in (l1){ if(l2.holds(i)) return(True) } False } fcn intersection(l1,l2){ l1.pump(List,l2.holds,'==(False),Void.Filter) }</lang>

Output:
Cheryl's birthday is July 16
Retrieved from "https://rosettacode.org/wiki/Cheryl%27s_birthday?oldid=285980"