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