From 560f4299261e95854473d3b6aaf7cf1ec04d1f65 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 8 Feb 2017 22:23:06 +1300 Subject: [PATCH] Adding SRFI 121 support, tests, all tests pass --- srfi/121.scm | 370 ++++++++++++++++++++++++++++++ srfi/121.sld | 28 +++ tests/srfi-121-tests.scm | 152 ++++++++++++ tests/srfi-41-primitive-tests.scm | 33 +++ 4 files changed, 583 insertions(+) create mode 100644 srfi/121.scm create mode 100644 srfi/121.sld create mode 100644 tests/srfi-121-tests.scm create mode 100644 tests/srfi-41-primitive-tests.scm diff --git a/srfi/121.scm b/srfi/121.scm new file mode 100644 index 00000000..5670f7ae --- /dev/null +++ b/srfi/121.scm @@ -0,0 +1,370 @@ +#| + | Copyright (c) 2016 John Cowan + | Copyright (c) 2017 Koz Ross + | + | Permission is hereby granted, free of charge, to any person obtaining a copy of + | this software and associated documentation files (the "Software"), to deal in + | the Software without restriction, including without limitation the rights to + | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of + | the Software, and to permit persons to whom the Software is furnished to do so, + | subject to the following conditions: + | + | The above copyright notice and this permission notice shall be included in all + | copies or substantial portions of the Software. + | + | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS + | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR + | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER + | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + |# + +(define (any pred ls) + (cond + ((null? ls) #f) + ((pred (car ls)) #t) + (else (any pred (cdr ls))))) + +(define (every pred ls) + (not (any (lambda (x) (not (pred x)))) ls)) + +(define (generator . args) + (lambda () + (if (null? args) + (eof-object) + (let ((next (car args))) + (set! args (cdr args)) + next)))) + +(define make-iota-generator + (case-lambda + ((count) (make-iota-generator count 0 1)) + ((count start) (make-iota-generator count start 1)) + ((count start step) (make-iota count start step)))) + +(define (make-iota count start step) + (lambda () + (if (<= count 0) ;; in case someone passes a negative count + (eof-object) + (let ((result start)) + (set! count (- count 1)) + (set! start (+ start step)) + result)))) + +(define make-range-generator + (case-lambda + ((start) (make-infinite-range start)) + ((start end) (make-range-generator start end 1)) + ((start end step) (make-range start end step)))) + +(define (make-range start end step) + (set! start (- (+ start step) step)) + (lambda () + (if (< start end) + (let ((v start)) + (set! start (+ start step)) + v) + (eof-object)))) + +(define (make-infinite-range start) + (lambda () + (let ((result start)) + (set! start (+ start 1)) + result))) + +(define (make-coroutine-generator proc) + (define return #f) + (define resume #f) + (define yield (lambda (v) + (call/cc (lambda (r) + (set! resume r) (return v))))) + (lambda () + (call/cc (lambda (cc) (set! return cc) + (if resume + (resume (if #f #f)) ;; call resume with undefined + (begin (proc yield) + (set! resume (lambda (v) (return (eof-object)))) + (return (eof-object)))))))) + +(define (list->generator lst) + (lambda () + (if (null? lst) + (eof-object) + (let ((next (car lst))) + (set! lst (cdr lst)) + next)))) + +;; NOTE: This, and similar, functions, should really be macro'd away. +(define vector->generator + (case-lambda + ((vec) (vector->generator vec 0 (vector-length vec))) + ((vec start) (vector->generator vec start (vector-length vec))) + ((vec start end) + (lambda () + (if (>= start end) + (eof-object) + (let ((next (vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define reverse-vector->generator + (case-lambda + ((vec) (reverse-vector->generator vec 0 (vector-length vec))) + ((vec start) (reverse-vector->generator vec start (vector-length vec))) + ((vec start end) + (lambda () + (if (>= start end) + (eof-object) + (let ((next (vector-ref vec (- end 1)))) + (set! end (- end 1)) + next)))))) + +;; NOTE: Under UTF-8 semantics, this is O(n^2) rather than O(n) +;; Should be rewritten using cursors or something +(define string->generator + (case-lambda + ((str) (string->generator str 0 (string-length str))) + ((str start) (string->generator str start (string-length str))) + ((str start end) + (lambda () + (if (>= start end) + (eof-object) + (let ((next (string-ref str start))) + (set! start (+ start 1)) + next)))))) + +(define bytevector->generator + (case-lambda + ((str) (bytevector->generator str 0 (bytevector-length str))) + ((str start) (bytevector->generator str start (bytevector-length str))) + ((str start end) + (lambda () + (if (>= start end) + (eof-object) + (let ((next (bytevector-u8-ref str start))) + (set! start (+ start 1)) + next)))))) + +(define (make-for-each-generator for-each obj) + (make-coroutine-generator (lambda (yield) (for-each yield obj)))) + +(define (make-unfold-generator stop? mapper successor seed) + (make-coroutine-generator (lambda (yield) + (let loop ((s seed)) + (if (stop? s) + (if #f #f) + (begin (yield (mapper s)) + (loop (successor s)))))))) + +(define (gcons* . args) + (lambda () + (cond + ((null? args) (eof-object)) + ((null? (cdr args)) ((car args))) + (else (let ((v (car args))) + (set! args (cdr args)) + v))))) + +(define (gappend . args) + (lambda () + (if (null? args) + (eof-object) + (let loop ((v ((car args)))) + (if (eof-object? v) + (begin (set! args (cdr args)) + (if (null? args) + (eof-object) + (loop ((car args))))) + v))))) + +(define (gcombine proc seed . gens) + (lambda () + (define items (map (lambda (x) (x)) gens)) + (if (any eof-object? items) + (eof-object) + (begin + (receive (value newseed) (apply proc (append items (list seed))) + (set! seed newseed) + value))))) + +(define (gfilter pred gen) + (lambda () + (let loop () + (let ((next (gen))) + (if (or (eof-object? next) + (pred next)) + next + (loop)))))) + +(define (gremove pred gen) + (gfilter (lambda (v) (not (pred v))) gen)) + +(define gtake + (case-lambda + ((gen k) (gtake gen k (eof-object))) + ((gen k padding) + (make-coroutine-generator + (lambda (yield) + (if (> k 0) + (let loop ((i 0) (v (gen))) + (begin + (if (eof-object? v) (yield padding) (yield v)) + (if (< (+ 1 i) k) + (loop (+ 1 i) (gen)) + (eof-object)))) + (eof-object))))))) + + +(define (gdrop gen k) + (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen)) + (gen))) + +(define (gdrop-while pred gen) + (define found #f) + (lambda () + (let loop () + (let ((val (gen))) + (cond (found val) + ((and (not (eof-object? val)) (pred val)) (loop)) + (else (set! found #t) val)))))) + +(define (gtake-while pred gen) + (lambda () + (let ((next (gen))) + (if (eof-object? next) + next + (if (pred next) + next + (begin (set! gen (generator)) + (gen))))))) + +(define gdelete + (case-lambda + ((item gen) (gdelete item gen equal?)) + ((item gen ==) + (lambda () + (let loop ((v (gen))) + (cond + ((eof-object? v) (eof-object)) + ((== item v) (loop (gen))) + (else v))))))) + +(define gdelete-neighbor-dups + (case-lambda + ((gen) (gdelete-neighbor-dups gen equal?)) + ((gen ==) + (define firsttime #t) + (define prev #f) + (lambda () + (if firsttime + (begin (set! firsttime #f) + (set! prev (gen)) + prev) + (let loop ((v (gen))) + (cond + ((eof-object? v) + v) + ((== prev v) + (loop (gen))) + (else + (set! prev v) + v)))))))) + +(define (gindex value-gen index-gen) + (let ((done? #f) (count 0)) + (lambda () + (if done? + (eof-object) + (let loop ((value (value-gen)) (index (index-gen))) + (cond + ((or (eof-object? value) (eof-object? index)) + (set! done? #t) + (eof-object)) + ((= index count) + (set! count (+ count 1)) + value) + (else + (set! count (+ count 1)) + (loop (value-gen) index)))))))) + +(define (gselect value-gen truth-gen) + (let ((done? #f)) + (lambda () + (if done? + (eof-object) + (let loop ((value (value-gen)) (truth (truth-gen))) + (cond + ((or (eof-object? value) (eof-object? truth)) + (set! done? #t) + (eof-object)) + (truth value) + (else (loop (value-gen) (truth-gen))))))))) + +(define generator->list + (case-lambda + ((gen n) (generator->list (gtake gen n))) + ((gen) (reverse (generator->reverse-list gen))))) + +(define generator->reverse-list + (case-lambda + ((gen n) (generator->reverse-list (gtake gen n))) + ((gen) (generator-fold cons '() gen)))) + +(define generator->vector + (case-lambda + ((gen) (list->vector (generator->list gen))) + ((gen n) (list->vector (generator->list gen n))))) + +(define (generator->vector! vector at gen) + (let loop ((value (gen)) (count 0) (at at)) + (cond + ((eof-object? value) count) + ((>= at (vector-length vector)) count) + (else (begin + (vector-set! vector at value) + (loop (gen) (+ count 1) (+ at 1))))))) + +(define generator->string + (case-lambda + ((gen) (list->string (generator->list gen))) + ((gen n) (list->string (generator->list gen n))))) + +(define (generator-fold f seed . gs) + (define (inner-fold seed) + (let ((vs (map (lambda (g) (g)) gs))) + (if (any eof-object? vs) + seed + (inner-fold (apply f (append vs (list seed))))))) + (inner-fold seed)) + +(define (generator-for-each f . gs) + (let loop () + (let ((vs (map (lambda (g) (g)) gs))) + (if (any eof-object? vs) + (if #f #f) + (begin (apply f vs) + (loop)))))) + +(define (generator-find pred g) + (let loop ((v (g))) + (cond + ((pred v) v) + ((eof-object? v) #f) + (else (loop (g)))))) + +(define (generator-count pred g) + (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g)) + +(define (generator-any pred g) + (let loop ((v (g))) + (cond + ((eof-object? v) #f) + ((pred v) #t) + (else (loop (g)))))) + +(define (generator-every pred g) + (not (generator-any (lambda (x) (not (pred x))) g))) + +(define (generator-unfold g unfold . args) + (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args)) diff --git a/srfi/121.sld b/srfi/121.sld new file mode 100644 index 00000000..4558e615 --- /dev/null +++ b/srfi/121.sld @@ -0,0 +1,28 @@ +;;;; Cyclone Scheme +;;;; https://github.com/justinethier/cyclone +;;;; +;;;; Copyright (c) 2014-2017, Justin Ethier +;;;; Copyright (c) 2017, Koz Ross +;;;; +;;;; This module is an interface to the Generators library. +(define-library + (srfi 121) + (import + (scheme base) + (scheme case-lambda)) + (export + generator make-iota-generator make-range-generator + make-coroutine-generator list->generator vector->generator + reverse-vector->generator string->generator + bytevector->generator + make-for-each-generator make-unfold-generator) + (export + gcons* gappend gcombine gfilter gremove + gtake gdrop gtake-while gdrop-while + gdelete gdelete-neighbor-dups gindex gselect) + (export + generator->list generator->reverse-list + generator->vector generator->vector! generator->string + generator-fold generator-for-each generator-find + generator-count generator-any generator-every generator-unfold) + (include "121.scm")) diff --git a/tests/srfi-121-tests.scm b/tests/srfi-121-tests.scm new file mode 100644 index 00000000..963ea127 --- /dev/null +++ b/tests/srfi-121-tests.scm @@ -0,0 +1,152 @@ +#| + | Copyright (c) 2017 Koz Ross + | + | Permission is hereby granted, free of charge, to any person obtaining a copy of + | this software and associated documentation files (the "Software"), to deal in + | the Software without restriction, including without limitation the rights to + | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of + | the Software, and to permit persons to whom the Software is furnished to do so, + | subject to the following conditions: + | + | The above copyright notice and this permission notice shall be included in all + | copies or substantial portions of the Software. + | + | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS + | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR + | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER + | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + |# + +(import + (scheme base) + (srfi 121) + (only (srfi 1) unfold) + (scheme cyclone test)) + +(define g + (make-coroutine-generator + (lambda (yield) + (let loop ((i 0)) + (when (< i 3) + (yield i) + (loop (+ i 1))))))) + +(define (for-each-digit proc n) + (when (> n 0) + (receive (div rem) (truncate/ n 10) + (proc rem) + (for-each-digit proc div)))) + +(test-group + "generator constructors" + (test '() (generator->list (generator))) + (test '(1 2 3) (generator->list (generator 1 2 3))) + (test '(8 9 10) (generator->list (make-iota-generator 3 8))) + (test '(8 10 12) (generator->list (make-iota-generator 3 8 2))) + (test '(3 4 5 6) (generator->list (make-range-generator 3) 4)) + (test '(3 4 5 6 7) (generator->list (make-range-generator 3 8))) + (test '(3 5 7) (generator->list (make-range-generator 3 8 2))) + (test '(0 1 2) (generator->list g)) + (test '(1 2 3 4 5) + (generator->list (list->generator (list 1 2 3 4 5)))) + (test '(1 2 3 4 5) + (generator->list (vector->generator (vector 1 2 3 4 5)))) + (test '(5 4 3 2 1) + (generator->list (reverse-vector->generator (vector 1 2 3 4 5)))) + (test '(#\a #\b #\c #\d #\e) + (generator->list (string->generator "abcde"))) + (test '(10 20 30) + (generator->list (bytevector->generator (bytevector 10 20 30)))) + (test '(5 4 3 2 1) + (generator->list (make-for-each-generator for-each-digit 12345))) + (test '(0 2 4 6 8 10) + (generator->list + (make-unfold-generator (lambda (s) (> s 5)) + (lambda (s) (* s 2)) + (lambda (s) (+ s 1)) + 0)))) + +(define g (make-range-generator 1 5)) + +(define g1 (generator 1 2 3)) + +(define g2 (generator 4 5 6 7)) + +(define (proc . args) + (values (apply + args) (apply + args))) + +(define (small? x) (< x 3)) + +(test-group + "generator operators" + (test '(a b 0 1) + (generator->list (gcons* 'a 'b (make-range-generator 0 2)))) + (test '(0 1 2 0 1) + (generator->list (gappend (make-range-generator 0 3) + (make-range-generator 0 2)))) + (test '() (generator->list (gappend))) + (test '(15 22 31) (generator->list (gcombine proc 10 g1 g2))) + (test '(1 3 5 7 9) + (generator->list (gfilter odd? (make-range-generator 1 11)))) + (test '(2 4 6 8 10) + (generator->list (gremove odd? (make-range-generator 1 11)))) + (test '(1 2 3) (generator->list (gtake g 3))) + (test '(4) (generator->list g)) + (test '(1 2) + (generator->list (gtake (make-range-generator 1 3) 3))) + (test '(1 2 0) + (generator->list (gtake (make-range-generator 1 3) 3 0))) + (test '(3 4) + (generator->list (gdrop (make-range-generator 1 5) 2))) + (set! g (make-range-generator 1 5)) + (test '(1 2) (generator->list (gtake-while small? g))) + (set! g (make-range-generator 1 5)) + (test '(3 4) (generator->list (gdrop-while small? g))) + (test '() + (generator->list (gdrop-while (lambda args #t) (generator 1 2 3)))) + (test '(0.0 1.0 0 2) + (generator->list (gdelete 1 (generator 0.0 1.0 0 1 2)))) + (test '(0.0 0 2) + (generator->list (gdelete 1 (generator 0.0 1.0 0 1 2) =))) + (test '(a c e) + (generator->list (gindex (list->generator '(a b c d e f)) + (list->generator '(0 2 4))))) + (test '(a d e) + (generator->list (gselect (list->generator '(a b c d e f)) + (list->generator '(#t #f #f #t #t #f))))) + (test '(1 2 3) + (generator->list (gdelete-neighbor-dups (generator 1 1 2 2 3 3) =))) + (test '(1) + (generator->list (gdelete-neighbor-dups (generator 1 2 3) + (lambda args #t))))) + +(define n 0) + +(test-group + "generator consumers" + (test '(1 2 3) (generator->list (generator 1 2 3 4 5) 3)) + (test '(5 4 3 2 1) (generator->reverse-list (generator 1 2 3 4 5))) + (test #(1 2 3 4 5) (generator->vector (generator 1 2 3 4 5))) + (test #(1 2 3) (generator->vector (generator 1 2 3 4 5) 3)) + (test "abc" (generator->string (generator #\a #\b #\c))) + (test 10 (generator-fold + 0 (generator 1 2 3 4))) + (generator-for-each (lambda v (set! n (apply + v))) + (generator 1) + (generator 2) + (generator 3)) + (test 6 n) + (test 3 (generator-find (lambda (x) (> x 2)) (make-range-generator 1 5))) + (test 2 (generator-count odd? (make-range-generator 1 5))) + (set! g (make-range-generator 2 5)) + (test-assert (generator-any odd? g)) + (test '(4) (generator->list g)) + (set! g (make-range-generator 2 5)) + (test-not (generator-every odd? g)) + (test '(3 4) (generator->list g)) + (test '(#\a #\b #\c) + (generator-unfold (make-for-each-generator string-for-each + "abc") unfold))) + +(test-exit) diff --git a/tests/srfi-41-primitive-tests.scm b/tests/srfi-41-primitive-tests.scm new file mode 100644 index 00000000..3844bb2a --- /dev/null +++ b/tests/srfi-41-primitive-tests.scm @@ -0,0 +1,33 @@ +(import + (scheme base) + (srfi 41 primitive) + (scheme cyclone test)) + +(test-group + "srfi 41 (primitive)" + (define strm123 (stream-cons 1 (stream-cons 2 (stream-cons 3 stream-null)))) + (test 1 (stream-car strm123)) + (test 2 (stream-car (stream-cdr strm123))) + (test-not (stream-pair? (stream-cdr (stream-cons (/ 1 0) stream-null)))) + (test-not (stream? (list 1 2 3))) + + (define iter (stream-lambda (f x) + (stream-cons x (iter f (f x))))) + + (define nats (iter (lambda (x) (+ x 1)) 0)) + + (test 1 (stream-car (stream-cdr nats))) + + (define stream-add + (stream-lambda (s1 s2) + (stream-cons (+ (stream-car s1) (stream-car s2)) + (stream-add (stream-cdr s1) + (stream-cdr s2))))) + + (define evens (stream-add nats nats)) + + (test 0 (stream-car evens)) + (test 2 (stream-car (stream-cdr evens))) + (test 4 (stream-car (stream-cdr (stream-cdr evens))))) + +(test-exit)