Changeset 5343 in project


Ignore:
Timestamp:
08/08/07 04:28:33 (12 years ago)
Author:
Ivan Raikov
Message:

Changes to make the API consistent with the documentation, and improvements to the test cases.

Location:
rb-tree/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • rb-tree/trunk/rb-tree.scm

    r5342 r5343  
    176176                 (loop (cdr objs)))))))
    177177
    178 (define-constant R 'Red)
    179 (define-constant B 'Black)
     178(define R 'Red)
     179(define B 'Black)
    180180
    181181(define (color? x) (or (eq? x 'Red) (eq? x 'Black)))
     
    195195  ;; This macro was borrowed from treap.scm by Oleg Kiselyov
    196196  ;;
    197   (define-macro (dispatch-on-key node key on-less on-equal on-greater)
     197  (define-macro (dispatch-on-key key node-key on-less on-equal on-greater)
    198198    (let ((result (gensym)))
    199       `(let ((,result (key-compare ,key (vector-ref ,node 0))))
     199      `(let ((,result (key-compare ,node-key ,key )))
    200200        (cond
    201201          ((zero? ,result) ,on-equal)
    202202          ((positive? ,result) ,on-greater)
    203203          (else ,on-less)))))
     204
    204205  (let ((root (Empty)) (size 0))
    205206
    206   (define (make-rb-tree-dispatcher root size)
     207    (define (make-rb-tree-dispatcher root size)
    207208
    208209    ;; Adds a new association to the tree (or replaces the old one if
     
    210211    ;; association, or #f if a new association was really added
    211212    (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                          (dispatch-on-key
    218                           key yk
    219                           ;; Case 1: key < yk
    220                           (match a
    221                                  (($ tree 'Tree 'Red c zk z d)
    222                                   (dispatch-on-key
    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                     (dispatch-on-key
     218                      key yk
     219                      ;; Case 1: key < yk
     220                      (match a
     221                             (($ tree 'Tree 'Red c zk z d)
     222                              (dispatch-on-key
     223                               key zk
     224                               ;; Case 1.1: key < zk
     225                               (let-values (((found? c1) (ins c)))
     226                                 (values found?
    227227                                         (match c1
    228228                                                (($ tree 'Tree 'Red e wk w f)
    229229                                                 (Tree R (Tree B e wk w f) zk z (Tree B d yk y b)))
    230230                                                (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                               (let-values (((found? d1) (ins d)))
     235                                 (values found?
    237236                                         (match d1
    238237                                                (($ tree 'Tree 'Red e wk w f)
    239238                                                 (Tree R (Tree B c zk z e)  wk  w  (Tree B f yk y b)))
    240239                                                (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                                   (dispatch-on-key
    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  (let-values (((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                              (dispatch-on-key
     248                               key zk
     249                               ;; Case 3.1: key < zk
     250                               (let-values (((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                               (let-values (((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 (let-values (((found? b1) (ins b)))
     266                                     (values found? (Tree B a yk y b1)))))))))
     267
     268      (let-values (((found? new-root)  (ins root)))
     269                  (set! root new-root)
     270                  (if (not found?)  (set! size (+ 1 size)))
     271                  found?))
    269272
    270273    ;; Looks for an item: Given a key, returns the corresponding (key
     
    277280               (Tree (c a yk y b)
    278281                     (dispatch-on-key
    279                       key yk (lambda () (find a)) (lambda () (cons yk y)) (lambda () (find b))))))
     282                      key yk (find a) (cons yk y) (find b)))))
    280283      (find root))
    281284
     
    300303               ;; case 1L
    301304               ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Red c yk y d) z) . a)
    302                 (bbZip (Left Red xk x c (Left Black yk y d z)) a))
     305                (bbZip (Left R xk x c (Left B yk y d z)) a))
    303306               ;; case 3L
    304307               ((($ zipper 'Left color xk x ($ tree 'Tree 'Black ($ tree 'Tree 'Red c yk y d) wk w e) z) . a)
     
    315318               ;; case 1R
    316319               ((($ zipper 'Right color ($ tree 'Tree 'Red c yk y d) xk x z) . b)
    317                 (bbZip (Right Red d xk x (Right Black c yk y z)) b))
     320                (bbZip (Right R d xk x (Right B c yk y z)) b))
    318321               ;; case 3R
    319322               ((($ zipper 'Right color ($ tree 'Tree 'Black ($ tree 'Tree 'Red c wk w d) yk y e) xk x z) . b)
     
    361364                (dispatch-on-key
    362365                 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))))))
    369369
    370370      (let ((item+tree  (del root (Top))))
     
    388388        (match root
    389389               (($ tree 'Empty)  #f)
    390                (($ tree 'Tree _ _ _ x ($ tree 'Empty))  (cons xk x))
     390               (($ tree 'Tree _ _ xk x ($ tree 'Empty))  (cons xk x))
    391391               (($ tree 'Tree _ _ _ _ b)   (f b))))
    392392      (f root))
     
    454454      (define (mapf tree)
    455455        (match tree
    456                (($ tree 'Empty)  (make-rb-tree-dispatcher (Empty) 0))
     456               (($ tree 'Empty)  (Empty))
    457457               (($ tree 'Tree color a xk x b) 
    458                 (make-rb-tree-dispatcher
    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      (make-rb-tree-dispatcher (mapf root) size))
    462460
    463461    (define (mapi f)
    464462      (define (mapf tree)
    465463        (match tree
    466                (($ tree 'Empty)  (make-rb-tree-dispatcher (Empty) 0))
     464               (($ tree 'Empty)   (Empty))
    467465               (($ tree 'Tree color a xk x b) 
    468                 (make-rb-tree-dispatcher
    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      (make-rb-tree-dispatcher  (mapf root) size))
    472468
    473469    (define (apply-default-clause label key default-clause)
  • rb-tree/trunk/rb-tree.setup

    r5342 r5343  
    22(define has-exports? (string>=? (chicken-version) "2.310"))
    33
    4 (compile -O2 -d0 -verbose -s
     4(compile  -d2 -s
    55         ,@(if has-exports? '(-check-imports -emit-exports rb-tree.exports) '())
    66         rb-tree.scm -lchicken -ldl -lm)
  • rb-tree/trunk/tests/run.scm

    r5342 r5343  
    1414
    1515
    16 (define (sfht-test)
     16(define (rb-tree-test)
    1717  (testeez "--> Inserting a set of numbers in a red-black tree"
    1818           
    1919           (test-define "" min-key 1)
    20            (test-define "" max-key 10)
     20           (test-define "" max-key 100)
    2121           
    2222           (test-define "" rb-tree (make-rb-tree (lambda (x y) (- x y))))
     
    5353                        (testeez (test/equal "" ((rb-tree 'put!) i (cdr (compute-assoc i))) #f)
    5454                                 (test/equal "" ((rb-tree 'get) i) (compute-assoc i))
    55                                  (test/equal "" ((rb-tree 'delete!) i) #t))))
     55                                 (test/equal "" (if ((rb-tree 'delete!) i) #t #f) #t))))
    5656                                 
    5757
     
    7171           (test-eval "looking up the elements in  the rb-tree"
    7272                      (do ((i min-key (++ i))) ((> i max-key))
    73                         (testeez (test/equal "" ((rb-tree 'get) i) (compute-assoc i)))))))
     73                        (testeez (test/equal "" ((rb-tree 'get) i) (compute-assoc i)))))
     74
     75           (test/equal "using fold to sum the elements in the rb-tree"
     76                       ((rb-tree 'fold) (lambda (x sum) (+ x sum)) 0)
     77                       (* 50 (+ (+ 1 min-key) (+ 1 max-key))))
     78
     79           (test-define "Using 'map to create a copy of tree with each element x mapped to x*10"
     80                        rb-tree-x10 ((rb-tree 'map) (lambda (x) (* x 10))))
     81
     82           (test-define "a hard-wired association between a key and a value multiplied by 10"
     83                        compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key)))))
     84
     85           (test-eval "looking up the elements in the x10 rb-tree"
     86                      (do ((i min-key (++ i))) ((> i max-key))
     87                        (testeez (test/equal "" ((rb-tree-x10 'get) i) (compute-assoc-x10 i)))))))
     88
     89
     90
     91
    7492
    7593(rb-tree-test)
Note: See TracChangeset for help on using the changeset viewer.