tasters wanted

[B. Pym]

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!

Testing:

(collect-repeats-simple '(2 2 3 4 5 5 7 8 8))
===>
((2 2) (5 5) (8 8))

Gauche Scheme

(use gauche.collection) ;; fold2

(define (monotonic the-list :key (test equal?))
(receive (tmp result)
(fold2
(^(x tmp result)
(if (or (null? tmp) (test x (car tmp)))
(values (cons x tmp) result)
(values (list x) (cons tmp result))))
'() '()
the-list)
(reverse (map reverse
(if (pair? tmp) (cons tmp result) result)))))

(monotonic '(0 2 3 4 0 5 7 9 6) :test >)
===>
((0 2 3 4) (0 5 7 9) (6))

(define (collect-repeats sorted-list :key (test equal?))
(remove (^x (null? (cdr x)))
(monotonic sorted-list :test test)))

(collect-repeats '(2 2 3 4 5 5 7 8 8))
===>
((2 2) (5 5) (8 8))

(collect-repeats '(2 2 3 4 5 5 7 8 8 9))
===>
((2 2) (5 5) (8 8))

[B. Pym]

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

[B. Pym]

Post by B. Pym

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

Post by B. Pym
(collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))

((4 4) (5 5 5 5) (8 8 8))

Post by B. Pym
(collect-repeats '( 4 4 0 5 5 5 5 8 8 8 ))

((4 4) (5 5 5 5) (8 8 8))

[B. Pym]

Post by B. Pym

Post by B. Pym

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

Post by B. Pym
(collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))

((4 4) (5 5 5 5) (8 8 8))

Post by B. Pym
(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)))

[B. Pym]

Post by B. Pym

Post by B. Pym

Post by B. Pym

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

Post by B. Pym
(collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))

((4 4) (5 5 5 5) (8 8 8))

Post by B. Pym
(collect-repeats '( 4 4 0 5 5 5 5 8 8 8 ))

((4 4) (5 5 5 5) (8 8 8))

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

[Kaz Kylheku]

Post by B. Pym

Post by B. Pym

Post by B. Pym

Post by B. Pym

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

Post by B. Pym
(collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))

((4 4) (5 5 5 5) (8 8 8))

Post by B. Pym
(collect-repeats '( 4 4 0 5 5 5 5 8 8 8 ))

((4 4) (5 5 5 5) (8 8 8))

(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.

[B. Pym]

Post by B. Pym

Post by B. Pym

Post by B. Pym

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

Post by B. Pym
(collect-repeats '(2 4 4 0 5 5 5 5 8 8 8 6))

((4 4) (5 5 5 5) (8 8 8))

Post by B. Pym
(collect-repeats '( 4 4 0 5 5 5 5 8 8 8 ))

((4 4) (5 5 5 5) (8 8 8))

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

Shorter:


(define (collect-repeats sorted)
(local (accum tmp a)
(while sorted
(setq a (sorted 0))
(setq tmp
(collect (and (true? sorted) (= a (sorted 0)) (pop sorted))))
(and (1 tmp) (push tmp accum)))
(reverse accum)))

[Jeff Barnett]

<SNIP SNIP>

Post by B. Pym

Post by B. Pym
(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)))

(define (collect-repeats sorted)
(local (accum tmp a)
(while sorted
(setq a (sorted 0))
(setq tmp
(collect (and (true? sorted) (= a (sorted 0)) (pop sorted))))
(and (1 tmp) (push tmp accum)))
(reverse accum)))

Shorter!!!!!!! Shorter because you moved the and clause embedded in the
collect clause into the same line as the collect operator. Good work.

I take from your recent barrage of similarly helpful postings that you
are once again between employers. It's probably good to keep in shape
doing all these coding exercises.

[Kaz Kylheku]

Post by B. Pym
Gauche Scheme
(use gauche.collection) ;; fold2
(define (monotonic the-list :key (test equal?))
(receive (tmp result)
(fold2
(^(x tmp result)
(if (or (null? tmp) (test x (car tmp)))
(values (cons x tmp) result)
(values (list x) (cons tmp result))))
'() '()
the-list)
(reverse (map reverse
(if (pair? tmp) (cons tmp result) result)))))
(monotonic '(0 2 3 4 0 5 7 9 6) :test >)
===>
((0 2 3 4) (0 5 7 9) (6))
(define (collect-repeats sorted-list :key (test equal?))
(remove (^x (null? (cdr x)))
(monotonic sorted-list :test test)))
(collect-repeats '(2 2 3 4 5 5 7 8 8))
===>
((2 2) (5 5) (8 8))
(collect-repeats '(2 2 3 4 5 5 7 8 8 9))
===>
((2 2) (5 5) (8 8))

This is the TXR Lisp interactive listener of TXR 294.
Quit with :quit or Ctrl-D on an empty line. Ctrl-X ? for cheatsheet.
If you get your macros hot enough, you get syntactic caramel!
1> [partition-by identity '(2 2 3 4 5 5 7 8 8 9)]
((2 2) (3) (4) (5 5) (7) (8 8) (9))
2> (remove-if (opip len (eq 1))
[partition-by identity '(2 2 3 4 5 5 7 8 8 9)])
((2 2) (5 5) (8 8))
3> (keep-if [chain len pred plusp]
[partition-by identity '(2 2 3 4 5 5 7 8 8 9)])
((2 2) (5 5) (8 8))