From c382d7808a8d41cd4e9ef8a17b7ba9553835499b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Linus=20Bj=C3=B6rnstam?= Date: Thu, 16 Jan 2020 20:31:45 +0100 Subject: [PATCH] Add SRFI-171 (transducers) to guile. The two guile-specific additions are powerful transducers which can be used to generalize transducers like tsegment. They are hard to get right, but powerful and useful enough to warrant inclusion. * doc/ref/srfi-modules.texi: added srfi-171 section * module/Makefile.am (SOURCES): * module/srfi/srfi-171.scm: * module/srfi/srfi-171/meta.scm: Add SRFI-171 * module/srfi/srfi-171/gnu.scm: Add 2 guile-specific extensions. * test-suite/Makefile.am (SCM_TESTS): * test-suite/tests/srfi-171.test: Add tests. --- doc/ref/srfi-modules.texi | 518 +++++++++++++++++++++++++++++++++ module/Makefile.am | 3 + module/srfi/srfi-171.scm | 458 +++++++++++++++++++++++++++++ module/srfi/srfi-171/gnu.scm | 65 +++++ module/srfi/srfi-171/meta.scm | 113 +++++++ test-suite/Makefile.am | 1 + test-suite/tests/srfi-171.test | 195 +++++++++++++ 7 files changed, 1353 insertions(+) create mode 100644 module/srfi/srfi-171.scm create mode 100644 module/srfi/srfi-171/gnu.scm create mode 100644 module/srfi/srfi-171/meta.scm create mode 100644 test-suite/tests/srfi-171.test diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 8f5b643c6..fcc4231a7 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -64,6 +64,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-98:: Accessing environment variables. * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. +* SRFI-171:: Transducers @end menu @@ -5602,6 +5603,523 @@ Return the current contents of @var{box}. Set the contents of @var{box} to @var{value}. @end deffn +@node SRFI-171 +@subsection Transducers +@cindex SRFI-171 +@cindex transducers + +Some of the most common operations used in the Scheme language are those +transforming lists: map, filter, take and so on. They work well, are well +understood, and are used daily by most Scheme programmers. They are however not +general because they only work on lists, and they do not compose very well +since combining N of them builds @code{(- N 1)} intermediate lists. + +Transducers are oblivious to what kind of process they are used in, and +are composable without building intermediate collections. This means we +can create a transducer that squares all even numbers: @code{(compose +(tfilter odd?) (tmap (lambda (x) (* x x))))} and reuse it with lists, +vectors, or in just about any context where data flows in one direction. +We could use it as a processing step for asynchronous channels, with an +event framework as a pre-processing step, or even in lazy contexts where +you pass a lazy collection and a transducer to a function and get a new +lazy collection back. + +The traditional Scheme approach of having collection-specific procedures +is not changed. We instead specify a general form of transformations +that complement these procedures. The benefits are obvious: a clear, +well-understood way of describing common transformations in a way that +is faster than just chaining the collection-specific counterparts. For +guile in particular this means a lot better GC performance. + +Notice however that @code{(compose @dots{})} composes transducers +left-to-right, due to how transducers are initiated. + +@menu +* SRFI-171 General Discussion:: General information about transducers +* SRFI-171 Applying Transducers:: Documentation of collection-specific forms +* SRFI-171 Reducers:: Reducers specified by the SRFI +* SRFI-171 Transducers:: Transducers specified by the SRFI +* SRFI-171 Helpers:: Utilities for writing your own transducers +@end menu + +@node SRFI-171 General Discussion +@subsubsection SRFI-171 General Discussion +@cindex transducers discussion + +@subheading The concept of reducers +The central part of transducers are 3-arity reducing functions. + +@itemize +@item +(): Produce an identity + +@item +(result-so-far): completion. If you have nothing to do, then just return +the result so far + +@item +(result-so-far input) do whatever you like to the input and produce a +new result-so-far +@end itemize + +In the case of a summing @code{+} reducer, the reducer would produce, in +arity order: @code{0}, @code{result-so-far}, @code{(+ result-so-far +input)}. This happens to be exactly what the regular @code{+} does. + +@subheading The concept of transducers + +A transducer is a one-arity function that takes a reducer and produces a +reducing function that behaves as follows: + +@itemize +@item +(): calls reducer with no arguments (producing its identity) + +@item +(result-so-far): Maybe transform the result-so-far and call reducer with it. + +@item +(result-so-far input) Maybe do something to input and maybe call the +reducer with result-so-far and the maybe-transformed input. +@end itemize + +a simple example is as following: @code{ (list-transduce (tfilter odd?) ++ '(1 2 3 4 5))}. This first returns a transducer filtering all odd +elements, then it runs @code{+} without arguments to retrieve its +identity. It then starts the transduction by passing @code{+} to the +transducer returned by @code{(tfilter odd?)} which returns a reducing +function. It works not unlike reduce from SRFI 1, but also checks +whether one of the intermediate transducers returns a "reduced" value +(implemented as a SRFI 9 record), which means the reduction finished +early. + +Because transducers compose and the final reduction is only executed in +the last step, composed transducers will not build any intermediate +result or collections. Although the normal way of thinking about +application of composed functions is right to left, due to how the +transduction is built it is applied left to right. @code{(compose +(tfilter odd?) (tmap sqrt))} will create a transducer that first filters +out any odd values and then computes the square root of the rest. + + +@subheading State + + Even though transducers appear to be somewhat of a generalisation of + map and friends, this is not really true. Since transducers don't know + in which context they are being used, some transducers must keep state + where their collection-specific counterparts do not. The transducers + that keep state do so using hidden mutable state, and as such all the + caveats of mutation, parallelism, and multi-shot continuations apply. + Each transducer keeping state is clearly described as doing so in the + documentation. + +@subheading Naming + +Reducers exported from the transducers module are named as in their +SRFI-1 counterpart, but prepended with an r. Transducers also follow +that naming, but are prepended with a t. + + +@node SRFI-171 Applying Transducers +@subsubsection Applying Transducers +@cindex transducers applying + +@deffn {Scheme Procedure} list-transduce xform f lst +@deffnx {Scheme Procedure} list-transduce xform f identity lst + Initializes the transducer @code{xform} by passing the reducer @code{f} + to it. If no identity is provided, @code{f} is run without arguments to + return the reducer identity. It then reduces over @code{lst} using the + identity as the seed. + +If one of the transducers finishes early (such as @code{ttake} or +@code{tdrop}), it communicates this by returning a reduced value, which +in the sample implementation is just a value wrapped in a SRFI 9 record +type named "reduced". If such a value is returned by the transducer, +@code{list-transduce} must stop execution and return an unreduced value +immediately. +@end deffn + +@deffn {Scheme Procedure} vector-transduce xform f vec +@deffnx {Scheme Procedure} vector-transduce xform f identity vec +@deffnx {Scheme Procedure} string-transduce xform f str +@deffnx {Scheme Procedure} string-transduce xform f identity str +@deffnx {Scheme Procedure} bytevector-u8-transduce xform f bv +@deffnx {Scheme Procedure} bytevector-u8-transduce xform f identity bv +@deffnx {Scheme Procedure} generator-transduce xform f gen +@deffnx {Scheme Procedure} generator-transduce xform f identity gen + +Same as @code{list-transduce}, but for vectors, strings, u8-bytevectors +and srfi-158-styled generators respectively. + +@end deffn + +@deffn {Scheme Procedure} port-transduce xform f reader +@deffnx {Scheme Procedure} port-transduce xform f reader port +@deffnx {Scheme Procedure} port-transduce xform f identity reader port + +Same as @code{list-reduce} but for ports. Called without a port, it +reduces over the results of applying @code{(reader)} until the +EOF-object is returned, presumably to read from +@code{current-input-port}. With a port @code{reader} is applied to +@code{port} instead of without any arguments. If an @code{identity} is +provided, that is used as the initial identity in the reduction. +@end deffn + + +@node SRFI-171 Reducers +@subsubsection Reducers +@cindex transducers reducers + +@deffn {Scheme Procedure} rcons +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. + +@example +(list-transduce (tmap (lambda (x) (+ x 1)) rcons (list 0 1 2 3)) +@result{} (1 2 3 4) +@end example +@end deffn + +@deffn {Scheme Procedure} reverse-rcons +same as 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) +@end example +@end deffn + + +@deffn {Scheme Procedure} rany pred? +The reducer version of any. Returns @code{(reduced (pred? value))} if +any @code{(pred? value)} returns non-#f. The identity is #f. + +@example +(list-transduce (tmap (lambda (x) (+ x 1))) (rany odd?) (list 1 3 5)) +@result{} #f + +(list-transduce (tmap (lambda (x) (+ x 1))) (rany odd?) (list 1 3 4 5)) +@result{} #t +@end example +@end deffn + + +@deffn {Scheme Procedure} revery pred? +The reducer version of 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. + +@example +(list-transduce + (tmap (lambda (x) (+ x 1))) + (revery (lambda (v) (if (odd? v) v #f))) + (list 2 4 6)) + @result{} 7 + +(list-transduce (tmap (lambda (x) (+ x 1)) (revery odd?) (list 2 4 5 6)) +@result{} #f +@end example +@end deffn + + +@deffn {Scheme Procedure} rcount +A simple counting reducer. Counts the values that pass through the transduction. +@example +(list-transduce (tfilter odd?) rcount (list 1 2 3 4)) @result{} 2. +@end example +@end deffn + + +@node SRFI-171 Transducers +@subsubsection Transducers +@cindex transducers transducers + +@deffn {Scheme Procedure} tmap proc +Returns a transducer that applies @code{proc} to all values. Stateless. +@end deffn + + +@deffn tfilter pred? +Returns a transducer that removes values for which @code{pred?} returns #f. + +Stateless. +@end deffn + + +@deffn {Scheme Procedure} tremove pred? +Returns a transducer that removes values for which @code{pred?} returns non-#f. + +Stateless +@end deffn + +@deffn {Scheme Procedure} tfilter-map proc +The same as @code{(compose (tmap proc) (tfilter values))}. Stateless. +@end deffn + + +@deffn {Scheme Procedure} treplace mapping +The argument @code{mapping} is an association list (using @code{equal?} +to compare keys), a hash-table, a one-argument procedure taking one +argument and either producing that same argument or a replacement value. + +Returns a transducer which checks for the presence of any value passed +through it in mapping. If a mapping is found, the value of that mapping +is returned, otherwise it just returns the original value. + +Does not keep internal state, but modifying the mapping while it's in +use by treplace is an error. +@end deffn + + +@deffn {Scheme Procedure} tdrop n +Returns a transducer that discards the first n values. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} ttake n +Returns a transducer that discards all values and stops the transduction +after the first n values have been let through. Any subsequent values +are ignored. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tdrop-while pred? +Returns a transducer that discards the the first values for which +@code{pred?} returns true. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} ttake-while pred? +@deffnx {Scheme Procedure} ttake-while pred? retf +Returns a transducer that stops the transduction after @code{pred?} has +returned #f. Any subsequent values are ignored and the last successful +value is returned. @code{retf} is a function that gets called whenever +@code{pred?} returns false. The arguments passed are the result so far +and the input for which pred? returns #f. The default function is +@code{(lambda (result input) result)}. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tconcatenate +tconcatenate @emph{is} a transducer that concatenates the content of +each value (that must be a list) into the reduction. +@example +(list-transduce tconcatenate rcons '((1 2) (3 4 5) (6 (7 8) 9))) +@result{} (1 2 3 4 5 6 (7 8) 9) +@end example +@end deffn + + +@deffn {Scheme Procedure} tappend-map proc +The same as @code{(compose (tmap proc) tconcatenate)}. +@end deffn + +@deffn {Scheme Procedure} tflatten +tflatten @emph{is} a transducer that flattens an input consisting of lists. + +@example +(list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7 8) 9) +@result{} (1 2 3 4 5 6 7 8 9) +@end example +@end deffn + +@deffn {Scheme Procedure} tdelete-neighbor-duplicates +@deffnx {Scheme Procedure} tdelete-neighbor-duplicates equality-predicate + +Returns a transducer that removes any directly following duplicate +elements. The default @code{equality-predicate} is @code{equal?}. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tdelete-duplicates +@deffnx {Scheme Procedure} tdelete-duplicates equality-predicate + +Returns a transducer that removes any subsequent duplicate elements +compared using @code{equality-predicate}. The default +@code{equality-predicate} is @code{equal?}. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tsegment n + +Returns a transducer that groups @code{n} inputs in lists of @code{n} +elements. When the transduction stops, it flushes any remaining +collection, even if it contains fewer than @code{n} elements. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tpartition pred? + +Returns a transducer that groups inputs in lists by whenever +@code{(pred? input)} changes value. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tadd-between value +Returns a transducer which interposes @code{value} between each value +and the next. This does not compose gracefully with transducers like +@code{ttake}, as you might end up ending the transduction on +@code{value}. + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tenumerate +@deffnx {Scheme Procedure} tenumerate start +Returns a transducer that indexes values passed through it, starting at +@code{start}, which defaults to 0. The indexing is done through cons +pairs like @code{(index . input)}. + +@example +(list-transduce (tenumerate 1) rcons (list 'first 'second 'third)) +@result{} ((1 . first) (2 . second) (3 . third)) +@end example + +Stateful. +@end deffn + + +@deffn {Scheme Procedure} tlog +@deffnx {Scheme Procedure} tlog logger + +Returns a transducer that can be used to log or print values and +results. The result of the @code{logger} procedure is discarded. The +default @code{logger} is @code{(lambda (result input) (write input) +(newline))}. + +Stateless. +@end deffn + +@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 +document. + +@deffn {Scheme Procedure} tbatch reducer +@deffnx {Scheme Procedure} tbatch transducer reducer +A batching transducer that accumulates results using @code{reducer} or +@code{((transducer) reducer)} until it returns a reduced value. This can +be used to generalize something like @code{tsegment}: + +@example +;; This behaves exactly like (tsegment 4). +(list-transduce (tbatch (ttake 4) rcons) rcons (iota 10)) +@result {} ((0 1 2 3) (4 5 6 7) (8 9)) +@end example +@end deffn + + +@deffn {Scheme Procedure} tfold reducer +@deffnx {Scheme Procedure} tfold reducer seed + +A folding transducer that yields the result of @code{(reducer seed +value)}, saving it's result between iterations. + +@example +(list-transduce (tfold +) rcons (iota 10)) +@result{} (0 1 3 6 10 15 21 28 36 45) +@end example +@end deffn + + + + +@node SRFI-171 Helpers +@subsubsection Helper functions for writing transducers +@cindex transducers helpers + +These functions are in the @code{(srfi 171 meta)} module and are only +usable when you want to write your own transducers. + +@deffn {Scheme Procedure} reduced value + +Wraps a value in a @code{} container, signalling that the +reduction should stop. +@end deffn + + +@deffn {Scheme Procedure} reduced? value + +Returns #t if value is a @code{} record. +@end deffn + + +@deffn {Scheme Procedure} unreduce reduced-container + +Returns the value in reduced-container. +@end deffn + +@deffn {Scheme Procedure} ensure-reduced value +Wraps value in a @code{} container if it is not already reduced. +@end deffn + + +@deffn {Scheme Procedure} preserving-reduced reducer + +Wraps @code{reducer} in another reducer that encapsulates any returned +reduced value in another reduced container. This is useful in places +where you re-use a reducer with [collection]-reduce. If the reducer +returns a reduced value, [collection]-reduce unwraps it. Unless handled, +this leads to the reduction continuing. +@end deffn + +@deffn {Scheme Procedure} list-reduce f identity lst +The reducing function used internally by @code{list-transduce}. @code{f} +is a reducer as returned by a transducer. @code{identity} is the +identity (sometimes called "seed") of the reduction. @code{lst} is a +list. If @code{f} returns a reduced value, the reduction stops +immediately and the unreduced value is returned. +@end deffn + + +@deffn {Scheme Procedure} vector-reduce f identity vec +The vector version of list-reduce. +@end deffn + + +@deffn {Scheme Procedure} string-reduce f identity str +The string version of list-reduce. +@end deffn + + +@deffn {Scheme Procedure} bytevector-u8-reduce f identity bv +The bytevector-u8 version of list-reduce. +@end deffn + + +@deffn {Scheme Procedure} port-reduce f identity reader port +The port version of list-reducer. It reduces over port using reader +until reader returns the EOF object. +@end deffn + + +@deffn {Scheme Procedure} generator-reduce f identity gen + +The port version of list-reduce. It reduces over @code{gen} until it +returns the EOF object + +@end deffn + + @c srfi-modules.texi ends here @c Local Variables: diff --git a/module/Makefile.am b/module/Makefile.am index 1d9d524cf..40b4b561a 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -312,6 +312,9 @@ SOURCES = \ srfi/srfi-88.scm \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ + srfi/srfi-171.scm \ + srfi/srfi-171/gnu.scm \ + srfi/srfi-171/meta.scm \ \ statprof.scm \ \ diff --git a/module/srfi/srfi-171.scm b/module/srfi/srfi-171.scm new file mode 100644 index 000000000..545581af5 --- /dev/null +++ b/module/srfi/srfi-171.scm @@ -0,0 +1,458 @@ +;; Copyright (C) 2020 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (srfi srfi-171) + #:declarative? #t + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module ((srfi srfi-43) #:select (vector->list)) + #:use-module ((srfi srfi-69) #:prefix srfi69:) + #:use-module ((rnrs hashtables) #:prefix rnrs:) + #:use-module (srfi srfi-171 meta) + #:export (rcons + reverse-rcons + rcount + rany + revery + list-transduce + vector-transduce + string-transduce + bytevector-u8-transduce + port-transduce + generator-transduce + + tmap + tfilter + tremove + treplace + tfilter-map + tdrop + tdrop-while + ttake + ttake-while + tconcatenate + tappend-map + tdelete-neighbor-duplicates + tdelete-duplicates + tflatten + tsegment + tpartition + tadd-between + tenumerate + tlog)) +(cond-expand-provide (current-module) '(srfi-171)) + + +;; A placeholder for a unique "nothing". +(define nothing (list 'nothing)) +(define (nothing? val) + (eq? val nothing)) + +;;; Reducing functions meant to be used at the end at the transducing process. +(define rcons + (case-lambda + "A transducer-friendly consing reducer with '() as identity." + (() '()) + ((lst) (reverse! lst)) + ((lst x) (cons x lst)))) + +(define reverse-rcons + (case-lambda + "A transducer-friendly consing reducer with '() as identity. +The resulting list is in reverse order." + (() '()) + ((lst) lst) + ((lst x) (cons x lst)))) + +(define rcount + (case-lambda + "A counting reducer that counts any elements that made it through the +transduction. +@example +(transduce (tfilter odd?) tcount (list 1 2 3)) @result{} 2 +@end example" + (() 0) + ((result) result) + ((result input) + (+ 1 result)))) + +(define (rany pred) + (case-lambda + "A reducer that tests input using @var{pred}. If any input satisfies +@var{pred}, it returns @code{(reduced value)}." + (() #f) + ((result) result) + ((result input) + (let ((test (pred input))) + (if test + (reduced test) + #f))))) + +(define (revery pred) + (case-lambda + "A reducer that tests input using @var{pred}. If any input satisfies +@var{pred}, it returns @code{(reduced #f)}." + (() #t) + ((result) result) + ((result input) + (let ((test (pred input))) + (if (and result test) + test + (reduced #f)))))) + + +(define list-transduce + (case-lambda + ((xform f coll) + (list-transduce xform f (f) coll)) + ((xform f init coll) + (let* ((xf (xform f)) + (result (list-reduce xf init coll))) + (xf result))))) + +(define vector-transduce + (case-lambda + ((xform f coll) + (vector-transduce xform f (f) coll)) + ((xform f init coll) + (let* ((xf (xform f)) + (result (vector-reduce xf init coll))) + (xf result))))) + +(define string-transduce + (case-lambda + ((xform f coll) + (string-transduce xform f (f) coll)) + ((xform f init coll) + (let* ((xf (xform f)) + (result (string-reduce xf init coll))) + (xf result))))) + +(define bytevector-u8-transduce + (case-lambda + ((xform f coll) + (bytevector-u8-transduce xform f (f) coll)) + ((xform f init coll) + (let* ((xf (xform f)) + (result (bytevector-u8-reduce xf init coll))) + (xf result))))) + +(define port-transduce + (case-lambda + ((xform f by) + (generator-transduce xform f by)) + ((xform f by port) + (port-transduce xform f (f) by port)) + ((xform f init by port) + (let* ((xf (xform f)) + (result (port-reduce xf init by port))) + (xf result))))) + +(define generator-transduce + (case-lambda + ((xform f gen) + (generator-transduce xform f (f) gen)) + ((xform f init gen) + (let* ((xf (xform f)) + (result (generator-reduce xf init gen))) + (xf result))))) + +;;; Transducers +(define (tmap f) + (lambda (reducer) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (reducer result (f input)))))) + +(define (tfilter pred) + (lambda (reducer) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (pred input) + (reducer result input) + result))))) + +(define (tremove pred) + (lambda (reducer) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (not (pred input)) + (reducer result input) + result))))) + +(define (tfilter-map f) + (compose (tmap f) (tfilter values))) + +(define (make-replacer map) + (cond + ((list? map) + (lambda (x) + (match (assoc x map) + ((_ . replacer) replacer) + (#f x)))) + ((srfi69:hash-table? map) + (lambda (x) + (srfi69:hash-table-ref/default map x x))) + ((rnrs:hashtable? map) + (lambda (x) + (rnrs:hashtable-ref map x x))) + ((hash-table? map) + (lambda (x) + (hash-ref map x x))) + ((procedure? map) map) + (else + (error "Unsupported mapping in treplace" map)))) + + +(define (treplace map) + "Returns a transducer that searches for any input in @var{map}, which may +be a guile native hashtable, an R6RS hashtable, a srfi-69 hashtable, an alist +or a one-argument procedure taking one value and producing either the same +value or a replacement one. Alists and guile-native hashtbles compare keys +using @code{equal?} whereas the other mappings use whatever equality predicate +they were created with." + (tmap (make-replacer map))) + +(define (tdrop n) + (lambda (reducer) + (let ((new-n (+ 1 n))) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (set! new-n (- new-n 1)) + (if (positive? new-n) + result + (reducer result input))))))) + +(define (tdrop-while pred) + (lambda (reducer) + (let ((drop? #t)) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (and (pred input) drop?) + result + (begin + (set! drop? #f) + (reducer result input)))))))) + +(define (ttake n) + (lambda (reducer) + ;; we need to reset new-n for every new transduction + (let ((new-n n)) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (let ((result (if (positive? new-n) + (reducer result input) + result))) + (set! new-n (- new-n 1)) + (if (not (positive? new-n)) + (ensure-reduced result) + result))))))) + +(define ttake-while + (case-lambda + ((pred) (ttake-while pred (lambda (result input) result))) + ((pred retf) + (lambda (reducer) + (let ((take? #t)) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (and take? (pred input)) + (reducer result input) + (begin + (set! take? #f) + (ensure-reduced (retf result input))))))))))) + +(define (tconcatenate reducer) + (let ((preserving-reducer (preserving-reduced reducer))) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (list-reduce preserving-reducer result input))))) + +(define (tappend-map f) + (compose (tmap f) tconcatenate)) + +(define (tflatten reducer) + "tflatten is a transducer that flattens any list passed through it. +@example +(list-transduce tflatten conj (list 1 2 (list 3 4 '(5 6) 7 8))) +@result{} (1 2 3 4 5 6 7 8) +@end example" + (case-lambda + (() '()) + ((result) (reducer result)) + ((result input) + (if (list? input) + (list-reduce (preserving-reduced (tflatten reducer)) result input) + (reducer result input))))) + + +(define tdelete-neighbor-duplicates + (case-lambda + (() (tdelete-neighbor-duplicates equal?)) + ((equality-pred?) + (lambda (reducer) + (let ((prev nothing)) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (equality-pred? prev input) + result + (begin + (set! prev input) + (reducer result input)))))))))) + + +(define* (tdelete-duplicates #:optional (equality-pred? equal?)) + "tdelede-duplicates is a transducer that deletes any subsequent duplicate +elements. Comparisons is done using @var{equality-pred?}, which defaults +to @code{equal?}." + (lambda (reducer) + (let ((already-seen (srfi69:make-hash-table equality-pred?))) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (if (srfi69:hash-table-exists? already-seen input) + result + (begin + (srfi69:hash-table-set! already-seen input #t) + (reducer result input)))))))) + +(define (tsegment n) + "tsegment returns a transducer that partitions the input into +lists of @var{n} items. If the input stops it flushes any +accumulated state, which may be shorter than @var{n}." + (if (not (and (integer? n) (positive? n))) + (error "argument to tsegment must be a positive integer") + (lambda (reducer) + (let ((i 0) + (collect (make-vector n))) + (case-lambda + (() (reducer)) + ((result) + ;; if there is anything collected when we are asked to quit + ;; we flush it to the remaining transducers + (let ((result + (if (zero? i) + result + (reducer result (vector->list collect 0 i))))) + (set! i 0) + ;; now finally, pass it downstreams + (if (reduced? result) + (reducer (unreduce result)) + (reducer result)))) + ((result input) + (vector-set! collect i input) + (set! i (+ i 1)) + ;; If we have collected enough input we can pass it on downstream + (if (< i n) + result + (let ((next-input (vector->list collect 0 i))) + (set! i 0) + (reducer result next-input))))))))) + +(define (tpartition f) + "tpartition returns a transducer that partitions any input by whenever +@code{(f input)} changes value. " + (lambda (reducer) + (let* ((prev nothing) + (collect '())) + (case-lambda + (() (reducer)) + ((result) + (let ((result + (if (null? collect) + result + (reducer result (reverse! collect))))) + (set! collect '()) + (if (reduced? result) + (reducer (unreduce result)) + (reducer result)))) + ((result input) + (let ((fout (f input))) + (cond + ((or (equal? fout prev) (nothing? prev)) ; collect + (set! prev fout) + (set! collect (cons input collect)) + result) + (else ; flush what we collected already to the reducer + (let ((next-input (reverse! collect))) + (set! prev fout) + (set! collect (list input)) + (reducer result next-input)))))))))) + +(define (tadd-between elem) + "Returns a transducer that interposes @var{elem} between each value pushed +through the transduction." + (lambda (reducer) + (let ((send-elem? #f)) + (case-lambda + (() (reducer)) + ((result) + (reducer result)) + ((result input) + (if send-elem? + (let ((result (reducer result elem))) + (if (reduced? result) + result + (reducer result input))) + (begin + (set! send-elem? #t) + (reducer result input)))))))) + +(define* (tenumerate #:optional (n 0)) + "Indexes every value passed through into a cons pair as +@code{(index . value)}. Starts at @var{n} which defaults to 0." + (lambda (reducer) + (let ((n n)) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (let ((input (cons n input))) + (set! n (+ n 1)) + (reducer result input))))))) + +(define* (tlog #:optional + (log-function (lambda (result input) (write input) (newline)))) + (lambda (reducer) + (case-lambda + (() (reducer)) + ((result) (reducer result)) + ((result input) + (log-function result input) + (reducer result input))))) + + + + diff --git a/module/srfi/srfi-171/gnu.scm b/module/srfi/srfi-171/gnu.scm new file mode 100644 index 000000000..45a4e19af --- /dev/null +++ b/module/srfi/srfi-171/gnu.scm @@ -0,0 +1,65 @@ +;; Copyright (C) 2020 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (srfi srfi-171 gnu) + #:use-module (srfi srfi-171) + #:use-module (srfi srfi-171 meta) + #:export (tbatch tfold)) + + +(define tbatch + (case-lambda + ((reducer) + (tbatch identity reducer)) + ((t r) + (lambda (reducer) + (let ((cur-reducer (t r)) + (cur-state (r))) + (case-lambda + (() (reducer)) + ((result) + (if (equal? cur-state (cur-reducer)) + (reducer result) + (let ((new-res (reducer result (cur-reducer cur-state)))) + (if (reduced? new-res) + (reducer (unreduce new-res)) + (reducer new-res))))) + ((result value) + (let ((val (cur-reducer cur-state value))) + (cond + ;; cur-reducer is done. Push value downstream + ;; re-instantiate the state and the cur-reducer + ((reduced? val) + (let ((unreduced-val (unreduce val))) + (set! cur-reducer (t r)) + (set! cur-state (cur-reducer)) + (reducer result (cur-reducer unreduced-val)))) + (else + (set! cur-state val) + result)))))))))) + + +(define* (tfold reducer #:optional (seed (reducer))) + (lambda (r) + (let ((state seed)) + (case-lambda + (() (r)) + ((result) (r result)) + ((result value) + (set! state (reducer state value)) + (if (reduced? state) + (reduced (reducer (unreduce state))) + (r result state))))))) diff --git a/module/srfi/srfi-171/meta.scm b/module/srfi/srfi-171/meta.scm new file mode 100644 index 000000000..771f707ee --- /dev/null +++ b/module/srfi/srfi-171/meta.scm @@ -0,0 +1,113 @@ +;; Copyright (C) 2020 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (srfi srfi-171 meta) + #:use-module (srfi srfi-9) + #:use-module ((rnrs bytevectors) #:select (bytevector-length bytevector-u8-ref)) + #:export (reduced reduced? + unreduce + ensure-reduced + preserving-reduced + + list-reduce + vector-reduce + string-reduce + bytevector-u8-reduce + port-reduce + generator-reduce)) + + +;; A reduced value is stops the transduction. +(define-record-type + (reduced val) + reduced? + (val unreduce)) + +(define (ensure-reduced x) + "Ensure that @var{x} is reduced" + (if (reduced? x) + x + (reduced x))) + +;; helper function that wraps a reduced value twice since reducing functions (like list-reduce) +;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce. +;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce" +;; that value and try to continue the transducing process. +(define (preserving-reduced reducer) + (lambda (a b) + (let ((return (reducer a b))) + (if (reduced? return) + (reduced return) + return)))) + +;; This is where the magic tofu is cooked +(define (list-reduce f identity lst) + (if (null? lst) + identity + (let ((v (f identity (car lst)))) + (if (reduced? v) + (unreduce v) + (list-reduce f v (cdr lst)))))) + +(define (vector-reduce f identity vec) + (let ((len (vector-length vec))) + (let loop ((i 0) (acc identity)) + (if (= i len) + acc + (let ((acc (f acc (vector-ref vec i)))) + (if (reduced? acc) + (unreduce acc) + (loop (+ i 1) acc))))))) + +(define (string-reduce f identity str) + (let ((len (string-length str))) + (let loop ((i 0) (acc identity)) + (if (= i len) + acc + (let ((acc (f acc (string-ref str i)))) + (if (reduced? acc) + (unreduce acc) + (loop (+ i 1) acc))))))) + +(define (bytevector-u8-reduce f identity vec) + (let ((len (bytevector-length vec))) + (let loop ((i 0) (acc identity)) + (if (= i len) + acc + (let ((acc (f acc (bytevector-u8-ref vec i)))) + (if (reduced? acc) + (unreduce acc) + (loop (+ i 1) acc))))))) + +(define (port-reduce f identity reader port) + (let loop ((val (reader port)) (acc identity)) + (if (eof-object? val) + acc + (let ((acc (f acc val))) + (if (reduced? acc) + (unreduce acc) + (loop (reader port) acc)))))) + +(define (generator-reduce f identity gen) + (let loop ((val (gen)) (acc identity)) + (if (eof-object? val) + acc + (let ((acc (f acc val))) + (if (reduced? acc) + (unreduce acc) + (loop (gen) acc)))))) + diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3810197e2..cafa5c92b 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -160,6 +160,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-98.test \ tests/srfi-105.test \ tests/srfi-111.test \ + tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-171.test b/test-suite/tests/srfi-171.test new file mode 100644 index 000000000..c6d574af2 --- /dev/null +++ b/test-suite/tests/srfi-171.test @@ -0,0 +1,195 @@ +;; TODO: test all transducers that take an equality predicate +;; TODO: test treplace with all kinds of hash tables + +(define-module (test-srfi-171) + #:use-module (test-suite lib) + #:use-module (ice-9 hash-table) + #:use-module (srfi srfi-171) + #:use-module (srfi srfi-171 gnu) + #:use-module (rnrs bytevectors) + #:use-module ((rnrs hashtables) #:prefix rnrs:) + #:use-module ((srfi srfi-69) #:prefix srfi:)) + +(define (add1 x) (+ x 1)) + + +(define numeric-list (iota 5)) +(define numeric-vec (list->vector numeric-list)) +(define bv (list->u8vector numeric-list)) +(define test-string "0123456789abcdef") +(define list-of-chars (string->list test-string)) + + +;; for testing all treplace variations +(define replace-alist '((1 . s) (2 . c) (3 . h) (4 . e) (5 . m))) +(define guile-hashtable (alist->hash-table replace-alist)) +(define srfi69-hashtable (srfi:alist->hash-table replace-alist)) +(define rnrs-hashtable (rnrs:make-eq-hashtable)) +(rnrs:hashtable-set! rnrs-hashtable 1 's) +(rnrs:hashtable-set! rnrs-hashtable 2 'c) +(rnrs:hashtable-set! rnrs-hashtable 3 'h) +(rnrs:hashtable-set! rnrs-hashtable 4 'e) +(rnrs:hashtable-set! rnrs-hashtable 5 'm) +(define (replace-function val) + (case val + ((1) 's) + ((2) 'c) + ((3) 'h) + ((4) 'e) + ((5) 'm) + (else val))) + + +;; Test procedures for port-transduce +;; broken out to properly close port +(define (port-transduce-test) + (let* ((port (open-input-string "0 1 2 3 4")) + (res (equal? 15 (port-transduce (tmap add1) + read (open-input-string "0 1 2 3 4"))))) + (close-port port) + res)) +(define (port-transduce-with-identity-test) + (let* ((port (open-input-string "0 1 2 3 4")) + (res (equal? 15 (port-transduce (tmap add1) + 0 read (open-input-string "0 1 2 3 4"))))) + (close-port port) + res)) + +(with-test-prefix "transducers" + (pass-if "tmap" (equal? '(1 2 3 4 5) (list-transduce (tmap add1) rcons numeric-list))) + + (pass-if "tfilter" (equal? '(0 2 4) (list-transduce (tfilter even?) rcons numeric-list))) + + (pass-if "tfilter+tmap" (equal? + '(1 3 5) + (list-transduce (compose (tfilter even?) (tmap add1)) rcons numeric-list))) + + (pass-if "tfilter-map" + (equal? '(1 3 5) + (list-transduce (tfilter-map + (lambda (x) + (if (even? x) + (+ x 1) + #f))) + rcons numeric-list))) + + (pass-if "tremove" + (equal? (list-transduce (tremove char-alphabetic?) rcount list-of-chars) + (string-transduce (tremove char-alphabetic?) rcount test-string))) + + (pass-if "treplace with alist" + (equal? '(s c h e m e r o c k s) + (list-transduce (treplace replace-alist) rcons '(1 2 3 4 5 4 r o c k s) ))) + + (pass-if "treplace with replace-function" + (equal? '(s c h e m e r o c k s) + (list-transduce (treplace replace-function) rcons '(1 2 3 4 5 4 r o c k s)))) + + + (pass-if "treplace with guile hash-table" + (equal? '(s c h e m e r o c k s) + (list-transduce (treplace guile-hashtable) rcons '(1 2 3 4 5 4 r o c k s)))) + + (pass-if "treplace with srfi-69 hash-table" + (equal? '(s c h e m e r o c k s) + (list-transduce (treplace srfi69-hashtable) rcons '(1 2 3 4 5 4 r o c k s)))) + + (pass-if "treplace with rnrs hash-table" + (equal? '(s c h e m e r o c k s) + (list-transduce (treplace rnrs-hashtable) rcons '(1 2 3 4 5 4 r o c k s)))) + + + + (pass-if "ttake" + (equal? 6 (list-transduce (ttake 4) + numeric-list))) + + (pass-if "tdrop" + (equal? 7 (list-transduce (tdrop 3) + numeric-list))) + + (pass-if "tdrop-while" + (equal? '(3 4) (list-transduce (tdrop-while (lambda (x) (< x 3))) rcons numeric-list))) + + (pass-if "ttake-while" (equal? '(0 1 2) (list-transduce (ttake-while (lambda (x) (< x 3))) rcons numeric-list))) + + (pass-if "tconcatenate" + (equal? '(0 1 2 3 4) (list-transduce tconcatenate rcons '((0 1) (2 3) (4))))) + + (pass-if "tappend-map" + (equal? '(1 2 2 4 3 6) (list-transduce (tappend-map (lambda (x) (list x (* x 2)))) rcons '(1 2 3)))) + + (pass-if "tdelete-neighbor-duplicates" + (equal? '(1 2 1 2 3) (list-transduce (tdelete-neighbor-duplicates) rcons '(1 1 1 2 2 1 2 3 3)))) + + (pass-if "tdelete-neighbor-duplicates with equality predicate" + (equal? + '(a b c "hej" "hej") + (list-transduce (tdelete-neighbor-duplicates eq?) rcons (list 'a 'a 'b 'c 'c "hej" (string #\h #\e #\j))))) + + (pass-if "tdelete-duplicates" + (equal? '(1 2 3 4) (list-transduce (tdelete-duplicates) rcons '(1 1 2 1 2 3 3 1 2 3 4)))) + + (pass-if "tdelete-duplicates with predicate" + (equal? '("hej" "hopp") + (list-transduce (tdelete-duplicates string-ci=?) rcons (list "hej" "HEJ" "hopp" "HOPP" "heJ")))) + + (pass-if "tflatten" + (equal? '(1 2 3 4 5 6 7 8 9) (list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7) 8 (9))))) + + (pass-if "tpartition" + (equal? '((1 1 1 1) (2 2 2 2) (3 3 3) (4 4 4 4)) (list-transduce (tpartition even?) rcons '(1 1 1 1 2 2 2 2 3 3 3 4 4 4 4)))) + + (pass-if "tsegment" + (equal? '((0 1) (2 3) (4)) (vector-transduce (tsegment 2) rcons numeric-vec))) + + (pass-if "tadd-between" + (equal? '(0 and 1 and 2 and 3 and 4) (list-transduce (tadd-between 'and) rcons numeric-list))) + + (pass-if "tenumerate" + (equal? '((-1 . 0) (0 . 1) (1 . 2) (2 . 3) (3 . 4)) (list-transduce (tenumerate (- 1)) rcons numeric-list))) + + (pass-if "tbatch" + (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)))) + + +(with-test-prefix "x-transduce" + (pass-if "list-transduce" + (equal? 15 (list-transduce (tmap add1) + numeric-list))) + + (pass-if "list-transduce with identity" + (equal? 15 (list-transduce (tmap add1) + 0 numeric-list))) + + (pass-if "vector-transduce" + (equal? 15 (vector-transduce (tmap add1) + numeric-vec))) + + (pass-if "vector-transduce with identity" (equal? 15 (vector-transduce (tmap add1) + 0 numeric-vec))) + + + (pass-if "port-transduce" (port-transduce-test)) + (pass-if "port-transduce with identity" (port-transduce-with-identity-test)) + + + ;; Converts each numeric char to it's corresponding integer and sums them. + (pass-if "string-transduce" + (equal? 15 (string-transduce (tmap (lambda (x) (- (char->integer x) 47))) + "01234"))) + + (pass-if "string-transduce with identity" + (equal? 15 (string-transduce (tmap (lambda (x) (- (char->integer x) 47))) + 0 "01234"))) + + (pass-if "generator-transduce" + (equal? '(1 2 3) (parameterize ((current-input-port (open-input-string "1 2 3"))) + (generator-transduce (tmap (lambda (x) x)) rcons read)))) + + (pass-if "generator-transduce with identity" + (equal? '(1 2 3) (parameterize ((current-input-port (open-input-string "1 2 3"))) + (generator-transduce (tmap (lambda (x) x)) rcons '() read)))) + + (pass-if "bytevector-u8-transduce" + (equal? 15 (bytevector-u8-transduce (tmap add1) + bv))) + + (pass-if "bytevector-u8-transduce with identity" + (equal? 15 (bytevector-u8-transduce (tmap add1) + 0 bv)))) -- 2.24.1