summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-171.scm
diff options
context:
space:
mode:
authorLinus Björnstam <linus.bjornstam@fastmail.se>2020-03-23 14:59:39 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-25 22:44:27 +0100
commit5f60eb6bb5af418b332101c69c88da639b117ae4 (patch)
tree421f6fbeb16bc6f098dcd788e30ebf0091d67f20 /module/srfi/srfi-171.scm
parentf8f8986e4a5fad520e0f9e5e150b45178c0a7ed4 (diff)
downloadguile-5f60eb6bb5af418b332101c69c88da639b117ae4.tar.gz
Add SRFI-171 to guile
This adds 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. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'module/srfi/srfi-171.scm')
-rw-r--r--module/srfi/srfi-171.scm457
1 files changed, 457 insertions, 0 deletions
diff --git a/module/srfi/srfi-171.scm b/module/srfi/srfi-171.scm
new file mode 100644
index 000000000..eb2d4d4e5
--- /dev/null
+++ b/module/srfi/srfi-171.scm
@@ -0,0 +1,457 @@
+;; 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)
+ #: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
+ "Return a reducer that tests input using @var{pred}. If any input satisfies
+@var{pred}, return @code{(reduced value)}."
+ (() #f)
+ ((result) result)
+ ((result input)
+ (let ((test (pred input)))
+ (if test
+ (reduced test)
+ #f)))))
+
+(define (revery pred)
+ (case-lambda
+ "Returns 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)
+ "Return 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)
+ "Return 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)
+ "Return 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)
+ "Return 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))
+ "Return a transducer that 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)))))
+
+
+
+