Changeset 5343 in project
 Timestamp:
 08/08/07 04:28:33 (12 years ago)
 Location:
 rbtree/trunk
 Files:

 3 edited
Legend:
 Unmodified
 Added
 Removed

rbtree/trunk/rbtree.scm
r5342 r5343 176 176 (loop (cdr objs))))))) 177 177 178 (define constantR 'Red)179 (define constantB 'Black)178 (define R 'Red) 179 (define B 'Black) 180 180 181 181 (define (color? x) (or (eq? x 'Red) (eq? x 'Black))) … … 195 195 ;; This macro was borrowed from treap.scm by Oleg Kiselyov 196 196 ;; 197 (definemacro (dispatchonkey nodekey onless onequal ongreater)197 (definemacro (dispatchonkey key nodekey onless onequal ongreater) 198 198 (let ((result (gensym))) 199 `(let ((,result (keycompare , key (vectorref ,node 0))))199 `(let ((,result (keycompare ,nodekey ,key ))) 200 200 (cond 201 201 ((zero? ,result) ,onequal) 202 202 ((positive? ,result) ,ongreater) 203 203 (else ,onless))))) 204 204 205 (let ((root (Empty)) (size 0)) 205 206 206 (define (makerbtreedispatcher root size)207 (define (makerbtreedispatcher root size) 207 208 208 209 ;; Adds a new association to the tree (or replaces the old one if … … 210 211 ;; association, or #f if a new association was really added 211 212 (define (insert! key value) 212 213 (define (ins root) 214 (cases tree root 215 (Empty () (Tree R (Empty) key value (Empty))) 216 (Tree (color a yk y b) 217 (dispatchonkey 218 key yk 219 ;; Case 1: key < yk 220 (match a 221 (($ tree 'Tree 'Red c zk z d) 222 (dispatchonkey 223 key zk 224 ;; Case 1.1: key < zk 225 (lambda () 226 (let ((c1 (ins c))) 213 (define (ins root) 214 (cases tree root 215 (Empty () (values #f (Tree R (Empty) key value (Empty)))) 216 (Tree (color a yk y b) 217 (dispatchonkey 218 key yk 219 ;; Case 1: key < yk 220 (match a 221 (($ tree 'Tree 'Red c zk z d) 222 (dispatchonkey 223 key zk 224 ;; Case 1.1: key < zk 225 (letvalues (((found? c1) (ins c))) 226 (values found? 227 227 (match c1 228 228 (($ tree 'Tree 'Red e wk w f) 229 229 (Tree R (Tree B e wk w f) zk z (Tree B d yk y b))) 230 230 (else (Tree B (Tree R c1 zk z d) yk y b))))) 231 ;; Case 1.2: key = zk 232 (lambda () 233 (Tree color (Tree R c key value d) yk y b)) 234 ;; Case 1.3: key > zk 235 (lambda () 236 (let ((d1 (ins d))) 231 ;; Case 1.2: key = zk 232 (values a (Tree color (Tree R c key value d) yk y b)) 233 ;; Case 1.3: key > zk 234 (letvalues (((found? d1) (ins d))) 235 (values found? 237 236 (match d1 238 237 (($ tree 'Tree 'Red e wk w f) 239 238 (Tree R (Tree B c zk z e) wk w (Tree B f yk y b))) 240 239 (else (Tree B (Tree R c zk z d1) yk y b))))))) 241 (else (Tree B (ins a) yk y b))) 242 ;; Case 2: key = yk 243 (Tree color a key value b) 244 ;; Case 3: key > yk 245 (match b 246 (($ tree 'Tree 'Red c zk z d) 247 (dispatchonkey 248 key zk 249 ;; Case 3.1: key < zk 250 (lambda () 251 (let ((c1 (ins c))) 252 (match c1 253 (($ tree 'Tree 'Red e wk w f) 254 (Tree R (Tree B a yk y e) wk w (Tree B f zk z d))) 255 (else (Tree B a yk y (Tree R c1 zk z d)))))) 256 ;; Case 3.2: key = zk 257 (lambda () 258 (Tree color a yk y (Tree R c key value d))) 259 ;; Case 3.3: key > zk 260 (lambda () 261 (let ((d1 (ins d))) 262 (match d1 263 (($ tree 'Tree 'Red e wk w f) 264 (Tree R (Tree B a yk y c) zk z (Tree B e wk w f))) 265 (else (Tree B a yk y (Tree R c zk z d1)))))))) 266 (else (Tree B a yk y (ins b)))))))) 267 (set! root (ins root)) 268 (set! size (+ 1 size))) 240 (else (letvalues (((found? a1) (ins a))) 241 (values found? (Tree B a1 yk y b))))) 242 ;; Case 2: key = yk 243 (values root (Tree color a key value b)) 244 ;; Case 3: key > yk 245 (match b 246 (($ tree 'Tree 'Red c zk z d) 247 (dispatchonkey 248 key zk 249 ;; Case 3.1: key < zk 250 (letvalues (((found? c1) (ins c))) 251 (values found? 252 (match c1 253 (($ tree 'Tree 'Red e wk w f) 254 (Tree R (Tree B a yk y e) wk w (Tree B f zk z d))) 255 (else (Tree B a yk y (Tree R c1 zk z d)))))) 256 ;; Case 3.2: key = zk 257 (values b (Tree color a yk y (Tree R c key value d))) 258 ;; Case 3.3: key > zk 259 (letvalues (((found? d1) (ins d))) 260 (values found? 261 (match d1 262 (($ tree 'Tree 'Red e wk w f) 263 (Tree R (Tree B a yk y c) zk z (Tree B e wk w f))) 264 (else (Tree B a yk y (Tree R c zk z d1)))))))) 265 (else (letvalues (((found? b1) (ins b))) 266 (values found? (Tree B a yk y b1))))))))) 267 268 (letvalues (((found? newroot) (ins root))) 269 (set! root newroot) 270 (if (not found?) (set! size (+ 1 size))) 271 found?)) 269 272 270 273 ;; Looks for an item: Given a key, returns the corresponding (key … … 277 280 (Tree (c a yk y b) 278 281 (dispatchonkey 279 key yk ( lambda () (find a)) (lambda () (cons yk y)) (lambda () (find b))))))282 key yk (find a) (cons yk y) (find b))))) 280 283 (find root)) 281 284 … … 300 303 ;; case 1L 301 304 ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Red c yk y d) z) . a) 302 (bbZip (Left R ed xk x c (Left Blackyk y d z)) a))305 (bbZip (Left R xk x c (Left B yk y d z)) a)) 303 306 ;; case 3L 304 307 ((($ zipper 'Left color xk x ($ tree 'Tree 'Black ($ tree 'Tree 'Red c yk y d) wk w e) z) . a) … … 315 318 ;; case 1R 316 319 ((($ zipper 'Right color ($ tree 'Tree 'Red c yk y d) xk x z) . b) 317 (bbZip (Right R ed d xk x (Right Blackc yk y z)) b))320 (bbZip (Right R d xk x (Right B c yk y z)) b)) 318 321 ;; case 3R 319 322 ((($ zipper 'Right color ($ tree 'Tree 'Black ($ tree 'Tree 'Red c wk w d) yk y e) xk x z) . b) … … 361 364 (dispatchonkey 362 365 key yk 363 (lambda () 364 (del a (Left color yk y b z))) 365 (lambda () 366 (cons (cons yk y) (join color a b z))) 367 (lambda () 368 (del b (Right color a yk y z))))))) 366 (del a (Left color yk y b z)) 367 (cons (cons yk y) (join color a b z)) 368 (del b (Right color a yk y z)))))) 369 369 370 370 (let ((item+tree (del root (Top)))) … … 388 388 (match root 389 389 (($ tree 'Empty) #f) 390 (($ tree 'Tree _ _ _x ($ tree 'Empty)) (cons xk x))390 (($ tree 'Tree _ _ xk x ($ tree 'Empty)) (cons xk x)) 391 391 (($ tree 'Tree _ _ _ _ b) (f b)))) 392 392 (f root)) … … 454 454 (define (mapf tree) 455 455 (match tree 456 (($ tree 'Empty) ( makerbtreedispatcher (Empty) 0))456 (($ tree 'Empty) (Empty)) 457 457 (($ tree 'Tree color a xk x b) 458 (makerbtreedispatcher 459 (Tree color (mapf a) xk (f x) (mapf b)) 460 size)))) 461 (mapf root)) 458 (Tree color (mapf a) xk (f x) (mapf b))))) 459 (makerbtreedispatcher (mapf root) size)) 462 460 463 461 (define (mapi f) 464 462 (define (mapf tree) 465 463 (match tree 466 (($ tree 'Empty) (makerbtreedispatcher (Empty) 0))464 (($ tree 'Empty) (Empty)) 467 465 (($ tree 'Tree color a xk x b) 468 (makerbtreedispatcher 469 (Tree color (mapf a) xk (f xk x) (mapf b)) 470 size)))) 471 (mapf root)) 466 (Tree color (mapf a) xk (f xk x) (mapf b))))) 467 (makerbtreedispatcher (mapf root) size)) 472 468 473 469 (define (applydefaultclause label key defaultclause) 
rbtree/trunk/rbtree.setup
r5342 r5343 2 2 (define hasexports? (string>=? (chickenversion) "2.310")) 3 3 4 (compile O2 d0 verboses4 (compile d2 s 5 5 ,@(if hasexports? '(checkimports emitexports rbtree.exports) '()) 6 6 rbtree.scm lchicken ldl lm) 
rbtree/trunk/tests/run.scm
r5342 r5343 14 14 15 15 16 (define ( sfhttest)16 (define (rbtreetest) 17 17 (testeez "> Inserting a set of numbers in a redblack tree" 18 18 19 19 (testdefine "" minkey 1) 20 (testdefine "" maxkey 10 )20 (testdefine "" maxkey 100) 21 21 22 22 (testdefine "" rbtree (makerbtree (lambda (x y) ( x y)))) … … 53 53 (testeez (test/equal "" ((rbtree 'put!) i (cdr (computeassoc i))) #f) 54 54 (test/equal "" ((rbtree 'get) i) (computeassoc i)) 55 (test/equal "" ( (rbtree 'delete!) i) #t))))55 (test/equal "" (if ((rbtree 'delete!) i) #t #f) #t)))) 56 56 57 57 … … 71 71 (testeval "looking up the elements in the rbtree" 72 72 (do ((i minkey (++ i))) ((> i maxkey)) 73 (testeez (test/equal "" ((rbtree 'get) i) (computeassoc i))))))) 73 (testeez (test/equal "" ((rbtree 'get) i) (computeassoc i))))) 74 75 (test/equal "using fold to sum the elements in the rbtree" 76 ((rbtree 'fold) (lambda (x sum) (+ x sum)) 0) 77 (* 50 (+ (+ 1 minkey) (+ 1 maxkey)))) 78 79 (testdefine "Using 'map to create a copy of tree with each element x mapped to x*10" 80 rbtreex10 ((rbtree 'map) (lambda (x) (* x 10)))) 81 82 (testdefine "a hardwired association between a key and a value multiplied by 10" 83 computeassocx10 (lambda (key) (cons key (* 10 (++ key))))) 84 85 (testeval "looking up the elements in the x10 rbtree" 86 (do ((i minkey (++ i))) ((> i maxkey)) 87 (testeez (test/equal "" ((rbtreex10 'get) i) (computeassocx10 i))))))) 88 89 90 91 74 92 75 93 (rbtreetest)
Note: See TracChangeset
for help on using the changeset viewer.