Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (srfi 127)

Browse source
This commit is contained in:
Alex Shinn 2018-01-15 23:15:14 +09:00
parent f8cc1402c2
commit b91022afea
4 changed files with 428 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

203
lib/srfi/127.scm Normal file
View file

@ -0,0 +1,203 @@
(define eof-object (read-char (open-input-string "")))
(define (generator->lseq gen)
(let ((val (gen)))
(if (eof-object? val)
'()
(cons val gen))))
(define lseq-car car)
(define lseq-first car)
(define (lseq-cdr lseq)
(if (procedure? (cdr lseq))
(let ((val ((cdr lseq))))
(cond
((eof-object? val)
(set-cdr! lseq '())
'())
(else
(let ((cell (cons val (cdr lseq))))
(set-cdr! lseq cell)
cell))))
(cdr lseq)))
(define lseq-rest lseq-cdr)
(define (lseq? x)
(if (pair? x)
(or (procedure? (cdr x))
(lseq? (cdr x)))
(null? x)))
(define (lseq=? eq lseq1 lseq2)
(let lp ((ls1 lseq1) (ls2 lseq2))
(cond
((null? ls1) (null? ls2))
((null? ls2) #f)
((eq (lseq-car ls1) (lseq-car ls2))
(lp (lseq-cdr ls1) (lseq-cdr ls2)))
(else #f))))
(define (lseq-drop lseq k)
(if (positive? k)
(lseq-drop (lseq-cdr lseq) (- k 1))
lseq))
(define (lseq-drop-while pred lseq)
(if (and (pair? lseq) (pred (lseq-car lseq)))
(lseq-drop-while pred (lseq-cdr lseq))
lseq))
(define (lseq-take lseq k)
(generator->lseq
(lambda ()
(if (positive? k)
(let ((val (lseq-car lseq)))
(set! lseq (lseq-cdr lseq))
(set! k (- k 1))
val)
eof-object))))
(define (lseq-take-while pred lseq)
(generator->lseq
(lambda ()
(if (and (pair? lseq) (pred (lseq-car lseq)))
(let ((val (lseq-car lseq)))
(set! lseq (lseq-cdr lseq))
val)
eof-object))))
(define (lseq-ref lseq k)
(lseq-first (lseq-drop lseq k)))
(define (lseq-realize lseq)
(let lp ((lseq lseq) (ls '()))
(if (null? lseq)
(reverse ls)
(lp (lseq-cdr lseq) (cons (lseq-car lseq) ls)))))
(define (lseq->generator lseq)
(lambda ()
(if (null? lseq)
eof-object
(let ((val (lseq-car lseq)))
(set! lseq (lseq-cdr lseq))
val))))
(define (lseq-length lseq)
(let lp ((lseq lseq) (len 0))
(if (null? lseq) len (lp (lseq-cdr lseq) (+ len 1)))))
(define (lseq-append . lseqs)
(if (every null? lseqs)
'()
(let ((lseq1 (car lseqs))
(ls (cdr lseqs)))
(define (gen)
(cond
((pair? lseq1)
(let ((val (lseq-car lseq1)))
(set! lseq1 (cdr lseq1))
val))
((pair? ls)
(set! lseq1 (car ls))
(set! ls (cdr ls))
(gen))
(else
eof-object)))
(generator->lseq gen))))
(define (lseq-zip . lseqs)
(generator->lseq
(lambda ()
(if (any null? lseqs)
eof-object
(let ((val (map lseq-car lseqs)))
(set! lseqs (map lseq-cdr lseqs))
val)))))
(define (lseq-map proc lseq . o)
(if (or (null? lseq) (any null? o))
'()
(let ((gen (lseq->generator lseq)))
(generator->lseq
(if (null? o)
(lambda ()
(let ((val (gen)))
(if (eof-object? val)
val
(proc val))))
(let ((gens (map lseq->generator o)))
(lambda ()
(let ((val (gen))
(vals (map (lambda (f) (f)) gens)))
(if (or (eof-object? val)
(any eof-object? vals))
eof-object
(apply proc val vals))))))))))
(define (lseq-for-each proc lseq . o)
(let lp ((lseq (apply lseq-map proc lseq o)))
(when (pair? lseq)
(lseq-car lseq)
(lp (lseq-cdr lseq)))))
(define (lseq-filter pred lseq)
(let ((gen (lseq->generator lseq)))
(define (filt)
(let ((val (gen)))
(if (or (eof-object? val) (pred val))
val
(filt))))
(generator->lseq filt)))
(define (lseq-remove pred lseq)
(lseq-filter (lambda (x) (not (pred x))) lseq))
(define (lseq-find-tail pred lseq)
(and (pair? lseq)
(if (pred (lseq-car lseq))
lseq
(lseq-find-tail pred (lseq-cdr lseq)))))
(define (lseq-find pred lseq)
(cond ((lseq-find-tail pred lseq) => lseq-car) (else #f)))
(define (lseq-any pred lseq . o)
(if (null? o)
(let any ((lseq lseq))
(and (pair? lseq)
(or (pred (lseq-car lseq))
(any (lseq-cdr lseq)))))
(let any ((lseqs (cons lseq o)))
(and (every pair? lseqs)
(or (apply pred (map lseq-car lseqs))
(any (map lseq-cdr lseqs)))))))
(define (lseq-every pred lseq . o)
(if (null? o)
(let every ((lseq lseq) (last #t))
(if (null? lseq)
last
(let ((val (pred (lseq-car lseq))))
(and val (every (lseq-cdr lseq) val)))))
(let every ((lseqs (cons lseq o)) (last #t))
(if (any null? lseqs)
last
(let ((val (apply pred (map lseq-car lseqs))))
(and val (every (map lseq-cdr lseqs) val)))))))
(define (lseq-index pred lseq . o)
(let ((i -1))
(and (apply lseq-any (lambda args (set! i (+ i 1)) (apply pred args)) lseq o)
i)))
(define (lseq-member elt lseq . o)
(let* ((eq (if (pair? o) (car o) equal?))
(res (lseq-drop-while (lambda (x) (not (eq x elt))) lseq)))
(and (pair? res) res)))
(define (lseq-memq elt lseq) (lseq-member elt lseq eq?))
(define (lseq-memv elt lseq) (lseq-member elt lseq eqv?))

26
lib/srfi/127.sld Normal file
View file

@ -0,0 +1,26 @@
(define-library (srfi 127)
(import (scheme base) (srfi 1))
(export
;; Constructors
generator->lseq
;; Predicates
lseq? lseq=?
;; Selectors
lseq-car lseq-cdr
lseq-first lseq-rest lseq-ref
lseq-take lseq-drop
;; The whole lazy sequence
lseq-realize lseq->generator
lseq-length
lseq-append lseq-zip
;; Mapping and filtering
lseq-map lseq-for-each
lseq-filter lseq-remove
;; Searching
lseq-find lseq-find-tail
lseq-any lseq-every
lseq-index
lseq-take-while lseq-drop-while
lseq-member lseq-memq lseq-memv)
(include "127.scm"))

197
lib/srfi/127/test.sld Normal file
View file

@ -0,0 +1,197 @@
(define-library (srfi 127 test)
(import (scheme base) (srfi 127) (chibi test))
(export run-tests)
(begin
;; Make-generator for tests cloned from SRFI 121
(define (make-generator . args)
(lambda ()
(if (null? args)
(eof-object)
(let ((next (car args)))
(set! args (cdr args))
next))))
;; Make-lseq creates an lseq, like list, but guarantees the use of
;; a generator.
(define (make-lseq . args)
(generator->lseq (apply make-generator args)))
(define (factorial n)
(cond
((< n 0) #f)
((= n 0) 1)
(else (* n (factorial (- n 1))))))
(define (run-tests)
(test-group "srfi-127: lseqs"
(test-group "lseqs/constructor"
(let ((one23 (make-lseq 1 2 3)))
(test 1 (car one23))
(test-assert (procedure? (cdr one23)))
(test '(1 2 3) (lseq-realize one23)))
)
(test-group "lseqs/predicates"
(test-assert (lseq? '()))
(test-assert (lseq? '(1 2 3)))
(test-assert (lseq? (make-lseq 1 2 3)))
(test-assert (lseq? (cons 'x (lambda () 'x))))
(test-assert (lseq=? = '() '()))
(test-assert (lseq=? = '(1 2 3) '(1 2 3)))
(test-assert (lseq=? = (make-lseq 1 2 3)
(make-lseq 1 2 3)))
(test-assert (lseq=? = (make-lseq 1 2 3) '(1 2 3)))
)
(test-group "lseqs/selectors"
(test-error (lseq-car (make-generator)))
(test 1 (lseq-car (make-lseq 1 2 3)))
(test 1 (lseq-car '(1 2 3)))
(test-error (lseq-car 2))
(test-error (lseq-first (make-generator)))
(test 1 (lseq-first (make-lseq 1 2 3)))
(test 1 (lseq-first '(1 2 3)))
(test-error (lseq-first 2))
(test-error (lseq-cdr (make-generator)))
(test 2 (lseq-cdr '(1 . 2)))
(test 2 (lseq-car (lseq-cdr '(1 2 3))))
(test 2 (lseq-car (lseq-cdr (make-lseq 1 2 3))))
(test-error (lseq-rest (make-generator)))
(test 2 (lseq-rest '(1 . 2)))
(test 2 (lseq-car (lseq-rest '(1 2 3))))
(test 2 (lseq-car (lseq-rest (make-lseq 1 2 3))))
(test-error (lseq-rest 2))
(test-error (lseq-ref '() 0))
(test 1 (lseq-ref '(1) 0))
(test 2 (lseq-ref '(1 2) 1))
(test-error (lseq-ref (make-lseq) 0))
(test 1 (lseq-ref (make-lseq 1) 0))
(test 1 (lseq-ref (make-lseq 1 2) 0))
(test 2 (lseq-ref (make-lseq 1 2) 1))
(test-error (lseq-take '() 1))
(test-error (lseq-take (make-lseq) 1))
(test-assert (procedure? (cdr (lseq-take '(1 2 3 4 5) 3)))) ; test laziness
(test '(1 2 3) (lseq-realize (lseq-take '(1 2 3 4 5) 3)))
(test-error (lseq-drop '() 1))
(test-error (lseq-drop (make-lseq 1) 2))
(test '(3 4 5) (lseq-realize (lseq-drop '(1 2 3 4 5) 2)))
(test '(3 4 5) (lseq-realize (lseq-drop (make-lseq 1 2 3 4 5) 2)))
)
(test-group "lseqs/whole"
(test '() (lseq-realize '()))
(test '(1 2 3) (lseq-realize '(1 2 3)))
(test '() (lseq-realize (make-lseq)))
(test '(1 2 3) (lseq-realize (make-lseq 1 2 3)))
(let ((g (lseq->generator '(1 2 3))))
(test 1 (g))
(test 2 (g))
(test 3 (g))
(test-assert (eof-object? (g))))
(let ((g (lseq->generator (make-lseq 1 2 3))))
(test 1 (g))
(test 2 (g))
(test 3 (g))
(test-assert (eof-object? (g))))
(test 0 (lseq-length '()))
(test 3 (lseq-length '(1 2 3)))
(test 3 (lseq-length (make-lseq 1 2 3)))
(test '(1 2 3 a b c) (lseq-realize (lseq-append '(1 2 3) '(a b c))))
(let ((one23abc (lseq-append (make-lseq 1 2 3) (make-lseq 'a 'b 'c))))
(test-assert (procedure? (cdr one23abc)))
(test-assert (lseq-realize one23abc)))
(let ((one2345 (make-lseq 1 2 3 4 5))
(oddeven (make-lseq 'odd 'even 'odd 'even 'odd 'even 'odd 'even)))
(test '((one 1 odd) (two 2 even) (three 3 odd))
(lseq-realize (lseq-zip '(one two three) one2345 oddeven))))
)
(test-group "lseqs/mapping"
(test '() (lseq-map - '()))
(test '(-1 -2 -3) (lseq-realize (lseq-map - '(1 2 3))))
(test '(-1 -2 -3) (lseq-realize (lseq-map - (make-lseq 1 2 3))))
(test-assert (procedure? (cdr (lseq-map - '(1 2 3)))))
(let* ((output '())
(out! (lambda (x) (set! output (cons x output)))))
(lseq-for-each out! '())
(test '() output)
(lseq-for-each out! '(a b c))
(test '(c b a) output)
(lseq-for-each out! (make-lseq 1 2 3))
(test '(3 2 1 c b a) output))
(test '() (lseq-filter odd? '()))
(let ((odds (lseq-filter odd? '(1 2 3 4 5))))
(test-assert (procedure? (cdr odds)))
(test '(1 3 5) (lseq-realize odds))
(test '(1 3 5) (lseq-realize (lseq-filter odd? (make-lseq 1 2 3 4 5)))))
(test '() (lseq-remove even? '()))
(let ((odds (lseq-remove even? '(1 2 3 4 5))))
(test-assert (procedure? (cdr odds)))
(test '(1 3 5) (lseq-realize odds))
(test '(1 3 5) (lseq-realize (lseq-remove even? (make-lseq 1 2 3 4 5))))))
(test-group "lseqs/searching"
(test 4 (lseq-find even? '(3 1 4 1 5 9 2 6)))
(test 4 (lseq-find even? (make-lseq 3 1 4 1 5 9 2 6)))
(test #f (lseq-find negative? (make-lseq 1 2 3 4 5)))
(test '(-8 -5 0 0) (lseq-realize (lseq-find-tail even? '(3 1 37 -8 -5 0 0))))
(test '(-8 -5 0 0) (lseq-realize (lseq-find-tail even?
(make-lseq 3 1 37 -8 -5 0 0))))
(test #f (lseq-find-tail even? '()))
(test #f (lseq-find-tail negative? (make-lseq 1 2 3 4 5)))
(test '(2 18) (lseq-realize (lseq-take-while even? '(2 18 3 10 22 9))))
(test '(2 18) (lseq-realize (lseq-take-while even?
(make-lseq 2 18 3 10 22 9))))
(test '(2 18) (lseq-realize (lseq-take-while even?
(make-lseq 2 18 3 10 22 9))))
(test '(3 10 22 9) (lseq-drop-while even? '(2 18 3 10 22 9)))
(test '(3 10 22 9) (lseq-realize (lseq-drop-while even?
(make-lseq 2 18 3 10 22 9))))
(test #t (lseq-any integer? '(a 3 b 2.7)))
(test #t (lseq-any integer? (make-lseq 'a 3 'b 2.7)))
(test #f (lseq-any integer? '(a 3.1 b 2.7)))
(test #f (lseq-any integer? (make-lseq 'a 3.1 'b 2.7)))
(test #t (lseq-any < '(3 1 4 1 5) '(2 7 1 8 2)))
(test 6 (lseq-any factorial '(-1 -2 3 4)))
(test 6 (lseq-any factorial (make-lseq -1 -2 3 4)))
(test 24 (lseq-every factorial '(1 2 3 4)))
(test 24 (lseq-every factorial (make-lseq 1 2 3 4)))
(test 2 (lseq-index even? '(3 1 4 1 5 9)))
(test 1 (lseq-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
(test #f (lseq-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
(test '(a b c) (lseq-realize (lseq-memq 'a '(a b c))))
(test '(a b c) (lseq-realize (lseq-memq 'a (make-lseq 'a 'b 'c))))
(test #f (lseq-memq 'a (make-lseq 'b 'c 'd)))
(test #f (lseq-memq (list 'a) '(b c d)))
(test #f (lseq-memq (list 'a) (make-lseq 'b 'c 'd)))
(test '(101 102) (lseq-realize (lseq-memv 101 (make-lseq 100 101 102))))
(test '((a) c) (lseq-realize (lseq-member (list 'a) (make-lseq 'b '(a) 'c))))
(test '(2 3) (lseq-realize (lseq-member 2.0 (make-lseq 1 2 3) =)))
)))
))

2
tests/lib-tests.scm
View file

@ -16,6 +16,7 @@
(rename (srfi 116 test) (run-tests run-srfi-116-tests))
(rename (srfi 117 test) (run-tests run-srfi-117-tests))
(rename (srfi 121 test) (run-tests run-srfi-121-tests))
(rename (srfi 127 test) (run-tests run-srfi-127-tests))
(rename (srfi 128 test) (run-tests run-srfi-128-tests))
(rename (srfi 129 test) (run-tests run-srfi-129-tests))
(rename (srfi 130 test) (run-tests run-srfi-130-tests))
@ -70,6 +71,7 @@
(run-srfi-116-tests)
(run-srfi-117-tests)
(run-srfi-121-tests)
(run-srfi-127-tests)
(run-srfi-128-tests)
(run-srfi-129-tests)
(run-srfi-130-tests)