# HG changeset patch # User Steve Losh # Date 1708446998 18000 # Node ID 322aefbbcb9f03b41ce4e4b446ef8256cace001c # Parent edf43f3bf670e66abe258f7ea53fc908c2ec15af Add `(reductions ... :result-type ...)` argument diff -r edf43f3bf670 -r 322aefbbcb9f DOCUMENTATION.markdown --- a/DOCUMENTATION.markdown Tue Feb 20 08:21:39 2024 -0500 +++ b/DOCUMENTATION.markdown Tue Feb 20 11:36:38 2024 -0500 @@ -2676,7 +2676,8 @@ ### `REDUCTIONS` (function) - (REDUCTIONS FUNCTION SEQUENCE &KEY KEY FROM-END START END (INITIAL-VALUE NIL IV?)) + (REDUCTIONS FUNCTION SEQUENCE &KEY KEY FROM-END START END (INITIAL-VALUE NIL IV?) + (RESULT-TYPE 'LIST)) Return a list of intermediate values of `reduce`ing `function` over `sequence`. @@ -2694,6 +2695,8 @@ provided) an empty list will be returned, instead of calling `function` with no arguments. + `result-type` must be a subtype of `list` or `vector`. + Examples: (reductions #'+ '(0 1 2 3)) diff -r edf43f3bf670 -r 322aefbbcb9f src/sequences.lisp --- a/src/sequences.lisp Tue Feb 20 08:21:39 2024 -0500 +++ b/src/sequences.lisp Tue Feb 20 11:36:38 2024 -0500 @@ -336,8 +336,66 @@ el))))) -(defun reductions (function sequence - &key key from-end start end (initial-value nil iv?)) +(defun reductions/list% (function sequence key from-end start end initial-value iv?) + (let ((result (list))) + (labels ((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% (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)))) + (push final result) + (nreverse result))))) + +(defun reductions/vector% (function sequence key from-end start end initial-value iv? result-type) + (let* ((end (or end (length sequence))) + (start (or start 0)) + (result (make-sequence result-type (+ (- end start) (if iv? 1 0)))) + (i -1)) + (labels ((collect (value) + (setf (aref result (incf i)) value)) + (f (&optional (a nil a?) b) + (when (not a?) + (return-from reductions/vector% result)) + (collect (if from-end b a)) + (funcall function a b))) + (let ((final (if iv? + (reduce #'f sequence + :key key + :from-end from-end + :start start + :end end + :initial-value initial-value) + (reduce #'f sequence + :key key + :from-end from-end + :start start + :end end)))) + (collect final) + result)))) + +(defun reductions (function sequence &key + key from-end start end + (initial-value nil iv?) + (result-type 'list)) "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 @@ -354,6 +412,8 @@ provided) an empty list will be returned, instead of calling `function` with no arguments. + `result-type` must be a subtype of `list` or `vector`. + Examples: (reductions #'+ '(0 1 2 3)) @@ -375,40 +435,11 @@ ; => (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))))))) - + (cond ((subtypep result-type 'vector) + (reductions/vector% function sequence key from-end start end initial-value iv? result-type)) + ((subtypep result-type 'list) + (reductions/list% function sequence key from-end start end initial-value iv?)) + (t (error "Bad result-type ~S: must be a subtype of list or vector." result-type)))) (defmacro doseq ((var sequence) &body body) "Perform `body` with `var` bound to each element in `sequence` in turn. diff -r edf43f3bf670 -r 322aefbbcb9f test/sequences.lisp --- a/test/sequences.lisp Tue Feb 20 08:21:39 2024 -0500 +++ b/test/sequences.lisp Tue Feb 20 11:36:38 2024 -0500 @@ -158,72 +158,96 @@ (* (1- n) (length (string sep)))) (length result)))))))) +(defun check-reductions (function expected input &rest args) + (is (equalp expected + (apply #'reductions function input :result-type 'list args))) + (is (equalp (coerce expected 'vector) + (apply #'reductions function input :result-type 'vector args))) + (is (equalp expected + (apply #'reductions function (coerce input 'vector) :result-type 'list args))) + (is (equalp (coerce expected 'vector) + (apply #'reductions function (coerce input 'vector) :result-type 'vector args)))) + (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)))) + (check-reductions #'+ '() '()) + (check-reductions #'+ '(1) '(1)) + (check-reductions #'+ '(1 3) '(1 2)) + (check-reductions #'+ '(1 3 6) '(1 2 3)) + (check-reductions #'+ '(100 101 103 106) '(1 2 3) + :initial-value 100) + (check-reductions #'cons + '(nil (-3) (-2 -3) (-1 -2 -3)) + '(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)))) + (check-reductions #'+ '(23) '() :initial-value 23) + (check-reductions #'+ '(23 123) '(100) :initial-value 23) + (check-reductions #'+ '(23 123 1123) '(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 #'-))) + (check-reductions #'+ + '(-1 -3 -6) + '(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)))) + (check-reductions #'+ + '(100 101 103 106) + '((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)))) + (check-reductions #'+ '(0 1 3 6 10 15) '(0 1 2 3 4 5) :start 0 :end nil) + (check-reductions #'+ '( 1 3 6 10 15) '(0 1 2 3 4 5) :start 1 :end nil) + (check-reductions #'+ '(0 1 3 6 10 ) '(0 1 2 3 4 5) :start 0 :end 5) + (check-reductions #'+ '( 2 5 9 ) '(0 1 2 3 4 5) :start 2 :end 5) + (check-reductions #'+ '( 2 ) '(0 1 2 3 4 5) :start 2 :end 3) + (check-reductions #'+ '( ) '(0 1 2 3 4 5) :start 2 :end 2) + (check-reductions #'+ '( ) '(0 1 2 3 4 5) :start 6 :end nil) + (check-reductions #'+ '( 2 5 9 ) (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))))) + (check-reductions #'cat + '("E" "DE" "CDE" "BCDE" "ABCDE") + '(a b c d e) + :from-end t + :key #'string) + (check-reductions #'cat + '("" "E" "DE" "CDE" "BCDE" "ABCDE") + '(a b c d e) + :from-end t + :key #'string :initial-value "") + (check-reductions #'cat + '("" "C" "BC") + '(a b c d e) + :from-end t + :key #'string :initial-value "" + :start 1 :end 3) + (check-reductions #'cat + '("C" "BC") + '(a b c d e) + :from-end t + :key #'string + :start 1 :end 3) + (check-reductions #'cat + '() + '(a b c d e) + :from-end t + :key #'string + :start 1 :end 1) + (check-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)))) + (check-reductions #'+ '(1 3 6) (vector 1 2 3)) + (check-reductions #'+ '(99 100) (vector 1 2 3) :start 0 :end 1 :initial-value 99) + (check-reductions #'+ '(99) (vector 1 2 3) :start 0 :end 0 :initial-value 99))