Path: ...!eternal-september.org!feeder3.eternal-september.org!news.eternal-september.org!.POSTED!not-for-mail
From: "B. Pym" <Nobody447095@here-nor-there.org>
Newsgroups: comp.lang.lisp,comp.lang.scheme
Subject: Re: Rosetta birthday problem
Date: Sun, 4 Aug 2024 21:37:34 -0000 (UTC)
Organization: A noiseless patient Spider
Lines: 115
Message-ID: <v8osao$8i81$1@dont-email.me>
References: <v814ag$30n60$1@dont-email.me>
MIME-Version: 1.0
Content-Type: text/plain; charset=iso-8859-1
Injection-Date: Sun, 04 Aug 2024 23:37:34 +0200 (CEST)
Injection-Info: dont-email.me; posting-host="e14708043080897b7486957644b6603d";
	logging-data="280833"; mail-complaints-to="abuse@eternal-september.org";	posting-account="U2FsdGVkX1+6BKWR4TcvMfSB8pLVeuVX"
User-Agent: XanaNews/1.18.1.6
Cancel-Lock: sha1:ANmOfOorcXdgjsf7zVcUJnpcnSU=
Bytes: 4243

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"))