summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--WORK16
-rw-r--r--arrays-procs116
-rw-r--r--bench.scm59
-rw-r--r--dyn-vector-procs20
-rw-r--r--iset-procs64
-rw-r--r--lazy-seq-procs34
-rw-r--r--srfi-1-procs67
-rw-r--r--srfi-113-procs113
-rw-r--r--srfi-116-procs99
-rw-r--r--srfi-117-procs23
-rw-r--r--srfi-127-procs29
-rw-r--r--srfi-13-procs86
-rw-r--r--srfi-41-procs70
-rw-r--r--tests/run.scm40
-rw-r--r--transducers.egg11
-rw-r--r--transducers.impl.scm276
-rw-r--r--transducers.scm50
17 files changed, 1173 insertions, 0 deletions
diff --git a/WORK b/WORK
new file mode 100644
index 0000000..e2cc15f
--- /dev/null
+++ b/WORK
@@ -0,0 +1,16 @@
+chicken-install -v -test
+
+git add -u
+git st
+git diff
+rm transducers
+git clean -n
+git clean -f
+
+csi -s tests/run.scm
+csc transducers.scm -sJ -O3 -debug o
+csc bench.scm -O3
+./bench
+win
+csi
+,l transducers.impl.scm
diff --git a/arrays-procs b/arrays-procs
new file mode 100644
index 0000000..9d44987
--- /dev/null
+++ b/arrays-procs
@@ -0,0 +1,116 @@
+array
+array->list
+array->vector
+array-add!
+array-append
+array-append!
+array-apply
+array-at
+array-bind
+array-butlast
+array-copy
+array-count
+array-cursor-finished?
+array-cursor-goto!
+array-cursor-index
+array-cursor-item
+array-cursor-next!
+array-cursor-start!
+array-drop
+array-drop-while
+array-eq?
+array-equ?
+array-equal?
+array-eqv?
+array-every?
+array-filter
+array-first
+array-fold-left
+array-fold-right
+array-for-each
+array-handler
+array-handler-iterate
+array-handler-iterate-until
+array-handler-iterate-while
+array-handler-messages
+array-handler-repeat
+array-handler?
+array-handlers
+array-in?
+array-interpose
+array-item
+array-iterate
+array-iterate-until
+array-iterate-while
+array-last
+array-length
+array-map
+array-mappend
+array-member
+array-memp
+array-memq
+array-memv
+array-null?
+array-prune!
+array-range
+array-remove
+array-remove-dups
+array-remp
+array-remq
+array-remv
+array-repeat
+array-rest
+array-reverse
+array-reverse!
+array-sets
+array-some?
+array-sort!
+array-sorted?
+array-split-at
+array-split-with
+array-swap!
+array-take
+array-take-while
+array-unzip
+array-update!
+array-zip
+array?
+arrays
+assert*
+list->array
+list->set
+make-array
+make-array-handler
+make-set
+nary
+nary?
+set
+set->list
+set->vector
+set-add!
+set-apply
+set-copy
+set-count
+set-difference
+set-equ?
+set-every?
+set-filter
+set-for-each
+set-handler
+set-in
+set-intersection
+set-item?
+set-iterate
+set-iterate-until
+set-iterate-while
+set-map
+set-null?
+set-remove!
+set-some?
+set-union
+set<=
+set=
+set>=
+set?
+vector->array
+vector->set
diff --git a/bench.scm b/bench.scm
new file mode 100644
index 0000000..c58c489
--- /dev/null
+++ b/bench.scm
@@ -0,0 +1,59 @@
+(module bench ()
+
+(import
+ scheme
+ (chicken base)
+ (chicken time)
+ (clojurian syntax)
+ (prefix srfi-1 s/)
+ (prefix transducers t/))
+
+(define num 1000000)
+;(define num 100000)
+;(define num 10000)
+;(define num 1000)
+
+(define primes
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97))
+
+(define (ask-divisible denom)
+ (lambda (num)
+ (and (not (= num denom))
+ (zero? (modulo num denom)))))
+
+(define (title str)
+ (newline)
+ (print str)
+ (print (make-string (string-length str) #\=))
+ (newline))
+
+(title "Traditional")
+
+(define (tradi-test nums)
+ (s/fold (lambda (p prev) (s/remove (ask-divisible p) prev))
+ nums
+ primes))
+
+#;(time (tradi-test (s/map add1 (s/iota num))))
+
+(time (s/filter odd? (s/map add1 (s/iota num))))
+
+(title "Transducers")
+
+(define (trans-test)
+ (foldl (lambda (r p) (compose r (t/remove (ask-divisible p))))
+ (t/unit)
+ primes))
+
+#;(time (t/transduce/list
+ (compose (t/map add1) (trans-test))
+ t/build/list
+ (s/iota num)))
+
+(time (t/transduce/list
+ (compose (t/map add1)
+ (t/filter odd?))
+ t/build/list
+ (s/iota num)))
+
+)
diff --git a/dyn-vector-procs b/dyn-vector-procs
new file mode 100644
index 0000000..0a23857
--- /dev/null
+++ b/dyn-vector-procs
@@ -0,0 +1,20 @@
+dynvector
+dynvector->list
+dynvector-any
+dynvector-clear!
+dynvector-copy
+dynvector-every
+dynvector-expand!
+dynvector-extend!
+dynvector-fold
+dynvector-fold-right
+dynvector-for-each
+dynvector-index
+dynvector-length
+dynvector-map
+dynvector-ref
+dynvector-set!
+dynvector-tabulate
+dynvector?
+list->dynvector
+make-dynvector
diff --git a/iset-procs b/iset-procs
new file mode 100644
index 0000000..8f60004
--- /dev/null
+++ b/iset-procs
@@ -0,0 +1,64 @@
+bit-vector-and
+bit-vector-and!
+bit-vector-copy
+bit-vector-count
+bit-vector-empty?
+bit-vector-eqv
+bit-vector-eqv!
+bit-vector-full?
+bit-vector-ior
+bit-vector-ior!
+bit-vector-length
+bit-vector-nand
+bit-vector-nand!
+bit-vector-nor
+bit-vector-nor!
+bit-vector-ref
+bit-vector-set
+bit-vector-set!
+bit-vector-shift
+bit-vector-shift!
+bit-vector-xor
+bit-vector-xor!
+bit-vector?
+end-of-iset?
+integer->bit-vector
+iset
+iset->list
+iset-adjoin
+iset-adjoin!
+iset-any
+iset-contains?
+iset-copy
+iset-cursor
+iset-cursor-next
+iset-delete
+iset-delete!
+iset-diff+intersection
+iset-diff+intersection!
+iset-difference
+iset-difference!
+iset-every
+iset-filter
+iset-filter!
+iset-fold
+iset-for-each
+iset-intersection
+iset-intersection!
+iset-map
+iset-ref
+iset-size
+iset-unfold
+iset-unfold!
+iset-union
+iset-union!
+iset-xor
+iset-xor!
+iset<=
+iset=
+iset>=
+iset?
+list->iset
+list->iset!
+make-bit-vector
+make-iset
diff --git a/lazy-seq-procs b/lazy-seq-procs
new file mode 100644
index 0000000..888b237
--- /dev/null
+++ b/lazy-seq-procs
@@ -0,0 +1,34 @@
+input-port->lazy-seq
+lazy-append
+lazy-append-map
+lazy-concatenate
+lazy-cycle
+lazy-drop
+lazy-drop-while
+lazy-each
+lazy-filter
+lazy-flatten
+lazy-fold
+lazy-head
+lazy-iterate
+lazy-length
+lazy-list
+lazy-map
+lazy-null
+lazy-null?
+lazy-numbers
+lazy-ref
+lazy-repeat
+lazy-repeatedly
+lazy-reverse
+lazy-seq
+lazy-seq->list
+lazy-seq->string
+lazy-seq-realized?
+lazy-seq?
+lazy-tail
+lazy-take
+lazy-take-while
+list->lazy-seq
+make-lazy-seq
+string->lazy-seq
diff --git a/srfi-1-procs b/srfi-1-procs
new file mode 100644
index 0000000..f93308e
--- /dev/null
+++ b/srfi-1-procs
@@ -0,0 +1,67 @@
+- (reverse list)
++ (take x i)
++ (drop x i)
+- (take-right flist i)
+- (drop-right flist i)
+- (split-at x i)
+- (last pair)
+ (last-pair pair)
++ (concatenate list-of-lists)
+ (append-reverse rev-head tail)
+- (zip clist_1 clist_2 ...)
+- (unzip1 list)
+- (unzip2 list)
+- (unzip3 list)
+- (unzip4 list)
+- (unzip5 list)
+- (count pred clist_1 clist_2)
+
+ (fold kons knil clist_1 clist_2 ...)
+ (fold-right kons knil clist_1 clist_2 ...)
+ (pair-fold kons knil clist_1 clist_2 ...)
+ (pair-fold-right kons knil clist_1 clist_2 ...)
+ (reduce f ridentity list)
+ (reduce-right f ridentity list)
+- (unfold p f g seed [tail-gen])
+- (unfold-right p f g seed [tail])
++ (map proc clist_1 clist_2 ...)
+ (for-each proc clist_1 clist_2 ...)
++ (append-map f clist_1 clist_2 ...)
+ (pair-for-each f clist_1 clist_2 ...)
++ (filter-map f clist_1 clist_2 ...)
+
++ (filter pred list)
+- (partition pred list)
++ (remove pred list)
+
+- (find pred clist)
+- (find-tail pred clist)
++ (take-while pred clist)
++ (drop-while pred clist)
+- (span pred clist)
+- (break pred clist)
+- (any pred clist_1 clist_2 ...)
+- (every pred clist_1 clist_2 ...)
+- (list-index pred clist_1 clist_2 ...)
+- (member x list [=])
++ (delete x list [=])
++ (delete-duplicates list [=])
+
+ (assoc key alist [=])
+ (alist-cons key datum alist)
+ (alist-copy alist)
+ (alist-delete key alist [=])
+
+ (lset<= = list_1 ...)
+ (lset= = list_1 list_2 ...)
+ (lset-adjoin = list elt_1 ...)
+ (lset-union = list_1 ...)
+ (lset-intersection = list_1 list_2 ...)
+ (lset-difference = list_1 list_2 ...)
+ (lset-xor = list_1 ...)
+ (lset-diff+intersection = list_1 list_2 ...)
+ (lset-union! = list_1 ...)
+ (lset-intersection! = list_1 list_2 ...)
+ (lset-difference! = list_1 list_2 ...)
+ (lset-xor! = list_1 ...)
+ (lset-diff+intersection! = list_1 list_2 ...)
diff --git a/srfi-113-procs b/srfi-113-procs
new file mode 100644
index 0000000..7bd2e95
--- /dev/null
+++ b/srfi-113-procs
@@ -0,0 +1,113 @@
+alist->bag
+bag
+bag->alist
+bag->list
+bag->set
+bag-adjoin
+bag-adjoin!
+bag-any?
+bag-comparator
+bag-contains?
+bag-copy
+bag-count
+bag-decrement!
+bag-delete
+bag-delete!
+bag-delete-all
+bag-delete-all!
+bag-difference
+bag-difference!
+bag-disjoint?
+bag-element-comparator
+bag-element-count
+bag-empty?
+bag-every?
+bag-filter
+bag-filter!
+bag-find
+bag-fold
+bag-fold-unique
+bag-for-each
+bag-for-each-unique
+bag-increment!
+bag-intersection
+bag-intersection!
+bag-map
+bag-member
+bag-partition
+bag-partition!
+bag-product
+bag-product!
+bag-remove
+bag-remove!
+bag-replace
+bag-replace!
+bag-search!
+bag-size
+bag-sum
+bag-sum!
+bag-unfold
+bag-union
+bag-union!
+bag-unique-size
+bag-xor
+bag-xor!
+bag<=?
+bag<?
+bag=?
+bag>=?
+bag>?
+bag?
+list->bag
+list->bag!
+list->set
+list->set!
+set
+set->bag
+set->bag!
+set->list
+set-adjoin
+set-adjoin!
+set-any?
+set-comparator
+set-contains?
+set-copy
+set-count
+set-delete
+set-delete!
+set-delete-all
+set-delete-all!
+set-difference
+set-difference!
+set-disjoint?
+set-element-comparator
+set-empty?
+set-every?
+set-filter
+set-filter!
+set-find
+set-fold
+set-for-each
+set-intersection
+set-intersection!
+set-map
+set-member
+set-partition
+set-partition!
+set-remove
+set-remove!
+set-replace
+set-replace!
+set-search!
+set-size
+set-unfold
+set-union
+set-union!
+set-xor
+set-xor!
+set<=?
+set<?
+set=?
+set>=?
+set>?
+set?
diff --git a/srfi-116-procs b/srfi-116-procs
new file mode 100644
index 0000000..530f139
--- /dev/null
+++ b/srfi-116-procs
@@ -0,0 +1,99 @@
+dotted-ilist?
+gtree->itree
+ialist-cons
+ialist-delete
+iany
+iappend
+iappend-map
+iappend-reverse
+iapply
+iassoc
+iassq
+iassv
+ibreak
+icaar
+icadr
+icar
+icdddar
+icddddr
+icdr
+iconcatenate
+icount
+idelete
+idelete-duplicates
+idrop
+idrop-right
+idrop-while
+ieigth
+ievery
+ififth
+ifilter
+ifilter-map
+ifind
+ifind-tail
+ifirst
+ifold
+ifold-right
+ifor-each
+ifourth
+iiota
+ilast
+ilength
+ilist
+ilist->list
+ilist-copy
+ilist-index
+ilist-ref
+ilist-tabulate
+ilist-tail
+ilist=
+ilist?
+imap
+imap-in-order
+imember
+imemq
+imemv
+ininth
+ipair
+ipair*
+ipair->pair
+ipair-fold
+ipair-fold-right
+ipair-for-each
+ipair?
+ipartition
+ireduce
+ireduce-right
+iremove
+ireverse
+isecond
+iseventh
+isixth
+ispan
+isplit-at
+itake
+itake-right
+itake-while
+itenth
+ithird
+itree->gtree
+itree->tree
+iunfold
+iunfold-right
+iunzip1
+iunzip2
+iunzip3
+iunzip4
+iunzip5
+izip
+last-ipair
+list->ilist
+make-ilist
+not-ipair?
+null-ilist?
+pair->ipair
+proper-ilist?
+replace-icar
+replace-icdr
+tree->itree
+xipair
diff --git a/srfi-117-procs b/srfi-117-procs
new file mode 100644
index 0000000..07f290d
--- /dev/null
+++ b/srfi-117-procs
@@ -0,0 +1,23 @@
+list-queue
+list-queue-add-back!
+list-queue-add-front!
+list-queue-append
+list-queue-append!
+list-queue-back
+list-queue-concatenate
+list-queue-copy
+list-queue-empty?
+list-queue-first-last
+list-queue-for-each
+list-queue-front
+list-queue-list
+list-queue-map
+list-queue-map!
+list-queue-remove-all!
+list-queue-remove-back!
+list-queue-remove-front!
+list-queue-set-list!
+list-queue-unfold
+list-queue-unfold-right
+list-queue?
+make-list-queue
diff --git a/srfi-127-procs b/srfi-127-procs
new file mode 100644
index 0000000..0efa53f
--- /dev/null
+++ b/srfi-127-procs
@@ -0,0 +1,29 @@
+generator->lseq
+lseq->generator
+lseq-any
+lseq-append
+lseq-car
+lseq-cdr
+lseq-drop
+lseq-drop-while
+lseq-every
+lseq-filter
+lseq-find
+lseq-find-tail
+lseq-first
+lseq-for-each
+lseq-index
+lseq-length
+lseq-map
+lseq-member
+lseq-memq
+lseq-memv
+lseq-realize
+lseq-ref
+lseq-remove
+lseq-rest
+lseq-take
+lseq-take-while
+lseq-zip
+lseq=?
+lseq?
diff --git a/srfi-13-procs b/srfi-13-procs
new file mode 100644
index 0000000..a65da98
--- /dev/null
+++ b/srfi-13-procs
@@ -0,0 +1,86 @@
+check-substring-spec
+kmp-step
+let-string-start+end
+make-kmp-restart-vector
+reverse-list->string
+string->list
+string-any
+string-append/shared
+string-ci<
+string-ci<=
+string-ci<>
+string-ci=
+string-ci>
+string-ci>=
+string-compare
+string-compare-ci
+string-concatenate
+string-concatenate-reverse
+string-concatenate-reverse/shared
+string-concatenate/shared
+string-contains
+string-contains-ci
+string-copy
+string-copy!
+string-count
+string-delete
+string-downcase
+string-downcase!
+string-drop
+string-drop-right
+string-every
+string-fill!
+string-filter
+string-fold
+string-fold-right
+string-for-each
+string-for-each-index
+string-hash
+string-hash-ci
+string-index
+string-index-right
+string-join
+string-kmp-partial-search
+string-map
+string-map!
+string-null?
+string-pad
+string-pad-right
+string-parse-final-start+end
+string-parse-start+end
+string-prefix-ci?
+string-prefix-length
+string-prefix-length-ci
+string-prefix?
+string-replace
+string-reverse
+string-reverse!
+string-skip
+string-skip-right
+string-suffix-ci?
+string-suffix-length
+string-suffix-length-ci
+string-suffix?
+string-tabulate
+string-take
+string-take-right
+string-titlecase
+string-titlecase!
+string-tokenize
+string-trim
+string-trim-both
+string-trim-right
+string-unfold
+string-unfold-right
+string-upcase
+string-upcase!
+string-xcopy!
+string<
+string<=
+string<>
+string=
+string>
+string>=
+substring-spec-ok?
+substring/shared
+xsubstring
diff --git a/srfi-41-procs b/srfi-41-procs
new file mode 100644
index 0000000..2b3a034
--- /dev/null
+++ b/srfi-41-procs
@@ -0,0 +1,70 @@
+binary-tree-same-fringe?
+cardinal-numbers-stream
+define-stream
+even-numbers-stream
+file->stream
+hamming-sequence-stream
+list->stream
+natural-numbers-stream
+odd-numbers-stream
+port->stream
+prime-numbers-stream
+stream
+stream->list
+stream-and
+stream-any
+stream-append
+stream-assoc
+stream-car
+stream-cdr
+stream-concat
+stream-cons
+stream-drop
+stream-drop-while
+stream-equal?
+stream-every
+stream-filter
+stream-find
+stream-finds
+stream-fold
+stream-fold-one
+stream-fold-right
+stream-fold-right-one
+stream-for-each
+stream-from
+stream-insertion-sort
+stream-intersperse
+stream-iterate
+stream-lambda
+stream-length
+stream-let
+stream-map
+stream-match
+stream-max
+stream-maximum
+stream-member
+stream-merge
+stream-merge-sort
+stream-min
+stream-minimum
+stream-null
+stream-null?
+stream-occupied?
+stream-of
+stream-or
+stream-pair?
+stream-partition
+stream-permutations
+stream-quick-sort
+stream-range
+stream-ref
+stream-remove
+stream-reverse
+stream-scan
+stream-split
+stream-sum
+stream-unfold
+stream-unfolds
+stream-unique
+stream-zip
+stream?
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..a8a5e74
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,40 @@
+(module transducers-tests ()
+(import scheme (chicken base) (prefix srfi-1 s:) transducers test)
+
+(test-group
+ "transduce and build procedures"
+ (test '(1 2 3) (transduce/list (map identity) build/list '(1 2 3)))
+ (test '#(1 2 3) (transduce/vector (map identity) build/vector '#(1 2 3)))
+ (define (generator)
+ (let ((v 0)) (lambda () (if (= v 3) '#!eof (begin (set! v (add1 v)) v)))))
+ (test '(1 2 3) (transduce/generator (map identity) build/list (generator))))
+
+(test-group "transducers"
+(test "partition-every flushing"
+ '((1 2) (3))
+ (transduce/list (partition-every 2) build/list '(1 2 3)))
+
+(test "take-while early return"
+ '(0 1 2 3)
+ (transduce/list (take-while (lambda (x) (< x 4))) build/list (s:iota 10)))
+
+(test "early return then flushing"
+ '((0 1 2) (3))
+ (transduce/list
+ (compose (take-while (lambda (x) (< x 4)))
+ (partition-every 3))
+ build/list
+ (s:iota 10)))
+
+(test "flushing then early return"
+ '((0 1) (2 3))
+ (transduce/list
+ (compose (take-while (lambda (x) (< x 5)))
+ (partition-every 2)
+ (take-while (lambda (l) (< (car l) 4))))
+ build/list
+ (s:iota 10)))
+) ; test-group
+
+(test-exit)
+) ; module
diff --git a/transducers.egg b/transducers.egg
new file mode 100644
index 0000000..28a9296
--- /dev/null
+++ b/transducers.egg
@@ -0,0 +1,11 @@
+((synopsis "Composable transformations library")
+ (category lang-exts)
+ (license "…") ; TODO
+ (author "Adrien (Kooda) Ramos")
+ (test-dependencies test)
+ (components
+ (extension transducers
+ (source-dependencies "transducers.impl.scm")
+ (csc-options -O3)
+ (types-file)
+ (inline-file))))
diff --git a/transducers.impl.scm b/transducers.impl.scm
new file mode 100644
index 0000000..466c27e
--- /dev/null
+++ b/transducers.impl.scm
@@ -0,0 +1,276 @@
+;;; Transducer makers in clojure
+;; + map
+;; + cat (concatenate)
+;; + mapcat (append-map)
+;; + filter
+;; + remove
+;; + take
+;; + take-while
+;; + take-nth
+;; + drop
+;; + drop-while
+;; - replace
+;; - partition-by
+;; + partition-all (partition-every)
+;; - keep
+;; - keep-indexed
+;; - map-indexed
+;; - distinct
+;; + interpose (intersperse)
+;; + dedupe (delete-duplicates)
+;; + random-sample
+
+;;; Procedures from eggs
+;; - ./srfi-1-procs
+;; - ./srfi-13-procs
+;; - ./srfi-41-procs
+;; - ./srfi-113-procs
+;; - ./srfi-116-procs
+;; - ./srfi-117-procs
+;; - ./srfi-127-procs
+;; - ./arrays-procs
+;; - ./dyn-vector-procs
+;; - ./iset-procs
+;; - ./lazy-seq-procs
+
+;;; Additionnal transducers libraries
+;; - https://github.com/cgrand/xforms
+
+;;; Reduced markers
+
+(define-record-type reduced-value
+ (reduced value)
+ reduced?
+ (value extract-reduced))
+
+(define (ensure-reduced x)
+ (if (reduced? x) x (reduced x)))
+
+(define (unreduced x)
+ (if (reduced? x) (extract-reduced x) x))
+
+;;; Transducers
+
+(define (unit) values)
+
+(define (map proc)
+ (lambda (step finalize)
+ (values (lambda (r x) (step r (proc x)))
+ finalize)))
+
+(define (concatenate)
+ (lambda (step finalize)
+ (values (lambda (r x) (foldl step r x))
+ finalize)))
+
+(define (append-map proc)
+ (compose (map proc) (concatenate)))
+
+(define (filter pred?)
+ (lambda (step finalize)
+ (values (lambda (r x) (if (pred? x) (step r x) r))
+ finalize)))
+
+(define (filter-map proc)
+ (compose (map proc) (filter identity)))
+
+(define (remove pred?)
+ (filter (lambda (x) (not (pred? x)))))
+
+(define (delete object #!optional (= equal?))
+ (remove (lambda (x) (= x object))))
+
+(define (take n)
+ (lambda (step finalize)
+ (values
+ (lambda (r x)
+ (if (positive? n)
+ (begin (set! n (sub1 n)) (step r x))
+ (reduced r)))
+ finalize)))
+
+(define (take-while pred?)
+ (lambda (step finalize)
+ (values (lambda (r x) (if (pred? x) (step r x) (reduced r)))
+ finalize)))
+
+(define (take-nth n)
+ (lambda (step finalize)
+ (let ((i -1))
+ (values (lambda (r x)
+ (set! i (add1 i))
+ (if (zero? (modulo i n))
+ (step r x)
+ r))
+ finalize))))
+
+(define (drop n)
+ (lambda (step finalize)
+ (values (lambda (r x)
+ (if (zero? n)
+ (step r x)
+ (begin
+ (set! n (sub1 n))
+ r)))
+ finalize)))
+
+(define (drop-while pred?)
+ (lambda (step finalize)
+ (let ((dropping #t))
+ (values (lambda (r x)
+ (if (and dropping
+ (pred? x))
+ r
+ (begin
+ (set! dropping #f)
+ (step r x))))
+ finalize))))
+
+(define (partition-every n)
+ (lambda (step finalize)
+ (let ((acc '()))
+ (values (lambda (r x)
+ (set! acc (cons x acc))
+ (if (= n (length acc))
+ (let ((val (reverse acc)))
+ (set! acc '())
+ (step r val))
+ r))
+ (lambda (r)
+ (if (null? acc)
+ (finalize r)
+ (let ((val (reverse acc)))
+ (set! acc '())
+ (finalize (unreduced (step r val))))))))))
+
+(define (intersperse separator)
+ (lambda (step finalize)
+ (let ((started #f))
+ (values (lambda (r x)
+ (if started
+ (let ((next (step r separator)))
+ (if (reduced? next)
+ next
+ (step next x)))
+ (begin
+ (set! started #t)
+ (step r x))))
+ finalize))))
+
+(define (delete-duplicates #!optional (= equal?))
+ (lambda (step finalize)
+ (let ((last (gensym)))
+ (values (lambda (r x)
+ (if (= x last)
+ r
+ (begin
+ (set! last x)
+ (step r x))))
+ finalize))))
+
+(define (random-sample probability)
+ (lambda (step finalize)
+ (values (lambda (r x)
+ (if (<= (pseudo-random-real) probability)
+ (step r x)
+ r))
+ finalize)))
+
+;;; Building procedures
+
+(define build/list
+ (case-lambda
+ (() '())
+ ((l) (reverse l)) ; TODO use reverse! ?
+ ((l x) (cons x l))))
+
+(define build/vector
+ (case-lambda
+ (() '())
+ ((l) (list->vector (reverse l))) ; TODO use reverse-list->vector ?
+ ((l x) (cons x l))))
+
+; TODO build/string
+; TODO build/XXXvector (SRFI-4)
+; TODO build/generator
+
+;;; Transducing processes
+
+(define transduce/list
+ (case-lambda
+ ((xf kons list)
+ (transduce/list xf kons (kons) list))
+ ((xf kons init list)
+ (let-values (((step finalize) (xf kons kons)))
+ (let lp ((result init)
+ (rest list))
+ (if (or (null? rest)
+ (reduced? result))
+ (finalize (unreduced result))
+ (lp (step result (car rest))
+ (cdr rest))))))))
+
+(define (make-vector-like-transduce length ref)
+ (letrec ((this-transduce
+ (case-lambda
+ ((xf kons vec-like)
+ (this-transduce xf kons (kons) vec-like))
+ ((xf kons init vec-like)
+ (let-values (((step finalize) (xf kons kons))
+ ((len) (length vec-like)))
+ (let lp ((i 0)
+ (result init))
+ (if (or (= i len)
+ (reduced? result))
+ (finalize (unreduced result))
+ (lp (add1 i) (step result (ref vec-like i))))))))))
+ this-transduce))
+
+(define transduce/string
+ (make-vector-like-transduce string-length string-ref))
+
+(define transduce/vector
+ (make-vector-like-transduce vector-length vector-ref))
+
+(define transduce/u8vector
+ (make-vector-like-transduce u8vector-length u8vector-ref))
+
+(define transduce/s8vector
+ (make-vector-like-transduce s8vector-length s8vector-ref))
+
+(define transduce/u16vector
+ (make-vector-like-transduce u16vector-length u16vector-ref))
+
+(define transduce/s16vector
+ (make-vector-like-transduce s16vector-length s16vector-ref))
+
+(define transduce/u32vector
+ (make-vector-like-transduce u32vector-length u32vector-ref))
+
+(define transduce/s32vector
+ (make-vector-like-transduce s32vector-length s32vector-ref))
+
+(define transduce/u64vector
+ (make-vector-like-transduce u64vector-length u64vector-ref))
+
+(define transduce/s64vector
+ (make-vector-like-transduce s64vector-length s64vector-ref))
+
+(define transduce/f32vector
+ (make-vector-like-transduce f32vector-length f32vector-ref))
+
+(define transduce/f64vector
+ (make-vector-like-transduce f64vector-length f64vector-ref))
+
+(define transduce/generator
+ (case-lambda
+ ((xf kons gen)
+ (transduce/generator xf kons (kons) gen))
+ ((xf kons init gen)
+ (let-values (((step finalize) (xf kons kons)))
+ (let lp ((result init))
+ (let ((val (gen)))
+ (if (or (eof-object? val)
+ (reduced? result))
+ (finalize (unreduced result))
+ (lp (step result val)))))))))
diff --git a/transducers.scm b/transducers.scm
new file mode 100644
index 0000000..325c3d7
--- /dev/null
+++ b/transducers.scm
@@ -0,0 +1,50 @@
+(module
+ transducers
+ (reduced-value
+ reduced
+ reduced?
+ extract-reduced
+ ensure-reduced
+ unreduced
+
+ unit
+ map
+ concatenate
+ append-map
+ filter
+ filter-map
+ remove
+ delete
+ take
+ take-while
+ take-nth
+ drop
+ drop-while
+ partition-every
+ intersperse
+ delete-duplicates
+ random-sample
+
+ build/list
+ build/vector
+
+ transduce/list
+ transduce/string
+ transduce/vector
+ transduce/u8vector
+ transduce/s8vector
+ transduce/u16vector
+ transduce/s16vector
+ transduce/u32vector
+ transduce/s32vector
+ transduce/u64vector
+ transduce/s64vector
+ transduce/f32vector
+ transduce/f64vector
+ transduce/generator)
+ (import
+ (except scheme map)
+ (except (chicken base) intersperse)
+ (chicken random)
+ srfi-4)
+ (include "transducers.impl.scm"))