From 69e2122af61ce1882b42a2e141f7db5993d86cd5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 3 May 2010 17:08:36 -0400 Subject: [PATCH] vector-mem{ber,q,v} --- collects/racket/vector.rkt | 43 +++++++++++++++++++++---------- collects/tests/racket/vector.rktl | 15 ++++++++++- 2 files changed, 44 insertions(+), 14 deletions(-) diff --git a/collects/racket/vector.rkt b/collects/racket/vector.rkt index b1bf40ceb2..6ee211047f 100644 --- a/collects/racket/vector.rkt +++ b/collects/racket/vector.rkt @@ -4,7 +4,8 @@ vector-take vector-drop vector-split-at vector-take-right vector-drop-right vector-split-at-right vector-filter vector-filter-not - vector-count vector-argmin vector-argmax) + vector-count vector-argmin vector-argmax + vector-member vector-memq vector-memv) (require racket/unsafe/ops) ;; unchecked version of `vector-copy' @@ -50,9 +51,9 @@ ;; length is passed to save the computation (define (vector-map/update f target length vs) (for ([i (in-range length)]) - (unsafe-vector-set! + (unsafe-vector*-set! target i - (apply f (map (lambda (vec) (unsafe-vector-ref vec i)) vs))))) + (apply f (map (lambda (vec) (unsafe-vector*-ref vec i)) vs))))) ;; check that `v' is a vector ;; that `v' and all the `vs' have the same length @@ -68,12 +69,12 @@ 0 f)) (unless (vector? v) (raise-type-error name "vector" 1 v)) - (let ([len (unsafe-vector-length v)]) + (let ([len (unsafe-vector*-length v)]) (for ([e (in-list vs)] [i (in-naturals 2)]) (unless (vector? e) (raise-type-error name "vector" e i)) - (unless (= len (unsafe-vector-length e)) + (unless (= len (unsafe-vector*-length e)) (raise (make-exn:fail:contract (format "~e: all vectors must have same size; ~a" @@ -129,8 +130,8 @@ ([i (in-range len)] #:when (apply f - (unsafe-vector-ref v i) - (map (lambda (v) (unsafe-vector-ref v i)) vs))) + (unsafe-vector*-ref v i) + (map (lambda (v) (unsafe-vector*-ref v i)) vs))) (add1 c)) (error 'vector-count "all vectors must have same size"))) (for/fold ([cnt 0]) ([i (in-vector v)] #:when (f i)) @@ -141,7 +142,7 @@ (raise-type-error name "vector" v)) (unless (exact-nonnegative-integer? n) (raise-type-error name "non-negative exact integer" n)) - (let ([len (unsafe-vector-length v)]) + (let ([len (unsafe-vector*-length v)]) (unless (<= 0 n len) (raise-mismatch-error name @@ -177,14 +178,14 @@ (let* ([vs (cons v vs)] [lens (for/list ([e (in-list vs)] [i (in-naturals)]) (if (vector? e) - (unsafe-vector-length e) + (unsafe-vector*-length e) (raise-type-error 'vector-append "vector" e i)))] [new-v (make-vector (apply + lens))]) (let loop ([start 0] [lens lens] [vs vs]) (when (pair? lens) (let ([len (car lens)] [v (car vs)]) (for ([i (in-range len)]) - (unsafe-vector-set! new-v (+ i start) (unsafe-vector-ref v i))) + (unsafe-vector*-set! new-v (+ i start) (unsafe-vector*-ref v i))) (loop (+ start len) (cdr lens) (cdr vs))))) new-v)) @@ -194,13 +195,13 @@ (procedure-arity-includes? f 1)) (raise-type-error name "procedure (arity 1)" f)) (unless (and (vector? xs) - (< 0 (unsafe-vector-length xs))) + (< 0 (unsafe-vector*-length xs))) (raise-type-error name "non-empty vector" xs)) - (let ([init-min-var (f (unsafe-vector-ref xs 0))]) + (let ([init-min-var (f (unsafe-vector*-ref xs 0))]) (unless (real? init-min-var) (raise-type-error name "procedure that returns real numbers" f)) (let-values ([(min* min-var*) - (for/fold ([min (unsafe-vector-ref xs 0)] + (for/fold ([min (unsafe-vector*-ref xs 0)] [min-var init-min-var]) ([e (in-vector xs 1)]) (let ([new-min (f e)]) @@ -214,3 +215,19 @@ (define (vector-argmin f xs) (mk-min < 'vector-argmin f xs)) (define (vector-argmax f xs) (mk-min > 'vector-argmax f xs)) + +(define-syntax-rule (vm-mk name cmp) + (define (name val vec) + (unless (vector? vec) + (raise-type-error 'name "vector" 1 vec)) + (let ([sz (unsafe-vector*-length vec)]) + (let loop ([k 0]) + (cond [(= k sz) #f] + [(cmp val + (unsafe-vector*-ref vec k)) + k] + [else (loop (unsafe-fx+ 1 k))]))))) + +(vm-mk vector-member equal?) +(vm-mk vector-memq eq?) +(vm-mk vector-memv eqv?) diff --git a/collects/tests/racket/vector.rktl b/collects/tests/racket/vector.rktl index a350a34458..b31693a8d7 100644 --- a/collects/tests/racket/vector.rktl +++ b/collects/tests/racket/vector.rktl @@ -3,7 +3,7 @@ (Section 'vector) -(require scheme/vector) +(require racket/vector) (test #t vector? '#(0 (2 2 2 2) "Anna")) @@ -184,6 +184,19 @@ (err/rt-test (vector-argmax (lambda (x) x) (vector)) (check-regs #rx"vector-argmax" #rx"non-empty vector"))) +;; vector-mem{ber,v,q} + + (test 0 vector-member 7 #(7 1 2)) + (test #f vector-member 7 #(0 1 2)) + (test 1 vector-memq 'x #(7 x 2)) + (test 1 vector-memv 'x #(7 x 2)) + (test #f vector-memq 1000000000000 #(7 1000000000000 2)) + (test 1 vector-memv 1000000000000 #(7 1000000000000 2)) + (test 1 vector-member 1000000000000 #(7 1000000000000 2)) + (test #f vector-memq (cons 1 2) (vector 7 (cons 1 2) 2)) + (test #f vector-memv (cons 1 2) (vector 7 (cons 1 2) 2)) + (test 1 vector-member (cons 1 2) (vector 7 (cons 1 2) 2)) + ;; ---------- check no collisions with srfi/43 ---------- #;(test (void)