diff --git a/lib/srfi/121.sld b/lib/srfi/121.sld new file mode 100644 index 00000000..03687bdf --- /dev/null +++ b/lib/srfi/121.sld @@ -0,0 +1,39 @@ +(define-library (srfi 121) + (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 + gcons* + gappend + gcombine + gfilter + gremove + gtake + gdrop + gtake-while + gdrop-while + gdelete + gdelete-neighbor-dups + gindex + gselect + 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) + (import (scheme base) (srfi 130)) + (include "121/generators.scm")) diff --git a/lib/srfi/121/generators.scm b/lib/srfi/121/generators.scm new file mode 100644 index 00000000..1e8e072f --- /dev/null +++ b/lib/srfi/121/generators.scm @@ -0,0 +1,352 @@ + +(define eof (read-char (open-input-string ""))) + +(define (list->generator ls) + (lambda () + (if (null? ls) + eof + (let ((res (car ls))) + (set! ls (cdr ls)) + res)))) + +(define (generator . elts) + (list->generator elts)) + +(define (make-iota-generator count . o) + (let ((val (if (pair? o) (car o) 0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)) + (i 0)) + (lambda () + (if (>= i count) + eof + (let ((res val)) + (set! val (+ val step)) + (set! i (+ i 1)) + res))))) + +(define (make-range-generator start . o) + (let ((end (if (pair? o) (car o) +inf.0)) + (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)) + (val start)) + (lambda () + (if (>= val end) + eof + (let ((res val)) + (set! val (+ val step)) + res))))) + +(define (make-coroutine-generator proc) + (let ((return #f) + (resume #f)) + (lambda () + (call-with-current-continuation + (lambda (outer) + (set! return outer) + (cond + (resume + (resume #f)) + (else + ;; first time + (proc (lambda (result) + (call-with-current-continuation + (lambda (inner) + (set! resume inner) + (return result))))) + ;; done + (set! resume (lambda (v) (return eof))) + (return eof)))))))) + +(define (vector->generator vec . o) + (let ((i (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec)))) + (lambda () + (if (>= i end) + eof + (let ((res (vector-ref vec i))) + (set! i (+ i 1)) + res))))) + +(define (reverse-vector->generator vec . o) + (let* ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))) + (i (- end 1))) + (lambda () + (if (< i start) + eof + (let ((res (vector-ref vec i))) + (set! i (- i 1)) + res))))) + +(define (string->generator str . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) + (let ((sc (string-index->cursor str start)) + (end-sc (string-index->cursor str end))) + (lambda () + (if (string-cursor>=? sc end-sc) + eof + (let ((res (string-ref/cursor str sc))) + (set! sc (string-cursor-next str sc)) + res)))))) + +(define (bytevector->generator bv . o) + (let ((i (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (bytevector-length bv)))) + (lambda () + (if (>= i end) + eof + (let ((res (bytevector-u8-ref bv i))) + (set! i (+ i 1)) + res))))) + +(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) + (lambda () + (if (stop? seed) + eof + (let ((res (mapper seed))) + (set! seed (successor seed)) + res)))) + +(define (gcons* . elts) + (if (null? elts) (error "gcons* requires at least one arg")) + (lambda () + (if (null? (cdr elts)) + ((car elts)) + (let ((res (car elts))) + (set! elts (cdr elts)) + res)))) + +(define (gappend . gens) + (define (g) + (if (null? gens) + eof + (let ((res ((car gens)))) + (cond + ((eof-object? res) + (set! gens (cdr gens)) + (g)) + (else + res))))) + g) + +(define (gcombine proc seed gen . o) + (if (null? o) + (lambda () + (call-with-values + (lambda () + (let ((elt (gen))) + (if (eof-object? elt) (values eof seed) (proc elt seed)))) + (lambda (res new-seed) + (set! seed new-seed) + res))) + (lambda () + (call-with-values + (lambda () + (let ((elts (cons (gen) (map (lambda (g) (g)) o)))) + (if (memq eof elts) + (values eof seed) + (apply proc (append elts (list seed)))))) + (lambda (res new-seed) + (set! seed new-seed) + res))))) + +(define (gfilter pred gen) + (define (g) + (let ((res (gen))) + (cond + ((eof-object? res) res) + ((pred res) res) + (else (g))))) + g) + +(define (gremove pred gen) + (gfilter (lambda (x) (not (pred x))) gen)) + +(define (gtake gen k . o) + (let ((pad? (pair? o)) + (pad (and (pair? o) (car o))) + (i 0)) + (lambda () + (if (>= i k) + eof + (let ((res (gen))) + (set! i (+ i 1)) + (if (and pad? (eof-object? res)) + pad + res)))))) + +(define (gdrop gen k) + (define (g) + (cond + ((<= k 0) (gen)) + (else (gen) (set! k (- k 1)) (g)))) + g) + +(define (gtake-while pred gen) + (let ((done? #f)) + (lambda () + (if done? + eof + (let ((res (gen))) + (cond + ((and (not (eof-object? res)) (pred res)) res) + (else (set! done? #t) eof))))))) + +(define (gdrop-while pred gen) + (define (g) + (let ((res (gen))) + (cond + ((eof-object? res) res) + ((pred res) (g)) + (else (set! pred (lambda (x) #f)) res)))) + g) + +(define (gdelete item gen . o) + (let ((eq (if (pair? o) (car o) equal?))) + (define (g) + (let ((res (gen))) + (cond + ((eof-object? res) res) + ((eq res item) (g)) + (else res)))) + g)) + +(define (gdelete-neighbor-dups gen . o) + (let ((eq (if (pair? o) (car o) equal?)) + (prev eof)) + (define (g) + (let ((res (gen))) + (cond + ((eof-object? res) + res) + ((and (not (eof-object? prev)) (eq res prev)) + (g)) + (else + (set! prev res) + res)))) + g)) + +(define (gindex value-gen index-gen) + (let ((index 0) + (next-index -1)) + (define (g) + (cond + ((> index next-index) + (let ((n (index-gen))) + (cond + ((eof-object? n) n) + (else + (if (<= n next-index) + (error "indexes must be monotonically increasing")) + (set! next-index n) + (g))))) + (else + (let ((value (value-gen)) + (keep? (= index next-index))) + (set! index (+ index 1)) + (cond + ((eof-object? value) value) + (keep? value) + (else (g))))))) + g)) + +(define (gselect value-gen truth-gen) + (define (g) + (let ((value (value-gen)) + (keep? (truth-gen))) + (cond + ((eof-object? value) value) + ((eof-object? keep?) keep?) + (keep? value) + (else (g))))) + g) + +(define (generator->reverse-list gen . o) + (let ((gen (if (pair? o) (gtake gen (car o)) gen))) + (let lp ((res '())) + (let ((elt (gen))) + (if (eof-object? elt) + res + (lp (cons elt res))))))) + +(define (generator->list gen . o) + (reverse (apply generator->reverse-list gen o))) + +(define (generator->vector gen . o) + (list->vector (generator->list (if (pair? o) (gtake gen (car o)) gen)))) + +(define (generator->vector! vec at gen) + (let ((len (vector-length vec))) + (let lp ((i at)) + (let ((elt (if (>= i len) eof (gen)))) + (cond + ((eof-object? elt) + (- len at)) + (else + (vector-set! vec i elt) + (lp (+ i 1)))))))) + +(define (generator->string gen . o) + (list->string (generator->list (if (pair? o) (gtake gen (car o)) gen)))) + +(define (generator-fold proc seed gen . o) + (if (null? o) + (let lp ((acc seed)) + (let ((elt (gen))) + (if (eof-object? elt) + acc + (lp (proc elt acc))))) + (let lp ((acc seed)) + (let ((elt (gen)) + (elts (map (lambda (g) (g)) o))) + (if (or (eof-object? elt) (memq eof elts)) + acc + (lp (apply proc elt (append elts (list acc))))))))) + +(define (generator-for-each proc gen . o) + (if (null? o) + (generator-fold (lambda (elt acc) (proc elt)) #f gen) + (let lp () + (let ((elt (gen)) + (elts (map (lambda (g) (g)) o))) + (unless (or (eof-object? elt) (memq eof elts)) + (apply proc elt elts) + (lp))))) + (if #f #f)) + +(define (generator-find pred gen) + (let lp () + (let ((elt (gen))) + (cond ((eof-object? elt) #f) + ((pred elt) elt) + (else (lp)))))) + +(define (generator-count pred gen) + (let lp ((count 0)) + (let ((elt (gen))) + (cond ((eof-object? elt) count) + ((pred elt) (lp (+ count 1))) + (else (lp count)))))) + +(define (generator-any pred gen) + (let lp () + (let ((elt (gen))) + (cond ((eof-object? elt) #f) + ((pred elt)) + (else (lp)))))) + +(define (generator-every pred gen) + (let lp () + (let ((elt (gen))) + (cond ((eof-object? elt) #t) + ((pred elt) (lp)) + (else #f))))) + +(define (generator-unfold gen unfold . args) + (apply unfold eof-object? values (lambda (x) (gen)) (gen) args)) diff --git a/lib/srfi/121/test.sld b/lib/srfi/121/test.sld new file mode 100644 index 00000000..90677c79 --- /dev/null +++ b/lib/srfi/121/test.sld @@ -0,0 +1,123 @@ +(define-library (srfi 121 test) + (export run-tests) + (import (scheme base) (scheme read) (srfi 1) (srfi 121) (chibi test)) + (begin + (define (run-tests) + (test-begin "srfi-121: generators") + + (test-group "generators/constructors" + (define (for-each-digit proc n) + (when (> n 0) + (let-values (((div rem) (truncate/ n 10))) + (proc rem) + (for-each-digit proc div)))) + (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 7) (generator->list (make-range-generator 3 8))) + (test '(3 4 5 6) (generator->list (make-range-generator 3) 4)) + (test '(3 5 7) (generator->list (make-range-generator 3 8 2))) + (test '(0 1 2) + (generator->list + (make-coroutine-generator + (lambda (yield) + (let lp ((i 0)) + (when (< i 3) (yield i) (lp (+ i 1)))))))) + (test '(1 2 3 4 5) (generator->list (list->generator '(1 2 3 4 5)))) + (test '(1 2 3 4 5) (generator->list (vector->generator '#(1 2 3 4 5)))) + (test '(5 4 3 2 1) + (generator->list (reverse-vector->generator '#(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))) + ) + + (test-group "generators/operators" + (define (small? x) (< x 3)) + (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 (lambda args (values (apply + args) (apply + args))) + 10 + (generator 1 2 3) + (generator 4 5 6 7)))) + (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)))) + (let ((g (make-range-generator 1 5))) + (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))) + (test '(1 2) + (generator->list (gtake-while small? (make-range-generator 1 5)))) + (test '(3 4) + (generator->list (gdrop-while small? (make-range-generator 1 5)))) + (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 3 3 3) + =))) + (test '(1) + (generator->list (gdelete-neighbor-dups + (generator 1 2 3) + (lambda args #t)))) + ) + + (test-group "generators/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 '(e d c b a . z) + (let ((in (open-input-string "a b c d e"))) + (generator-fold cons 'z (lambda () (read in))))) + (let ((n 0)) + (generator-for-each (lambda values (set! n (apply + values))) + (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))) + (let ((g (make-range-generator 2 5))) + (test #t (generator-any odd? g)) + (test '(4) (generator->list g))) + (let ((g (make-range-generator 2 5))) + (test #f (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-end))))