Skip to content

Commit

Permalink
Give runs a compare-last parameter
Browse files Browse the repository at this point in the history
  • Loading branch information
@ruricolist
ruricolist committed Oct 16, 2023
1 parent 82bb486 commit bd549f1
Show file tree
Hide file tree
Showing 2 changed files with 78 additions and 48 deletions.
117 changes: 69 additions & 48 deletions sequences.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -625,59 +625,73 @@ instead. However TEST must be acceptable as the `:test' argument to
(bucket-seq seq (agroup-bucket group)))
(qlist groups))))))))

(defun list-runs (list start end key test count)
(defun list-runs (list start end key test count compare-last)
(declare ((and fixnum unsigned-byte) count))
(when (zerop count)
(return-from list-runs nil))
(fbind ((test (key-test key test)))
(declare (dynamic-extent #'test))
;; This is a little more complicated than you might expect,
;; because we need to keep hold of the first element of each list.
(let ((runs
(nlet rec ((runs nil)
(count count)
(list
(nthcdr start
(if end
(ldiff list (nthcdr (- end start) list))
list))))
(if (endp list) runs
(let ((y (car list)))
(if (null runs)
(rec (list (list y))
count
(cdr list))
(let ((x (caar runs)))
(if (test x y)
(rec (cons (list* x y (cdar runs))
(cdr runs))
count
(rest list))
(if (zerop (1- count))
runs
(rec (list* (list y)
(cons (caar runs)
(nreverse (cdar runs)))
(cdr runs))
(1- count)
(rest list)))))))))))
(nreverse (cons (cons (caar runs)
(nreverse (cdar runs)))
(cdr runs))))))

(defun runs (seq &key (start 0) end (key #'identity) (test #'eql)
(with-boolean (compare-last)
;; This is a little more complicated than you might expect,
;; because we need to keep hold of the first element of each list.
(let ((runs
(nlet rec ((runs nil)
(count count)
(list
(nthcdr start
(if end
(ldiff list (nthcdr (- end start) list))
list))))
(if (endp list) runs
(let ((y (car list)))
(if (null runs)
(rec (list (list y))
count
(cdr list))
(let ((x (caar runs)))
(if (test x y)
(rec (cons (if compare-last
(cons y (car runs))
(list* x y (cdar runs)))
(cdr runs))
count
(rest list))
(if (zerop (1- count))
runs
(rec (list* (list y)
(if compare-last
(nreverse (car runs))
(cons (caar runs)
(nreverse (cdar runs))))
(cdr runs))
(1- count)
(rest list)))))))))))
(nreverse
(if compare-last
(cons (nreverse (car runs)) (cdr runs))
(cons (cons (caar runs)
(nreverse (cdar runs)))
(cdr runs))))))))

(defun runs (seq &key (start 0) end (key #'identity) (test #'eql) compare-last
(count most-positive-fixnum))
"Return a list of runs of similar elements in SEQ.
The arguments START, END, and KEY are as for `reduce'.
(runs '(head tail head head tail))
=> '((head) (tail) (head head) (tail))
The function TEST is called with the first element of the run as its
first argument.
By defualt, the function TEST is called with the first element of the
run as its first argument.
(runs '(1 2 3 1 2 3) :test #'<)
=> ((1 2 3) (1 2 3))
(runs #(10 1 5 10 1) :test #'>)
=> (#(10 1 5) #(10))
COMPARE-LAST changes this behavior to test against the previous
element of the run:
(runs #(10 1 5 10 1) :test #'> :compare-last t)
(#(10 1) #(5) #(10))
The COUNT argument limits how many runs are returned.
Expand All @@ -688,23 +702,30 @@ The COUNT argument limits how many runs are returned.
(cond ((zerop count) (list))
((emptyp seq) (list seq))
(t (seq-dispatch seq
(list-runs seq start end key test count)
(list-runs seq start end key test count compare-last)
(fbind ((test (key-test key test)))
(declare (dynamic-extent #'test))
(collecting*
(nlet runs ((start start)
(count count))
(when (plusp count)
(let* ((elt (elt seq start))
(pos (position-if-not (partial #'test elt)
seq
:start (1+ start)
:end end)))
(if (null pos)
(run-end-pos
(position-if-not
(if compare-last
(lambda (x)
(when (test elt x)
(setf elt x)
t))
(partial #'test elt))
seq
:start (1+ start)
:end end)))
(if (null run-end-pos)
(collect (subseq seq start end))
(progn
(collect (subseq seq start pos))
(runs pos (1- count)))))))))))))
(collect (subseq seq start run-end-pos))
(runs run-end-pos (1- count)))))))))))))

(defun batches (seq n &key (start 0) end even)
"Return SEQ in batches of N elements.
Expand Down
9 changes: 9 additions & 0 deletions tests/sequences.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -122,6 +122,15 @@
(is (>= j (length (runs ns :test #'< :count j))))
(is (>= j (length (runs ns-list :test #'< :count j)))))))

(test runs-compare-last
(is (equal '(()) (runs '() :compare-last t)))
(is (equalp '((1)) (runs '(1) :compare-last t)))
(is (equalp '(#()) (runs #() :compare-last t)))
(is (equalp '(#(1)) (runs #(1) :compare-last t)))
(is (seq= (runs #(10 2 3 2 1) :test #'> :compare-last t)
(runs '(10 2 3 2 1) :test #'> :compare-last t)
'((10 2) (3 2 1)))))

(test batches
(is (equal '((a b) (c d) (e)) (batches '(a b c d e) 2)))
(is (equal '("ab" "cd" "e") (batches "abcde" 2)))
Expand Down

0 comments on commit bd549f1

Please sign in to comment.