Re: tasters wanted

On 2024-08-15, B. Pym <Nobody447095@here-nor-there.org> wrote:

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

I don't feel that all your squirmy wiggling above is improving on:

1> (keep-if [chain len pred plusp]
            [partition-by identity '(2 4 4 0 5 5 5 5 8 8 8 6)])
((4 4) (5 5 5 5) (8 8 8))
2> (keep-if [chain len pred plusp]
            [partition-by identity '(4 4 0 5 5 5 5 8 8 8)])
((4 4) (5 5 5 5) (8 8 8))

that I already posted elsethread.

--
TXR Programming Language: http://nongnu.org/txr
Cygnal: Cygwin Native Application Library: http://kylheku.com/cygnal
Mastodon: @Kazinator@mstdn.ca