adding (srfi 121)

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"))

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))

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))))