844 lines
36 KiB
Scheme
844 lines
36 KiB
Scheme
;;; Copyright (C) 2005-2008 by Chongkai Zhu.
|
|
|
|
(module vector-lib mzscheme
|
|
|
|
(require srfi/8/receive
|
|
mzlib/etc
|
|
mzlib/contract)
|
|
|
|
(define mutable-vector/c
|
|
(and/c vector? (not/c immutable?)))
|
|
(define index/c
|
|
(and/c natural-number/c
|
|
exact?))
|
|
|
|
(define (vec-start-end-contract vector?)
|
|
(case->
|
|
(-> vector? any)
|
|
(->r ((vec vector?)
|
|
(start (and/c index/c
|
|
(<=/c (vector-length vec)))))
|
|
any)
|
|
(->pp ((vec vector?)
|
|
(start index/c)
|
|
(end index/c))
|
|
(<= start end (vector-length vec))
|
|
any)))
|
|
|
|
;;; (%SMALLEST-LENGTH <vector-list> <default-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)
|
|
(define (%smallest-length vector-list length)
|
|
(if (null? vector-list)
|
|
length
|
|
(%smallest-length (cdr vector-list)
|
|
(min length
|
|
(vector-length (car vector-list))))))
|
|
|
|
(define (vectors-ref vectors i)
|
|
(map (lambda (v) (vector-ref v i)) vectors))
|
|
|
|
;;; from vector-unfold-right
|
|
(define (unfold1! f vec i seed)
|
|
(if (>= i 0)
|
|
(receive (elt new-seed)
|
|
(f i seed)
|
|
(vector-set! vec i elt)
|
|
(unfold1! f vec (sub1 i) new-seed))))
|
|
|
|
(define unfold-contract
|
|
(->r ((f (lambda (f)
|
|
(and (procedure? f)
|
|
(procedure-arity-includes? f (add1 (length seeds))))))
|
|
(len index/c))
|
|
seeds list?
|
|
any))
|
|
|
|
(define copy-contract
|
|
(case->
|
|
(-> vector? any)
|
|
(->r ((vec vector?)
|
|
(start (and/c index/c
|
|
(<=/c (vector-length vec)))))
|
|
any)
|
|
(->r ((vec vector?)
|
|
(start (and/c index/c
|
|
(<=/c (vector-length vec))))
|
|
(end (and/c index/c
|
|
(>=/c start))))
|
|
any)
|
|
(->r ((vec vector?)
|
|
(start (and/c index/c
|
|
(<=/c (vector-length vec))))
|
|
(end (and/c index/c
|
|
(>=/c start)))
|
|
(fill any/c))
|
|
any)))
|
|
|
|
(provide/contract (vector-unfold unfold-contract)
|
|
(vector-unfold-right unfold-contract)
|
|
(vector-copy copy-contract)
|
|
(vector-reverse-copy (vec-start-end-contract vector?))
|
|
(vector-append (->* () (listof vector?) any))
|
|
(vector-concatenate (-> (listof vector?) any)))
|
|
|
|
;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
|
|
;;; (F <index> <seed> ...) -> [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
|
|
(letrec ((tabulate! ; Special zero-seed case.
|
|
(lambda (f vec i len)
|
|
(cond ((< i len)
|
|
(vector-set! vec i (f i))
|
|
(tabulate! f vec (add1 i) 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 (add1 i) 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 (add1 i) len new-seeds))))))
|
|
(lambda (f len . initial-seeds)
|
|
(let ((vec (make-vector len)))
|
|
(cond ((null? initial-seeds)
|
|
(tabulate! f vec 0 len))
|
|
((null? (cdr initial-seeds))
|
|
(unfold1! f vec 0 len (car initial-seeds)))
|
|
(else
|
|
(unfold2+! f vec 0 len initial-seeds)))
|
|
vec))))
|
|
|
|
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
|
|
;;; (F <seed> ...) -> [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
|
|
(letrec ((tabulate!
|
|
(lambda (f vec i)
|
|
(cond ((>= i 0)
|
|
(vector-set! vec i (f i))
|
|
(tabulate! f vec (sub1 i))))))
|
|
(unfold2+!
|
|
(lambda (f vec i seeds)
|
|
(if (>= i 0)
|
|
(receive (elt . new-seeds)
|
|
(apply f i seeds)
|
|
(vector-set! vec i elt)
|
|
(unfold2+! f vec (sub1 i) new-seeds))))))
|
|
(lambda (f len . initial-seeds)
|
|
(let ((vec (make-vector len))
|
|
(i (sub1 len)))
|
|
(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)))
|
|
vec))))
|
|
|
|
;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> 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
|
|
(opt-lambda (vec (start 0) (end (vector-length vec)) (fill 0))
|
|
(let ((new-vector
|
|
(make-vector (- end start) fill)))
|
|
(vector-copy! new-vector 0
|
|
vec start
|
|
(min end (vector-length vec)))
|
|
new-vector)))
|
|
|
|
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> 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
|
|
(opt-lambda (vec (start 0) (end (vector-length vec)))
|
|
(let ((new (make-vector (- end start))))
|
|
(vector-reverse-copy! new 0 vec start end)
|
|
new)))
|
|
|
|
;;; (VECTOR-APPEND <vector> ...) -> vector
|
|
;;; Append VECTOR ... into a newly allocated vector and return that
|
|
;;; new vector.
|
|
(define (vector-append . vectors)
|
|
(vector-concatenate vectors))
|
|
|
|
;;; (VECTOR-CONCATENATE <vector-list>) -> vector
|
|
;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to
|
|
;;; (apply vector-append VECTOR-LIST)
|
|
;;; Actually, they're both implemented in terms of an internal routine.
|
|
(define vector-concatenate
|
|
(letrec ((compute-length
|
|
(lambda (vectors len)
|
|
(if (null? vectors)
|
|
len
|
|
(let ((vec (car vectors)))
|
|
(compute-length (cdr vectors)
|
|
(+ (vector-length vec) len))))))
|
|
(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)
|
|
(let ((new-vector
|
|
(make-vector (compute-length vectors 0))))
|
|
(concatenate! vectors new-vector 0)
|
|
new-vector))))
|
|
|
|
(provide/contract (vector-empty?
|
|
(-> vector? any))
|
|
(vector=
|
|
(->* ((-> any/c any/c any))
|
|
(listof vector?)
|
|
any)))
|
|
|
|
;;; (VECTOR-EMPTY? <vector>) -> 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)
|
|
(zero? (vector-length vec)))
|
|
|
|
;;; (VECTOR= <elt=?> <vector> ...) -> boolean
|
|
;;; (ELT=? <value> <value>) -> 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)
|
|
(or (null? vectors)
|
|
(null? (cdr vectors))
|
|
(let loop ((vecs vectors))
|
|
(let ((vec1 (car vecs))
|
|
(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)))
|
|
(and (= length-a (vector-length vector-b))
|
|
(let loop ((i 0))
|
|
(or (= i length-a)
|
|
(and (elt=? (vector-ref vector-a i)
|
|
(vector-ref vector-b i))
|
|
(loop (add1 i)))))))))
|
|
|
|
(define fold-contract
|
|
(->r ((kons (lambda (f)
|
|
(and (procedure? f)
|
|
(procedure-arity-includes? f (+ 3 (length vec))))))
|
|
(knil any/c)
|
|
(vec1 vector?))
|
|
vec (listof vector?)
|
|
any))
|
|
|
|
(define (map-contract m)
|
|
(->r ((f (lambda (f)
|
|
(and (procedure? f)
|
|
(procedure-arity-includes? f (+ 2 (length vec))))))
|
|
(vec1 m))
|
|
vec (listof vector?)
|
|
any))
|
|
|
|
(provide/contract (vector-fold fold-contract)
|
|
(vector-fold-right fold-contract)
|
|
(vector-map (map-contract vector?))
|
|
(vector-map! (map-contract mutable-vector/c))
|
|
(vector-for-each (map-contract vector?))
|
|
(vector-count (map-contract vector?)))
|
|
|
|
;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
|
|
;;; (KONS <knil> <elt> ...) -> 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)
|
|
(if (null? vectors)
|
|
(%vector-fold1 kons knil (vector-length vec) vec)
|
|
(%vector-fold2+ kons knil
|
|
(%smallest-length vectors
|
|
(vector-length vec))
|
|
(cons vec vectors))))
|
|
|
|
(define %vector-fold1
|
|
(letrec ((loop (lambda (kons knil len vec i)
|
|
(if (= i len)
|
|
knil
|
|
(loop kons
|
|
(kons i knil (vector-ref vec i))
|
|
len vec (add1 i))))))
|
|
(lambda (kons knil len vec)
|
|
(loop kons knil len vec 0))))
|
|
(define %vector-fold2+
|
|
(letrec ((loop (lambda (kons knil len vectors i)
|
|
(if (= i len)
|
|
knil
|
|
(loop kons
|
|
(apply kons i knil
|
|
(vectors-ref vectors i))
|
|
len vectors (add1 i))))))
|
|
(lambda (kons knil len vectors)
|
|
(loop kons knil len vectors 0))))
|
|
|
|
;;; (VECTOR-COUNT <predicate?> <vector> ...)
|
|
;;; -> exact, nonnegative integer
|
|
;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 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)
|
|
(if (null? vectors)
|
|
(%vector-fold1 (lambda (index count elt)
|
|
(if (pred? index elt)
|
|
(add1 count)
|
|
count))
|
|
0
|
|
(vector-length vec)
|
|
vec)
|
|
(%vector-fold2+ (lambda (index count . elts)
|
|
(if (apply pred? index elts)
|
|
(add1 count)
|
|
count))
|
|
0
|
|
(%smallest-length vectors
|
|
(vector-length vec))
|
|
(cons vec vectors))))
|
|
|
|
;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
|
|
;;; (KONS <knil> <elt> ...) -> 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 (zero? i)
|
|
knil
|
|
(let ((j (sub1 i)))
|
|
(loop1 kons
|
|
(kons j knil (vector-ref vec j))
|
|
vec
|
|
j)))))
|
|
(loop2+ (lambda (kons knil vectors i)
|
|
(if (zero? i)
|
|
knil
|
|
(let ((j (sub1 i)))
|
|
(loop2+ kons
|
|
(apply kons j knil
|
|
(vectors-ref vectors j))
|
|
vectors
|
|
j))))))
|
|
(lambda (kons knil vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 kons knil vec (vector-length vec))
|
|
(loop2+ kons knil (cons vec vectors)
|
|
(%smallest-length vectors
|
|
(vector-length vec)))))))
|
|
|
|
;;; (VECTOR-MAP <f> <vector> ...) -> vector
|
|
;;; (F <elt> ...) -> 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)
|
|
(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-map2+! f (make-vector len)
|
|
(cons vec vectors) len))))
|
|
|
|
;;; (%VECTOR-MAP1! <f> <target> <length> <vector>)
|
|
;;; (F <index> <elt>) -> elt'
|
|
(define (%vector-map1! f target vec i)
|
|
(if (zero? i)
|
|
target
|
|
(let ((j (sub1 i)))
|
|
(vector-set! target j
|
|
(f j (vector-ref vec j)))
|
|
(%vector-map1! f target vec j))))
|
|
(define (%vector-map2+! f target vectors i)
|
|
(if (zero? i)
|
|
target
|
|
(let ((j (sub1 i)))
|
|
(vector-set! target j
|
|
(apply f j (vectors-ref vectors j)))
|
|
(%vector-map2+! f target vectors j))))
|
|
|
|
;;; (VECTOR-MAP! <f> <vector> ...) -> vector
|
|
;;; (F <elt> ...) -> 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)
|
|
(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-FOR-EACH <f> <vector> ...) -> void
|
|
;;; (F <elt> ...) ; 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)
|
|
(when (< i len)
|
|
(f i (vector-ref vec i))
|
|
(for-each1 f vec (add1 i) len))))
|
|
(for-each2+
|
|
(lambda (f vecs i len)
|
|
(when (< i len)
|
|
(apply f i (vectors-ref vecs i))
|
|
(for-each2+ f vecs (add1 i) len)))))
|
|
(lambda (f vec . vectors)
|
|
(if (null? vectors)
|
|
(for-each1 f vec 0 (vector-length vec))
|
|
(for-each2+ f (cons vec vectors) 0
|
|
(%smallest-length vectors
|
|
(vector-length vec)))))))
|
|
|
|
(define index-contract
|
|
(->r ((f (lambda (f)
|
|
(and (procedure? f)
|
|
(procedure-arity-includes? f (add1 (length vec))))))
|
|
(vec1 vector?))
|
|
vec (listof vector?)
|
|
any))
|
|
|
|
(provide/contract (vector-index index-contract)
|
|
(vector-index-right index-contract)
|
|
(vector-skip index-contract)
|
|
(vector-skip-right index-contract)
|
|
(vector-binary-search
|
|
(-> vector? any/c
|
|
(-> any/c any/c real?)
|
|
any))
|
|
(vector-any index-contract)
|
|
(vector-every index-contract))
|
|
|
|
;; All the functions (except vector-binary-search) here can be
|
|
;; abstracted, but for performance I didn't do so.
|
|
|
|
;;; (VECTOR-INDEX <predicate?> <vector> ...)
|
|
;;; -> exact, nonnegative integer or #F
|
|
;;; (PREDICATE? <elt> ...) -> 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
|
|
(letrec ((loop1 (lambda (pred? vec len i)
|
|
(cond ((= i len) #f)
|
|
((pred? (vector-ref vec i)) i)
|
|
(else (loop1 pred? vec len (add1 i))))))
|
|
(loop2+ (lambda (pred? vectors len i)
|
|
(cond ((= i len) #f)
|
|
((apply pred? (vectors-ref vectors i)) i)
|
|
(else (loop2+ pred? vectors len (add1 i)))))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec (vector-length vec) 0)
|
|
(loop2+ pred? (cons vec vectors)
|
|
(%smallest-length vectors
|
|
(vector-length vec))
|
|
0)))))
|
|
|
|
;;; (VECTOR-SKIP <predicate?> <vector> ...)
|
|
;;; -> exact, nonnegative integer or #F
|
|
;;; (PREDICATE? <elt> ...) -> 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
|
|
(letrec ((loop1 (lambda (pred? vec len i)
|
|
(cond ((= i len) #f)
|
|
((pred? (vector-ref vec i))
|
|
(loop1 pred? vec len (add1 i)))
|
|
(else i))))
|
|
(loop2+ (lambda (pred? vectors len i)
|
|
(cond ((= i len) #f)
|
|
((apply pred? (vectors-ref vectors i))
|
|
(loop2+ pred? vectors len (add1 i)))
|
|
(else i)))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec (vector-length vec) 0)
|
|
(loop2+ pred? (cons vec vectors)
|
|
(%smallest-length vectors
|
|
(vector-length vec))
|
|
0)))))
|
|
|
|
;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
|
|
;;; -> exact, nonnegative integer or #F
|
|
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
|
|
;;; Right-to-left variant of VECTOR-INDEX.
|
|
(define vector-index-right
|
|
(letrec ((loop1 (lambda (pred? vec i)
|
|
(if (zero? i)
|
|
#f
|
|
(let ((i (sub1 i)))
|
|
(if (pred? (vector-ref vec i))
|
|
i
|
|
(loop1 pred? vec i))))))
|
|
(loop2+ (lambda (pred? vectors i)
|
|
(if (zero? i)
|
|
#f
|
|
(let ((i (sub1 i)))
|
|
(if (apply pred? (vectors-ref vectors i))
|
|
i
|
|
(loop2+ pred? vectors i)))))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec (vector-length vec))
|
|
(loop2+ pred? (cons vec vectors)
|
|
(%smallest-length vectors
|
|
(vector-length vec)))))))
|
|
|
|
;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
|
|
;;; -> exact, nonnegative integer or #F
|
|
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
|
|
;;; Right-to-left variant of VECTOR-SKIP.
|
|
(define vector-skip-right
|
|
(letrec ((loop1 (lambda (pred? vec i)
|
|
(if (zero? i)
|
|
#f
|
|
(let ((i (sub1 i)))
|
|
(if (pred? (vector-ref vec i))
|
|
(loop1 pred? vec i)
|
|
i)))))
|
|
(loop2+ (lambda (pred? vectors i)
|
|
(if (zero? i)
|
|
#f
|
|
(let ((i (sub1 i)))
|
|
(if (apply pred? (vectors-ref vectors i))
|
|
(loop2+ pred? vectors i)
|
|
i))))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec (vector-length vec))
|
|
(loop2+ pred? (cons vec vectors)
|
|
(%smallest-length vectors
|
|
(vector-length vec)))))))
|
|
|
|
;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>)
|
|
;;; -> exact, nonnegative integer or #F
|
|
;;; (CMP <value1> <value2>) -> 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)
|
|
(let loop ((start 0)
|
|
(end (vector-length vec)))
|
|
(if (= start end)
|
|
#f
|
|
(let* ((i (quotient (+ start end) 2))
|
|
(comparison (cmp (vector-ref vec i) value)))
|
|
(cond ((zero? comparison) i)
|
|
((positive? comparison) (loop start i))
|
|
(else (loop (add1 i) end)))))))
|
|
|
|
;;; (VECTOR-ANY <pred?> <vector> ...) -> 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)
|
|
(and (not (= i len))
|
|
(or (pred? (vector-ref vec i))
|
|
(loop1 pred? vec (add1 i) len)))))
|
|
(loop2+ (lambda (pred? vectors i len)
|
|
(and (not (= i len))
|
|
(or (apply pred? (vectors-ref vectors i))
|
|
(loop2+ pred? vectors (add1 i) len))))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec 0 (vector-length vec))
|
|
(loop2+ pred? (cons vec vectors)
|
|
0 (%smallest-length vectors
|
|
(vector-length vec)))))))
|
|
|
|
;;; (VECTOR-EVERY <pred?> <vector> ...) -> 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)
|
|
(or (> i len)
|
|
(if (= i len)
|
|
(pred? (vector-ref vec i))
|
|
(and (pred? (vector-ref vec i))
|
|
(loop1 pred? vec (add1 i) len))))))
|
|
(loop2+ (lambda (pred? vectors i len)
|
|
(or (> i len)
|
|
(if (= i len)
|
|
(apply pred? (vectors-ref vectors i))
|
|
(and (apply pred? (vectors-ref vectors i))
|
|
(loop2+ pred? vectors (add1 i) len)))))))
|
|
(lambda (pred? vec . vectors)
|
|
(if (null? vectors)
|
|
(loop1 pred? vec 0 (sub1 (vector-length vec)))
|
|
(loop2+ pred?
|
|
(cons vec vectors)
|
|
0
|
|
(sub1
|
|
(%smallest-length vectors
|
|
(vector-length vec))))))))
|
|
|
|
(define copy!-contract
|
|
(case->
|
|
(->r ((target mutable-vector/c)
|
|
(tstart (and/c index/c
|
|
(<=/c (- (vector-length target)
|
|
(vector-length source)))))
|
|
(source vector?))
|
|
any)
|
|
(->r ((target mutable-vector/c)
|
|
(tstart (and/c index/c
|
|
(<=/c (- (vector-length target)
|
|
(- (vector-length source)
|
|
sstart)))))
|
|
(source vector?)
|
|
(sstart (and/c index/c
|
|
(<=/c (vector-length source)))))
|
|
any)
|
|
(->pp ((target mutable-vector/c)
|
|
(tstart (and/c index/c
|
|
(<=/c (- (vector-length target)
|
|
(- send sstart)))))
|
|
(source vector?)
|
|
(sstart index/c)
|
|
(send index/c))
|
|
(<= sstart send (vector-length source))
|
|
any)))
|
|
|
|
(provide/contract (vector-swap!
|
|
(->r ((vec mutable-vector/c)
|
|
(i (and/c index/c
|
|
(</c (vector-length vec))))
|
|
(j (and/c index/c
|
|
(</c (vector-length vec)))))
|
|
any))
|
|
(rename my-vector-fill! s:vector-fill!
|
|
(case->
|
|
(-> vector? any/c any)
|
|
(->r ((vec vector?)
|
|
(fill any/c)
|
|
(start (and/c index/c
|
|
(<=/c (vector-length vec)))))
|
|
any)
|
|
(->pp ((vec vector?)
|
|
(fill any/c)
|
|
(start index/c)
|
|
(end index/c))
|
|
(<= start end (vector-length vec))
|
|
any)))
|
|
(vector-reverse! (vec-start-end-contract mutable-vector/c))
|
|
(vector-copy! copy!-contract)
|
|
(vector-reverse-copy! copy!-contract))
|
|
|
|
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void
|
|
;;; Swap the values in the locations at INDEX1 and INDEX2.
|
|
(define (vector-swap! vec i j)
|
|
(let ((x (vector-ref vec i)))
|
|
(vector-set! vec i (vector-ref vec j))
|
|
(vector-set! vec j x)))
|
|
|
|
;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector>
|
|
;;; [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 my-vector-fill!
|
|
(case-lambda
|
|
((vec value)
|
|
(vector-fill! vec value))
|
|
((vec value start)
|
|
(my-vector-fill! vec value start (vector-length vec)))
|
|
((vec value start end)
|
|
(do ((i start (add1 i)))
|
|
((= i end))
|
|
(vector-set! vec i value))
|
|
vec)))
|
|
|
|
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void
|
|
;;; 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!
|
|
(letrec ((loop (lambda (vec i j)
|
|
(when (< i j)
|
|
(vector-swap! vec i j)
|
|
(loop vec (add1 i) (sub1 j))))))
|
|
(opt-lambda (vec (start 0) (end (vector-length vec)))
|
|
(loop vec start (sub1 end)))))
|
|
|
|
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
|
|
;;; -> unspecified
|
|
;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
|
|
;;; to TARGET, starting at TSTART in TARGET.
|
|
(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
|
|
(add1 i) (add1 j))))))
|
|
(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
|
|
(sub1 i) (sub1 j)))))))
|
|
(opt-lambda (target tstart source (sstart 0) (send (vector-length source)))
|
|
(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 (sub1 send)
|
|
(+ -1 tstart send (- sstart)))))))
|
|
|
|
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
|
|
(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
|
|
(sub1 i)
|
|
(add1 j)))))))
|
|
(opt-lambda (target tstart source (sstart 0) (send (vector-length source)))
|
|
(cond ((and (eq? target source)
|
|
(= sstart tstart))
|
|
(vector-reverse! target tstart send))
|
|
((and (eq? target source)
|
|
(or (between? sstart tstart send)
|
|
(between? tstart sstart
|
|
(+ tstart (- send sstart)))))
|
|
;an error in the reference implement here
|
|
(error 'vector-reverse-copy!
|
|
"Vector range for self-copying overlaps"))
|
|
(else
|
|
(loop target source sstart
|
|
(sub1 send)
|
|
tstart))))))
|
|
|
|
(define (between? x y z)
|
|
(and (< x y)
|
|
(<= y z)))
|
|
|
|
(provide/contract (rename my-vector->list s:vector->list
|
|
(vec-start-end-contract vector?))
|
|
(reverse-vector->list vec-start-end-contract)
|
|
(reverse-list->vector (-> list? any)))
|
|
|
|
;;; (VECTOR->LIST <vector> [<start> <end>]) -> 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 my-vector->list
|
|
(case-lambda
|
|
((vec)
|
|
(vector->list vec)) ;+++
|
|
((vec start)
|
|
(my-vector->list vec start (vector-length vec)))
|
|
((vec start end)
|
|
(do ((i (sub1 end) (sub1 i))
|
|
(result '() (cons (vector-ref vec i) result)))
|
|
((< i start) result)))))
|
|
|
|
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> 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
|
|
(opt-lambda (vec (start 0) (end (vector-length vec)))
|
|
;(unfold (lambda (i) (= i end)) ; No SRFI 1.
|
|
; (lambda (i) (vector-ref vec i))
|
|
; (lambda (i) (add1 i))
|
|
; start)
|
|
(do ((i start (add1 i))
|
|
(result '() (cons (vector-ref vec i) result)))
|
|
((= i end) result))))
|
|
|
|
;;; (REVERSE-LIST->VECTOR <list> -> vector
|
|
;;; Produce a vector containing the elements in LIST in reverse order.
|
|
(define (reverse-list->vector lst)
|
|
(let* ((len (length lst))
|
|
(vec (make-vector len)))
|
|
(unfold1! (lambda (index l) (values (car l) (cdr l)))
|
|
vec
|
|
(sub1 len)
|
|
lst)
|
|
vec)))
|