# HG changeset patch # User Steve Losh # Date 1708435299 18000 # Node ID edf43f3bf670e66abe258f7ea53fc908c2ec15af # Parent 09232fd60df50e0be96ddc5b106fa5e3dc507057 Add `reductions` diff -r 09232fd60df5 -r edf43f3bf670 DOCUMENTATION.markdown --- 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) diff -r 09232fd60df5 -r edf43f3bf670 src/arrays.lisp --- 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)))) + diff -r 09232fd60df5 -r edf43f3bf670 src/package.lisp --- 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)) diff -r 09232fd60df5 -r edf43f3bf670 src/sequences.lisp --- 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)))))) - diff -r 09232fd60df5 -r edf43f3bf670 test/sequences.lisp --- 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))))