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] srfi171: Add twindow and various reducers
This adds a number of reduction primitives often seen in other languages
to Guile's SRFI171 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 SRFI171 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 adhoc reducers,
as any 2arg 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`.
`rforeach` also cannot be forgotten as a classic adaptation of its
SRFI1 cousin.
Also added is `twindow`, handy for analysing groups of adjacent items.
* module/srfi/srfi171.scm: Add new functions.
* testsuite/tests/srfi171.test: Add tests for new functions.
* doc/ref/srfimodules.texi: Document new functions.

doc/ref/srfimodules.texi  96 ++++++++++++++++++++++++++++++++
module/srfi/srfi171/gnu.scm  87 +++++++++++++++++++++++++++++
testsuite/tests/srfi171.test  66 ++++++++++++++++++++
3 files changed, 236 insertions(+), 13 deletions()
diff git a/doc/ref/srfimodules.texi b/doc/ref/srfimodules.texi
index bce5b4eac..6eb1a563e 100644
 a/doc/ref/srfimodules.texi
+++ b/doc/ref/srfimodules.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} reversercons
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
(listtransduce (tmap (lambda (x) (+ x 1))) reversercons (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 Guilespecific reducers
+These reducers are available in the @code{(srfi srfi171 gnu)} module,
+and are provided outside the standard described by the SRFI171
+document.
+
+@deffn {Scheme Procedure} rfold proc seed
+The fundamental reducer. @code{rfold} creates an adhoc reducer based on
+a given 2argument @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 asis as
+reducers since they require at least 2 arguments. For functions like
+this, @code{rfold} is appropriate.
+
+@example
+;; Turning builtins into reducers. Identical to rmax.
+(listtransduce (tfilter odd?) (rfold max 0) '(1 2 3 4 5))
+@result{} 5
+
+;; Custom lambdas into reducers. Identical to rlast.
+(listtransduce (tmap identity)
+ (rfold (lambda (_ input) input) #f)
+ '("abc" "def" "ghi"))
+@result{} "ghi"
+
+;; Track the 3 largest values in a transduction.
+(define (threelargest acc input)
+ (take (sort (cons input acc) >) 3))
+
+(listtransduce (tfilter odd?)
+ (rfold threelargest '(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
+(listtransduce (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} rforeach proc
+Apply @var{proc} for its sideeffects to every value of the
+transduction, ignoring all results. Like its @ref{SRFI1} 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 SRFI171 Transducers
@subsubsection Transducers
@@ 6057,7 +6128,7 @@ Stateless.
@subheading Guilespecific transducers
These transducers are available in the @code{(srfi srfi171 gnu)}
library, and are provided outside the standard described by the SRFI171
+module, and are provided outside the standard described by the SRFI171
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
+nonoverlapping windows. If there were fewer items in the input than
+@var{n}, then this yields nothing.
+
+@example
+(listtransduce (twindow 3) rcons '(1 2 3 4 5))
+@result{} ((1 2 3) (2 3 4) (3 4 5))
+@end example
+
+Stateful.
+@end deffn
+
@node SRFI171 Helpers
@subsubsection Helper functions for writing transducers
diff git a/module/srfi/srfi171/gnu.scm b/module/srfi/srfi171/gnu.scm
index 45a4e19af..c41925e8a 100644
 a/module/srfi/srfi171/gnu.scm
+++ b/module/srfi/srfi171/gnu.scm
@@ 15,10 +15,17 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 021101301 USA
(definemodule (srfi srfi171 gnu)
+ #:usemodule (ice9 q)
#:usemodule (srfi srfi171)
#:usemodule (srfi srfi171 meta)
 #:export (tbatch tfold))

+ #:export (tbatch
+ tfold
+ twindow
+ rfind
+ rfirst rlast
+ rfold
+ rforeach
+ rmax rmin))
(define tbatch
(caselambda
@@ 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 nonoverlapping 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 (makeq)))
+ (caselambda
+ (() (reducer))
+ ((result) (reducer result))
+ ((result input)
+ (enq! q input)
+ (set! i (1+ i))
+ (cond ((< i n) result)
+ ((= i n) (reducer result (listcopy (car q))))
+ (else (deq! q)
+ (reducer result (listcopy (car q))))))))))
+
+(define rforeach
+ (caselambda
+ "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."
+ (caselambda
+ (() 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."
+ (caselambda
+ (() seed)
+ ((acc) acc)
+ ((_ input) input)))
+
+(define (rfold f seed)
+ "The fundamental reducer. @code{rfold} creates an adhoc reducer based on
+a given 2argument 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 asis as reducers since they
+require at least 2 arguments. For functions like this, @code{rfold} is
+appropriate."
+ (caselambda
+ (() 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."
+ (caselambda
+ (() #f)
+ ((acc) acc)
+ ((acc input) (if (pred? input) (reduced input) #f))))
diff git a/testsuite/tests/srfi171.test b/testsuite/tests/srfi171.test
index 1ef7bc5f2..d1d54b2ec 100644
 a/testsuite/tests/srfi171.test
+++ b/testsuite/tests/srfi171.test
@@ 207,15 +207,69 @@
(listtransduce (tenumerate ( 1)) rcons numericlist)))
(passif "tbatch"
 (equal?
 '((0 1) (2 3) (4))
+ (equal? '((0 1) (2 3) (4))
(listtransduce (tbatch (ttake 2) rcons) rcons numericlist)))
(passif "tfold"
 (equal?
 '(0 1 3 6 10)
 (listtransduce (tfold +) rcons numericlist))))

+ (equal? '(0 1 3 6 10)
+ (listtransduce (tfold +) rcons numericlist)))
+
+ (passif "twindow: too wide of a window"
+ (equal? '()
+ (listtransduce (twindow 10) rcons '(1 2 3))))
+
+ (passif "twindow: acceptable window"
+ (equal? '((1 2 3) (2 3 4) (3 4 5))
+ (listtransduce (twindow 3) rcons '(1 2 3 4 5)))))
+
+(withtestprefix "reducers"
+ (passif "rfold: builtin"
+ (equal? 5
+ (listtransduce (tfilter odd?) (rfold max 0) '(1 2 3 4 5))))
+
+ (passif "rfold: custom lambda"
+ (equal? "ghi"
+ (listtransduce (tmap identity)
+ (rfold (lambda (_ input) input) #f)
+ '("abc" "def" "ghi"))))
+
+ (passif "rfirst: empty"
+ (equal? 0
+ (listtransduce (tmap identity) (rfirst 0) '())))
+
+ (passif "rfirst: nonempty"
+ (equal? 1
+ (listtransduce (tmap identity) (rfirst 0) '(1 2 3))))
+
+ (passif "rlast: empty"
+ (equal? 0
+ (listtransduce (tfilter (lambda (_) #f)) (rlast 0) '(1 2 3))))
+
+ (passif "rlast: nonempty"
+ (equal? 5
+ (listtransduce (tmap identity) (rlast 0) '(1 2 3 4 5))))
+
+ (passif "rmax: empty"
+ (equal? 0
+ (listtransduce (tmap identity) (rmax 0) '())))
+
+ (passif "rmax: nonempty"
+ (equal? 31
+ (listtransduce (tmap identity) (rmax 0) '(1 2 31 4 5))))
+
+ (passif "rmin: empty"
+ (equal? 0
+ (listtransduce (tmap identity) (rmin 0) '())))
+
+ (passif "rmin: nonempty"
+ (equal? 1
+ (listtransduce (tmap identity) (rmin 1000) '(5 3 1 7 6))))
+
+ (passif "rfind"
+ (equal? "Jack"
+ (listtransduce (tmap identity)
+ (rfind string?)
+ '(1 c #t 4.12 "Jack" ())))))
(withtestprefix "xtransduce"
(passif "listtransduce"

2.39.0