mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
adding (srfi 121)
This commit is contained in:
Alex Shinn
parent
eb79e98d20
commit
dc3283a13b
3 changed files with 514 additions and 0 deletions
39
lib/srfi/121.sld
Normal file
39
lib/srfi/121.sld
Normal file
|
|
@ -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"))
|
||||
352
lib/srfi/121/generators.scm
Normal file
352
lib/srfi/121/generators.scm
Normal file
|
|
@ -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))
|
||||
123
lib/srfi/121/test.sld
Normal file
123
lib/srfi/121/test.sld
Normal file
|
|
@ -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))))
|
||||
Loading…
Add table
Reference in a new issue