From f17a7480b972e192a21c67965ce5597cb3d4379d Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Mon, 19 Dec 2022 09:39:37 +0900 Subject: [PATCH 1/2] srfi-171: Add twindow and various reducers This adds a number of reduction primitives often seen in other languages to Guile's SRFI-171 extensions. Most critical may be `rfold`, which could be called the fundamental reducer, as it's likely that all other reducers could be defined in terms of it (though not all are). While `tfold` already exists in Guile's SRFI-171 extension as a transducer, folding is in essence a reduction. Also without a primative like `rlast` (also introduced here), the results of `tfold` are difficult to consume. This is avoided by providing `rfold` directly as a generalised means to collapse an entire transduction down into a single value (i.e. the whole point of reducers). `rfold` is also useful for the creation of ad-hoc reducers, as any 2-arg function can be passed to it to fold the stream of values. `rfirst`, `rlast`, and `rfind` are common idioms and so have been added. The equivalent of `rmax` and `rmin` are easy to write manually via `rfold`, but they have been provided here as a convenience in the same spirit as `rcons`. `rfor-each` also cannot be forgotten as a classic adaptation of its SRFI-1 cousin. Also added is `twindow`, handy for analysing groups of adjacent items. * module/srfi/srfi-171.scm: Add new functions. * test-suite/tests/srfi-171.test: Add tests for new functions. * doc/ref/srfi-modules.texi: Document new functions. --- doc/ref/srfi-modules.texi | 96 ++++++++++++++++++++++++++++++++-- module/srfi/srfi-171/gnu.scm | 87 +++++++++++++++++++++++++++++- test-suite/tests/srfi-171.test | 66 ++++++++++++++++++++--- 3 files changed, 236 insertions(+), 13 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index bce5b4eac..6eb1a563e 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -5836,7 +5836,7 @@ identity in the reduction. @cindex transducers reducers @deffn {Scheme Procedure} rcons -a simple consing reducer. When called without values, it returns its +A simple consing reducer. When called without values, it returns its identity, @code{'()}. With one value, which will be a list, it reverses the list (using @code{reverse!}). When called with two values, it conses the second value to the first. @@ -5848,7 +5848,7 @@ the second value to the first. @end deffn @deffn {Scheme Procedure} reverse-rcons -same as rcons, but leaves the values in their reversed order. +The same as @code{rcons}, but leaves the values in their reversed order. @example (list-transduce (tmap (lambda (x) (+ x 1))) reverse-rcons (list 0 1 2 3)) @result{} (4 3 2 1) @@ -5856,7 +5856,7 @@ same as rcons, but leaves the values in their reversed order. @end deffn @deffn {Scheme Procedure} rany pred? -The reducer version of any. Returns @code{(reduced (pred? value))} if +The reducer version of @code{any}. Returns @code{(reduced (pred? value))} if any @code{(pred? value)} returns non-#f. The identity is #f. @example @@ -5869,7 +5869,7 @@ any @code{(pred? value)} returns non-#f. The identity is #f. @end deffn @deffn {Scheme Procedure} revery pred? -The reducer version of every. Stops the transduction and returns +The reducer version of @code{every}. Stops the transduction and returns @code{(reduced #f)} if any @code{(pred? value)} returns #f. If every @code{(pred? value)} returns true, it returns the result of the last invocation of @code{(pred? value)}. The identity is #t. @@ -5894,6 +5894,77 @@ transduction. @end example @end deffn +@subheading Guile-specific reducers +These reducers are available in the @code{(srfi srfi-171 gnu)} module, +and are provided outside the standard described by the SRFI-171 +document. + +@deffn {Scheme Procedure} rfold proc seed +The fundamental reducer. @code{rfold} creates an ad-hoc reducer based on +a given 2-argument @var{proc}. A @var{seed} is required as the initial +accumulator value, which also becomes the final return value in the case +where there was no input left in the transduction. + +The first argument to the @var{proc} is the accumulating value, and the +second is the current item of the transduction. + +Note that functions like @code{+} and @code{*} are automatically valid +reducers, because they yield sane values even when given 0 or 1 +arguments. Other functions like @code{max} cannot be used as-is as +reducers since they require at least 2 arguments. For functions like +this, @code{rfold} is appropriate. + +@example +;; Turning built-ins into reducers. Identical to rmax. +(list-transduce (tfilter odd?) (rfold max 0) '(1 2 3 4 5)) +@result{} 5 + +;; Custom lambdas into reducers. Identical to rlast. +(list-transduce (tmap identity) + (rfold (lambda (_ input) input) #f) + '("abc" "def" "ghi")) +@result{} "ghi" + +;; Track the 3 largest values in a transduction. +(define (three-largest acc input) + (take (sort (cons input acc) >) 3)) + +(list-transduce (tfilter odd?) + (rfold three-largest '(0 0 0)) + '(7 1 4 2 13 5 9 2 8)) +@result{} (13 9 7) +@end example +@end deffn + +@deffn {Scheme Procedure} rfind pred? +Find the first element in the transduction that satisfies a given +predicate. Yields #f if no such element was found. + +@example +(list-transduce (tmap identity) + (rfind string?) + '(1 c #t 4.12 "Jack" ())) +@result{} "Jack" +@end example +@end deffn + +@deffn {Scheme Procedure} rfirst seed +@deffnx {Scheme Procedure} rlast seed +Yield the first (or last) value of the transduction, or the @var{seed} +value if there is none. +@end deffn + +@deffn {Scheme Procedure} rfor-each proc +Apply @var{proc} for its side-effects to every value of the +transduction, ignoring all results. Like its @ref{SRFI-1} cousin, yields +@code{*unspecified*}. +@end deffn + +@deffn {Scheme Procedure} rmax seed +@deffnx {Scheme Procedure} rmin seed +Yield the maximum (or minimum) value of the transduction, or the +@var{seed} value if there is none. +@end deffn @node SRFI-171 Transducers @subsubsection Transducers @@ -6057,7 +6128,7 @@ Stateless. @subheading Guile-specific transducers These transducers are available in the @code{(srfi srfi-171 gnu)} -library, and are provided outside the standard described by the SRFI-171 +module, and are provided outside the standard described by the SRFI-171 document. @deffn {Scheme Procedure} tbatch reducer @@ -6085,6 +6156,21 @@ value)}, saving it's result between iterations. @end example @end deffn +@deffn {Scheme Procedure} twindow n + +Returns a transducer that yields @var{n}-length windows of overlapping +values. This is different from @code{tsegment} which yields +non-overlapping windows. If there were fewer items in the input than +@var{n}, then this yields nothing. + +@example +(list-transduce (twindow 3) rcons '(1 2 3 4 5)) +@result{} ((1 2 3) (2 3 4) (3 4 5)) +@end example + +Stateful. +@end deffn + @node SRFI-171 Helpers @subsubsection Helper functions for writing transducers diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm index 45a4e19af..c41925e8a 100644 --- a/module/srfi/srfi-171/gnu.scm +++ b/module/srfi/srfi-171/gnu.scm @@ -15,10 +15,17 @@ ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (srfi srfi-171 gnu) + #:use-module (ice-9 q) #:use-module (srfi srfi-171) #:use-module (srfi srfi-171 meta) - #:export (tbatch tfold)) - + #:export (tbatch + tfold + twindow + rfind + rfirst rlast + rfold + rfor-each + rmax rmin)) (define tbatch (case-lambda @@ -63,3 +70,79 @@ (if (reduced? state) (reduced (reducer (unreduce state))) (r result state))))))) + +(define (twindow n) + "Yield @var{n}-length windows of overlapping values. This is different from +@code{tsegment} which yields non-overlapping windows. If there were +fewer items in the input than @var{n}, then this yields nothing." + (when (not (and (integer? n) (positive? n))) + (error "argument to twindow must be a positive integer")) + (lambda (reducer) + (let ((i 0) + (q (make-q))) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (enq! q input) + (set! i (1+ i)) + (cond ((< i n) result) + ((= i n) (reducer result (list-copy (car q)))) + (else (deq! q) + (reducer result (list-copy (car q)))))))))) + +(define rfor-each + (case-lambda + "Run through every item in a transduction for their side effects but throw away +all results." + (() *unspecified*) + ((acc) *unspecified*) + ((acc input) *unspecified*))) + +(define (rfirst seed) + "Yield the first value of the transduction, or the @var{seed} value if there is none." + (case-lambda + (() seed) + ((acc) acc) + ((_ input) (reduced input)))) + +(define (rlast seed) + "Yield the final value of the transduction, or the @var{seed} value if there is none." + (case-lambda + (() seed) + ((acc) acc) + ((_ input) input))) + +(define (rfold f seed) + "The fundamental reducer. @code{rfold} creates an ad-hoc reducer based on +a given 2-argument function. A @var{seed} is also required as the +initial accumulator value, which also becomes the return value in case +there was no input left in the transduction. + +Functions like @code{+} and @code{*} are automatically valid reducers, +because they yield sane values even when given 0 or 1 arguments. Other +functions like @code{max} cannot be used as-is as reducers since they +require at least 2 arguments. For functions like this, @code{rfold} is +appropriate." + (case-lambda + (() seed) + ((acc) acc) + ((acc input) (f acc input)))) + +(define (rmax seed) + "Yield the maximum value of the transduction, or the @var{seed} value if +there is none." + (rfold max seed)) + +(define (rmin seed) + "Yield the minimum value of the transduction, or the @var{seed} value if +there is none." + (rfold min seed)) + +(define (rfind pred?) + "Find the first element in the transduction that satisfies a given predicate. +Yields #f if no such element was found." + (case-lambda + (() #f) + ((acc) acc) + ((acc input) (if (pred? input) (reduced input) #f)))) diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test index 1ef7bc5f2..d1d54b2ec 100644 --- a/test-suite/tests/srfi-171.test +++ b/test-suite/tests/srfi-171.test @@ -207,15 +207,69 @@ (list-transduce (tenumerate (- 1)) rcons numeric-list))) (pass-if "tbatch" - (equal? - '((0 1) (2 3) (4)) + (equal? '((0 1) (2 3) (4)) (list-transduce (tbatch (ttake 2) rcons) rcons numeric-list))) (pass-if "tfold" - (equal? - '(0 1 3 6 10) - (list-transduce (tfold +) rcons numeric-list)))) - + (equal? '(0 1 3 6 10) + (list-transduce (tfold +) rcons numeric-list))) + + (pass-if "twindow: too wide of a window" + (equal? '() + (list-transduce (twindow 10) rcons '(1 2 3)))) + + (pass-if "twindow: acceptable window" + (equal? '((1 2 3) (2 3 4) (3 4 5)) + (list-transduce (twindow 3) rcons '(1 2 3 4 5))))) + +(with-test-prefix "reducers" + (pass-if "rfold: builtin" + (equal? 5 + (list-transduce (tfilter odd?) (rfold max 0) '(1 2 3 4 5)))) + + (pass-if "rfold: custom lambda" + (equal? "ghi" + (list-transduce (tmap identity) + (rfold (lambda (_ input) input) #f) + '("abc" "def" "ghi")))) + + (pass-if "rfirst: empty" + (equal? 0 + (list-transduce (tmap identity) (rfirst 0) '()))) + + (pass-if "rfirst: non-empty" + (equal? 1 + (list-transduce (tmap identity) (rfirst 0) '(1 2 3)))) + + (pass-if "rlast: empty" + (equal? 0 + (list-transduce (tfilter (lambda (_) #f)) (rlast 0) '(1 2 3)))) + + (pass-if "rlast: non-empty" + (equal? 5 + (list-transduce (tmap identity) (rlast 0) '(1 2 3 4 5)))) + + (pass-if "rmax: empty" + (equal? 0 + (list-transduce (tmap identity) (rmax 0) '()))) + + (pass-if "rmax: non-empty" + (equal? 31 + (list-transduce (tmap identity) (rmax 0) '(1 2 31 4 5)))) + + (pass-if "rmin: empty" + (equal? 0 + (list-transduce (tmap identity) (rmin 0) '()))) + + (pass-if "rmin: non-empty" + (equal? 1 + (list-transduce (tmap identity) (rmin 1000) '(5 3 1 7 6)))) + + (pass-if "rfind" + (equal? "Jack" + (list-transduce (tmap identity) + (rfind string?) + '(1 c #t 4.12 "Jack" ()))))) (with-test-prefix "x-transduce" (pass-if "list-transduce" -- 2.39.0