322aefbbcb9f

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

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

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