mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
Implement SRFI 158.
This commit is contained in:
Marc Nieper-Wißkirchen
parent
9100909ae1
commit
15b3449b85
4 changed files with 875 additions and 0 deletions
583
lib/srfi/158.scm
Normal file
583
lib/srfi/158.scm
Normal file
|
|
@ -0,0 +1,583 @@
|
|||
;; Chibi Scheme version of any
|
||||
|
||||
(define (any pred ls)
|
||||
(if (null? (cdr ls))
|
||||
(pred (car ls))
|
||||
((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls)))))
|
||||
|
||||
;; list->bytevector
|
||||
(define (list->bytevector list)
|
||||
(let ((vec (make-bytevector (length list) 0)))
|
||||
(let loop ((i 0) (list list))
|
||||
(if (null? list)
|
||||
vec
|
||||
(begin
|
||||
(bytevector-u8-set! vec i (car list))
|
||||
(loop (+ i 1) (cdr list)))))))
|
||||
|
||||
|
||||
;; generator
|
||||
(define (generator . args)
|
||||
(lambda () (if (null? args)
|
||||
(eof-object)
|
||||
(let ((next (car args)))
|
||||
(set! args (cdr args))
|
||||
next))))
|
||||
|
||||
;; circular-generator
|
||||
(define (circular-generator . args)
|
||||
(let ((base-args args))
|
||||
(lambda ()
|
||||
(when (null? args)
|
||||
(set! args base-args))
|
||||
(let ((next (car args)))
|
||||
(set! args (cdr args))
|
||||
next))))
|
||||
|
||||
|
||||
;; make-iota-generator
|
||||
(define make-iota-generator
|
||||
(case-lambda ((count) (make-iota-generator count 0 1))
|
||||
((count start) (make-iota-generator count start 1))
|
||||
((count start step) (make-iota count start step))))
|
||||
|
||||
;; make-iota
|
||||
(define (make-iota count start step)
|
||||
(lambda ()
|
||||
(cond
|
||||
((<= count 0)
|
||||
(eof-object))
|
||||
(else
|
||||
(let ((result start))
|
||||
(set! count (- count 1))
|
||||
(set! start (+ start step))
|
||||
result)))))
|
||||
|
||||
|
||||
;; make-range-generator
|
||||
(define make-range-generator
|
||||
(case-lambda ((start end) (make-range-generator start end 1))
|
||||
((start) (make-infinite-range-generator start))
|
||||
((start end step)
|
||||
(set! start (- (+ start step) step))
|
||||
(lambda () (if (< start end)
|
||||
(let ((v start))
|
||||
(set! start (+ start step))
|
||||
v)
|
||||
(eof-object))))))
|
||||
|
||||
(define (make-infinite-range-generator start)
|
||||
(lambda ()
|
||||
(let ((result start))
|
||||
(set! start (+ start 1))
|
||||
result)))
|
||||
|
||||
|
||||
|
||||
;; make-coroutine-generator
|
||||
(define (make-coroutine-generator proc)
|
||||
(define return #f)
|
||||
(define resume #f)
|
||||
(define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v)))))
|
||||
(lambda () (call/cc (lambda (cc) (set! return cc)
|
||||
(if resume
|
||||
(resume (if #f #f)) ; void? or yield again?
|
||||
(begin (proc yield)
|
||||
(set! resume (lambda (v) (return (eof-object))))
|
||||
(return (eof-object))))))))
|
||||
|
||||
|
||||
;; list->generator
|
||||
(define (list->generator lst)
|
||||
(lambda () (if (null? lst)
|
||||
(eof-object)
|
||||
(let ((next (car lst)))
|
||||
(set! lst (cdr lst))
|
||||
next))))
|
||||
|
||||
|
||||
;; vector->generator
|
||||
(define vector->generator
|
||||
(case-lambda ((vec) (vector->generator vec 0 (vector-length vec)))
|
||||
((vec start) (vector->generator vec start (vector-length vec)))
|
||||
((vec start end)
|
||||
(lambda () (if (>= start end)
|
||||
(eof-object)
|
||||
(let ((next (vector-ref vec start)))
|
||||
(set! start (+ start 1))
|
||||
next))))))
|
||||
|
||||
|
||||
;; reverse-vector->generator
|
||||
(define reverse-vector->generator
|
||||
(case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec)))
|
||||
((vec start) (reverse-vector->generator vec start (vector-length vec)))
|
||||
((vec start end)
|
||||
(lambda () (if (>= start end)
|
||||
(eof-object)
|
||||
(let ((next (vector-ref vec (- end 1))))
|
||||
(set! end (- end 1))
|
||||
next))))))
|
||||
|
||||
|
||||
;; string->generator
|
||||
(define string->generator
|
||||
(case-lambda ((str) (string->generator str 0 (string-length str)))
|
||||
((str start) (string->generator str start (string-length str)))
|
||||
((str start end)
|
||||
(lambda () (if (>= start end)
|
||||
(eof-object)
|
||||
(let ((next (string-ref str start)))
|
||||
(set! start (+ start 1))
|
||||
next))))))
|
||||
|
||||
|
||||
;; bytevector->generator
|
||||
(define bytevector->generator
|
||||
(case-lambda ((str) (bytevector->generator str 0 (bytevector-length str)))
|
||||
((str start) (bytevector->generator str start (bytevector-length str)))
|
||||
((str start end)
|
||||
(lambda () (if (>= start end)
|
||||
(eof-object)
|
||||
(let ((next (bytevector-u8-ref str start)))
|
||||
(set! start (+ start 1))
|
||||
next))))))
|
||||
|
||||
|
||||
;; make-for-each-generator
|
||||
;FIXME: seems to fail test
|
||||
(define (make-for-each-generator for-each obj)
|
||||
(make-coroutine-generator (lambda (yield) (for-each yield obj))))
|
||||
|
||||
|
||||
;; make-unfold-generator
|
||||
(define (make-unfold-generator stop? mapper successor seed)
|
||||
(make-coroutine-generator (lambda (yield)
|
||||
(let loop ((s seed))
|
||||
(if (stop? s)
|
||||
(if #f #f)
|
||||
(begin (yield (mapper s))
|
||||
(loop (successor s))))))))
|
||||
|
||||
|
||||
;; gcons*
|
||||
(define (gcons* . args)
|
||||
(lambda () (if (null? args)
|
||||
(eof-object)
|
||||
(if (= (length args) 1)
|
||||
((car args))
|
||||
(let ((v (car args)))
|
||||
(set! args (cdr args))
|
||||
v)))))
|
||||
|
||||
|
||||
;; gappend
|
||||
(define (gappend . args)
|
||||
(lambda () (if (null? args)
|
||||
(eof-object)
|
||||
(let loop ((v ((car args))))
|
||||
(if (eof-object? v)
|
||||
(begin (set! args (cdr args))
|
||||
(if (null? args)
|
||||
(eof-object)
|
||||
(loop ((car args)))))
|
||||
v)))))
|
||||
|
||||
;; gflatten
|
||||
(define (gflatten gen)
|
||||
(let ((state '()))
|
||||
(lambda ()
|
||||
(if (null? state) (set! state (gen)))
|
||||
(if (eof-object? state)
|
||||
state
|
||||
(let ((obj (car state)))
|
||||
(set! state (cdr state))
|
||||
obj)))))
|
||||
|
||||
;; ggroup
|
||||
(define ggroup
|
||||
(case-lambda
|
||||
((gen k)
|
||||
(simple-ggroup gen k))
|
||||
((gen k padding)
|
||||
(padded-ggroup (simple-ggroup gen k) k padding))))
|
||||
|
||||
(define (simple-ggroup gen k)
|
||||
(lambda ()
|
||||
(let loop ((item (gen)) (result '()) (count (- k 1)))
|
||||
(if (eof-object? item)
|
||||
(if (null? result) item (reverse result))
|
||||
(if (= count 0)
|
||||
(reverse (cons item result))
|
||||
(loop (gen) (cons item result) (- count 1)))))))
|
||||
|
||||
(define (padded-ggroup gen k padding)
|
||||
(lambda ()
|
||||
(let ((item (gen)))
|
||||
(if (eof-object? item)
|
||||
item
|
||||
(let ((len (length item)))
|
||||
(if (= len k)
|
||||
item
|
||||
(append item (make-list (- k len) padding))))))))
|
||||
|
||||
;; gmerge
|
||||
(define gmerge
|
||||
(case-lambda
|
||||
((<) (error "wrong number of arguments for gmerge"))
|
||||
((< gen) gen)
|
||||
((< genleft genright)
|
||||
(let ((left (genleft))
|
||||
(right (genright)))
|
||||
(lambda ()
|
||||
(cond
|
||||
((and (eof-object? left) (eof-object? right))
|
||||
left)
|
||||
((eof-object? left)
|
||||
(let ((obj right)) (set! right (genright)) obj))
|
||||
((eof-object? right)
|
||||
(let ((obj left)) (set! left (genleft)) obj))
|
||||
((< right left)
|
||||
(let ((obj right)) (set! right (genright)) obj))
|
||||
(else
|
||||
(let ((obj left)) (set! left (genleft)) obj))))))
|
||||
((< . gens)
|
||||
(apply gmerge <
|
||||
(let loop ((gens gens) (gs '()))
|
||||
(cond ((null? gens) (reverse gs))
|
||||
((null? (cdr gens)) (reverse (cons (car gens) gs)))
|
||||
(else (loop (cddr gens)
|
||||
(cons (gmerge < (car gens) (cadr gens)) gs)))))))))
|
||||
|
||||
;; gmap
|
||||
(define gmap
|
||||
(case-lambda
|
||||
((proc) (error "wrong number of arguments for gmap"))
|
||||
((proc gen)
|
||||
(lambda ()
|
||||
(let ((item (gen)))
|
||||
(if (eof-object? item) item (proc item)))))
|
||||
((proc . gens)
|
||||
(lambda ()
|
||||
(let ((items (map (lambda (x) (x)) gens)))
|
||||
(if (any eof-object? items) (eof-object) (apply proc items)))))))
|
||||
|
||||
;; gcombine
|
||||
(define (gcombine proc seed . gens)
|
||||
(lambda ()
|
||||
(define items (map (lambda (x) (x)) gens))
|
||||
(if (any eof-object? items)
|
||||
(eof-object)
|
||||
(let ()
|
||||
(define-values (value newseed) (apply proc (append items (list seed))))
|
||||
(set! seed newseed)
|
||||
value))))
|
||||
|
||||
;; gfilter
|
||||
(define (gfilter pred gen)
|
||||
(lambda () (let loop ()
|
||||
(let ((next (gen)))
|
||||
(if (or (eof-object? next)
|
||||
(pred next))
|
||||
next
|
||||
(loop))))))
|
||||
|
||||
;; gstate-filter
|
||||
(define (gstate-filter proc seed gen)
|
||||
(let ((state seed))
|
||||
(lambda ()
|
||||
(let loop ((item (gen)))
|
||||
(if (eof-object? item)
|
||||
item
|
||||
(let-values (((yes newstate) (proc item state)))
|
||||
(set! state newstate)
|
||||
(if yes
|
||||
item
|
||||
(loop (gen)))))))))
|
||||
|
||||
|
||||
|
||||
;; gremove
|
||||
(define (gremove pred gen)
|
||||
(gfilter (lambda (v) (not (pred v))) gen))
|
||||
|
||||
|
||||
|
||||
;; gtake
|
||||
(define gtake
|
||||
(case-lambda ((gen k) (gtake gen k (eof-object)))
|
||||
((gen k padding)
|
||||
(make-coroutine-generator (lambda (yield)
|
||||
(if (> k 0)
|
||||
(let loop ((i 0) (v (gen)))
|
||||
(begin (if (eof-object? v) (yield padding) (yield v))
|
||||
(if (< (+ 1 i) k)
|
||||
(loop (+ 1 i) (gen))
|
||||
(eof-object))))
|
||||
(eof-object)))))))
|
||||
|
||||
|
||||
|
||||
;; gdrop
|
||||
(define (gdrop gen k)
|
||||
(lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen))
|
||||
(gen)))
|
||||
|
||||
|
||||
|
||||
;; gdrop-while
|
||||
(define (gdrop-while pred gen)
|
||||
(define found #f)
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ((val (gen)))
|
||||
(cond (found val)
|
||||
((and (not (eof-object? val)) (pred val)) (loop))
|
||||
(else (set! found #t) val))))))
|
||||
|
||||
|
||||
;; gtake-while
|
||||
(define (gtake-while pred gen)
|
||||
(lambda () (let ((next (gen)))
|
||||
(if (eof-object? next)
|
||||
next
|
||||
(if (pred next)
|
||||
next
|
||||
(begin (set! gen (generator))
|
||||
(gen)))))))
|
||||
|
||||
|
||||
|
||||
;; gdelete
|
||||
(define gdelete
|
||||
(case-lambda ((item gen) (gdelete item gen equal?))
|
||||
((item gen ==)
|
||||
(lambda () (let loop ((v (gen)))
|
||||
(cond
|
||||
((eof-object? v) (eof-object))
|
||||
((== item v) (loop (gen)))
|
||||
(else v)))))))
|
||||
|
||||
|
||||
|
||||
;; gdelete-neighbor-dups
|
||||
(define gdelete-neighbor-dups
|
||||
(case-lambda ((gen)
|
||||
(gdelete-neighbor-dups gen equal?))
|
||||
((gen ==)
|
||||
(define firsttime #t)
|
||||
(define prev #f)
|
||||
(lambda () (if firsttime
|
||||
(begin (set! firsttime #f)
|
||||
(set! prev (gen))
|
||||
prev)
|
||||
(let loop ((v (gen)))
|
||||
(cond
|
||||
((eof-object? v)
|
||||
v)
|
||||
((== prev v)
|
||||
(loop (gen)))
|
||||
(else
|
||||
(set! prev v)
|
||||
v))))))))
|
||||
|
||||
|
||||
;; gindex
|
||||
(define (gindex value-gen index-gen)
|
||||
(let ((done? #f) (count 0))
|
||||
(lambda ()
|
||||
(if done?
|
||||
(eof-object)
|
||||
(let loop ((value (value-gen)) (index (index-gen)))
|
||||
(cond
|
||||
((or (eof-object? value) (eof-object? index))
|
||||
(set! done? #t)
|
||||
(eof-object))
|
||||
((= index count)
|
||||
(set! count (+ count 1))
|
||||
value)
|
||||
(else
|
||||
(set! count (+ count 1))
|
||||
(loop (value-gen) index))))))))
|
||||
|
||||
|
||||
;; gselect
|
||||
(define (gselect value-gen truth-gen)
|
||||
(let ((done? #f))
|
||||
(lambda ()
|
||||
(if done?
|
||||
(eof-object)
|
||||
(let loop ((value (value-gen)) (truth (truth-gen)))
|
||||
(cond
|
||||
((or (eof-object? value) (eof-object? truth))
|
||||
(set! done? #t)
|
||||
(eof-object))
|
||||
(truth value)
|
||||
(else (loop (value-gen) (truth-gen)))))))))
|
||||
|
||||
;; generator->list
|
||||
(define generator->list
|
||||
(case-lambda ((gen n)
|
||||
(generator->list (gtake gen n)))
|
||||
((gen)
|
||||
(reverse (generator->reverse-list gen)))))
|
||||
|
||||
;; generator->reverse-list
|
||||
(define generator->reverse-list
|
||||
(case-lambda ((gen n)
|
||||
(generator->reverse-list (gtake gen n)))
|
||||
((gen)
|
||||
(generator-fold cons '() gen))))
|
||||
|
||||
;; generator->vector
|
||||
(define generator->vector
|
||||
(case-lambda ((gen) (list->vector (generator->list gen)))
|
||||
((gen n) (list->vector (generator->list gen n)))))
|
||||
|
||||
|
||||
;; generator->vector!
|
||||
(define (generator->vector! vector at gen)
|
||||
(let loop ((value (gen)) (count 0) (at at))
|
||||
(cond
|
||||
((eof-object? value) count)
|
||||
((>= at (vector-length vector)) count)
|
||||
(else (begin
|
||||
(vector-set! vector at value)
|
||||
(loop (gen) (+ count 1) (+ at 1)))))))
|
||||
|
||||
|
||||
;; generator->string
|
||||
(define generator->string
|
||||
(case-lambda ((gen) (list->string (generator->list gen)))
|
||||
((gen n) (list->string (generator->list gen n)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; generator-fold
|
||||
(define (generator-fold f seed . gs)
|
||||
(define (inner-fold seed)
|
||||
(let ((vs (map (lambda (g) (g)) gs)))
|
||||
(if (any eof-object? vs)
|
||||
seed
|
||||
(inner-fold (apply f (append vs (list seed)))))))
|
||||
(inner-fold seed))
|
||||
|
||||
|
||||
|
||||
;; generator-for-each
|
||||
(define (generator-for-each f . gs)
|
||||
(let loop ()
|
||||
(let ((vs (map (lambda (g) (g)) gs)))
|
||||
(if (any eof-object? vs)
|
||||
(if #f #f)
|
||||
(begin (apply f vs)
|
||||
(loop))))))
|
||||
|
||||
|
||||
(define (generator-map->list f . gs)
|
||||
(let loop ((result '()))
|
||||
(let ((vs (map (lambda (g) (g)) gs)))
|
||||
(if (any eof-object? vs)
|
||||
(reverse result)
|
||||
(loop (cons (apply f vs) result))))))
|
||||
|
||||
|
||||
;; generator-find
|
||||
(define (generator-find pred g)
|
||||
(let loop ((v (g)))
|
||||
; A literal interpretation might say it only terminates on #eof if (pred #eof) but I think this makes more sense...
|
||||
(if (or (pred v) (eof-object? v))
|
||||
v
|
||||
(loop (g)))))
|
||||
|
||||
|
||||
;; generator-count
|
||||
(define (generator-count pred g)
|
||||
(generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g))
|
||||
|
||||
|
||||
;; generator-any
|
||||
(define (generator-any pred g)
|
||||
(let loop ((v (g)))
|
||||
(if (eof-object? v)
|
||||
#f
|
||||
(if (pred v)
|
||||
#t
|
||||
(loop (g))))))
|
||||
|
||||
|
||||
;; generator-every
|
||||
(define (generator-every pred g)
|
||||
(let loop ((v (g)))
|
||||
(if (eof-object? v)
|
||||
#t
|
||||
(if (pred v)
|
||||
(loop (g))
|
||||
#f ; the spec would have me return #f, but I think it must simply be wrong...
|
||||
))))
|
||||
|
||||
|
||||
;; generator-unfold
|
||||
(define (generator-unfold g unfold . args)
|
||||
(apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args))
|
||||
|
||||
|
||||
;; make-accumulator
|
||||
(define (make-accumulator kons knil finalize)
|
||||
(let ((state knil))
|
||||
(lambda (obj)
|
||||
(if (eof-object? obj)
|
||||
(finalize state)
|
||||
(set! state (kons obj state))))))
|
||||
|
||||
|
||||
;; count-accumulator
|
||||
(define (count-accumulator) (make-accumulator
|
||||
(lambda (obj state) (+ 1 state)) 0 (lambda (x) x)))
|
||||
|
||||
;; list-accumulator
|
||||
(define (list-accumulator) (make-accumulator cons '() reverse))
|
||||
|
||||
;; reverse-list-accumulator
|
||||
(define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x)))
|
||||
|
||||
;; vector-accumulator
|
||||
(define (vector-accumulator)
|
||||
(make-accumulator cons '() (lambda (x) (list->vector (reverse x)))))
|
||||
|
||||
;; reverse-vector-accumulator
|
||||
(define (reverse-vector-accumulator)
|
||||
(make-accumulator cons '() list->vector))
|
||||
|
||||
;; vector-accumulator!
|
||||
(define (vector-accumulator! vec at)
|
||||
(lambda (obj)
|
||||
(if (eof-object? obj)
|
||||
vec
|
||||
(begin
|
||||
(vector-set! vec at obj)
|
||||
(set! at (+ at 1))))))
|
||||
|
||||
;; bytevector-accumulator
|
||||
(define (bytevector-accumulator)
|
||||
(make-accumulator cons '() (lambda (x) (list->bytevector (reverse x)))))
|
||||
|
||||
(define (bytevector-accumulator! bytevec at)
|
||||
(lambda (obj)
|
||||
(if (eof-object? obj)
|
||||
bytevec
|
||||
(begin
|
||||
(bytevector-u8-set! bytevec at obj)
|
||||
(set! at (+ at 1))))))
|
||||
|
||||
;; string-accumulator
|
||||
(define (string-accumulator)
|
||||
(make-accumulator cons '()
|
||||
(lambda (lst) (list->string (reverse lst)))))
|
||||
|
||||
;; sum-accumulator
|
||||
(define (sum-accumulator) (make-accumulator + 0 (lambda (x) x)))
|
||||
|
||||
;; product-accumulator
|
||||
(define (product-accumulator) (make-accumulator * 1 (lambda (x) x)))
|
||||
23
lib/srfi/158.sld
Normal file
23
lib/srfi/158.sld
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
(define-library (srfi 158)
|
||||
(import (scheme base))
|
||||
(import (scheme case-lambda))
|
||||
(export generator circular-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)
|
||||
(export gcons* gappend gcombine gfilter gremove
|
||||
gtake gdrop gtake-while gdrop-while
|
||||
gflatten ggroup gmerge gmap gstate-filter
|
||||
gdelete gdelete-neighbor-dups gindex gselect)
|
||||
(export generator->list generator->reverse-list
|
||||
generator->vector generator->vector! generator->string
|
||||
generator-fold generator-map->list generator-for-each generator-find
|
||||
generator-count generator-any generator-every generator-unfold)
|
||||
(export make-accumulator count-accumulator list-accumulator
|
||||
reverse-list-accumulator vector-accumulator
|
||||
reverse-vector-accumulator vector-accumulator!
|
||||
string-accumulator bytevector-accumulator bytevector-accumulator!
|
||||
sum-accumulator product-accumulator)
|
||||
(include "158.scm")
|
||||
)
|
||||
267
lib/srfi/158/test.sld
Normal file
267
lib/srfi/158/test.sld
Normal file
|
|
@ -0,0 +1,267 @@
|
|||
(define-library (srfi 158 test)
|
||||
(import (scheme base)
|
||||
(scheme read)
|
||||
(srfi 1)
|
||||
(srfi 158)
|
||||
(chibi test))
|
||||
(export run-tests)
|
||||
(begin
|
||||
(define (with-input-from-string str thunk)
|
||||
(parameterize ((current-input-port (open-input-string str)))
|
||||
(thunk)))
|
||||
(define g
|
||||
(make-coroutine-generator
|
||||
(lambda (yield) (let loop ((i 0))
|
||||
(when (< i 3) (yield i) (loop (+ i 1)))))))
|
||||
(define (for-each-digit proc n)
|
||||
(when (> n 0)
|
||||
(let-values (((div rem) (truncate/ n 10)))
|
||||
(proc rem)
|
||||
(for-each-digit proc div))))
|
||||
(define g1 (generator 1 2 3))
|
||||
(define g2 (generator 4 5 6 7))
|
||||
(define (proc . args) (values (apply + args) (apply + args)))
|
||||
(define (small? x) (< x 3))
|
||||
(define n 0)
|
||||
(define (run-tests)
|
||||
(test-group "generators"
|
||||
(test-group "generators/constructors"
|
||||
(test '() (generator->list (generator)))
|
||||
(test '(1 2 3) (generator->list (generator 1 2 3)))
|
||||
(test '(1 2 3 1 2) (generator->list (circular-generator 1 2 3) 5))
|
||||
(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) (generator->list (make-range-generator 3) 4))
|
||||
(test '(3 4 5 6 7) (generator->list (make-range-generator 3 8)))
|
||||
(test '(3 5 7) (generator->list (make-range-generator 3 8 2)))
|
||||
|
||||
(test '(0 1 2) (generator->list g))
|
||||
(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 '#(0 0 1 2 4)
|
||||
(let ((v (make-vector 5 0)))
|
||||
(generator->vector! v 2 (generator 1 2 4))
|
||||
v))
|
||||
(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)))
|
||||
) ; end "generators/constructors"
|
||||
|
||||
(test-group "generators/operators"
|
||||
(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 proc 10 g1 g2)))
|
||||
(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))))
|
||||
(set! 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)))
|
||||
(set! g (make-range-generator 1 5))
|
||||
(test '(1 2) (generator->list (gtake-while small? g)))
|
||||
(set! g (make-range-generator 1 5))
|
||||
(test '(3 4) (generator->list (gdrop-while small? g)))
|
||||
(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 '(1 2 3 a b c)
|
||||
(generator->list
|
||||
(gflatten (generator '(1 2 3) '(a b c)))))
|
||||
(test '((1 2 3) (4 5 6) (7 8))
|
||||
(generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3)))
|
||||
(test '((1 2 3) (4 5 6) (7 8 0))
|
||||
(generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3 0)))
|
||||
(test '(1 2 3)
|
||||
(generator->list (gmerge < (generator 1 2 3))))
|
||||
(test '(1 2 3 4 5 6)
|
||||
(generator->list (gmerge < (generator 1 2 3) (generator 4 5 6))))
|
||||
(test '(1 2 3 4 4 5 6)
|
||||
(generator->list (gmerge <
|
||||
(generator 1 2 4 6)
|
||||
(generator)
|
||||
(generator 3 4 5))))
|
||||
(test '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
|
||||
(generator->list (gmerge <
|
||||
(generator 1 10 11)
|
||||
(generator 2 9 12)
|
||||
(generator 3 8 13)
|
||||
(generator 4 7 14)
|
||||
(generator 5 6 15))))
|
||||
;; check the tie-break rule
|
||||
(test '((1 a) (1 e) (1 b) (1 c) (1 d))
|
||||
(generator->list (gmerge (lambda (x y) (< (car x) (car y)))
|
||||
(generator '(1 a) '(1 e))
|
||||
(generator '(1 b))
|
||||
(generator '(1 c) '(1 d)))))
|
||||
|
||||
(test '(-1 -2 -3 -4 -5)
|
||||
(generator->list (gmap - (generator 1 2 3 4 5))))
|
||||
(test '(7 9 11 13)
|
||||
(generator->list (gmap +
|
||||
(generator 1 2 3 4 5)
|
||||
(generator 6 7 8 9))))
|
||||
(test '(54 140 264)
|
||||
(generator->list (gmap *
|
||||
(generator 1 2 3 4 5)
|
||||
(generator 6 7 8)
|
||||
(generator 9 10 11 12 13))))
|
||||
(test '(a c e g i)
|
||||
(generator->list
|
||||
(gstate-filter
|
||||
(lambda (item state) (values (even? state) (+ 1 state)))
|
||||
0
|
||||
(generator 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j))))
|
||||
) ; end "generators/operators"
|
||||
|
||||
|
||||
(test-group "generators/consumers"
|
||||
;; no test for plain generator->list (used throughout)
|
||||
(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) (with-input-from-string "a b c d e"
|
||||
(lambda () (generator-fold cons 'z read))))
|
||||
|
||||
(generator-for-each (lambda values (set! n (apply + values)))
|
||||
(generator 1) (generator 2) (generator 3))
|
||||
(test 6 n)
|
||||
(test '(6 15)
|
||||
(generator-map->list (lambda values (apply + values))
|
||||
(generator 1 4) (generator 2 5) (generator 3 6)))
|
||||
(test 3 (generator-find (lambda (x) (> x 2)) (make-range-generator 1 5)))
|
||||
(test 2 (generator-count odd? (make-range-generator 1 5)))
|
||||
(set! g (make-range-generator 2 5))
|
||||
(test #t (generator-any odd? g))
|
||||
(test '(4) (generator->list g))
|
||||
(set! 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))
|
||||
|
||||
) ; end "generators/consumers"
|
||||
|
||||
) ; end "generators"
|
||||
|
||||
|
||||
(test-group "accumulators"
|
||||
(test -8
|
||||
(let ((a (make-accumulator * 1 -)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test 3
|
||||
(let ((a (count-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '(1 2 4)
|
||||
(let ((a (list-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '(4 2 1)
|
||||
(let ((a (reverse-list-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '#(1 2 4)
|
||||
(let ((a (vector-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '#(0 0 1 2 4)
|
||||
(let* ((v (vector 0 0 0 0 0))
|
||||
(a (vector-accumulator! v 2)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '#u8(0 0 1 2 4)
|
||||
(let* ((v (bytevector 0 0 0 0 0))
|
||||
(a (bytevector-accumulator! v 2)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test '#(4 2 1)
|
||||
(let ((a (reverse-vector-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test "abc"
|
||||
(let ((a (string-accumulator)))
|
||||
(a #\a)
|
||||
(a #\b)
|
||||
(a #\c)
|
||||
(a (eof-object))))
|
||||
|
||||
(test #u8(1 2 4)
|
||||
(let ((a (bytevector-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test 7
|
||||
(let ((a (sum-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
(test 8
|
||||
(let ((a (product-accumulator)))
|
||||
(a 1)
|
||||
(a 2)
|
||||
(a 4)
|
||||
(a (eof-object))))
|
||||
|
||||
) ; end "accumulators"
|
||||
|
||||
)))
|
||||
|
|
@ -28,6 +28,7 @@
|
|||
(rename (srfi 134 test) (run-tests run-srfi-134-tests))
|
||||
(rename (srfi 139 test) (run-tests run-srfi-139-tests))
|
||||
(rename (srfi 151 test) (run-tests run-srfi-151-tests))
|
||||
(rename (srfi 158 test) (run-tests run-srfi-158-tests))
|
||||
(rename (srfi 160 test) (run-tests run-srfi-160-tests))
|
||||
(rename (chibi base64-test) (run-tests run-base64-tests))
|
||||
(rename (chibi bytevector-test) (run-tests run-bytevector-tests))
|
||||
|
|
@ -91,6 +92,7 @@
|
|||
(run-srfi-134-tests)
|
||||
(run-srfi-139-tests)
|
||||
(run-srfi-151-tests)
|
||||
(run-srfi-158-tests)
|
||||
(run-srfi-160-tests)
|
||||
(run-base64-tests)
|
||||
(run-bytevector-tests)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue