--- a/DOCUMENTATION.markdown Sun Dec 03 17:34:41 2023 -0500
+++ b/DOCUMENTATION.markdown Tue Feb 20 08:21:39 2024 -0500
@@ -2674,6 +2674,48 @@
+### `REDUCTIONS` (function)
+
+ (REDUCTIONS FUNCTION SEQUENCE &KEY KEY FROM-END START END (INITIAL-VALUE NIL IV?))
+
+Return a list of intermediate values of `reduce`ing `function` over `sequence`.
+
+ If `initial-value` is provided it will be included as the first element in the
+ results.
+
+ If `from-end` is true the sequence will be walked in reverse order, but the
+ order of the *results* will still be in the order they were produced (with the
+ `initial-value` first, if one is provided).
+
+ Like `reduce`, `key` is only called on the elements of `sequence`, *not* on
+ `initial-value` if one is provided.
+
+ *Unlike* `reduce`, if the (sub)sequence is empty (and no `initial-value` is
+ provided) an empty list will be returned, instead of calling `function` with
+ no arguments.
+
+ Examples:
+
+ (reductions #'+ '(0 1 2 3))
+ ; => (0 1 3 6)
+
+ (reductions #'+ '(0 1 2 3) :from-end t)
+ ; => (3 5 6 6)
+
+ (reductions #'+ '(10 20 30) :initial-value 100)
+ ; => (100 110 120 130)
+
+ (reductions #'+ '((10) (20) (30)) :initial-value 100 :key #'car)
+ ; => (100 110 120 130)
+
+ (reductions #'+ '(10 20 30) :start 1 :end 1)
+ ; => ()
+
+ (reductions #'+ '(10 20 30) :start 1 :end 1 :initial-value 111)
+ ; => (111)
+
+
+
### `STRING-JOIN` (function)
(STRING-JOIN SEPARATOR SEQUENCE)
--- a/src/arrays.lisp Sun Dec 03 17:34:41 2023 -0500
+++ b/src/arrays.lisp Tue Feb 20 08:21:39 2024 -0500
@@ -209,3 +209,4 @@
(if (zerop length)
(values nil nil)
(values (aref vector (1- length)) t))))
+
--- a/src/package.lisp Sun Dec 03 17:34:41 2023 -0500
+++ b/src/package.lisp Tue Feb 20 08:21:39 2024 -0500
@@ -418,6 +418,7 @@
:product
:doseq
:string-join
+ :reductions
:define-sorting-predicate
:make-sorting-predicate))
--- a/src/sequences.lisp Sun Dec 03 17:34:41 2023 -0500
+++ b/src/sequences.lisp Tue Feb 20 08:21:39 2024 -0500
@@ -336,6 +336,80 @@
el)))))
+(defun reductions (function sequence
+ &key key from-end start end (initial-value nil iv?))
+ "Return a list of intermediate values of `reduce`ing `function` over `sequence`.
+
+ If `initial-value` is provided it will be included as the first element in the
+ results.
+
+ If `from-end` is true the sequence will be walked in reverse order, but the
+ order of the *results* will still be in the order they were produced (with the
+ `initial-value` first, if one is provided).
+
+ Like `reduce`, `key` is only called on the elements of `sequence`, *not* on
+ `initial-value` if one is provided.
+
+ *Unlike* `reduce`, if the (sub)sequence is empty (and no `initial-value` is
+ provided) an empty list will be returned, instead of calling `function` with
+ no arguments.
+
+ Examples:
+
+ (reductions #'+ '(0 1 2 3))
+ ; => (0 1 3 6)
+
+ (reductions #'+ '(0 1 2 3) :from-end t)
+ ; => (3 5 6 6)
+
+ (reductions #'+ '(10 20 30) :initial-value 100)
+ ; => (100 110 120 130)
+
+ (reductions #'+ '((10) (20) (30)) :initial-value 100 :key #'car)
+ ; => (100 110 120 130)
+
+ (reductions #'+ '(10 20 30) :start 1 :end 1)
+ ; => ()
+
+ (reductions #'+ '(10 20 30) :start 1 :end 1 :initial-value 111)
+ ; => (111)
+
+ "
+ (let ((result (list)))
+ (flet ((f (&optional (a nil a?) b)
+ ;; The only time the reducing function is called with zero
+ ;; arguments is if we have an empty (sub)seq. If that's the case
+ ;; we can just bail immediately.
+ (when (not a?)
+ (return-from reductions (list)))
+ ;; Otherwise push the current value (we'll handle the final one at
+ ;; the end) and return the next.
+ (push (if from-end b a) result)
+ (funcall function a b)))
+ (let ((final (if iv?
+ (reduce #'f sequence
+ :key key
+ :from-end from-end
+ :start (or start 0)
+ :end end
+ :initial-value initial-value)
+ ;; We have to specifically NOT pass :initial-value if it's
+ ;; omitted. We could apply (when …), but that's ugly.
+ (reduce #'f sequence
+ :key key
+ :from-end from-end
+ :start (or start 0)
+ :end end))))
+ (if (null result)
+ ;; If we made it here without ever pushing to result or bailing on an
+ ;; empty (sub)seq, then we must have either had a one-element seq with
+ ;; no IV, or an empty seq with an IV. Either way, return it.
+ (list final)
+ ;; Otherwise we built something, return it after tacking on the last
+ ;; value we didn't have a chance to record.
+ (nreverse (cons final result)))))))
+
+
(defmacro doseq ((var sequence) &body body)
"Perform `body` with `var` bound to each element in `sequence` in turn.
@@ -574,4 +648,3 @@
,(expand (cons predicate-spec more-predicate-specs))))))
-
--- a/test/sequences.lisp Sun Dec 03 17:34:41 2023 -0500
+++ b/test/sequences.lisp Tue Feb 20 08:21:39 2024 -0500
@@ -157,3 +157,73 @@
(is (= (+ (reduce #'+ ws :key #'length)
(* (1- n) (length (string sep))))
(length result))))))))
+
+(define-test reductions/basic
+ (is (equal '() (reductions #'+ '())))
+ (is (equal '(1) (reductions #'+ '(1))))
+ (is (equal '(1 3) (reductions #'+ '(1 2))))
+ (is (equal '(1 3 6) (reductions #'+ '(1 2 3))))
+ (is (equal '(100 101 103 106)
+ (reductions #'+ '(1 2 3) :initial-value 100)))
+ (is (equal '(nil (-3) (-2 -3) (-1 -2 -3))
+ (reductions #'cons '(1 2 3)
+ :initial-value nil
+ :key #'-
+ :from-end t))))
+
+(define-test reductions/initial-value
+ (is (equal '(23) (reductions #'+ '() :initial-value 23)))
+ (is (equal '(23 123) (reductions #'+ '(100) :initial-value 23)))
+ (is (equal '(23 123 1123) (reductions #'+ '(100 1000) :initial-value 23))))
+
+(define-test reductions/key
+ ;; Key should be called on the contents.
+ (is (equal '(-1 -3 -6)
+ (reductions #'+ '(1 2 3)
+ :key #'-)))
+ ;; Key should NOT be called on the initial value, if given.
+ (is (equal '(100 101 103 106)
+ (reductions #'+ '((1) (2) (3))
+ :initial-value 100
+ :key #'car))))
+
+(define-test reductions/start-end
+ (is (equal '(0 1 3 6 10 15) (reductions #'+ '(0 1 2 3 4 5) :start 0 :end nil)))
+ (is (equal '( 1 3 6 10 15) (reductions #'+ '(0 1 2 3 4 5) :start 1 :end nil)))
+ (is (equal '(0 1 3 6 10 ) (reductions #'+ '(0 1 2 3 4 5) :start 0 :end 5)))
+ (is (equal '( 2 5 9 ) (reductions #'+ '(0 1 2 3 4 5) :start 2 :end 5)))
+ (is (equal '( 2 ) (reductions #'+ '(0 1 2 3 4 5) :start 2 :end 3)))
+ (is (equal '( ) (reductions #'+ '(0 1 2 3 4 5) :start 2 :end 2)))
+ (is (equal '( ) (reductions #'+ '(0 1 2 3 4 5) :start 6 :end nil)))
+ (is (equal '( 2 5 9 ) (reductions #'+ (mapcar #'list '(0 1 2 3 4 5))
+ :start 2 :end 5 :key #'car))))
+
+(define-test reductions/from-end
+ (flet ((cat (a b) (concatenate 'string a b)))
+ (is (equalp '("E" "DE" "CDE" "BCDE" "ABCDE")
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string)))
+ (is (equalp '("" "E" "DE" "CDE" "BCDE" "ABCDE")
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string :initial-value "")))
+ (is (equalp '("" "C" "BC")
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string :initial-value ""
+ :start 1 :end 3)))
+ (is (equalp '("C" "BC")
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string
+ :start 1 :end 3)))
+ (is (equalp '()
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string
+ :start 1 :end 1)))
+ (is (equalp '("")
+ (reductions #'cat '(a b c d e) :from-end t
+ :key #'string :initial-value ""
+ :start 1 :end 1)))))
+
+(define-test reductions/non-list
+ (is (equal '(1 3 6) (reductions #'+ (vector 1 2 3))))
+ (is (equal '(99 100) (reductions #'+ (vector 1 2 3) :start 0 :end 1 :initial-value 99)))
+ (is (equal '(99) (reductions #'+ (vector 1 2 3) :start 0 :end 0 :initial-value 99))))