Add `(reductions ... :result-type ...)` argument
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 20 Feb 2024 11:36:38 -0500 |
| parents |
edf43f3bf670
|
| children |
(none) |
| branches/tags |
default tip |
| files |
DOCUMENTATION.markdown src/sequences.lisp test/sequences.lisp |
Changes
--- 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))