Re: Rosetta birthday problem

B. Pym wrote:

http://rosettacode.org/wiki/Cheryl%27s_birthday
 

Cheryl's birthday
 
Albert and Bernard just became friends with Cheryl, and they
want to know when her birthday is.
 
Cheryl gave them a list of ten 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 the   month   of birth,   and Bernard
the   day   (of the month)   of birth.
 
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 didn't know when Cheryl's birthday is,
but I know now.
 
3)  Albert:   Then I also know when Cheryl's birthday is.

 
 
Gauche Scheme
 
(use gauche.generator)
(use gauche.collection)
 
(define (remove-from xs key pred  group?)
  (let* ((keys (map key xs))
         (bad
           (filter
             (lambda (k)
               (let ((cnt (count (lambda(x) (equal? x k)) keys)))
                 (pred cnt)))
             keys)))
    (append-map
      (lambda(g)
        (if (any (lambda(x) (member (key x) bad)) g) '() g))
      (if group?
        (group-collection xs :key car :test equal?)
        (map list xs)))))
 
(define (foo)
  (define dates
    (slices
      (with-input-from-string
        "May 15     May 16     May 19
        June 17    June 18
        July 14    July 16
        August 14  August 15  August 17"
        (cut  generator->list read))
      2))
  (set! dates (remove-from dates cadr (^c (= c 1)) #t))
  (print dates)
  (set! dates (remove-from dates cadr (^c (> c 1)) #f))
  (print dates)
  (set! dates (remove-from dates car (^c (> c 1)) #t))
  dates)
 
  ===>
((July 14) (July 16) (August 14) (August 15) (August 17))
((July 16) (August 15) (August 17))
((July 16))

newLISP

(define (get-month xs) (first xs))
(define (get-day xs) (nth 1 xs))
(define single? (curry = 1))
(define multiple? (curry < 1))
(define (count1 x xs) (first (count (list x) xs)))

(define (remove-from xs key pred  delete-whole-month?)
  (letn (keys (map key xs)
         bad-keys '()
         bad-months '())
    (dolist (birthday xs)
      (when (pred (count1 (key birthday) keys))
        (push (get-month birthday) bad-months)
        (push (key birthday) bad-keys)))
    (if delete-whole-month?
      (clean
        (fn (birthday) (member (get-month birthday) bad-months))
        xs)
      (clean
        (fn (birthday) (member (key birthday) bad-keys))
        xs))))

(define (foo)
  (let (dates (explode (parse
                  "May 15     May 16     May 19
                  June 17    June 18
                  July 14    July 16
                  August 14  August 15  August 17")
                2))
    (setq dates (remove-from dates get-day single? true))
    (println dates)
    (setq dates (remove-from dates get-day multiple? nil))
    (println dates)
    (setq dates (remove-from dates get-month multiple? true))))

(foo)

(("July" "14") ("July" "16") ("August" "14") ("August" "15")
 ("August" "17"))
(("July" "16") ("August" "15") ("August" "17"))
(("July" "16"))