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!

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

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!

[partition-by identity '(2 2 3 4 5 5 7 8 8 9)]

((2 2) (3) (4) (5 5) (7) (8 8) (9))

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

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

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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:

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

(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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

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

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

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

On 8/17/2024 12:24 PM, B. Pym wrote:

B. Pym wrote:

<SNIP SNIP>

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

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.
--
Jeff Barnett

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)