suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

contracts for gvector, skip-list

Browse Source 
reorganized tests
This commit is contained in:
Ryan Culpepper 2010-09-14 19:55:01 -06:00
parent 50c408e872
commit 19be445d89
4 changed files with 153 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/data/gvector.rkt
View File

@ -6,23 +6,18 @@
racket/dict
racket/vector)
(define make-gvector*
(let ([make-gvector
(lambda (#:capacity [capacity 10])
(make-gvector (make-vector capacity #f) 0))])
make-gvector))
(define (make-gvector #:capacity [capacity 10])
(make-gvector (make-vector capacity #f) 0))
(define gvector*
(let ([gvector
(lambda init-elements
(let ([gv (make-gvector*)])
(let ([gv (make-gvector)])
(apply gvector-add! gv init-elements)
gv))])
gvector))
(define (check-index who index n set-to-add?)
(unless (exact-nonnegative-integer? index)
(raise-type-error who "exact nonnegative integer" index))
(unless (< index n)
(error who "index out of range ~a~a: ~s"
(let ([max-index (if set-to-add? (- n 2) (- n 1))])
@ -149,7 +144,7 @@
(syntax-case stx ()
[(_ (clause ...) . body)
(quasisyntax/loc stx
(let ([gv (make-gvector*)])
(let ([gv (make-gvector)])
(for/fold/derived #,stx () (clause ...)
(call-with-values (lambda () . body)
(lambda args (apply gvector-add! gv args) (values))))
@ -159,25 +154,29 @@
(syntax-case stx ()
[(_ (clause ...) . body)
(quasisyntax/loc stx
(let ([gv (make-gvector*)])
(let ([gv (make-gvector)])
(for*/fold/derived #,stx () (clause ...)
(call-with-values (lambda () . body)
(lambda args (apply gvector-add! gv args) (values))))
gv))]))
(define-struct gvector (vec n)
(struct gvector (vec n)
#:mutable
#:property prop:dict
(vector gvector-ref
gvector-set!
#f ;; set
gvector-remove!
#f ;; remove
gvector-count
gvector-iterate-first
gvector-iterate-next
gvector-iterate-key
gvector-iterate-value)
#:property prop:dict/contract
(list (vector-immutable gvector-ref
gvector-set!
#f ;; set
gvector-remove!
#f ;; remove
gvector-count
gvector-iterate-first
gvector-iterate-next
gvector-iterate-key
gvector-iterate-value)
(vector-immutable exact-nonnegative-integer?
any/c
exact-nonnegative-integer?
#f #f #f))
#:property prop:equal+hash
(let ([equals
(lambda (x y recursive-equal?)
@ -204,7 +203,7 @@
(-> any/c any)]
[rename gvector* gvector
(->* () () #:rest any/c gvector?)]
[rename make-gvector* make-gvector
[make-gvector
(->* () (#:capacity exact-positive-integer?) gvector?)]
[gvector-ref
(->* (gvector? exact-nonnegative-integer?) (any/c) any)]

24
collects/data/skip-list.rkt
View File

@ -282,17 +282,19 @@ Levels are indexed starting at 1, as in the paper.
(set-item-data! (skip-list-iter-item iter) value))
(struct skip-list ([head #:mutable] [num-entries #:mutable] =? <?)
#:property prop:dict
(vector skip-list-ref
skip-list-set!
#f ;; set
skip-list-remove!
#f ;; remove
skip-list-count
skip-list-iterate-first
skip-list-iterate-next
skip-list-iterate-key
skip-list-iterate-value)
#:property prop:dict/contract
(list (vector-immutable skip-list-ref
skip-list-set!
#f ;; set
skip-list-remove!
#f ;; remove
skip-list-count
skip-list-iterate-first
skip-list-iterate-next
skip-list-iterate-key
skip-list-iterate-value)
(vector-immutable any/c any/c skip-list-iter?
#f #f #f))
#:property prop:ordered-dict
(vector-immutable skip-list-iterate-min
skip-list-iterate-max

43
collects/data/splay-tree.rkt
View File

@ -200,6 +200,49 @@ In (values status nroot pside pnode):
(when B
(set-node-key! B (+ (node-key B) Kx))))]))
#|
Top-down splay
|#
#|
(define (findt cmp tx k x scratch)
(if x
(findt* cmp tx k x scratch scratch scratch)
(values #f #f)))
(define (findt* cmp tx k t scratch l r)
(define-syntax-rule (assemble! t)
(set-node-right! l (node-left t))
(set-node-left! r (node-right t))
(set-node-left! t (node-right scratch))
(set-node-right! t (node-left scratch))
t)
(define-syntax-rule (continue t)
(findt* cmp tx k t scratch l r))
(define-syntax-rule (rotate&link cmpresult rl (node-A set-node-A!) (node-B set-node-B!))
(let ([tsub (node-A t)])
(cond [tsub
(let-values ([(continue? t)
(case (cmp k (node-key tsub))
((cmpresult)
(set-node-A! t (node-B tsub))
(set-node-B! tsub t)
(cond [(node-A tsub) (values #t tsub)]
[else (values #f tsub)])))])
(cond [continue?
(set-node-A! rl t)
(continue t)]
[else
(assemble! t)]))])))
(case (cmp k (node-key x))
((<)
(rotate&link < r (node-left set-node-left!) (node-right set-node-right!)))
((>)
(rotate&link > l (node-right set-node-right!) (node-left! set-node-left!)))
(else
(assemble t))))
|#
;; --------
;; if left is node, new root is max(left)

105
collects/tests/data/ordered-dict.rkt
View File

@ -9,11 +9,8 @@
;; - skip-list
;; - splay-tree
(test-case "random keys and values"
(let ([hash (make-hash)]
[dicts (list (make-skip-list = <)
(make-splay-tree = <)
(make-integer-splay-tree #:adjust? #t))])
(define (rand-test dicts ordered?)
(let ([hash (make-hash)])
(for ([c (in-range 100)])
(let* ([k (- (random 2000) 1000)]
[v (- (random 2000) 1000)])
@ -27,29 +24,77 @@
(check-equal? vh vd (format "dict ~e, key = ~s, value = ~s, expected = ~s"
d i vd vh)))))
(when ordered?
(for ([c (in-range 100)])
(let* ([k0 (- (random 2000) 1000)])
(for ([d dicts])
(let* ([has? (dict-has-key? d k0)]
[l>i (dict-iterate-least/>? d k0)]
[l>=i (dict-iterate-least/>=? d k0)]
[g<i (dict-iterate-greatest/<? d k0)]
[g<=i (dict-iterate-greatest/<=? d k0)]
[l> (and l>i (dict-iterate-key d l>i))]
[l>= (and l>=i (dict-iterate-key d l>=i))]
[g< (and g<i (dict-iterate-key d g<i))]
[g<= (and g<=i (dict-iterate-key d g<=i))])
(when has?
(check-equal? l>= g<= "has, should be same"))
(unless has?
(check-equal? l> l>= "not has, should be same")
(check-equal? g< g<= "not has, should be same"))
(when l> (check > l> k0))
(when l>= (check >= l>= k0))
(when g< (check < g< k0))
(when g<= (check <= g<= k0))
(for ([k (in-dict-keys d)])
(when (and l> (and (> k k0) (< k l>))) (error "l>"))
(when (and l>= (and (>= k k0) (< k l>=))) (error "l>="))
(when (and g< (and (< k k0) (> k g<))) (error "g<"))
(when (and g<= (and (<= k k0) (> k g<=))) (error "g<="))))))))))
(test-case "skip-list tests"
(rand-test (list (make-skip-list = <)) #t))
(test-case "splay-tree test"
(rand-test (list (make-splay-tree = <)) #t))
(test-case "int-splay-tree w adjust"
(rand-test (list (make-integer-splay-tree #:adjust? #t)) #t))
(provide rand-test)
#|
(define (splay-test splays _eh)
(let ([hash (make-hash)])
(for ([c (in-range 100)])
(let* ([k0 (- (random 2000) 1000)])
(for ([d dicts])
(let* ([has? (dict-has-key? d k0)]
[l>i (dict-iterate-least/>? d k0)]
[l>=i (dict-iterate-least/>=? d k0)]
[g<i (dict-iterate-greatest/<? d k0)]
[g<=i (dict-iterate-greatest/<=? d k0)]
[l> (and l>i (dict-iterate-key d l>i))]
[l>= (and l>=i (dict-iterate-key d l>=i))]
[g< (and g<i (dict-iterate-key d g<i))]
[g<= (and g<=i (dict-iterate-key d g<=i))])
(when has?
(check-equal? l>= g<= "has, should be same"))
(unless has?
(check-equal? l> l>= "not has, should be same")
(check-equal? g< g<= "not has, should be same"))
(when l> (check > l> k0))
(when l>= (check >= l>= k0))
(when g< (check < g< k0))
(when g<= (check <= g<= k0))
(for ([k (in-dict-keys d)])
(when (and l> (and (> k k0) (< k l>))) (error "l>"))
(when (and l>= (and (>= k k0) (< k l>=))) (error "l>="))
(when (and g< (and (< k k0) (> k g<))) (error "g<"))
(when (and g<= (and (<= k k0) (> k g<=))) (error "g<=")))))))))
(let* ([k (- (random 2000) 1000)]
[v (- (random 2000) 1000)])
(hash-set! hash k v)
(for ([d splays])
(splay-tree-set! d k v))))
(for ([i (in-range -1000 1000)])
(for ([d splays])
(let ([vh (hash-ref hash i 'not-there)]
[vd (splay-tree-ref d i 'not-there)])
(check-equal? vh vd (format "dict ~e, key = ~s, value = ~s, expected = ~s"
d i vd vh)))))))
(provide splay-test)
(require (prefix-in ud: racket/private/dict)
(prefix-in cd: racket/dict))
(define-syntax-rule (htest *dict-set! *dict-ref)
(let ([h (make-hash)])
(for ([c (in-range 100)])
(*dict-set! h (- (random 2000) 1000) (- (random 2000) 1000)))
(for ([i (in-range -1000 1000)])
(*dict-ref h i 'not-there))))
(define (ud-test) (htest ud:dict-set! ud:dict-ref))
(define (cd-test) (htest cd:dict-set! cd:dict-ref))
(provide ud-test
cd-test)
|#