diff --git a/srfi/vectors/vectors-impl.scm b/srfi/vectors/vectors-impl.scm new file mode 100644 index 00000000..9eaabd0f --- /dev/null +++ b/srfi/vectors/vectors-impl.scm @@ -0,0 +1,1382 @@ +;;;;;; SRFI 43: Vector library -*- Scheme -*- +;;; +;;; $Id$ +;;; +;;; Taylor Campbell wrote this code; he places it in the public domain. +;;; Will Clinger [wdc] made some corrections, also in the public domain. +;;; John Cowan modified this code for SRFI 133; his changes are also in +;;; the public domain. However, in jurisdictions where it is not possible +;;; to dedicate something to the public domain, the entire implementation +;;; is made available under the same license as SRFI 133. + +;;; -------------------- +;;; Exported procedure index +;;; +;;; * Constructors +;;; vector-unfold vector-unfold-right +;;; vector-copy vector-reverse-copy +;;; vector-append vector-concatenate +;;; vector-append-subvectors +;;; +;;; * Predicates +;;; vector-empty? +;;; vector= +;;; +;;; * Iteration +;;; vector-fold vector-fold-right +;;; vector-map vector-map! +;;; vector-for-each +;;; vector-count vector-cumulate +;;; +;;; * Searching +;;; vector-index vector-skip +;;; vector-index-right vector-skip-right +;;; vector-binary-search +;;; vector-any vector-every +;;; vector-partition +;;; +;;; * Mutators +;;; vector-swap! +;;; vector-fill! +;;; vector-reverse! +;;; vector-copy! vector-reverse-copy! +;;; vector-reverse! +;;; vector-unfold! vector-unfold-right! +;;; +;;; * Conversion +;;; vector->list reverse-vector->list +;;; list->vector reverse-list->vector +;;; vector->string string->vector + +;;; -------------------- +;;; Commentary on efficiency of the code + +;;; This code is somewhat tuned for efficiency. There are several +;;; internal routines that can be optimized greatly to greatly improve +;;; the performance of much of the library. These internal procedures +;;; are already carefully tuned for performance, and lambda-lifted by +;;; hand. Some other routines are lambda-lifted by hand, but only the +;;; loops are lambda-lifted, and only if some routine has two possible +;;; loops -- a fast path and an n-ary case --, whereas _all_ of the +;;; internal routines' loops are lambda-lifted so as to never cons a +;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop), +;;; even in Scheme systems that perform no loop optimization (which is +;;; most of them, unfortunately). +;;; +;;; Fast paths are provided for common cases in most of the loops in +;;; this library. +;;; +;;; All calls to primitive vector operations are protected by a prior +;;; type check; they can be safely converted to use unsafe equivalents +;;; of the operations, if available. Ideally, the compiler should be +;;; able to determine this, but the state of Scheme compilers today is +;;; not a happy one. +;;; +;;; Efficiency of the actual algorithms is a rather mundane point to +;;; mention; vector operations are rarely beyond being straightforward. + + + +;;; -------------------- +;;; Utilities + +;;; SRFI 8, too trivial to put in the dependencies list. +(define-syntax receive + (syntax-rules () + ((receive ?formals ?producer ?body1 ?body2 ...) + (call-with-values (lambda () ?producer) + (lambda ?formals ?body1 ?body2 ...))))) + +;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's +;;; if it's available to you. +(define-syntax let*-optionals + (syntax-rules () + ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...) + (let ((args (?x ...))) + (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...))) + ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...) + (let*-optionals:aux ?args ?args ((?var ?default) ...) + ?body1 ?body2 ...)))) + +(define-syntax let*-optionals:aux + (syntax-rules () + ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...) + (if (null? ?args-var) + (let () ?body1 ?body2 ...) + (error "too many arguments" (length ?orig-args-var) + ?orig-args-var))) + ((aux ?orig-args-var ?args-var + ((?var ?default) ?more ...) + ?body1 ?body2 ...) + (if (null? ?args-var) + (let* ((?var ?default) ?more ...) ?body1 ?body2 ...) + (let ((?var (car ?args-var)) + (new-args (cdr ?args-var))) + (let*-optionals:aux ?orig-args-var new-args + (?more ...) + ?body1 ?body2 ...)))))) + +(define (nonneg-int? x) + (and (integer? x) + (not (negative? x)))) + +(define (between? x y z) + (and (< x y) + (<= y z))) + +(define (unspecified-value) (if #f #f)) + +;++ This should be implemented more efficiently. It shouldn't cons a +;++ closure, and the cons cells used in the loops when using this could +;++ be reused. +(define (vectors-ref vectors i) + (map (lambda (v) (vector-ref v i)) vectors)) + + + +;;; -------------------- +;;; Error checking + +;;; Error signalling (not checking) is done in a way that tries to be +;;; as helpful to the person who gets the debugging prompt as possible. +;;; That said, error _checking_ tries to be as unredundant as possible. + +;;; I don't use any sort of general condition mechanism; I use simply +;;; SRFI 23's ERROR, even in cases where it might be better to use such +;;; a general condition mechanism. Fix that when porting this to a +;;; Scheme implementation that has its own condition system. + +;;; In argument checks, upon receiving an invalid argument, the checker +;;; procedure recursively calls itself, but in one of the arguments to +;;; itself is a call to ERROR; this mechanism is used in the hopes that +;;; the user may be thrown into a debugger prompt, proceed with another +;;; value, and let it be checked again. + +;;; Type checking is pretty basic, but easily factored out and replaced +;;; with whatever your implementation's preferred type checking method +;;; is. I doubt there will be many other methods of index checking, +;;; though the index checkers might be better implemented natively. + +;;; (CHECK-TYPE ) -> value +;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an +;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing +;;; that this happened while calling CALLEE. Return VALUE if no +;;; error was signalled. +(define (check-type pred? value callee) + (if (pred? value) + value + ;; Recur: when (or if) the user gets a debugger prompt, he can + ;; proceed where the call to ERROR was with the correct value. + (check-type pred? + (error "erroneous value" + (list pred? value) + `(while calling ,callee)) + callee))) + +;;; (CHECK-INDEX ) -> index +;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an +;;; error stating that it is not and that this happened in a call to +;;; CALLEE. Return INDEX when it is valid. (Note that this does NOT +;;; check that VECTOR is indeed a vector.) +(define (check-index vec index callee) + (let ((index (check-type integer? index callee))) + (cond ((< index 0) + (check-index vec + (error "vector index too low" + index + `(into vector ,vec) + `(while calling ,callee)) + callee)) + ((>= index (vector-length vec)) + (check-index vec + (error "vector index too high" + index + `(into vector ,vec) + `(while calling ,callee)) + callee)) + (else index)))) + +;;; (CHECK-INDICES +;;; +;;; +;;; ) -> [start end] +;;; Ensure that START and END are valid bounds of a range within +;;; VECTOR; if not, signal an error stating that they are not, with +;;; the message being informative about what the argument names were +;;; called -- by using START-NAME & END-NAME --, and that it occurred +;;; while calling CALLEE. Also ensure that VEC is in fact a vector. +;;; Returns no useful value. +(define (check-indices vec start start-name end end-name callee) + (let ((lose (lambda things + (apply error "vector range out of bounds" + (append things + `(vector was ,vec) + `(,start-name was ,start) + `(,end-name was ,end) + `(while calling ,callee))))) + (start (check-type integer? start callee)) + (end (check-type integer? end callee))) + (cond ((> start end) + ;; I'm not sure how well this will work. The intent is that + ;; the programmer tells the debugger to proceed with both a + ;; new START & a new END by returning multiple values + ;; somewhere. + (receive (new-start new-end) + (lose `(,end-name < ,start-name)) + (check-indices vec + new-start start-name + new-end end-name + callee))) + ((< start 0) + (check-indices vec + (lose `(,start-name < 0)) + start-name + end end-name + callee)) + ((>= start (vector-length vec)) + (check-indices vec + (lose `(,start-name > len) + `(len was ,(vector-length vec))) + start-name + end end-name + callee)) + ((> end (vector-length vec)) + (check-indices vec + start start-name + (lose `(,end-name > len) + `(len was ,(vector-length vec))) + end-name + callee)) + (else + (values start end))))) + + + +;;; -------------------- +;;; Internal routines + +;;; These should all be integrated, native, or otherwise optimized -- +;;; they're used a _lot_ --. All of the loops and LETs inside loops +;;; are lambda-lifted by hand, just so as not to cons closures in the +;;; loops. (If your compiler can do better than that if they're not +;;; lambda-lifted, then lambda-drop (?) them.) + +;;; (VECTOR-PARSE-START+END +;;; +;;; ) +;;; -> [start end] +;;; Return two values, composing a valid range within VECTOR, as +;;; extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START +;;; and the length of VECTOR for END --; START-NAME and END-NAME are +;;; purely for error checking. +(define (vector-parse-start+end vec args start-name end-name callee) + (let ((len (vector-length vec))) + (cond ((null? args) + (values 0 len)) + ((null? (cdr args)) + (check-indices vec + (car args) start-name + len end-name + callee)) + ((null? (cddr args)) + (check-indices vec + (car args) start-name + (cadr args) end-name + callee)) + (else + (error "too many arguments" + `(extra args were ,(cddr args)) + `(while calling ,callee)))))) + +(define-syntax let-vector-start+end + (syntax-rules () + ((let-vector-start+end ?callee ?vec ?args (?start ?end) + ?body1 ?body2 ...) + (let ((?vec (check-type vector? ?vec ?callee))) + (receive (?start ?end) + (vector-parse-start+end ?vec ?args '?start '?end + ?callee) + ?body1 ?body2 ...))))) + +;;; (%SMALLEST-LENGTH ) +;;; -> exact, nonnegative integer +;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is +;;; the length that is returned if VECTOR-LIST is empty. Common use +;;; of this is in n-ary vector routines: +;;; (define (f vec . vectors) +;;; (let ((vec (check-type vector? vec f))) +;;; ...(%smallest-length vectors (vector-length vec) f)...)) +;;; %SMALLEST-LENGTH takes care of the type checking -- which is what +;;; the CALLEE argument is for --; thus, the design is tuned for +;;; avoiding redundant type checks. +(define %smallest-length + (letrec ((loop (lambda (vector-list length callee) + (if (null? vector-list) + length + (loop (cdr vector-list) + (min (vector-length + (check-type vector? + (car vector-list) + callee)) + length) + callee))))) + loop)) + +;;; (%VECTOR-COPY! ) +;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, +;;; starting at TSTART in TARGET. +;;; +;;; Optimize this! Probably with some combination of: +;;; - Force it to be integrated. +;;; - Let it use unsafe vector element dereferencing routines: bounds +;;; checking already happens outside of it. (Or use a compiler +;;; that figures this out, but Olin Shivers' PhD thesis seems to +;;; have been largely ignored in actual implementations...) +;;; - Implement it natively as a VM primitive: the VM can undoubtedly +;;; perform much faster than it can make Scheme perform, even with +;;; bounds checking. +;;; - Implement it in assembly: you _want_ the fine control that +;;; assembly can give you for this. +;;; I already lambda-lift it by hand, but you should be able to make it +;;; even better than that. +(define %vector-copy! + (letrec ((loop/l->r (lambda (target source send i j) + (cond ((< i send) + (vector-set! target j + (vector-ref source i)) + (loop/l->r target source send + (+ i 1) (+ j 1)))))) + (loop/r->l (lambda (target source sstart i j) + (cond ((>= i sstart) + (vector-set! target j + (vector-ref source i)) + (loop/r->l target source sstart + (- i 1) (- j 1))))))) + (lambda (target tstart source sstart send) + (if (> sstart tstart) ; Make sure we don't copy over + ; ourselves. + (loop/l->r target source send sstart tstart) + (loop/r->l target source sstart (- send 1) + (+ -1 tstart send (- sstart))))))) + +;;; (%VECTOR-REVERSE-COPY! ) +;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the +;;; reverse order. +(define %vector-reverse-copy! + (letrec ((loop (lambda (target source sstart i j) + (cond ((>= i sstart) + (vector-set! target j (vector-ref source i)) + (loop target source sstart + (- i 1) + (+ j 1))))))) + (lambda (target tstart source sstart send) + (loop target source sstart + (- send 1) + tstart)))) + +;;; (%VECTOR-REVERSE! ) +(define %vector-reverse! + (letrec ((loop (lambda (vec i j) + (cond ((<= i j) + (let ((v (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j v) + (loop vec (+ i 1) (- j 1)))))))) + (lambda (vec start end) + (loop vec start (- end 1))))) + +;;; (%VECTOR-FOLD1 ) -> knil' +;;; (KONS ) -> knil' +(define %vector-fold1 + (letrec ((loop (lambda (kons knil len vec i) + (if (= i len) + knil + (loop kons + (kons knil (vector-ref vec i)) + len vec (+ i 1)))))) + (lambda (kons knil len vec) + (loop kons knil len vec 0)))) + +;;; (%VECTOR-FOLD2+ ...) -> knil' +;;; (KONS ...) -> knil' +(define %vector-fold2+ + (letrec ((loop (lambda (kons knil len vectors i) + (if (= i len) + knil + (loop kons + (apply kons knil + (vectors-ref vectors i)) + len vectors (+ i 1)))))) + (lambda (kons knil len vectors) + (loop kons knil len vectors 0)))) + +;;; (%VECTOR-MAP! ) -> target +;;; (F ) -> elt' +(define %vector-map1! + (letrec ((loop (lambda (f target vec i) + (if (zero? i) + target + (let ((j (- i 1))) + (vector-set! target j + (f (vector-ref vec j))) + (loop f target vec j)))))) + (lambda (f target vec len) + (loop f target vec len)))) + +;;; (%VECTOR-MAP2+! ) -> target +;;; (F ...) -> elt' +(define %vector-map2+! + (letrec ((loop (lambda (f target vectors i) + (if (zero? i) + target + (let ((j (- i 1))) + (vector-set! target j + (apply f (vectors-ref vectors j))) + (loop f target vectors j)))))) + (lambda (f target vectors len) + (loop f target vectors len)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;; + +;;; -------------------- +;;; Constructors + +;;; (VECTOR-UNFOLD ...) -> vector +;;; (F ...) -> [elt seed' ...] +;;; The fundamental vector constructor. Creates a vector whose +;;; length is LENGTH and iterates across each index K between 0 and +;;; LENGTH, applying F at each iteration to the current index and the +;;; current seeds to receive N+1 values: first, the element to put in +;;; the Kth slot and then N new seeds for the next iteration. +(define (vector-unfold f length . initial-seeds) + (define vec (make-vector length)) + (apply vector-unfold! f vec 0 length initial-seeds) + vec) + +;;; (VECTOR-UNFOLD! ...) -> vector +;;; (F ...) -> [elt seed' ...] +;;; Like VECTOR-UNFOLD, but unfolds onto an existing vector starting +;;; at up to but not including . +(define vector-unfold! + (letrec ((tabulate! ; Special zero-seed case. + (lambda (f vec i len) + (cond ((< i len) + (vector-set! vec i (f i)) + (tabulate! f vec (+ i 1) len))))) + (unfold1! ; Fast path for one seed. + (lambda (f vec i len seed) + (if (< i len) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) + (unfold1! f vec (+ i 1) len new-seed))))) + (unfold2+! ; Slower variant for N seeds. + (lambda (f vec i len seeds) + (if (< i len) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (+ i 1) len new-seeds)))))) + (lambda (f vec start end . initial-seeds) + (let ((f (check-type procedure? f vector-unfold!)) + (start (check-type nonneg-int? start vector-unfold!)) + (end (check-type nonneg-int? end vector-unfold!))) + (let () + (cond ((null? initial-seeds) + (tabulate! f vec start end)) + ((null? (cdr initial-seeds)) + (unfold1! f vec start end (car initial-seeds))) + (else + (unfold2+! f vec start end initial-seeds)))))))) + +;;; (VECTOR-UNFOLD-RIGHT ...) -> vector +;;; (F ...) -> [seed' ...] +;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 +;;; (still exclusive with LENGTH and inclusive with 0), not 0 to +;;; LENGTH as with VECTOR-UNFOLD. +(define (vector-unfold-right f len . initial-seeds) + (define vec (make-vector len)) + (apply vector-unfold-right! f vec 0 len initial-seeds) + vec) + +;;; (VECTOR-UNFOLD-RIGHT! ...) -> vector +;;; Like VECTOR-UNFOLD-RIGHT, but unfolds onto an existing vector. +(define (vector-unfold-right! f vec start end . initial-seeds) + (letrec ((tabulate! + (lambda (f vec i) + (cond ((>= i start) + (vector-set! vec i (f i)) + (tabulate! f vec (- i 1)))))) + (unfold1! + (lambda (f vec i seed) + (if (>= i start) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) + (unfold1! f vec (- i 1) new-seed))))) + (unfold2+! + (lambda (f vec i seeds) + (if (>= i start) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (- i 1) new-seeds)))))) + (let ((f (check-type procedure? f vector-unfold-right!)) + (start (check-type nonneg-int? start vector-unfold-right!)) + (end (check-type nonneg-int? end vector-unfold-right!))) + (let ((i (- end 1))) + (cond ((null? initial-seeds) + (tabulate! f vec i)) + ((null? (cdr initial-seeds)) + (unfold1! f vec i (car initial-seeds))) + (else + (unfold2+! f vec i initial-seeds))))))) + +;;; (VECTOR-COPY [ ]) -> vector +;;; Create a newly allocated vector containing the elements from the +;;; range [START,END) in VECTOR. START defaults to 0; END defaults +;;; to the length of VECTOR. END may be greater than the length of +;;; VECTOR, in which case the vector is enlarged; if FILL is passed, +;;; the new locations from which there is no respective element in +;;; VECTOR are filled with FILL. +(define (vector-copy vec . args) + (let ((vec (check-type vector? vec vector-copy))) + ;; We can't use LET-VECTOR-START+END, because we have one more + ;; argument, and we want finer control, too. + ;; + ;; Olin's implementation of LET*-OPTIONALS would prove useful here: + ;; the built-in argument-checks-as-you-go-along produces almost + ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS. + (receive (start end fill) + (vector-copy:parse-args vec args) + (let ((new-vector (make-vector (- end start) fill))) + (%vector-copy! new-vector 0 + vec start + (if (> end (vector-length vec)) + (vector-length vec) + end)) + new-vector)))) + +;;; Auxiliary for VECTOR-COPY. +;;; [wdc] Corrected to allow 0 <= start <= (vector-length vec). +(define (vector-copy:parse-args vec args) + (define (parse-args start end n fill) + (let ((start (check-type nonneg-int? start vector-copy)) + (end (check-type nonneg-int? end vector-copy))) + (cond ((and (<= 0 start end) + (<= start n)) + (values start end fill)) + (else + (error "illegal arguments" + `(while calling ,vector-copy) + `(start was ,start) + `(end was ,end) + `(vector was ,vec)))))) + (let ((n (vector-length vec))) + (cond ((null? args) + (parse-args 0 n n (unspecified-value))) + ((null? (cdr args)) + (parse-args (car args) n n (unspecified-value))) + ((null? (cddr args)) + (parse-args (car args) (cadr args) n (unspecified-value))) + ((null? (cdddr args)) + (parse-args (car args) (cadr args) n (caddr args))) + (else + (error "too many arguments" + vector-copy + (cdddr args)))))) + +;;; (VECTOR-REVERSE-COPY [ ]) -> vector +;;; Create a newly allocated vector whose elements are the reversed +;;; sequence of elements between START and END in VECTOR. START's +;;; default is 0; END's default is the length of VECTOR. +(define (vector-reverse-copy vec . maybe-start+end) + (let-vector-start+end vector-reverse-copy vec maybe-start+end + (start end) + (let ((new (make-vector (- end start)))) + (%vector-reverse-copy! new 0 vec start end) + new))) + +;;; (VECTOR-APPEND ...) -> vector +;;; Append VECTOR ... into a newly allocated vector and return that +;;; new vector. +(define (vector-append . vectors) + (vector-concatenate:aux vectors vector-append)) + +;;; (VECTOR-CONCATENATE ) -> vector +;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to +;;; (apply vector-append VECTOR-LIST) +;;; but VECTOR-APPEND tends to be implemented in terms of +;;; VECTOR-CONCATENATE, and some Schemes bork when the list to apply +;;; a function to is too long. +;;; +;;; Actually, they're both implemented in terms of an internal routine. +(define (vector-concatenate vector-list) + (vector-concatenate:aux vector-list vector-concatenate)) + +;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE +(define vector-concatenate:aux + (letrec ((compute-length + (lambda (vectors len callee) + (if (null? vectors) + len + (let ((vec (check-type vector? (car vectors) + callee))) + (compute-length (cdr vectors) + (+ (vector-length vec) len) + callee))))) + (concatenate! + (lambda (vectors target to) + (if (null? vectors) + target + (let* ((vec1 (car vectors)) + (len (vector-length vec1))) + (%vector-copy! target to vec1 0 len) + (concatenate! (cdr vectors) target + (+ to len))))))) + (lambda (vectors callee) + (cond ((null? vectors) ;+++ + (make-vector 0)) + ((null? (cdr vectors)) ;+++ + ;; Blech, we still have to allocate a new one. + (let* ((vec (check-type vector? (car vectors) callee)) + (len (vector-length vec)) + (new (make-vector len))) + (%vector-copy! new 0 vec 0 len) + new)) + (else + (let ((new-vector + (make-vector (compute-length vectors 0 callee)))) + (concatenate! vectors new-vector 0) + new-vector)))))) + +;;; (VECTOR-APPEND-SUBVECTORS ...) -> vector +;;; Like VECTOR-APPEND but appends subvectors specified by +;;; argument triples. +(define (vector-append-subvectors . args) + ;; GATHER-ARGS returns three values: vectors, starts, ends + (define (gather-args args) + (let loop ((args args) (vecs '()) (starts '()) (ends '())) + (if (null? args) + (values (reverse vecs) (reverse starts) (reverse ends)) + (loop (cdddr args) + (cons (car args) vecs) + (cons (cadr args) starts) + (cons (caddr args) ends))))) + ;; TOTAL-LENGTH computes the length of all subvectors + (define (total-length starts ends) + (let loop ((count 0) (starts starts) (ends ends)) + (if (null? starts) + count + (let ((start (car starts)) (end (car ends))) + (loop (+ count (- end start)) + (cdr starts) + (cdr ends)))))) + ;; COPY-EACH! copies each subvector into a result vector + (define (copy-each! result vecs starts ends) + (let loop ((at 0) (vecs vecs) (starts starts) (ends ends)) + (if (null? vecs) + result + (let ((vec (car vecs)) (start (car starts)) (end (car ends))) + (%vector-copy! result at vec start end) + (loop (+ at (- end start)) + (cdr vecs) + (cdr starts) + (cdr ends)))))) + ;; put them all together, they spell VECTOR-APPEND-SUBVECTORS + (receive (vecs starts ends) (gather-args args) + (define result (make-vector (total-length starts ends))) + (copy-each! result vecs starts ends))) + + +;;; -------------------- +;;; Predicates + +;;; (VECTOR-EMPTY? ) -> boolean +;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length +;;; is 0, and #F if not. +(define (vector-empty? vec) + (let ((vec (check-type vector? vec vector-empty?))) + (zero? (vector-length vec)))) + +;;; (VECTOR= ...) -> boolean +;;; (ELT=? ) -> boolean +;;; Determine vector equality generalized across element comparators. +;;; Vectors A and B are equal iff their lengths are the same and for +;;; each respective elements E_a and E_b (element=? E_a E_b) returns +;;; a true value. ELT=? is always applied to two arguments. Element +;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) +;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a +;;; true value. This may be exploited to avoid multiple unnecessary +;;; element comparisons. (This implementation does, but does not deal +;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary +;;; comparisons, but I believe this optimization is probably fairly +;;; insignificant.) +;;; +;;; If the number of vector arguments is zero or one, then #T is +;;; automatically returned. If there are N vector arguments, +;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are +;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N +;;; are compared. The precise order in which ELT=? is applied is not +;;; specified. +(define (vector= elt=? . vectors) + (let ((elt=? (check-type procedure? elt=? vector=))) + (cond ((null? vectors) + #t) + ((null? (cdr vectors)) + (check-type vector? (car vectors) vector=) + #t) + (else + (let loop ((vecs vectors)) + (let ((vec1 (check-type vector? (car vecs) vector=)) + (vec2+ (cdr vecs))) + (or (null? vec2+) + (and (binary-vector= elt=? vec1 (car vec2+)) + (loop vec2+))))))))) +(define (binary-vector= elt=? vector-a vector-b) + (or (eq? vector-a vector-b) ;+++ + (let ((length-a (vector-length vector-a)) + (length-b (vector-length vector-b))) + (letrec ((loop (lambda (i) + (or (= i length-a) + (and (< i length-b) + (test (vector-ref vector-a i) + (vector-ref vector-b i) + i))))) + (test (lambda (elt-a elt-b i) + (and (or (eq? elt-a elt-b) ;+++ + (elt=? elt-a elt-b)) + (loop (+ i 1)))))) + (and (= length-a length-b) + (loop 0)))))) + + + +;;; -------------------- +;;; Selectors + + + +;;; -------------------- +;;; Iteration + +;;; (VECTOR-FOLD ...) -> knil +;;; (KONS ...) -> knil' ; N vectors -> N+1 args +;;; The fundamental vector iterator. KONS is iterated over each +;;; index in all of the vectors in parallel, stopping at the end of +;;; the shortest; KONS is applied to an argument list of (list I +;;; STATE (vector-ref VEC I) ...), where STATE is the current state +;;; value -- the state value begins with KNIL and becomes whatever +;;; KONS returned at the respective iteration --, and I is the +;;; current index in the iteration. The iteration is strictly left- +;;; to-right. +;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) +;;; <=> +;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) +(define (vector-fold kons knil vec . vectors) + (let ((kons (check-type procedure? kons vector-fold)) + (vec (check-type vector? vec vector-fold))) + (if (null? vectors) + (%vector-fold1 kons knil (vector-length vec) vec) + (%vector-fold2+ kons knil + (%smallest-length vectors + (vector-length vec) + vector-fold) + (cons vec vectors))))) + +;;; (VECTOR-FOLD-RIGHT ...) -> knil +;;; (KONS ...) -> knil' ; N vectors => N+1 args +;;; The fundamental vector recursor. Iterates in parallel across +;;; VECTOR ... right to left, applying KONS to the elements and the +;;; current state value; the state value becomes what KONS returns +;;; at each next iteration. KNIL is the initial state value. +;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) +;;; <=> +;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) +;;; +;;; Not implemented in terms of a more primitive operations that might +;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very +;;; useful elsewhere. +(define vector-fold-right + (letrec ((loop1 (lambda (kons knil vec i) + (if (negative? i) + knil + (loop1 kons (kons knil (vector-ref vec i)) + vec + (- i 1))))) + (loop2+ (lambda (kons knil vectors i) + (if (negative? i) + knil + (loop2+ kons + (apply kons knil + (vectors-ref vectors i)) + vectors + (- i 1)))))) + (lambda (kons knil vec . vectors) + (let ((kons (check-type procedure? kons vector-fold-right)) + (vec (check-type vector? vec vector-fold-right))) + (if (null? vectors) + (loop1 kons knil vec (- (vector-length vec) 1)) + (loop2+ kons knil (cons vec vectors) + (- (%smallest-length vectors + (vector-length vec) + vector-fold-right) + 1))))))) + +;;; (VECTOR-MAP ...) -> vector +;;; (F ...) -> value ; N vectors -> N args +;;; Constructs a new vector of the shortest length of the vector +;;; arguments. Each element at index I of the new vector is mapped +;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The +;;; dynamic order of application of F is unspecified. +(define (vector-map f vec . vectors) + (let ((f (check-type procedure? f vector-map)) + (vec (check-type vector? vec vector-map))) + (if (null? vectors) + (let ((len (vector-length vec))) + (%vector-map1! f (make-vector len) vec len)) + (let ((len (%smallest-length vectors + (vector-length vec) + vector-map))) + (%vector-map2+! f (make-vector len) (cons vec vectors) + len))))) + +;;; (VECTOR-MAP! ...) -> unspecified +;;; (F ...) -> element' ; N vectors -> N args +;;; Similar to VECTOR-MAP, but rather than mapping the new elements +;;; into a new vector, the new mapped elements are destructively +;;; inserted into the first vector. Again, the dynamic order of +;;; application of F is unspecified, so it is dangerous for F to +;;; manipulate the first VECTOR. +(define (vector-map! f vec . vectors) + (let ((f (check-type procedure? f vector-map!)) + (vec (check-type vector? vec vector-map!))) + (if (null? vectors) + (%vector-map1! f vec vec (vector-length vec)) + (%vector-map2+! f vec (cons vec vectors) + (%smallest-length vectors + (vector-length vec) + vector-map!))) + (unspecified-value))) + +;;; (VECTOR-FOR-EACH ...) -> unspecified +;;; (F ...) ; N vectors -> N args +;;; Simple vector iterator: applies F to each index in the range [0, +;;; LENGTH), where LENGTH is the length of the smallest vector +;;; argument passed, and the respective element at that index. In +;;; contrast with VECTOR-MAP, F is reliably applied to each +;;; subsequent elements, starting at index 0 from left to right, in +;;; the vectors. +(define vector-for-each + (letrec ((for-each1 + (lambda (f vec i len) + (cond ((< i len) + (f (vector-ref vec i)) + (for-each1 f vec (+ i 1) len))))) + (for-each2+ + (lambda (f vecs i len) + (cond ((< i len) + (apply f (vectors-ref vecs i)) + (for-each2+ f vecs (+ i 1) len)))))) + (lambda (f vec . vectors) + (let ((f (check-type procedure? f vector-for-each)) + (vec (check-type vector? vec vector-for-each))) + (if (null? vectors) + (for-each1 f vec 0 (vector-length vec)) + (for-each2+ f (cons vec vectors) 0 + (%smallest-length vectors + (vector-length vec) + vector-for-each))))))) + +;;; (VECTOR-COUNT ...) +;;; -> exact, nonnegative integer +;;; (PREDICATE? ...) ; N vectors -> N args +;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., +;;; and a count is tallied of the number of elements for which a +;;; true value is produced by PREDICATE?. This count is returned. +(define (vector-count pred? vec . vectors) + (let ((pred? (check-type procedure? pred? vector-count)) + (vec (check-type vector? vec vector-count))) + (if (null? vectors) + (%vector-fold1 (lambda (count elt) + (if (pred? elt) + (+ count 1) + count)) + 0 + (vector-length vec) + vec) + (%vector-fold2+ (lambda (count . elts) + (if (apply pred? elts) + (+ count 1) + count)) + 0 + (%smallest-length vectors + (vector-length vec) + vector-count) + (cons vec vectors))))) + +;;; (VECTOR-CUMULATE ) +;;; -> vector +;;; Returns a ly allocated vector with the same length as +;;; . Each element of is set to the result of invoking on +;;; [i-1] and [i], except that for the first call on , the first +;;; argument is . The vector is returned. +(define (vector-cumulate f vec knil) + (let* ((len (vector-length vec)) + (result (make-vector len))) + (let loop ((i 0) (left knil)) + (if (= i len) + result + (let* ((right (vector-ref vec i)) (r (f left right))) + (vector-set! result i r) + (loop (+ i 1) r)))))) + + + +;;; -------------------- +;;; Searching + +;;; (VECTOR-INDEX ...) +;;; -> exact, nonnegative integer or #F +;;; (PREDICATE? ...) -> boolean ; N vectors -> N args +;;; Search left-to-right across VECTOR ... in parallel, returning the +;;; index of the first set of values VALUE ... such that (PREDICATE? +;;; VALUE ...) returns a true value; if no such set of elements is +;;; reached, return #F. +(define (vector-index pred? vec . vectors) + (vector-index/skip pred? vec vectors vector-index)) + +;;; (VECTOR-SKIP ...) +;;; -> exact, nonnegative integer or #F +;;; (PREDICATE? ...) -> boolean ; N vectors -> N args +;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) +;;; VECTOR ...) +;;; Like VECTOR-INDEX, but find the index of the first set of values +;;; that do _not_ satisfy PREDICATE?. +(define (vector-skip pred? vec . vectors) + (vector-index/skip (lambda elts (not (apply pred? elts))) + vec vectors + vector-skip)) + +;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP +(define vector-index/skip + (letrec ((loop1 (lambda (pred? vec len i) + (cond ((= i len) #f) + ((pred? (vector-ref vec i)) i) + (else (loop1 pred? vec len (+ i 1)))))) + (loop2+ (lambda (pred? vectors len i) + (cond ((= i len) #f) + ((apply pred? (vectors-ref vectors i)) i) + (else (loop2+ pred? vectors len + (+ i 1))))))) + (lambda (pred? vec vectors callee) + (let ((pred? (check-type procedure? pred? callee)) + (vec (check-type vector? vec callee))) + (if (null? vectors) + (loop1 pred? vec (vector-length vec) 0) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec) + callee) + 0)))))) + +;;; (VECTOR-INDEX-RIGHT ...) +;;; -> exact, nonnegative integer or #F +;;; (PREDICATE? ...) -> boolean ; N vectors -> N args +;;; Right-to-left variant of VECTOR-INDEX. +(define (vector-index-right pred? vec . vectors) + (vector-index/skip-right pred? vec vectors vector-index-right)) + +;;; (VECTOR-SKIP-RIGHT ...) +;;; -> exact, nonnegative integer or #F +;;; (PREDICATE? ...) -> boolean ; N vectors -> N args +;;; Right-to-left variant of VECTOR-SKIP. +(define (vector-skip-right pred? vec . vectors) + (vector-index/skip-right (lambda elts (not (apply pred? elts))) + vec vectors + vector-index-right)) + +(define vector-index/skip-right + (letrec ((loop1 (lambda (pred? vec i) + (cond ((negative? i) #f) + ((pred? (vector-ref vec i)) i) + (else (loop1 pred? vec (- i 1)))))) + (loop2+ (lambda (pred? vectors i) + (cond ((negative? i) #f) + ((apply pred? (vectors-ref vectors i)) i) + (else (loop2+ pred? vectors (- i 1))))))) + (lambda (pred? vec vectors callee) + (let ((pred? (check-type procedure? pred? callee)) + (vec (check-type vector? vec callee))) + (if (null? vectors) + (loop1 pred? vec (- (vector-length vec) 1)) + (loop2+ pred? (cons vec vectors) + (- (%smallest-length vectors + (vector-length vec) + callee) + 1))))))) + +;;; (VECTOR-BINARY-SEARCH [ ]) +;;; -> exact, nonnegative integer or #F +;;; (CMP ) -> integer +;;; positive -> VALUE1 > VALUE2 +;;; zero -> VALUE1 = VALUE2 +;;; negative -> VALUE1 < VALUE2 +;;; Perform a binary search through VECTOR for VALUE, comparing each +;;; element to VALUE with CMP. +(define (vector-binary-search vec value cmp . maybe-start+end) + (let ((cmp (check-type procedure? cmp vector-binary-search))) + (let-vector-start+end vector-binary-search vec maybe-start+end + (start end) + (let loop ((start start) (end end) (j #f)) + (let ((i (quotient (+ start end) 2))) + (if (or (= start end) (and j (= i j))) + #f + (let ((comparison + (check-type integer? + (cmp (vector-ref vec i) value) + `(,cmp for ,vector-binary-search)))) + (cond ((zero? comparison) i) + ((positive? comparison) (loop start i i)) + (else (loop i end i)))))))))) + +;;; (VECTOR-ANY ...) -> value +;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? +;;; should ever return a true value, immediately stop and return that +;;; value; otherwise, when the shortest vector runs out, return #F. +;;; The iteration and order of application of PRED? across elements +;;; is of the vectors is strictly left-to-right. +(define vector-any + (letrec ((loop1 (lambda (pred? vec i len len-1) + (and (not (= i len)) + (if (= i len-1) + (pred? (vector-ref vec i)) + (or (pred? (vector-ref vec i)) + (loop1 pred? vec (+ i 1) + len len-1)))))) + (loop2+ (lambda (pred? vectors i len len-1) + (and (not (= i len)) + (if (= i len-1) + (apply pred? (vectors-ref vectors i)) + (or (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (+ i 1) + len len-1))))))) + (lambda (pred? vec . vectors) + (let ((pred? (check-type procedure? pred? vector-any)) + (vec (check-type vector? vec vector-any))) + (if (null? vectors) + (let ((len (vector-length vec))) + (loop1 pred? vec 0 len (- len 1))) + (let ((len (%smallest-length vectors + (vector-length vec) + vector-any))) + (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) + +;;; (VECTOR-EVERY ...) -> value +;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? +;;; should ever return #F, immediately stop and return #F; otherwise, +;;; if PRED? should return a true value for each element, stopping at +;;; the end of the shortest vector, return the last value that PRED? +;;; returned. In the case that there is an empty vector, return #T. +;;; The iteration and order of application of PRED? across elements +;;; is of the vectors is strictly left-to-right. +(define vector-every + (letrec ((loop1 (lambda (pred? vec i len len-1) + (or (= i len) + (if (= i len-1) + (pred? (vector-ref vec i)) + (and (pred? (vector-ref vec i)) + (loop1 pred? vec (+ i 1) + len len-1)))))) + (loop2+ (lambda (pred? vectors i len len-1) + (or (= i len) + (if (= i len-1) + (apply pred? (vectors-ref vectors i)) + (and (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (+ i 1) + len len-1))))))) + (lambda (pred? vec . vectors) + (let ((pred? (check-type procedure? pred? vector-every)) + (vec (check-type vector? vec vector-every))) + (if (null? vectors) + (let ((len (vector-length vec))) + (loop1 pred? vec 0 len (- len 1))) + (let ((len (%smallest-length vectors + (vector-length vec) + vector-every))) + (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) + +;;; (VECTOR-PARTITION ) -> vector +;;; A vector the same size as is newly allocated and filled with +;;; all the elements of that satisfy in their original +;;; order followed by all the elements that do not satisfy , +;;; also in their original order. + +;;; Two values are returned, the newly allocated vector and the index +;;; of the leftmost element that does not satisfy . +(define (vector-partition pred? vec) + (let* ((len (vector-length vec)) + (cnt (vector-count pred? vec)) + (result (make-vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (if (= i len) + (values result cnt) + (let ((elem (vector-ref vec i))) + (if (pred? elem) + (begin + (vector-set! result yes elem) + (loop (+ i 1) (+ yes 1) no)) + (begin + (vector-set! result no elem) + (loop (+ i 1) yes (+ no 1))))))))) + + + +;;; -------------------- +;;; Mutators + +;;; (VECTOR-SWAP! ) -> unspecified +;;; Swap the values in the locations at INDEX1 and INDEX2. +(define (vector-swap! vec i j) + (let ((vec (check-type vector? vec vector-swap!))) + (let ((i (check-index vec i vector-swap!)) + (j (check-index vec j vector-swap!))) + (let ((x (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j x))))) + +;;; (VECTOR-FILL! [ ]) -> unspecified +;;; [R5RS+] Fill the locations in VECTOR between START, whose default +;;; is 0, and END, whose default is the length of VECTOR, with VALUE. +;;; +;;; This one can probably be made really fast natively. +(define (vector-fill! vec value . maybe-start+end) + (let-vector-start+end vector-fill! vec maybe-start+end (start end) + (do ((i start (+ i 1))) + ((= i end)) + (vector-set! vec i value)))) + +;;; (VECTOR-COPY! [ ]) +;;; -> unspecified +;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to +;;; to TARGET, starting at TSTART in TARGET. +;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). +(define (vector-copy! target tstart source . maybe-sstart+send) + (define (doit! sstart send source-length) + (let ((tstart (check-type nonneg-int? tstart vector-copy!)) + (sstart (check-type nonneg-int? sstart vector-copy!)) + (send (check-type nonneg-int? send vector-copy!))) + (cond ((and (<= 0 sstart send source-length) + (<= (+ tstart (- send sstart)) (vector-length target))) + (%vector-copy! target tstart source sstart send)) + (else + (error "illegal arguments" + `(while calling ,vector-copy!) + `(target was ,target) + `(target-length was ,(vector-length target)) + `(tstart was ,tstart) + `(source was ,source) + `(source-length was ,source-length) + `(sstart was ,sstart) + `(send was ,send)))))) + (let ((n (vector-length source))) + (cond ((null? maybe-sstart+send) + (doit! 0 n n)) + ((null? (cdr maybe-sstart+send)) + (doit! (car maybe-sstart+send) n n)) + ((null? (cddr maybe-sstart+send)) + (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) + (else + (error "too many arguments" + vector-copy! + (cddr maybe-sstart+send)))))) + +;;; (VECTOR-REVERSE-COPY! [ ]) +;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). +(define (vector-reverse-copy! target tstart source . maybe-sstart+send) + (define (doit! sstart send source-length) + (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!)) + (sstart (check-type nonneg-int? sstart vector-reverse-copy!)) + (send (check-type nonneg-int? send vector-reverse-copy!))) + (cond ((and (eq? target source) + (or (between? sstart tstart send) + (between? tstart sstart + (+ tstart (- send sstart))))) + (error "vector range for self-copying overlaps" + vector-reverse-copy! + `(vector was ,target) + `(tstart was ,tstart) + `(sstart was ,sstart) + `(send was ,send))) + ((and (<= 0 sstart send source-length) + (<= (+ tstart (- send sstart)) (vector-length target))) + (%vector-reverse-copy! target tstart source sstart send)) + (else + (error "illegal arguments" + `(while calling ,vector-reverse-copy!) + `(target was ,target) + `(target-length was ,(vector-length target)) + `(tstart was ,tstart) + `(source was ,source) + `(source-length was ,source-length) + `(sstart was ,sstart) + `(send was ,send)))))) + (let ((n (vector-length source))) + (cond ((null? maybe-sstart+send) + (doit! 0 n n)) + ((null? (cdr maybe-sstart+send)) + (doit! (car maybe-sstart+send) n n)) + ((null? (cddr maybe-sstart+send)) + (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) + (else + (error "too many arguments" + vector-reverse-copy! + (cddr maybe-sstart+send)))))) + +;;; (VECTOR-REVERSE! [ ]) -> unspecified +;;; Destructively reverse the contents of the sequence of locations +;;; in VECTOR between START, whose default is 0, and END, whose +;;; default is the length of VECTOR. +(define (vector-reverse! vec . start+end) + (let-vector-start+end vector-reverse! vec start+end + (start end) + (%vector-reverse! vec start end))) + + + +;;; -------------------- +;;; Conversion + +;;; (VECTOR->LIST [ ]) -> list +;;; [R5RS+] Produce a list containing the elements in the locations +;;; between START, whose default is 0, and END, whose default is the +;;; length of VECTOR, from VECTOR. +(define (vector->list vec . maybe-start+end) + (let-vector-start+end vector->list vec maybe-start+end (start end) + (do ((i (- end 1) (- i 1)) + (result '() (cons (vector-ref vec i) result))) + ((< i start) result)))) + +;;; (REVERSE-VECTOR->LIST [ ]) -> list +;;; Produce a list containing the elements in the locations between +;;; START, whose default is 0, and END, whose default is the length +;;; of VECTOR, from VECTOR, in reverse order. +(define (reverse-vector->list vec . maybe-start+end) + (let-vector-start+end reverse-vector->list vec maybe-start+end (start end) + (do ((i start (+ i 1)) + (result '() (cons (vector-ref vec i) result))) + ((= i end) result)))) + +;;; (LIST->VECTOR [ ]) -> vector +;;; [R5RS+] Produce a vector containing the elements in LIST, which +;;; must be a proper list, between START, whose default is 0, & END, +;;; whose default is the length of LIST. It is suggested that if the +;;; length of LIST is known in advance, the START and END arguments +;;; be passed, so that LIST->VECTOR need not call LENGTH to determine +;;; the length. +;;; +;;; This implementation diverges on circular lists, unless LENGTH fails +;;; and causes - to fail as well. Given a LENGTH* that computes the +;;; length of a list's cycle, this wouldn't diverge, and would work +;;; great for circular lists. +(define (list->vector lst . maybe-start+end) + ;; We can't use LET-VECTOR-START+END, because we're using the + ;; bounds of a _list_, not a vector. + (let*-optionals maybe-start+end + ((start 0) + (end (length lst))) ; Ugh -- LENGTH + (let ((start (check-type nonneg-int? start list->vector)) + (end (check-type nonneg-int? end list->vector))) + ((lambda (f) + (vector-unfold f (- end start) (list-tail lst start))) + (lambda (index l) + (cond ((null? l) + (error "list was too short" + `(list was ,lst) + `(attempted end was ,end) + `(while calling ,list->vector))) + ((pair? l) + (values (car l) (cdr l))) + (else + ;; Make this look as much like what CHECK-TYPE + ;; would report as possible. + (error "erroneous value" + ;; We want SRFI 1's PROPER-LIST?, but it + ;; would be a waste to link all of SRFI + ;; 1 to this module for only the single + ;; function PROPER-LIST?. + (list list? lst) + `(while calling + ,list->vector))))))))) + +;;; (REVERSE-LIST->VECTOR [ ]) -> vector +;;; Produce a vector containing the elements in LIST, which must be a +;;; proper list, between START, whose default is 0, and END, whose +;;; default is the length of LIST, in reverse order. It is suggested +;;; that if the length of LIST is known in advance, the START and END +;;; arguments be passed, so that REVERSE-LIST->VECTOR need not call +;;; LENGTH to determine the the length. +;;; +;;; This also diverges on circular lists unless, again, LENGTH returns +;;; something that makes - bork. +(define (reverse-list->vector lst . maybe-start+end) + (let*-optionals maybe-start+end + ((start 0) + (end (length lst))) ; Ugh -- LENGTH + (let ((start (check-type nonneg-int? start reverse-list->vector)) + (end (check-type nonneg-int? end reverse-list->vector))) + ((lambda (f) + (vector-unfold-right f (- end start) (list-tail lst start))) + (lambda (index l) + (cond ((null? l) + (error "list too short" + `(list was ,lst) + `(attempted end was ,end) + `(while calling ,reverse-list->vector))) + ((pair? l) + (values (car l) (cdr l))) + (else + (error "erroneous value" + (list list? lst) + `(while calling ,reverse-list->vector))))))))) + +;;; (VECTOR->STRING [ ]) -> string +;;; Produce a string containing the elements in the locations +;;; between START, whose default is 0, and END, whose default is the +;;; length of VECTOR, from VECTOR. +(define (vector->string vec . maybe-start+end) + (let* ((len (vector-length vec)) + (start (if (null? maybe-start+end) 0 (car maybe-start+end))) + (end (if (null? maybe-start+end) + len + (if (null? (cdr maybe-start+end)) len (cadr maybe-start+end)))) + (size (- end start))) + (define result (make-string size)) + (let loop ((at 0) (i start)) + (if (= i end) + result + (begin + (string-set! result at (vector-ref vec i)) + (loop (+ at 1) (+ i 1))))))) + +;;; (STRING->VECTOR [ ]) -> vector +;;; Produce a vector containing the elements in STRING +;;; between START, whose default is 0, & END, +;;; whose default is the length of STRING, from STRING. +(define (string->vector str . maybe-start+end) + (let* ((len (string-length str)) + (start (if (null? maybe-start+end) 0 (car maybe-start+end))) + (end (if (null? maybe-start+end) + len + (if (null? (cdr maybe-start+end)) len (cadr maybe-start+end)))) + (size (- end start))) + (define result (make-vector size)) + (let loop ((at 0) (i start)) + (if (= i end) + result + (begin + (vector-set! result at (string-ref str i)) + (loop (+ at 1) (+ i 1))))))) + diff --git a/srfi/vectors/vectors-test.scm b/srfi/vectors/vectors-test.scm new file mode 100644 index 00000000..6d89c51c --- /dev/null +++ b/srfi/vectors/vectors-test.scm @@ -0,0 +1,192 @@ +(cond-expand + (chicken (use test srfi-133)) + (chibi (import (scheme base) (chibi test) (vectors)))) +(test-group "vectors" + (test-group "vectors/basics" + (define v (make-vector 3 3)) + (test-assert (vector? #(1 2 3))) + (test-assert (vector? (make-vector 10))) + (test 3 (vector-ref v 0)) + (test 3 (vector-ref v 1)) + (test 3 (vector-ref v 2)) + (test-error (vector-ref v -1)) + (test-error (vector-ref v 3)) + (vector-set! v 0 -32) + (test -32 (vector-ref v 0)) + (test 3 (vector-length v)) + (test 0 (vector-length '#())) + ) ; end vectors/basics + + (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)) + ) ; end vectors/constructors + + (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)))) + ) ; end vectors/predicates + + (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 + '#(3 1 4 1 5 9 2 5 6) 0)) + ) ; end vectors/iteration + + (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))) + ) ; end vectors-searching + + (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)) + + ) ; end vectors/mutation + + (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)) + ) ; end vectors/conversion +) ; end vectors +(test-exit) diff --git a/srfi/vectors/vectors.sld b/srfi/vectors/vectors.sld new file mode 100644 index 00000000..fb0da4f7 --- /dev/null +++ b/srfi/vectors/vectors.sld @@ -0,0 +1,21 @@ +(define-library (vectors) + (import (scheme base)) + (import (scheme cxr)) + ;; Constructors + (export vector-unfold vector-unfold-right vector-reverse-copy + vector-concatenate vector-append-subvectors) + ;; Predicates + (export vector-empty? vector=) + ;; Iteration + (export vector-fold vector-fold-right vector-map! + vector-count vector-cumulate) + ;; Searching + (export vector-index vector-index-right vector-skip vector-skip-right + vector-binary-search vector-any vector-every vector-partition) + ;; Mutators + (export vector-swap! vector-reverse! + vector-reverse-copy! vector-unfold! vector-unfold-right!) + ;; Conversion + (export reverse-vector->list reverse-list->vector) + (include "vectors-impl.scm") +)