diff options
| -rw-r--r-- | implementation/Makefile | 12 | ||||
| -rw-r--r-- | implementation/README.md | 11 | ||||
| -rw-r--r-- | implementation/flexvectors-body1.scm | 222 | ||||
| -rw-r--r-- | implementation/flexvectors-body2.scm | 391 | ||||
| -rw-r--r-- | implementation/flexvectors.sld | 50 | ||||
| -rw-r--r-- | implementation/srfi-64-minimal.scm | 50 | ||||
| -rw-r--r-- | implementation/tests.scm | 278 |
7 files changed, 1014 insertions, 0 deletions
diff --git a/implementation/Makefile b/implementation/Makefile new file mode 100644 index 0000000..bb70d1f --- /dev/null +++ b/implementation/Makefile @@ -0,0 +1,12 @@ +.PHONY: test-all test-gauche test-sagittarius test-chibi + +test-all: test-gauche test-sagittarius test-chibi + +test-gauche: + gosh -I. tests.scm + +test-sagittarius: + sash -c -r7 -L. tests.scm + +test-chibi: + chibi-scheme tests.scm diff --git a/implementation/README.md b/implementation/README.md new file mode 100644 index 0000000..d3fe58a --- /dev/null +++ b/implementation/README.md @@ -0,0 +1,11 @@ +# Flexvectors + +An implementation of flexvectors (also known as dynamic arrays or arraylists) in +R7RS Scheme. Contains an R7RS library (`flexvectors.sld`) and a test suite +(`tests.scm`). + +This implementation supports Gauche, Sagittarius, and Chibi. If all three of +these are installed (binaries `gosh`, `sash`, and `chibi-scheme`), running +`make` should run the test suite for all three. To run the test suite in +a specific Scheme, use `make test-gauche`, `make test-sagittarius`, or `make +test-chibi`. diff --git a/implementation/flexvectors-body1.scm b/implementation/flexvectors-body1.scm new file mode 100644 index 0000000..fb8ba67 --- /dev/null +++ b/implementation/flexvectors-body1.scm @@ -0,0 +1,222 @@ +(define-record-type Flexvector + (%make-flexvector fv-vector fv-length) + flexvector? + (fv-vector vec set-vec!) + (fv-length flexvector-length set-flexvector-length!)) + +(define (cap fv) + (vector-length (vec fv))) + +(define (grow! fv) + (define old-vec (vec fv)) + (define new-vec (make-vector (quotient (* (vector-length old-vec) 3) 2))) + (vector-copy! new-vec 0 old-vec) + (set-vec! fv new-vec) + new-vec) + +(define make-flexvector + (case-lambda + ((size) + (assume (>= size 0)) + (%make-flexvector (make-vector (max size 4)) size)) + ((size fill) + (assume (>= size 0)) + (%make-flexvector (make-vector (max size 4) fill) size)))) + +(define (flexvector . xs) + (if (null? xs) + (%make-flexvector (make-vector 4) 0) + (list->flexvector xs))) + +(define (flexvector-ref fv index) + (assume (flexvector? fv)) + (assume (integer? index)) + (assume (< -1 index (flexvector-length fv))) + (vector-ref (vec fv) index)) + +(define (flexvector-set! fv index x) + (assume (flexvector? fv)) + (assume (integer? index)) + (assume (< -1 index (flexvector-length fv))) + (let ((last-value (vector-ref (vec fv) index))) + (vector-set! (vec fv) index x) + last-value)) + +(define flexvector-add! + (case-lambda + ((fv i x) + (assume (flexvector? fv)) + (assume (integer? i)) + (let* ((len (flexvector-length fv)) + (v (if (< len (cap fv)) (vec fv) (grow! fv)))) + (assume (<= 0 i len)) + (vector-copy! v (+ i 1) v i len) + (vector-set! v i x) + (set-flexvector-length! fv (+ len 1)) + fv)) + ((fv i . xs) + (flexvector-add-all! fv i xs)))) + +(define flexvector-add-back! + (case-lambda + ((fv x) + (assume (flexvector? fv)) + (let* ((len (flexvector-length fv)) + (v (if (< len (cap fv)) (vec fv) (grow! fv)))) + (vector-set! v len x) + (set-flexvector-length! fv (+ len 1)) + fv)) + ((fv x . xs) + (flexvector-add-back! fv x) + (apply flexvector-add-back! fv xs)))) + +(define (flexvector-add-all! fv i xs) + (assume (flexvector? fv)) + (assume (integer? i)) + (assume (list? xs)) + (let* ((len (flexvector-length fv)) + (xv (list->vector xs)) + (xvlen (vector-length xv)) + (v (let lp ((v (vec fv))) + (if (< (+ len xvlen) (vector-length v)) v (lp (grow! fv)))))) + (assume (<= 0 i len)) + (vector-copy! v (+ i xvlen) v i len) + (vector-copy! v i xv 0 xvlen) + (set-flexvector-length! fv (+ len xvlen)) + fv)) + +(define (flexvector-remove! fv i) + (assume (flexvector? fv)) + (assume (integer? i)) + (assume (<= 0 i (- (flexvector-length fv) 1))) + (let ((removed (flexvector-ref fv i))) + (flexvector-remove-range! fv i (+ i 1)) + removed)) + +(define (flexvector-remove-range! fv start end) + (assume (flexvector? fv)) + (let ((len (flexvector-length fv))) + (when (< start 0) (set! start 0)) + (when (>= end len) (set! end len)) + (assume (<= start end)) + (vector-copy! (vec fv) start (vec fv) end) + (let ((new-len (- len (- end start)))) + (vector-fill! (vec fv) #f new-len len) + (set-flexvector-length! fv new-len))) + fv) + +(define (flexvector-clear! fv) + (assume (flexvector? fv)) + (set-vec! fv (make-vector 4)) + (set-flexvector-length! fv 0) + fv) + +(define vector->flexvector + (case-lambda + ((vec) + (assume (vector? vec)) + (vector->flexvector vec 0 (vector-length vec))) + ((vec start) + (assume (vector? vec)) + (vector->flexvector vec start (vector-length vec))) + ((vec start end) + (assume (vector? vec)) + (assume (<= 0 start end (vector-length vec))) + (let ((len (- end start))) + (cond + ((< len 4) + (let ((new-vec (make-vector 4))) + (vector-copy! new-vec 0 vec start end) + (%make-flexvector new-vec len))) + (else + (%make-flexvector (vector-copy vec start end) len))))))) + +(define flexvector->vector + (case-lambda + ((fv) + (assume (flexvector? fv)) + (flexvector->vector fv 0 (flexvector-length fv))) + ((fv start) + (assume (flexvector? fv)) + (flexvector->vector fv start (flexvector-length fv))) + ((fv start end) + (assume (flexvector? fv)) + (assume (<= 0 start end (flexvector-length fv))) + (vector-copy (vec fv) start end)))) + +(define (list->flexvector xs) + (let* ((vec (list->vector xs)) + (len (vector-length vec))) + (cond + ((< len 4) + (let ((new-vec (make-vector 4))) + (vector-copy! new-vec 0 vec) + (%make-flexvector new-vec len))) + (else + (%make-flexvector vec len))))) + +(define flexvector-filter/index! + (case-lambda + ((pred? fv) + (assume (flexvector? fv)) + (let ((v (vec fv)) (len (flexvector-length fv))) + (let lp ((i 0) (j 0)) + (cond + ((>= i len) + (set-flexvector-length! fv j) + fv) + ((pred? i (vector-ref v i)) + (unless (= i j) (vector-set! v j (vector-ref v i))) + (lp (+ i 1) (+ j 1))) + (else + (lp (+ i 1) j)))))) + ((pred? fv . fvs) + (assume (flexvector? fv)) + (let ((v (vec fv)) (len (flexvector-length fv))) + (let lp ((i 0) (j 0)) + (cond + ((>= i len) + (set-flexvector-length! fv j) + fv) + ((apply pred? + i + (vector-ref v i) + (map (lambda (fv) (flexvector-ref fv i)) fvs)) + (unless (= i j) (vector-set! v j (vector-ref v i))) + (lp (+ i 1) (+ j 1))) + (else + (lp (+ i 1) j)))))))) + +(define flexvector-copy + (case-lambda + ((fv) + (assume (flexvector? fv)) + (%make-flexvector (vector-copy (vec fv)) + (flexvector-length fv))) + ((fv start) + (assume (flexvector? fv)) + (flexvector-copy fv start (flexvector-length fv))) + ((fv start end) + (assume (flexvector? fv)) + (assume (<= 0 start end (flexvector-length fv))) + (vector->flexvector (vector-copy (vec fv) start end))))) + +(define flexvector-copy! + (case-lambda + ((to at from) + (assume (flexvector? from)) + (flexvector-copy! to at from 0 (flexvector-length from))) + ((to at from start) + (assume (flexvector? from)) + (flexvector-copy! to at from start (flexvector-length from))) + ((to at from start end) + (assume (flexvector? to)) + (assume (<= 0 at (flexvector-length to))) + (assume (<= 0 start end (flexvector-length from))) + (let* ((vf (vec from)) + (lt (+ (flexvector-length to) (- end start))) + (vt (let lp ((v (vec to))) + (if (< lt (vector-length v)) v (lp (grow! to)))))) + (vector-copy! vt at vf start end) + (set-flexvector-length! to + (max (flexvector-length to) (+ at (- end start)))))))) diff --git a/implementation/flexvectors-body2.scm b/implementation/flexvectors-body2.scm new file mode 100644 index 0000000..ba3e2f5 --- /dev/null +++ b/implementation/flexvectors-body2.scm @@ -0,0 +1,391 @@ +(define flexvector-unfold + (case-lambda + ((p f g seed) + (define fv (flexvector)) + (assume (procedure? p)) + (assume (procedure? f)) + (assume (procedure? g)) + (do ((seed seed (g seed))) ((p seed) fv) + (flexvector-add-back! fv (f seed)))) + ((p f g . seeds) + (define fv (flexvector)) + (assume (procedure? p)) + (assume (procedure? f)) + (assume (procedure? g)) + (do ((seeds seeds (let-values ((seeds (apply g seeds))) seeds))) + ((apply p seeds) fv) + (flexvector-add-back! fv (apply f seeds)))))) + +(define (flexvector-unfold-right . args) + (define fv (apply flexvector-unfold args)) + (flexvector-reverse! fv) + fv) + +(define (flexvector-reverse-copy . args) + (define fv (apply flexvector-copy args)) + (flexvector-reverse! fv) + fv) + +(define flexvector-reverse-copy! + (case-lambda + ((to at from) + (assume (flexvector? from)) + (flexvector-reverse-copy! to at from 0 (flexvector-length from))) + ((to at from start) + (assume (flexvector? from)) + (flexvector-reverse-copy! to at from start (flexvector-length from))) + ((to at from start end) + (flexvector-copy! to at from start end) + (flexvector-reverse! to at (+ at (- end start)))))) + +(define (flexvector-append! fv . fvs) + (assume (flexvector? fv)) + (assume (every flexvector? fvs)) + (for-each + (lambda (fv2) (flexvector-copy! fv (flexvector-length fv) fv2)) + fvs) + fv) + +(define (flexvector-front fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-ref fv 0)) + +(define (flexvector-back fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-ref fv (- (flexvector-length fv) 1))) + +(define flexvector-add-front! + (case-lambda + ((fv x) (flexvector-add! fv 0 x)) + ((fv . xs) (apply flexvector-add! fv 0 xs)))) + +(define (flexvector-remove-front! fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-remove! fv 0)) + +(define (flexvector-remove-back! fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-remove! fv (- (flexvector-length fv) 1))) + +(define (flexvector=? eq . o) + (cond + ((null? o) #t) + ((null? (cdr o)) #t) + (else + (and (let* ((fv1 (car o)) + (fv2 (cadr o)) + (len (flexvector-length fv1))) + (and (= len (flexvector-length fv2)) + (let lp ((i 0)) + (or (>= i len) + (and (eq (flexvector-ref fv1 i) (flexvector-ref fv2 i)) + (lp (+ i 1))))))) + (apply flexvector=? eq (cdr o)))))) + +(define (flexvector-fold kons knil fv1 . o) + (assume (procedure? kons)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (if (null? o) + (let lp ((i 0) (acc knil)) + (if (>= i len) acc (lp (+ i 1) (kons acc (flexvector-ref fv1 i))))) + (let lp ((i 0) (acc knil)) + (if (>= i len) + acc + (lp (+ i 1) + (apply kons acc (flexvector-ref v1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)))))))) + +(define (flexvector-fold-right kons knil fv1 . o) + (assume (procedure? kons)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (if (null? o) + (let lp ((i (- len 1)) (acc knil)) + (if (negative? i) acc (lp (- i 1) (kons acc (flexvector-ref fv1 i))))) + (let lp ((i (- len 1)) (acc knil)) + (if (negative? i) + acc + (lp (- i 1) + (apply kons acc (flexvector-ref v1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)))))))) + +(define flexvector-for-each/index + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (let ((len (flexvector-length fv))) + (do ((i 0 (+ i 1))) ((= i len)) + (proc i (flexvector-ref fv i))))) + ((proc . fvs) + (assume (procedure? proc)) + (let ((len (apply min (map flexvector-length fvs)))) + (do ((i 0 (+ i 1))) ((= i len)) + (apply proc i (map (lambda (fv) (flexvector-ref fv i)) fvs))))))) + +(define flexvector-for-each + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (flexvector-for-each/index (lambda (i x) (proc x)) fv)) + ((proc . fvs) + (assume (procedure? proc)) + (apply flexvector-for-each/index (lambda (i . xs) (apply proc xs)) fvs)))) + +(define flexvector-map/index! + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (flexvector-for-each/index + (lambda (i x) (flexvector-set! fv i (proc i x))) + fv) + fv) + ((proc fv . fvs) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (apply flexvector-for-each/index + (lambda (i . xs) (flexvector-set! fv i (apply proc i xs))) + fv + fvs) + fv))) + +(define flexvector-map! + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (flexvector-map/index! (lambda (i x) (proc x)) fv)) + ((proc . fvs) + (assume (procedure? proc)) + (apply flexvector-map/index! (lambda (i . xs) (apply proc xs)) fvs)))) + +(define (flexvector-map/index proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-map/index! proc (flexvector-copy fv) fvs)) + +(define (flexvector-map proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-map! proc (flexvector-copy fv) fvs)) + +(define (flexvector-append-map/index proc fv . fvs) + (define out (flexvector)) + (flexvector-for-each + (lambda (x) (flexvector-append! out x)) + (apply flexvector-map/index proc fv fvs)) + out) + +(define (flexvector-append-map proc fv . fvs) + (define out (flexvector)) + (flexvector-for-each + (lambda (x) (flexvector-append! out x)) + (apply flexvector-map proc fv fvs)) + out) + +(define flexvector-filter! + (case-lambda + ((pred? fv) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (flexvector-filter/index! (lambda (i x) (pred? x)) fv)) + ((pred? . fvs) + (assume (procedure? pred?)) + (apply flexvector-filter/index! (lambda (i . xs) (apply pred? xs)) fvs)))) + +(define (flexvector-filter/index proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-filter/index! proc (flexvector-copy fv) fvs)) + +(define (flexvector-filter proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-filter! proc (flexvector-copy fv) fvs)) + +(define (flexvector-index pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (let lp ((i 0)) + (and (< i len) + (if (apply pred? + (flexvector-ref fv1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)) + i + (lp (+ i 1))))))) + +(define (flexvector-index-right pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (let lp ((i (- len 1))) + (and (>= i 0) + (if (apply pred? + (flexvector-ref fv1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)) + i + (lp (- i 1))))))) + +(define (complement f) + (lambda args (not (apply f args)))) + +(define (flexvector-skip pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-index (complement pred?) fv1 o)) + +(define (flexvector-skip-right pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-index-right (complement pred?) fv1 o)) + +(define flexvector-binary-search + (case-lambda + ((fv value cmp) + (flexvector-binary-search fv value cmp 0 (flexvector-length fv))) + ((fv value cmp start) + (flexvector-binary-search fv value cmp start (flexvector-length fv))) + ((fv value cmp start end) + (assume (flexvector? fv)) + (assume (procedure? cmp)) + (assume (integer? start)) + (assume (integer? end)) + (assume (<= start end)) + (let lp ((lo (max start 0)) + (hi (- (min end (flexvector-length fv)) 1))) + (and (<= lo hi) + (let* ((mid (quotient (+ lo hi) 2)) + (x (flexvector-ref fv mid)) + (y (cmp value x))) + (cond + ((< y 0) (lp lo (- mid 1))) + ((> y 0) (lp (+ mid 1) hi)) + (else mid)))))))) + +(define (flexvector-any pred? fv . o) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((len (apply min (flexvector-length fv) (map flexvector-length o)))) + (let lp ((i 0)) + (and (< i len) + (or (apply pred? + (flexvector-ref fv i) + (map (lambda (v) (flexvector-ref v i)) o)) + (lp (+ i 1))))))) + +(define (flexvector-every pred? fv . o) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((len (apply min (flexvector-length fv) (map flexvector-length o)))) + (or (zero? len) + (let lp ((i 0)) + (let ((x (apply pred? + (flexvector-ref fv i) + (map (lambda (v) (flexvector-ref v i)) o)))) + (if (= i (- len 1)) + x + (and x (lp (+ i 1))))))))) + +(define (flexvector-swap! fv i j) + (assume (flexvector? fv)) + (assume (integer? i)) + (assume (integer? j)) + (let ((tmp (flexvector-ref fv i))) + (flexvector-set! fv i (flexvector-ref fv j)) + (flexvector-set! fv j tmp))) + +(define (flexvector-reverse! fv . o) + (assume (flexvector? fv)) + (let lp ((left (if (pair? o) (car o) 0)) + (right (- (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (flexvector-length fv)) + 1))) + (cond + ((>= left right) (if #f #f)) + (else + (flexvector-swap! fv left right) + (lp (+ left 1) (- right 1)))))) + +(define (flexvector-reverse-copy! to at from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (flexvector-length from)))) + (flexvector-copy! to at from start end) + (flexvector-reverse! to at (+ at (- end start))))) + +(define (flexvector-append fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-append! (flexvector-copy fv) fvs)) + +(define (flexvector-concatenate ls) + (apply flexvector-append ls)) + +(define (flexvector-append-subvectors . o) + (let lp ((ls o) (vecs '())) + (if (null? ls) + (flexvector-concatenate (reverse vecs)) + (lp (cdr (cddr ls)) + (cons (flexvector-copy (car ls) (cadr ls) (car (cddr ls))) vecs))))) + +(define (flexvector-empty? fv) + (assume (flexvector? fv)) + (zero? (flexvector-length fv))) + +(define (flexvector-count pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-fold + (lambda (count . x) (+ count (if (apply pred? x) 1 0))) + 0 + fv1 o)) + +(define (flexvector-cumulate f knil fv) + (assume (procedure? f)) + (assume (flexvector? fv)) + (let* ((len (flexvector-length fv)) + (res (make-vector len))) + (let lp ((i 0) (acc knil)) + (if (>= i len) + (vector->flexvector res) + (let ((acc (f acc (flexvector-ref fv i)))) + (vector-set! res i acc) + (lp (+ i 1) acc)))))) + +(define (flexvector-partition pred? fv) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((left (flexvector)) (right (flexvector))) + (flexvector-for-each + (lambda (x) (flexvector-add-back! (if (pred? x) left right) x)) + fv) + (values left right))) + +(define (flexvector->list fv) + (assume (flexvector? fv)) + (flexvector-fold-right (lambda (x y) (cons y x)) '() fv)) + +(define (reverse-flexvector->list fv . o) + (assume (flexvector? fv)) + (flexvector->list (apply flexvector-reverse-copy fv o))) + +(define (reverse-list->flexvector ls) + (assume (list? ls)) + (let ((fv (list->flexvector ls))) + (flexvector-reverse! fv) + fv)) + +(define (string->flexvector s . o) + (assume (string? s)) + (vector->flexvector (apply string->vector s o))) + +(define (flexvector->string fv . o) + (assume (flexvector? fv)) + (vector->string (apply flexvector->vector fv o))) + +(define (generator->flexvector g) + (assume (procedure? g)) + (flexvector-unfold eof-object? (lambda (x) x) (lambda (_) (g)) (g))) diff --git a/implementation/flexvectors.sld b/implementation/flexvectors.sld new file mode 100644 index 0000000..25e1543 --- /dev/null +++ b/implementation/flexvectors.sld @@ -0,0 +1,50 @@ +(define-library (flexvectors) + (export ; Constructors + make-flexvector flexvector + flexvector-unfold flexvector-unfold-right + flexvector-copy flexvector-reverse-copy + flexvector-append flexvector-concatenate flexvector-append-subvectors + + ; Predicates + flexvector? flexvector-empty? flexvector=? + + ; Selectors + flexvector-ref flexvector-front flexvector-back flexvector-length + + ; Mutators + flexvector-add! flexvector-add-front! flexvector-add-back! + flexvector-remove! flexvector-remove-front! flexvector-remove-back! + flexvector-add-all! flexvector-remove-range! flexvector-clear! + flexvector-set! flexvector-swap! + flexvector-fill! flexvector-reverse! + flexvector-copy! flexvector-reverse-copy! + flexvector-append! + + ; Iteration + flexvector-fold flexvector-fold-right + flexvector-map flexvector-map! flexvector-map/index flexvector-map/index! + flexvector-append-map flexvector-append-map/index + flexvector-filter flexvector-filter! flexvector-filter/index flexvector-filter/index! + flexvector-for-each flexvector-for-each/index + flexvector-count flexvector-cumulate + + ; Searching + flexvector-index flexvector-index-right + flexvector-skip flexvector-skip-right + flexvector-binary-search + flexvector-any flexvector-every flexvector-partition + + ; Conversion + flexvector->vector flexvector->list flexvector->string + vector->flexvector list->flexvector string->flexvector + reverse-flexvector->list reverse-list->flexvector + generator->flexvector) + + (import (scheme base) + (scheme case-lambda) + (scheme write) + (srfi 1) + (srfi 145)) + + (include "flexvectors-body1.scm") + (include "flexvectors-body2.scm")) diff --git a/implementation/srfi-64-minimal.scm b/implementation/srfi-64-minimal.scm new file mode 100644 index 0000000..e60632b --- /dev/null +++ b/implementation/srfi-64-minimal.scm @@ -0,0 +1,50 @@ +; Just enough of SRFI 64 (unit tests) to run test.scm. + +(define *test-failures* '()) + +(define (test-begin name) + (newline) + (display "Test group: ") + (display name) + (newline) + (newline)) + +(define (test-end name) + (newline) + (cond + ((null? *test-failures*) + (display "All tests passed!") + (newline) + (newline) + (exit 0)) + (else + (write (length *test-failures*)) + (display " TEST(S) FAILED:") + (newline) + (for-each (lambda (x) (x)) (reverse *test-failures*)) + (newline) + (exit 1)))) + +(define (%test-equal name expected actual) + (cond + ((equal? expected actual) + (display "pass: ")) + (else + (set! *test-failures* + (cons + (lambda () + (display name) + (display ": Expected ") + (write expected) + (display ", got ") + (write actual) + (newline)) + *test-failures*)) + (display "FAIL: "))) + (display name) + (newline)) + +(define-syntax test-equal + (syntax-rules () + ((_ name expected actual) + (%test-equal name expected (guard (e (#t e)) actual))))) diff --git a/implementation/tests.scm b/implementation/tests.scm new file mode 100644 index 0000000..329a8d6 --- /dev/null +++ b/implementation/tests.scm @@ -0,0 +1,278 @@ +(import (scheme base) + (scheme write) + (scheme process-context) + (flexvectors)) + +(include "./srfi-64-minimal.scm") + +(test-begin "Flexvectors") + +(test-equal "flexvector?" #t (flexvector? (flexvector))) +(test-equal "flexvector-length" 3 (flexvector-length (make-flexvector 3 #f))) +(test-equal "flexvector" 3 (flexvector-length (flexvector 1 2 3))) + +(let ((fv (flexvector 'a 'b 'c))) + (test-equal "flexvector-ref" 'b (flexvector-ref fv 1)) + (test-equal "flexvector-front" 'a (flexvector-front fv)) + (test-equal "flexvector-back" 'c (flexvector-back fv)) + (test-equal "flexvector-set! return" 'b (flexvector-set! fv 1 'd)) + (test-equal "flexvector-set! mutate" 'd (flexvector-ref fv 1)) + (test-equal "flexvector-add-back! return" fv (flexvector-add-back! fv 'e)) + (test-equal "flexvector-add-back! mutate" '(4 . e) + (cons (flexvector-length fv) + (flexvector-ref fv (- (flexvector-length fv) 1)))) + (test-equal "flexvector-remove! return" 'd (flexvector-remove! fv 1)) + (test-equal "flexvector-remove! mutate" '(3 . c) + (cons (flexvector-length fv) + (flexvector-ref fv 1))) + (test-equal "flexvector-clear! return" fv (flexvector-clear! fv)) + (test-equal "flexvector-clear! mutate" 0 (flexvector-length fv)) + (test-equal "flexvector-empty?" #t (flexvector-empty? fv))) + +(test-equal "flexvector=? same symbols" #t + (flexvector=? eq? (flexvector 'a 'b) (flexvector 'a 'b))) +(test-equal "flexvector=? different symbols" #f + (flexvector=? eq? (flexvector 'a 'b) (flexvector 'b 'a))) +(test-equal "flexvector=? different lengths" #f + (flexvector=? = (flexvector 1 2 3 4 5) (flexvector 1 2 3 4))) +(test-equal "flexvector=? same numbers" #t + (flexvector=? = (flexvector 1 2 3 4) (flexvector 1 2 3 4))) +(test-equal "flexvector=? 0 arguments" #t + (flexvector=? eq?)) +(test-equal "flexvector=? 1 argument" #t + (flexvector=? eq? (flexvector 'a))) + +(test-equal "make-flexvector" #(a a a) (flexvector->vector (make-flexvector 3 'a))) + +(test-equal "flexvector-unfold" + #(1 4 9 16 25 36 49 64 81 100) + (flexvector->vector + (flexvector-unfold (lambda (x) (> x 10)) + (lambda (x) (* x x)) + (lambda (x) (+ x 1)) + 1))) +(test-equal "flexvector-unfold-right" + #(100 81 64 49 36 25 16 9 4 1) + (flexvector->vector + (flexvector-unfold-right (lambda (x) (> x 10)) + (lambda (x) (* x x)) + (lambda (x) (+ x 1)) + 1))) + + +(test-equal "string->flexvector" #(#\a #\b #\c) + (flexvector->vector (string->flexvector "abc"))) +(test-equal "flexvector->string" "abc" (flexvector->string (flexvector #\a #\b #\c))) + +; Nondestructive operations on one vector +(let ((fv (flexvector 10 20 30))) + (test-equal "flexvector->vector" #(10 20 30) (flexvector->vector fv)) + (test-equal "flexvector->list" '(10 20 30) (flexvector->list fv)) + (test-equal "reverse-flexvector->list" '(30 20 10) (reverse-flexvector->list fv)) + (test-equal "flexvector-copy" #t + (let ((copy (flexvector-copy fv))) + (and (= (flexvector-length fv) (flexvector-length copy)) + (not (eq? fv copy))))) + (test-equal "flexvector-reverse-copy" #(30 20 10) + (flexvector->vector (flexvector-reverse-copy fv))) + (test-equal "flexvector-copy start" #(20 30) + (flexvector->vector (flexvector-copy fv 1))) + (test-equal "flexvector-copy start end" #(20) + (flexvector->vector (flexvector-copy fv 1 2))) + (test-equal "flexvector-for-each" '(30 20 10) + (let ((res '())) + (flexvector-for-each (lambda (x) (set! res (cons x res))) fv) + res)) + (test-equal "flexvector-for-each/index" '(34 22 10) + (let ((res '())) + (flexvector-for-each/index + (lambda (i x) (set! res (cons (+ x (* i 2)) res))) + fv) + res)) + (test-equal "flexvector-map" #(100 200 300) + (flexvector->vector (flexvector-map (lambda (x) (* x 10)) fv))) + (test-equal "flexvector-map/index" #(10 22 34) + (flexvector->vector (flexvector-map/index (lambda (i x) (+ x (* i 2))) fv))) + (test-equal "flexvector-append-map" #(10 100 20 200 30 300) + (flexvector->vector + (flexvector-append-map (lambda (x) (flexvector x (* x 10))) fv))) + (test-equal "flexvector-append-map/index" #(0 10 10 1 20 22 2 30 34) + (flexvector->vector + (flexvector-append-map/index + (lambda (i x) (flexvector i x (+ x (* i 2)))) + fv))) + (test-equal "flexvector-filter" #(10) + (flexvector->vector (flexvector-filter (lambda (x) (< x 15)) fv))) + (test-equal "flexvector-filter/index" #(10 30) + (flexvector->vector (flexvector-filter/index (lambda (i x) (not (= i 1))) fv))) + (test-equal "flexvector-fold" '(30 20 10) + (flexvector-fold (lambda (x y) (cons y x)) '() fv)) + (test-equal "flexvector-fold-right" '(10 20 30) + (flexvector-fold-right (lambda (x y) (cons y x)) '() fv)) + (test-equal "flexvector-count" 2 + (flexvector-count (lambda (x) (< x 25)) fv)) + (test-equal "flexvector-cumulate" #(3 4 8 9 14 23 25 30 36) + (flexvector->vector + (flexvector-cumulate + 0 (flexvector 3 1 4 1 5 9 2 5 6)))) + (test-equal "flexvector-any" '(#t . #f) + (cons (flexvector-any (lambda (x) (= x 20)) fv) + (flexvector-any (lambda (x) (= x 21)) fv))) + (test-equal "flexvector-every" '(#t . #f) + (cons (flexvector-every (lambda (x) (< x 40)) fv) + (flexvector-every (lambda (x) (< x 30)) fv))) + (test-equal "flexvector-index" 1 + (flexvector-index (lambda (x) (> x 10)) fv)) + (test-equal "flexvector-index-right" 2 + (flexvector-index-right (lambda (x) (> x 10)) fv)) + (test-equal "flexvector-skip" 1 + (flexvector-skip (lambda (x) (< x 20)) fv)) + (test-equal "flexvector-skip-right" 0 + (flexvector-skip-right (lambda (x) (> x 10)) fv)) + (test-equal "flexvector-partition" '(#(10 20) #(30)) + (call-with-values + (lambda () (flexvector-partition (lambda (x) (< x 25)) fv)) + (lambda vs (map flexvector->vector vs))))) + +(let ((fv (flexvector #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j)) + (cmp (lambda (char1 char2) + (cond ((char<? char1 char2) -1) + ((char=? char1 char2) 0) + (else 1))))) + (test-equal "flexvector-binary-search" 3 + (flexvector-binary-search fv #\d cmp)) + (test-equal "flexvector-binary-search first" 0 + (flexvector-binary-search fv #\a cmp)) + (test-equal "flexvector-binary-search last" 9 + (flexvector-binary-search fv #\j cmp)) + (test-equal "flexvector-binary-search not found" #f + (flexvector-binary-search fv #\k cmp)) + + (test-equal "flexvector-binary-search in range" 5 + (flexvector-binary-search fv #\f cmp 2 6)) + (test-equal "flexvector-binary-search out of range" #f + (flexvector-binary-search fv #\f cmp 1 5))) + +; Nondestructive operations on multiple vectors +(test-equal "flexvector-append" #(10 20 30 40 50 60) + (flexvector->vector + (flexvector-append (flexvector 10 20) + (flexvector) + (flexvector 30 40) + (flexvector 50 60)))) +(test-equal "flexvector-concatenate" #(10 20 30 40 50 60) + (flexvector->vector + (flexvector-concatenate + (list (flexvector 10 20) + (flexvector) + (flexvector 30 40) + (flexvector 50 60))))) +(test-equal "flexvector-append-subvectors" #(a b h i) + (flexvector->vector + (flexvector-append-subvectors + (flexvector 'a 'b 'c 'd 'e) 0 2 + (flexvector 'f 'g 'h 'i 'j) 2 4))) + + +; Destructive operations on one vector +(define-syntax mutate-as + (syntax-rules () + ((_ name vec expr) + (let ((name (vector->flexvector vec))) + expr + (flexvector->vector name))))) + +(test-equal "flexvector-add! empty" '#(foo) + (mutate-as x '#() (flexvector-add! x 0 'foo))) +(test-equal "flexvector-add! empty multiple" '#(foo bar baz) + (mutate-as x '#() (flexvector-add! x 0 'foo 'bar 'baz))) +(test-equal "flexvector-add! start" '#(foo bar baz) + (mutate-as x '#(bar baz) (flexvector-add! x 0 'foo))) +(test-equal "flexvector-add! start multiple" '#(foo bar baz qux quux) + (mutate-as x '#(qux quux) (flexvector-add! x 0 'foo 'bar 'baz))) +(test-equal "flexvector-add! middle" '#(foo bar baz) + (mutate-as x '#(foo baz) (flexvector-add! x 1 'bar))) +(test-equal "flexvector-add! middle multiple" '#(foo bar baz qux quux) + (mutate-as x '#(foo quux) (flexvector-add! x 1 'bar 'baz 'qux))) +(test-equal "flexvector-add! end" '#(foo bar baz) + (mutate-as x '#(foo bar) (flexvector-add! x 2 'baz))) +(test-equal "flexvector-add! end multiple" '#(foo bar baz qux quux) + (mutate-as x '#(foo bar) (flexvector-add! x 2 'baz 'qux 'quux))) + +(test-equal "flexvector-add-all!" '#(foo bar baz qux) + (mutate-as x '#(foo qux) (flexvector-add-all! x 1 '(bar baz)))) + +(test-equal "flexvector-add-front! empty" '#(foo) + (mutate-as x '#() (flexvector-add-front! x 'foo))) +(test-equal "flexvector-add-front! empty multiple" '#(foo bar baz) + (mutate-as x '#() (flexvector-add-front! x 'foo 'bar 'baz))) +(test-equal "flexvector-add-front!" '#(foo bar baz) + (mutate-as x '#(bar baz) (flexvector-add-front! x 'foo))) +(test-equal "flexvector-add-front! multiple" '#(foo bar baz qux quux) + (mutate-as x '#(qux quux) (flexvector-add-front! x 'foo 'bar 'baz))) + +(test-equal "flexvector-add-back! empty" '#(foo) + (mutate-as x '#() (flexvector-add-back! x 'foo))) +(test-equal "flexvector-add-back! empty multiple" '#(foo bar baz) + (mutate-as x '#() (flexvector-add-back! x 'foo 'bar 'baz))) +(test-equal "flexvector-add-back!" '#(foo bar baz) + (mutate-as x '#(foo bar) (flexvector-add-back! x 'baz))) +(test-equal "flexvector-add-back! multiple" '#(foo bar baz qux quux) + (mutate-as x '#(foo bar) (flexvector-add-back! x 'baz 'qux 'quux))) + +(test-equal "flexvector-append!" '#(foo bar baz qux) + (mutate-as x '#(foo bar) (flexvector-append! x (flexvector 'baz 'qux)))) +(test-equal "flexvector-append! multiple" '#(foo bar baz qux quux) + (mutate-as x '#(foo bar) (flexvector-append! x (flexvector 'baz 'qux) (flexvector 'quux)))) + +(test-equal "flexvector-remove!" '#(foo baz) + (mutate-as x '#(foo bar baz) (flexvector-remove! x 1))) +(test-equal "flexvector-remove! only" '#() + (mutate-as x '#(foo) (flexvector-remove! x 0))) + +(test-equal "flexvector-remove-front!" '#(bar baz) + (mutate-as x '#(foo bar baz) (flexvector-remove-front! x))) +(test-equal "flexvector-remove-front! only" '#() + (mutate-as x '#(foo) (flexvector-remove-front! x))) + +(test-equal "flexvector-remove-back!" '#(foo bar) + (mutate-as x '#(foo bar baz) (flexvector-remove-back! x))) +(test-equal "flexvector-remove-back! only" '#() + (mutate-as x '#(foo) (flexvector-remove-back! x))) + +(test-equal "flexvector-remove-range!" '#(a e f) + (mutate-as x '#(a b c d e f) (flexvector-remove-range! x 1 4))) +(test-equal "flexvector-remove-range! empty range" '#(a b c d e f) + (mutate-as x '#(a b c d e f) (flexvector-remove-range! x 1 1))) +(test-equal "flexvector-remove-range! overflow left" '#(e f) + (mutate-as x '#(a b c d e f) (flexvector-remove-range! x -1 4))) +(test-equal "flexvector-remove-range! overflow right" '#(a b) + (mutate-as x '#(a b c d e f) (flexvector-remove-range! x 2 10))) + +(test-equal "flexvector-map!" '#(100 200 300) + (mutate-as fv '#(10 20 30) (flexvector-map! (lambda (x) (* x 10)) fv))) +(test-equal "flexvector-map/index!" '#(10 22 34) + (mutate-as fv '#(10 20 30) (flexvector-map/index! (lambda (i x) (+ x (* i 2))) fv))) +(test-equal "flexvector-filter!" '#(10) + (mutate-as fv '#(10 20 30) (flexvector-filter! (lambda (x) (< x 15)) fv))) +(test-equal "flexvector-filter/index!" '#(10 30) + (mutate-as fv '#(10 20 30) (flexvector-filter/index! (lambda (i x) (not (= i 1))) fv))) + +(test-equal "flexvector-swap!" #(10 30 20) + (mutate-as fv '#(10 20 30) (flexvector-swap! fv 1 2))) +(test-equal "flexvector-reverse!" #(30 20 10) + (mutate-as fv '#(10 20 30) (flexvector-reverse! fv))) + +(test-equal "flexvector-copy!" #(1 20 30 40 5) + (mutate-as fv '#(1 2 3 4 5) (flexvector-copy! fv 1 (flexvector 20 30 40)))) +(test-equal "flexvector-copy! bounded" #(1 20 30 40 5) + (mutate-as fv '#(1 2 3 4 5) (flexvector-copy! fv 1 (flexvector 10 20 30 40 50) 1 4))) +(test-equal "flexvector-copy! overflow" #(1 2 30 40 50) + (mutate-as fv '#(1 2 3) (flexvector-copy! fv 2 (flexvector 30 40 50)))) +(test-equal "flexvector-reverse-copy!" #(1 40 30 20 5) + (mutate-as fv '#(1 2 3 4 5) (flexvector-reverse-copy! fv 1 (flexvector 20 30 40)))) +(test-equal "flexvector-reverse-copy! bounded" #(1 40 30 20 5) + (mutate-as fv '#(1 2 3 4 5) (flexvector-reverse-copy! fv 1 (flexvector 10 20 30 40 50) 1 4))) +(test-equal "flexvector-reverse-copy! overflow" #(1 2 50 40 30) + (mutate-as fv '#(1 2 3) (flexvector-reverse-copy! fv 2 (flexvector 30 40 50)))) + +(test-end "Flexvectors") |