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

adding (srfi 133)

Browse source
This commit is contained in:
Alex Shinn 2017-03-31 00:48:35 +09:00
parent 67712e5624
commit 04ed6e1388
3 changed files with 433 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
lib/srfi/133.sld Normal file
View file

@ -0,0 +1,36 @@
(define-library (srfi 133)
(import (scheme base))
(export
;; Constructors
make-vector vector
vector-unfold vector-unfold-right
vector-copy vector-reverse-copy
vector-append vector-concatenate vector-append-subvectors
;; Predicates
vector?
vector-empty?
vector=
;; Selectors
vector-ref
vector-length
;; Iteration
vector-fold vector-fold-right
vector-map vector-map!
vector-for-each vector-count
vector-cumulate
;; Searching
vector-index vector-index-right
vector-skip vector-skip-right
vector-binary-search
vector-any vector-every
vector-partition
;; Mutators
vector-set! vector-swap!
vector-fill! vector-reverse!
vector-copy! vector-reverse-copy!
vector-unfold! vector-unfold-right!
;; Conversion
vector->list reverse-vector->list
list->vector reverse-list->vector
vector->string string->vector)
(include "133/vector.scm"))

176
lib/srfi/133/test.sld Normal file
View file

@ -0,0 +1,176 @@
(define-library (srfi 133 test)
(import (scheme base) (srfi 133) (chibi test))
(export run-tests)
(begin
(define (run-tests)
(test-group "vectors/constructors"
(test '#(0 1 2 3 4) (vector 0 1 2 3 4))
(test '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
(vector-unfold (lambda (i x) (values x (- x 1))) 10 0))
(test '#(0 1 2 3 4 5 6) (vector-unfold values 7))
(test '#((0 . 4) (1 . 3) (2 . 2) (3 . 1) (4 . 0))
(vector-unfold-right (lambda (i x) (values (cons i x) (+ x 1))) 5 0))
(define a2i '#(a b c d e f g h i))
(test a2i (vector-copy a2i))
(test-assert (not (eqv? a2i (vector-copy a2i))))
(test '#(g h i) (vector-copy a2i 6))
(test '#(d e f) (vector-copy a2i 3 6))
(test '#(1 2 3 4) (vector-reverse-copy '#(5 4 3 2 1 0) 1 5))
(test '#(x y) (vector-append '#(x) '#(y)))
(test '#(a b c d) (vector-append '#(a) '#(b c d)))
(test '#(a #(b) #(c)) (vector-append '#(a #(b)) '#(#(c))))
(test '#(a b c d) (vector-concatenate '(#(a b) #(c d))))
(test '#(a b h i) (vector-append-subvectors '#(a b c d e) 0 2 '#(f g h i j) 2 4))
)
(test-group "vectors/predicates"
(test #f (vector-empty? '#(a)))
(test #f (vector-empty? '#(())))
(test #f (vector-empty? '#(#())))
(test-assert (vector-empty? '#()))
(test-assert (vector= eq? '#(a b c d) '#(a b c d)))
(test #f (vector= eq? '#(a b c d) '#(a b d c)))
(test #f (vector= = '#(1 2 3 4 5) '#(1 2 3 4)))
(test-assert (vector= eq?))
(test-assert (vector= eq? '#(a)))
(test #f (vector= eq? (vector (vector 'a)) (vector (vector 'a))))
(test-assert (vector= equal? (vector (vector 'a)) (vector (vector 'a))))
)
(test-group "vectors/iteration"
(define vos '#("abc" "abcde" "abcd"))
(define vec '#(0 1 2 3 4 5))
(define vec2 (vector 0 1 2 3 4))
(define vec3 (vector 1 2 3 4 5))
(define result '())
(define (sqr x) (* x x))
(test 5 (vector-fold (lambda (len str) (max (string-length str) len))
0 vos))
(test '(5 4 3 2 1 0)
(vector-fold (lambda (tail elt) (cons elt tail)) '() vec))
(test 3 (vector-fold (lambda (ctr n) (if (even? n) (+ ctr 1) ctr)) 0 vec))
(test '(a b c d) (vector-fold-right (lambda (tail elt) (cons elt tail))
'() '#(a b c d)))
(test '#(1 4 9 16) (vector-map sqr '#(1 2 3 4)))
(test '#(5 8 9 8 5) (vector-map * '#(1 2 3 4 5) '#(5 4 3 2 1)))
(vector-map! sqr vec2)
(test '#(0 1 4 9 16) (vector-copy vec2))
(vector-map! * vec2 vec3)
(test '#(0 2 12 36 80) (vector-copy vec2))
(vector-for-each (lambda (x) (set! result (cons x result))) vec)
(test '(5 4 3 2 1 0) (cons (car result) (cdr result)))
(test 3 (vector-count even? '#(3 1 4 1 5 9 2 5 6)))
(test 2 (vector-count < '#(1 3 6 9) '#(2 4 6 8 10 12)))
(test '#(3 4 8 9 14 23 25 30 36) (vector-cumulate + 0 '#(3 1 4 1 5 9 2 5 6)))
)
(test-group "vectors/searching"
(define (cmp a b)
(cond
((< a b) -1)
((= a b) 0)
(else 1)))
(define v '#(0 2 4 6 8 10 12))
(test 2 (vector-index even? '#(3 1 4 1 5 9 6)))
(test 1 (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
(test #f (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
(test 5 (vector-index-right odd? '#(3 1 4 1 5 9 6)))
(test 3 (vector-index-right < '#(3 1 4 1 5) '#(2 7 1 8 2)))
(test 2 (vector-skip number? '#(1 2 a b 3 4 c d)))
(test 2 (vector-skip = '#(1 2 3 4 5) '#(1 2 -3 4)))
(test 7 (vector-skip-right number? '#(1 2 a b 3 4 c d)))
(test 3 (vector-skip-right = '#(1 2 3 4 5) '#(1 2 -3 -4 5)))
(test 0 (vector-binary-search v 0 cmp))
(test 3 (vector-binary-search v 6 cmp))
(test #f (vector-binary-search v 1 cmp))
(test-assert (vector-any number? '#(1 2 x y z)))
(test-assert (vector-any < '#(1 2 3 4 5) '#(2 1 3 4 5)))
(test #f (vector-any number? '#(a b c d e)))
(test #f (vector-any > '#(1 2 3 4 5) '#(1 2 3 4 5)))
(test #f (vector-every number? '#(1 2 x y z)))
(test-assert (vector-every number? '#(1 2 3 4 5)))
(test #f (vector-every < '#(1 2 3) '#(2 3 3)))
(test-assert (vector-every < '#(1 2 3) '#(2 3 4)))
(test 'yes (vector-any (lambda (x) (if (number? x) 'yes #f)) '#(1 2 x y z)))
(let-values (((new off) (vector-partition number? '#(1 x 2 y 3 z))))
(test '#(1 2 3 x y z) (vector-copy new))
(test 3 (+ off 0)))
)
(test-group "vectors/mutation"
(define vs (vector 1 2 3))
(define vf0 (vector 1 2 3))
(define vf1 (vector 1 2 3))
(define vf2 (vector 1 2 3))
(define vr0 (vector 1 2 3))
(define vr1 (vector 1 2 3))
(define vr2 (vector 1 2 3))
(define vc0 (vector 1 2 3 4 5))
(define vc1 (vector 1 2 3 4 5))
(define vc2 (vector 1 2 3 4 5))
(define vrc0 (vector 1 2 3 4 5))
(define vrc1 (vector 1 2 3 4 5))
(define vrc2 (vector 1 2 3 4 5))
(define vu0 (vector 1 2 3 4 5))
(define vu1 (vector 1 2 3 4 5))
(define vu2 (vector 1 2 3 4 5))
(define vur0 (vector 1 2 3 4 5))
(define vur1 (vector 1 2 3 4 5))
(define vur2 (vector 1 2 3 4 5))
(vector-swap! vs 0 1)
(test '#(2 1 3) (vector-copy vs))
(vector-fill! vf0 0)
(test '#(0 0 0) (vector-copy vf0))
(vector-fill! vf1 0 1)
(test '#(1 0 0) (vector-copy vf1))
(vector-fill! vf2 0 0 1)
(test '#(0 2 3) (vector-copy vf2))
(vector-reverse! vr0)
(test '#(3 2 1) (vector-copy vr0))
(vector-reverse! vr1 1)
(test '#(1 3 2) (vector-copy vr1))
(vector-reverse! vr2 0 2)
(test '#(2 1 3) (vector-copy vr2))
(vector-copy! vc0 1 '#(10 20 30))
(test '#(1 10 20 30 5) (vector-copy vc0))
(vector-copy! vc1 1 '#(0 10 20 30 40) 1)
(test '#(1 10 20 30 40) (vector-copy vc1))
(vector-copy! vc2 1 '#(0 10 20 30 40) 1 4)
(test '#(1 10 20 30 5) (vector-copy vc2))
(vector-reverse-copy! vrc0 1 '#(10 20 30))
(test '#(1 30 20 10 5) (vector-copy vrc0))
(vector-reverse-copy! vrc1 1 '#(0 10 20 30 40) 1)
(test '#(1 40 30 20 10) (vector-copy vrc1))
(vector-reverse-copy! vrc2 1 '#(0 10 20 30 40) 1 4)
(test '#(1 30 20 10 5) (vector-copy vrc2))
(vector-unfold! (lambda (i) (+ 10 i)) vu0 1 4)
(test '#(1 11 12 13 5) (vector-copy vu0))
(vector-unfold! (lambda (i x) (values (+ i x) (+ x 1))) vu1 1 4 0)
(test '#(1 1 3 5 5) (vector-copy vu1))
(vector-unfold! (lambda (i x y) (values (+ i x y) (+ x 1) (+ x 1))) vu2 1 4 0 0)
(test '#(1 1 4 7 5) (vector-copy vu2))
(vector-unfold-right! (lambda (i) (+ 10 i)) vur0 1 4)
(test '#(1 11 12 13 5) (vector-copy vur0))
(vector-unfold-right! (lambda (i x) (values (+ i x) (+ x 1))) vur1 1 4 0)
(test '#(1 3 3 3 5) (vector-copy vur1))
(vector-unfold-right! (lambda (i x y) (values (+ i x y) (+ x 1) (+ x 1))) vur2 1 4 0 0)
(test '#(1 5 4 3 5) (vector-copy vur2))
)
(test-group "vectors/conversion"
(test '(1 2 3) (vector->list '#(1 2 3)))
(test '(2 3) (vector->list '#(1 2 3) 1))
(test '(1 2) (vector->list '#(1 2 3) 0 2))
(test '#(1 2 3) (list->vector '(1 2 3)))
(test '(3 2 1) (reverse-vector->list '#(1 2 3)))
(test '(3 2) (reverse-vector->list '#(1 2 3) 1))
(test '(2 1) (reverse-vector->list '#(1 2 3) 0 2))
(test '#(3 2 1) (reverse-list->vector '(1 2 3)))
(test "abc" (vector->string '#(#\a #\b #\c)))
(test "bc" (vector->string '#(#\a #\b #\c) 1))
(test "ab" (vector->string '#(#\a #\b #\c) 0 2))
(test '#(#\a #\b #\c) (string->vector "abc"))
(test '#(#\b #\c) (string->vector "abc" 1))
(test '#(#\a #\b) (string->vector "abc" 0 2))
))))

221
lib/srfi/133/vector.scm Normal file
View file

@ -0,0 +1,221 @@
(define (vector-unfold! f vec start end . o)
(let lp ((i start) (seeds o))
(if (< i end)
(call-with-values (lambda () (apply f i seeds))
(lambda (x . seeds)
(vector-set! vec i x)
(lp (+ i 1) seeds))))))
(define (vector-unfold-right! f vec start end . o)
(let lp ((i (- end 1)) (seeds o))
(if (>= i start)
(call-with-values (lambda () (apply f i seeds))
(lambda (x . seeds)
(vector-set! vec i x)
(lp (- i 1) seeds))))))
(define (vector-unfold f len . o)
(let ((res (make-vector len)))
(apply vector-unfold! f res 0 len o)
res))
(define (vector-unfold-right f len . o)
(let ((res (make-vector len)))
(apply vector-unfold-right! f res 0 len o)
res))
(define (vector-reverse-copy vec . o)
(let* ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec)))
(len (- end start)))
(vector-unfold-right (lambda (i) (vector-ref vec (- end i 1))) len)))
(define (vector-concatenate ls)
(apply vector-append ls))
(define (vector-append-subvectors . o)
(let lp ((ls o) (vecs '()))
(if (null? ls)
(vector-concatenate (reverse vecs))
(lp (cdr (cddr ls))
(cons (vector-copy (car ls) (cadr ls) (car (cddr ls))) vecs)))))
(define (vector-empty? vec)
(zero? (vector-length vec)))
(define (vector= eq . o)
(cond
((null? o) #t)
((null? (cdr o)) #t)
(else
(and (let* ((v1 (car o))
(v2 (cadr o))
(len (vector-length v1)))
(and (= len (vector-length v2))
(let lp ((i 0))
(or (>= i len)
(and (eq (vector-ref v1 i) (vector-ref v2 i))
(lp (+ i 1)))))))
(apply vector= eq (cdr o))))))
(define (vector-fold kons knil vec1 . o)
(let ((len (vector-length vec1)))
(if (null? o)
(let lp ((i 0) (acc knil))
(if (>= i len) acc (lp (+ i 1) (kons acc (vector-ref vec1 i)))))
(let lp ((i 0) (acc knil))
(if (>= i len)
acc
(lp (+ i 1)
(apply kons acc (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))))))))
(define (vector-fold-right kons knil vec1 . o)
(let ((len (vector-length vec1)))
(if (null? o)
(let lp ((i (- len 1)) (acc knil))
(if (negative? i) acc (lp (- i 1) (kons acc (vector-ref vec1 i)))))
(let lp ((i (- len 1)) (acc knil))
(if (negative? i)
acc
(lp (- i 1)
(apply kons acc (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))))))))
(define (vector-map! proc vec1 . o)
(let ((len (vector-length vec1)))
(if (null? o)
(let lp ((i 0))
(cond
((>= i len) vec1)
(else (vector-set! vec1 i (proc (vector-ref vec1 i))) (lp (+ i 1)))))
(let lp ((i 0))
(cond
((>= i len) vec1)
(else
(let ((x (apply proc (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))))
(vector-set! vec1 i x)
(lp (+ i 1)))))))))
(define (vector-count pred? vec1 . o)
(apply vector-fold
(lambda (count . x) (+ count (if (apply pred? x) 1 0)))
0
vec1 o))
(define (vector-cumulate f knil vec)
(let* ((len (vector-length vec))
(res (make-vector len)))
(let lp ((i 0) (acc knil))
(if (>= i len)
res
(let ((acc (f acc (vector-ref vec i))))
(vector-set! res i acc)
(lp (+ i 1) acc))))))
(define (vector-index pred? vec1 . o)
(let ((len (apply min (vector-length vec1) (map vector-length o))))
(let lp ((i 0))
(and (< i len)
(if (apply pred? (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))
i
(lp (+ i 1)))))))
(define (vector-index-right pred? vec1 . o)
(let ((len (vector-length vec1)))
(let lp ((i (- len 1)))
(and (>= i 0)
(if (apply pred? (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))
i
(lp (- i 1)))))))
(define (complement f)
(lambda args (not (apply f args))))
(define (vector-skip pred? vec1 . o)
(apply vector-index (complement pred?) vec1 o))
(define (vector-skip-right pred? vec1 . o)
(apply vector-index-right (complement pred?) vec1 o))
(define (vector-binary-search vec value cmp)
(let lp ((lo 0) (hi (- (vector-length vec) 1)))
(and (<= lo hi)
(let* ((mid (quotient (+ lo hi) 2))
(x (vector-ref vec mid))
(y (cmp value x)))
(cond
((< y 0) (lp lo (- mid 1)))
((> y 0) (lp (+ mid 1) hi))
(else mid))))))
(define (vector-any pred? vec1 . o)
(let ((len (apply min (vector-length vec1) (map vector-length o))))
(let lp ((i 0))
(and (< i len)
(or (apply pred? (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))
(lp (+ i 1)))))))
(define (vector-every pred? vec1 . o)
(let ((len (apply min (vector-length vec1) (map vector-length o))))
(let lp ((i 0))
(let ((x (apply pred? (vector-ref vec1 i)
(map (lambda (v) (vector-ref v i)) o))))
(if (= i (- len 1))
x
(and x (lp (+ i 1))))))))
(define (vector-swap! vec i j)
(let ((tmp (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j tmp)))
(define (vector-reverse! vec . o)
(let lp ((left (if (pair? o) (car o) 0))
(right (- (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(vector-length vec))
1)))
(cond
((>= left right) (if #f #f))
(else
(vector-swap! vec left right)
(lp (+ left 1) (- right 1))))))
(define (vector-reverse-copy! to at from . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(vector-length from))))
(vector-copy! to at from start end)
(vector-reverse! to at (+ at (- end start)))))
(define (reverse-vector->list vec . o)
(reverse (apply vector->list vec o)))
(define (reverse-list->vector ls)
(list->vector (reverse ls)))
(define (vector-partition pred? vec)
(let* ((len (vector-length vec))
(res (make-vector len)))
(let lp ((i 0) (left 0) (right (- len 1)))
(cond
((= i len)
(if (< left len)
(vector-reverse! res left))
(values res left))
(else
(let ((x (vector-ref vec i)))
(cond
((pred? x)
(vector-set! res left x)
(lp (+ i 1) (+ left 1) right))
(else
(vector-set! res right x)
(lp (+ i 1) left (- right 1))))))))))