Path: ...!news.nobody.at!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
Subject: Re: tasters wanted
Date: Thu, 15 Aug 2024 18:41:04 -0000 (UTC)
Organization: A noiseless patient Spider
Lines: 78
Message-ID: <v9li3s$1285c$1@dont-email.me>
References: <v7bkuk$2hcim$1@dont-email.me> <v7c38d$2jti1$1@dont-email.me> <v9jovo$q7cm$1@dont-email.me> <v9k670$ru4a$1@dont-email.me>
MIME-Version: 1.0
Content-Type: text/plain; charset=iso-8859-1
Injection-Date: Thu, 15 Aug 2024 20:41:04 +0200 (CEST)
Injection-Info: dont-email.me; posting-host="8dad861bfe843a3d57c9af5848302e29";
	logging-data="1122476"; mail-complaints-to="abuse@eternal-september.org";	posting-account="U2FsdGVkX1/ZQbquj+O5F0zy7y/cnhod"
User-Agent: XanaNews/1.18.1.6
Cancel-Lock: sha1:pkLJByVNmNBL+rTW7maVvClmlj8=
Bytes: 3159

B. Pym wrote:

> B. Pym wrote:
> 
> > B. Pym wrote:
> > 
> > > B. Pym wrote:
> > > 
> > > > Ken Tilton wrote:
> > > > 
> > > > > Ooh! Ooh! Lemme try again!
> > > > > 
> > > > > (defun collect-repeats-simple (sorted-list &key (test 'eql))
> > > > >    (loop with acc and tail
> > > > >        for a in sorted-list
> > > > >        for b in (cdr sorted-list)
> > > > > 
> > > > >        if (funcall test a b)
> > > > >        if acc do (setf tail (rplacd tail (list b)))
> > > > >        else do (setf acc (list* a (setf tail (list b))))
> > > > >        else when acc collect acc into result
> > > > >        and do (setf acc nil)
> > > > > 
> > > > >        finally (return (nconc result
> > > > >                          (when acc (list acc))))))
> > > > > 
> > > > > God I love rplaca/d!
> > > 
> > > 
> > > His definition is buggy.
> > > 
> > > (collect-repeats-simple '(4 5 5 5 5 5 5 5 8 8))
> > >   ===>
> > > ((5 5 5) (8 8))
> > 
> > newLISP
> > 
> > (define (collect-repeats sorted)
> >   (let (accum '()  tmp '()  a 0)
> >     (until (empty? (rest sorted))
> >       (setq a (pop sorted))
> >       (when (= a (sorted 0))
> >         (setq tmp (list a))
> >         (while (and sorted (= a (first sorted)))
> >           (push (pop sorted) tmp))
> >         (push tmp accum)))
> >     (reverse accum)))
> > 
> > > (collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))
> > ((4 4) (5 5 5 5) (8 8 8))
> > > (collect-repeats '( 4 4 0 5 5 5 5 8 8 8 ))
> > ((4 4) (5 5 5 5) (8 8 8))
> >  
> 
> Shorter:
> 
> (define (collect-repeats sorted)
>   (let (accum '()  tmp '()  a)
>     (until (empty? sorted)
>       (setq a (sorted 0))
>       (setq tmp
>         (collect
>           (and (true? sorted) (= a (sorted 0)) (pop sorted))))
>       (when (> (length tmp) 1) (push tmp accum)))
>     (reverse accum)))

Gauche Scheme

(use srfi-1) ;; span

(define (collect-repeats sorted)
  (let1 accum '()
    (while (pair? sorted)
      (receive (taken rejected)
               (span (cut  equal? <> (car sorted)) sorted)
        (and (pair? (cdr taken)) (push! accum taken))
        (set! sorted rejected)))
    (reverse accum)))