chibi-scheme/lib/srfi/121/generators.scm

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