Changeset 20634 in project


Ignore:
Timestamp:
10/04/10 09:00:46 (9 years ago)
Author:
Ivan Raikov
Message:

rb-tree: refactoring to allow distinct persistent and ephemeral structures and to enable map combination operations

Location:
release/4/rb-tree/trunk
Files:
3 edited

Legend:

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

    r20529 r20634  
    3030;; <http://www.gnu.org/licenses/>.
    3131;;
    32 ;;
    33 ;; TODO: Add the linear-time tree construction code from the
    34 ;; paper _Constructing red-black trees_ by Hinze.
    35 ;;
    3632
    3733(module rb-tree
    3834       
    39   (make-rb-tree)
     35  (make-ephemeral-map make-persistent-map
     36   ephemeral-map-operations persistent-map-operations               
     37   union-with union-withi
     38   tree-map? map-size map-root map-key-compare map-insdel-key-compare )
    4039
    4140  (import scheme chicken data-structures)
     
    5756;;
    5857;;
    59 ;; The red-black tree object is created by procedure make-rb-tree, the
    60 ;; only user-visible function defined in this library:
     58;; The red-black tree object is created by procedure make-rb-tree:
    6159;;
    6260;;  make-rb-tree:: KEY-COMPARE-PROC -> RB-TREE
     
    183181(define (color? x) (or (eq? x 'Red) (eq? x 'Black)))
    184182
     183
    185184(define-datatype tree tree?
    186185  (Empty)
    187186  (Tree  (color color?) (left tree?) (key identity) (value identity) (right tree?)))
     187
    188188
    189189(define-datatype zipper zipper?
     
    191191  (Left (color color?) (key identity) (value identity) (tree tree?) (zipper zipper?))
    192192  (Right (color color?) (tree tree?) (key identity) (value identity) (zipper zipper?)))
     193
     194
     195(define-record-type tree-map
     196  (make-tree-map size root key-compare insdel-key-compare)
     197  tree-map?
     198  (size        map-size)
     199  (root        map-root)
     200  (key-compare map-key-compare)
     201  (insdel-key-compare map-insdel-key-compare)
     202  )
    193203
    194204
     
    208218               (display (tree-tag r) out)
    209219               (display ")" out))))
     220
    210221
    211222;;
     
    230241                 ((,%zero? ,result)     ,on-equal)
    231242                 ((,%positive? ,result) ,on-greater)
    232                  (,%else              ,on-less)))))))
    233 
    234 
    235 (define (make-rb-tree key-compare #!key
    236                       (insert-key-compare key-compare)
    237                       (delete-key-compare key-compare) )
    238 
    239   (let ((root (Empty)) (size 0))
    240 
    241     (define (make-rb-tree-dispatcher root size)
    242 
    243     ;; Adds a new association to the tree (or replaces the old one if
    244     ;; existed). Returns the (key . value) pair of the old
    245     ;; association, or #f if a new association was really added
    246     (define (insert root key value)
    247       (define (ins root)
    248         (cases tree root
    249                (Empty ()  (values #f (Tree R (Empty) key value (Empty))))
    250                (Tree (color a yk y b) 
    251                      (dispatch-on-key insert-key-compare
     243                 (,%else                ,on-less)))))))
     244
     245
     246;; Adds a new association to the tree (or replaces the old one if
     247;; existed). Returns the (key . value) pair of the old
     248;; association, or #f if a new association was really added
     249(define (insert key-compare root)
     250  (lambda (key value)
     251    (let ins ((root root))
     252      (cases tree root
     253           (Empty ()  (values #f (Tree R (Empty) key value (Empty))))
     254           (Tree (color a yk y b) 
     255                 (dispatch-on-key key-compare
    252256                      key yk
    253257                      ;; Case 1: key < yk
    254258                      (match a
    255259                             (($ tree 'Tree 'Red c zk z d)
    256                               (dispatch-on-key insert-key-compare
     260                              (dispatch-on-key key-compare
    257261                               key zk
    258262                               ;; Case 1.1: key < zk
     
    279283                      (match b
    280284                             (($ tree 'Tree 'Red c zk z d)
    281                               (dispatch-on-key insert-key-compare
     285                              (dispatch-on-key key-compare
    282286                               key zk
    283287                               ;; Case 3.1: key < zk
     
    299303                             (else (let-values (((found? b1) (ins b)))
    300304                                     (values found? (Tree B a yk y b1)))))))))
    301 
    302       (ins root))
    303 
    304 
    305     ;; Looks for an item: Given a key, returns the corresponding (key
    306     ;; . value) association or #f if the tree does not contain an
    307     ;; association with that key.
    308     (define (find-assoc key)
    309       (define (find root)
    310         (cases tree root
    311                (Empty ()  #f)
    312                (Tree (c a yk y b)
    313                      (dispatch-on-key key-compare
    314                       key yk (find a) (cons yk y) (find b)))))
    315       (find root))
    316 
    317     ;; Looks for an item: Given a key, returns the value of the
    318     ;; corresponding (key . value) association or #f if the tree does
    319     ;; not contain an association with that key.
    320     (define (find-ref key)
    321       (define (find root)
    322         (cases tree root
    323                (Empty ()  #f)
    324                (Tree (c a yk y b)
    325                      (dispatch-on-key key-compare
    326                       key yk (find a) y (find b)))))
    327       (find root))
    328 
    329     ;; Finds an association with a given key, and deletes it.  Returns
    330     ;; the (key . value) pair of the deleted association, or #f if it
    331     ;; couldn't be found
    332     (define (delete root key)
    333 
    334       (define (zip zipper tree)
    335         (match (cons zipper tree)
    336                ((($ zipper 'Top) . a)  tree)
    337                ((($ zipper 'Left color xk x b z) . a)   (zip z (Tree color a xk x b)))
    338                ((($ zipper 'Right color a xk x z) . b)  (zip z (Tree color a xk x b)))))
    339 
    340       ;; bbZip propagates a black deficit up the tree until either
    341       ;; the top is reached, or the deficit can be covered.  It
    342       ;; returns a boolean that is true if there is still a deficit
    343       ;; and the zipped tree.
    344      (define (bbZip zipper tree)
    345         (match (cons zipper tree)
    346                ((($ zipper 'Top) . a)  (cons #t a))
    347                ;; case 1L
    348                ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Red c yk y d) z) . a)
    349                 (bbZip (Left R xk x c (Left B yk y d z)) a))
    350                ;; case 3L
    351                ((($ zipper 'Left color xk x ($ tree 'Tree 'Black ($ tree 'Tree 'Red c yk y d) wk w e) z) . a)
    352                 (bbZip (Left color xk x (Tree B c yk y (Tree R d wk w e)) z) a))
    353                ;; case 4L
    354                ((($ zipper 'Left color xk x ($ tree 'Tree 'Black c yk y ($ tree 'Tree 'Red d wk w e)) z) . a)
    355                 (cons #f (zip z (Tree color (Tree B a xk x c) yk y (Tree B d wk w e)))))
    356                ;; case 2L
    357                ((($ zipper 'Left 'Red xk x ($ tree 'Tree 'Black c yk y d) z) . a)
    358                 (cons #f (zip z (Tree B a xk x (Tree R c yk y d)))))
    359                ;; case 2L
    360                ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Black c yk y d) z) . a)
    361                 (bbZip z (Tree B a xk x (Tree R c yk y d))))
    362                ;; case 1R
    363                ((($ zipper 'Right color ($ tree 'Tree 'Red c yk y d) xk x z) . b)
    364                 (bbZip (Right R d xk x (Right B c yk y z)) b))
    365                ;; case 3R
    366                ((($ zipper 'Right color ($ tree 'Tree 'Black ($ tree 'Tree 'Red c wk w d) yk y e) xk x z) . b)
    367                 (bbZip (Right color (Tree B c wk w (Tree R d yk y e)) xk x z) b))
    368                ;; case 4R
    369                ((($ zipper 'Right color ($ tree 'Tree 'Black c yk y ($ tree 'Tree 'Red d wk w e)) xk x z) . b)
    370                 (cons #f (zip z (Tree color c yk y (Tree B (Tree R d wk w e) xk x b)))))
    371                ;; case 2R
    372                ((($ zipper 'Right 'Red ($ tree 'Tree 'Black c yk y d) xk x z) . b)
    373                 (cons #f (zip z (Tree B (Tree R c yk y d) xk x b))))
    374                ;; case 2R
    375                ((($ zipper 'Right 'Black ($ tree 'Tree 'Black c yk y d) xk x z) . b)
    376                 (bbZip z (Tree B (Tree R c yk y d) xk x b)))
    377                (else   (cons #f (zip zipper tree)))))
    378 
    379       (define (delMin tree z)
    380         (match tree
    381                (($ tree 'Tree 'Red ($ tree 'Empty) yk y b)
    382                 (values yk y (cons #f (zip z b))))
    383                (($ tree 'Tree 'Black ($ tree Empty) yk y b)
    384                 (values yk y (bbZip z b)))
    385                (($ tree 'Tree color a yk y b)
    386                 (delMin a (Left color yk y b z)))
    387                (($ tree 'Empty) (rb-tree:error 'delete! "invalid tree"))))
    388 
    389       (define (join color a b z)
    390         (match (list color a b)
    391                (( 'Red ($ tree 'Empty) ($ tree 'Empty)) 
    392                 (zip z (Empty)))
    393                (( _ a ($ tree 'Empty)) 
    394                 (cdr  (bbZip z a)))
    395                (( _ ($ tree 'Empty) b)
    396                 (cdr  (bbZip z b)))
    397                (( color a b)
    398                 (let-values (((xk x b)  (delMin b (Top))))
    399                     (match b
    400                            ((#t . b1)  (cdr  (bbZip z (Tree color a xk x b1))))
    401                            ((#f . b1)  (zip z (Tree color a xk x b1))))))))
    402 
    403 
    404       (define (del tree z)
    405         (match tree
    406                (($ tree 'Empty)  #f)
    407                (($ tree 'Tree color a yk y b) 
    408                 (dispatch-on-key delete-key-compare
    409                  key yk
    410                  (del a (Left color yk y b z))
    411                  (cons (cons yk y) (join color a b z))
    412                  (del b (Right color a yk y z))))))
    413 
    414       (del root (Top)))
    415 
    416     (define (delete! key)
    417       (let ((item+tree  (delete root key)))
    418         (and item+tree
    419              (begin
    420                (set! root (cdr item+tree))
    421                (set! size (- size 1))
    422                (car item+tree)))))
    423 
    424 
    425     (define (get-min)
    426       (define (f root)
    427         (match root
    428                (($ tree 'Empty)  #f)
    429                (($ tree 'Tree _ _ ($ tree 'Empty) xk x _)  (cons xk x))
    430                (($ tree 'Tree _ a _ _ _)   (f a))))
    431       (f root))
    432 
    433     (define (get-max)
    434       (define (f root)
    435         (match root
    436                (($ tree 'Empty)  #f)
    437                (($ tree 'Tree _ _ xk x ($ tree 'Empty))  (cons xk x))
    438                (($ tree 'Tree _ _ _ _ b)   (f b))))
    439       (f root))
    440 
    441 
    442     (define (fold-limit p f init)
    443       (define (foldf tree ax)
    444         (match tree
    445                (($ tree 'Empty)  ax)
    446                (($ tree 'Tree _ a _ x b) 
    447                 (if (p ax) ax (foldf b (f x (foldf a ax)))))))
    448       (foldf root init))
    449 
    450     (define (fold-right-limit p f init)
    451       (define (foldf tree ax)
    452         (match tree
    453                (($ tree 'Empty)  ax)
    454                (($ tree 'Tree _ a _ x b) 
    455                 (if (p ax) ax (foldf a (f x (foldf b ax)))))))
    456       (foldf root init))
    457 
    458     (define (fold-partial p f init)
    459       (define (foldf tree ax)
    460         (match tree
    461                (($ tree 'Empty)  ax)
    462                (($ tree 'Tree _ a _ x b) 
    463                 (if (p x) (foldf b (f x (foldf a ax))) ax))))
    464       (foldf root init))
    465 
    466     (define (foldi-partial p f init)
    467       (define (foldf tree ax)
    468         (match tree
    469                (($ tree 'Empty)  ax)
    470                (($ tree 'Tree _ a xk x b) 
    471                 (if (p xk x) (foldf b (f xk x (foldf a ax))) ax))))
    472       (foldf root init))
    473 
    474     (define (fold-right-partial p f init)
    475       (define (foldf tree ax)
    476         (match tree
    477                (($ tree 'Empty)  ax)
    478                (($ tree 'Tree _ a _ x b) 
    479                 (if (p x) (foldf a (f x (foldf b ax))) ax))))
    480       (foldf root init))
    481 
    482     (define (foldi-right-partial p f init)
    483       (define (foldf tree ax)
    484         (match tree
    485                (($ tree 'Empty)  ax)
    486                (($ tree 'Tree _ a xk x b) 
    487                 (if (p xk x) (foldf a (f xk x (foldf b ax))) ax))))
    488       (foldf root init))
    489 
    490 
    491     (define (fold f init)
    492       (define (foldf tree ax)
    493         (match tree
    494                (($ tree 'Empty)  ax)
    495                (($ tree 'Tree _ a _ x b)  (foldf b (f x (foldf a ax))))))
    496       (foldf root init))
    497 
    498     (define (foldi f init)
    499       (define (foldf tree ax)
    500         (match tree
    501                (($ tree 'Empty)  ax)
    502                (($ tree 'Tree _ a xk x b)  (foldf b (f xk x (foldf a ax))))))
    503       (foldf root init))
    504 
    505     (define (fold-right f init)
    506       (define (foldf tree ax)
    507         (match tree
    508                (($ tree 'Empty)  ax)
    509                (($ tree 'Tree _ a _ x b)  (foldf a (f x (foldf b ax))))))
    510       (foldf root init))
    511 
    512     (define (foldi-right f init)
    513       (define (foldf tree ax)
    514         (match tree
    515                (($ tree 'Empty)  ax)
    516                (($ tree 'Tree _ a xk x b)  (foldf a (f xk x (foldf b ax))))))
    517       (foldf root init))
    518 
    519 
    520     (define (get-depth)
    521       (let loop ((node root) (level 0))
    522         (match node
    523                (($ tree 'Empty)  level)
    524                (($ tree 'Tree _ a _ _ b)  (max (loop a (+ 1 level))
    525                                                 (loop b (+ 1 level)))))))
    526 
    527     ;; Returns an ordered list of the keys in the tree
    528     (define (list-keys)
    529       (foldi-right (lambda (k x l) (cons k l)) (list)))
    530 
    531     ;; Returns an ordered list of the (key . item) pairs in the tree
    532     (define (list-items)
    533       (foldi-right (lambda (k x l) (cons (cons k x) l)) (list)))
    534 
    535     (define (for-each-ascending f)
    536       (define (appf tree)
    537         (match tree
    538                (($ tree 'Empty)  (void))
    539                (($ tree 'Tree _ a k x b)  (begin (appf a) (f (cons k x)) (appf b)))))
    540       (appf root))
    541 
    542     (define (for-each-descending f)
    543       (define (appf tree)
    544         (match tree
    545                (($ tree 'Empty)  (void))
    546                (($ tree 'Tree _ a k x b)  (begin (appf b) (f (cons k x)) (appf a)))))
    547       (appf root))
    548 
    549     (define (map f)
    550       (define (mapf tree)
    551         (match tree
    552                (($ tree 'Empty)  (Empty))
    553                (($ tree 'Tree color a xk x b) 
    554                 (Tree color (mapf a) xk (f x) (mapf b)))))
    555       (make-rb-tree-dispatcher (mapf root) size))
    556 
    557     (define (mapi f)
    558       (define (mapf tree)
    559         (match tree
    560                (($ tree 'Empty)   (Empty))
    561                (($ tree 'Tree color a xk x b) 
    562                  (Tree color (mapf a) xk (f xk x) (mapf b)))))
    563       (make-rb-tree-dispatcher  (mapf root) size))
    564 
    565 
    566     (define (apply-default-clause label key default-clause)
    567       (cond
    568         ((null? default-clause)
    569           (rb-tree:error label "key " key " was not found in the tree"))
    570         ((pair? (cdr default-clause))
    571           (rb-tree:error label "default argument must be a single clause"))
    572         ((procedure? (car default-clause)) ((car default-clause)))
    573         (else (car default-clause))))
    574    
    575     ;; Dispatcher
    576     (lambda (selector)
    577       (case selector
    578         ((get)
    579           (lambda (key . default-clause)
    580             (or (find-assoc key) (apply-default-clause 'get key default-clause))))
    581 
    582         ((get-value)
    583           (lambda (key . default-clause)
    584             (or (find-ref key) (apply-default-clause 'get key default-clause))))
    585 
    586         ((delete!)
    587           (lambda (key . default-clause)
    588             (or (delete! key)
    589                 (apply-default-clause 'delete! key default-clause))))
    590 
    591         ((delete)
    592           (lambda (key . default-clause)
    593             (or (let ((item+tree  (delete root key)))
    594                   (and item+tree
    595                        (make-rb-tree-dispatcher  (cdr item+tree)
    596                                                  (if (car item+tree) (- size 1) size))))
    597                 (apply-default-clause 'delete key default-clause))))
    598 
    599         ((put!)
    600          (lambda (key value)
    601            (let-values (((found? new-root)  (insert root key value)))
    602                        (set! root new-root)
    603                        (if (not found?)  (set! size (+ 1 size)))
    604                        found?)))
    605 
    606         ((put)
    607          (lambda (key value)
    608            (let-values (((found? new-root)  (insert root key value)))
    609                        (make-rb-tree-dispatcher  new-root (if (not found?) (+ 1 size) size)))))
    610 
    611 
    612         ((get-min) (get-min))
    613         ((get-max) (get-max))
    614 
    615         ((delete-min!)   (delete! (car (get-min))))
    616         ((delete-max!)   (delete! (car (get-max))))
    617 
    618         ((empty?)  (cases tree root
    619                           (Empty () #t)
    620                           (else #f)))
    621         ((size)    size)
    622 
    623         ((depth)   (get-depth))
    624 
    625         ((clear!)  (begin
    626                      (set! root (Empty))
    627                      (set! size 0)))
    628 
    629         ((for-each-ascending)   for-each-ascending)
    630         ((for-each-descending)  for-each-descending)
    631 
    632         ((list-keys)            (list-keys))
    633         ((list-items)           (list-items))
    634        
    635         ((map)                  map)
    636         ((mapi)                 mapi)
    637 
    638         ((fold)                fold)
    639         ((foldi)               foldi)
    640         ((fold-right)          fold-right)
    641         ((foldi-right)         foldi-right)
    642 
    643         ((fold-partial)        fold-partial)
    644         ((foldi-partial)       foldi-partial)
    645         ((fold-right-partial)          fold-right-partial)
    646         ((foldi-right-partial)         foldi-right-partial)
    647 
    648         ((fold-limit)          fold-limit)
    649         ((fold-right-limit)    fold-right-limit)
    650 
    651         (else
    652           (rb-tree:error 'selector "unknown message " selector " sent to a red-black tree")))))
    653 
    654   (make-rb-tree-dispatcher root size)))
     305    ))
     306
     307
     308;; Looks for an item: Given a key, returns the corresponding (key
     309;; . value) association or #f if the tree does not contain an
     310;; association with that key.
     311(define (find-assoc key-compare root)
     312  (lambda (key)
     313    (let recur ((root root))
     314      (cases tree root
     315             (Empty ()  #f)
     316             (Tree (c a yk y b)
     317                   (dispatch-on-key key-compare
     318                                    key yk (recur a) (cons yk y) (recur b)))))
     319    ))
     320
     321;; Looks for an item: Given a key, returns the value of the
     322;; corresponding (key . value) association or #f if the tree does
     323;; not contain an association with that key.
     324(define (find-ref key-compare root)
     325  (lambda (key)
     326    (let recur ((key key))
     327      (cases tree root
     328             (Empty ()  #f)
     329             (Tree (c a yk y b)
     330                   (dispatch-on-key key-compare
     331                                    key yk (recur a) y (recur b)))))
     332    ))
     333
     334;; Finds an association with a given key, and deletes it.  Returns
     335;; the (key . value) pair of the deleted association, or #f if it
     336;; couldn't be found
     337(define (delete-assoc key-compare root)
     338
     339  (define (zip zipper tree)
     340    (match (cons zipper tree)
     341           ((($ zipper 'Top) . a)  tree)
     342           ((($ zipper 'Left color xk x b z) . a)   (zip z (Tree color a xk x b)))
     343           ((($ zipper 'Right color a xk x z) . b)  (zip z (Tree color a xk x b)))))
     344 
     345  ;; bbZip propagates a black deficit up the tree until either
     346  ;; the top is reached, or the deficit can be covered.  It
     347  ;; returns a boolean that is true if there is still a deficit
     348  ;; and the zipped tree.
     349  (define (bbZip zipper tree)
     350    (match (cons zipper tree)
     351           ((($ zipper 'Top) . a)  (cons #t a))
     352           ;; case 1L
     353           ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Red c yk y d) z) . a)
     354            (bbZip (Left R xk x c (Left B yk y d z)) a))
     355           ;; case 3L
     356           ((($ zipper 'Left color xk x ($ tree 'Tree 'Black ($ tree 'Tree 'Red c yk y d) wk w e) z) . a)
     357            (bbZip (Left color xk x (Tree B c yk y (Tree R d wk w e)) z) a))
     358           ;; case 4L
     359           ((($ zipper 'Left color xk x ($ tree 'Tree 'Black c yk y ($ tree 'Tree 'Red d wk w e)) z) . a)
     360            (cons #f (zip z (Tree color (Tree B a xk x c) yk y (Tree B d wk w e)))))
     361           ;; case 2L
     362           ((($ zipper 'Left 'Red xk x ($ tree 'Tree 'Black c yk y d) z) . a)
     363            (cons #f (zip z (Tree B a xk x (Tree R c yk y d)))))
     364           ;; case 2L
     365           ((($ zipper 'Left 'Black xk x ($ tree 'Tree 'Black c yk y d) z) . a)
     366            (bbZip z (Tree B a xk x (Tree R c yk y d))))
     367           ;; case 1R
     368           ((($ zipper 'Right color ($ tree 'Tree 'Red c yk y d) xk x z) . b)
     369            (bbZip (Right R d xk x (Right B c yk y z)) b))
     370           ;; case 3R
     371           ((($ zipper 'Right color ($ tree 'Tree 'Black ($ tree 'Tree 'Red c wk w d) yk y e) xk x z) . b)
     372            (bbZip (Right color (Tree B c wk w (Tree R d yk y e)) xk x z) b))
     373           ;; case 4R
     374           ((($ zipper 'Right color ($ tree 'Tree 'Black c yk y ($ tree 'Tree 'Red d wk w e)) xk x z) . b)
     375            (cons #f (zip z (Tree color c yk y (Tree B (Tree R d wk w e) xk x b)))))
     376           ;; case 2R
     377           ((($ zipper 'Right 'Red ($ tree 'Tree 'Black c yk y d) xk x z) . b)
     378            (cons #f (zip z (Tree B (Tree R c yk y d) xk x b))))
     379           ;; case 2R
     380           ((($ zipper 'Right 'Black ($ tree 'Tree 'Black c yk y d) xk x z) . b)
     381            (bbZip z (Tree B (Tree R c yk y d) xk x b)))
     382           (else   (cons #f (zip zipper tree)))))
     383 
     384  (define (delMin tree z)
     385    (match tree
     386           (($ tree 'Tree 'Red ($ tree 'Empty) yk y b)
     387            (values yk y (cons #f (zip z b))))
     388           (($ tree 'Tree 'Black ($ tree Empty) yk y b)
     389            (values yk y (bbZip z b)))
     390           (($ tree 'Tree color a yk y b)
     391            (delMin a (Left color yk y b z)))
     392           (($ tree 'Empty) (rb-tree:error 'delete "invalid tree"))))
     393 
     394  (define (join color a b z)
     395    (match (list color a b)
     396           (( 'Red ($ tree 'Empty) ($ tree 'Empty)) 
     397            (zip z (Empty)))
     398           (( _ a ($ tree 'Empty)) 
     399            (cdr  (bbZip z a)))
     400           (( _ ($ tree 'Empty) b)
     401            (cdr  (bbZip z b)))
     402           (( color a b)
     403            (let-values (((xk x b)  (delMin b (Top))))
     404              (match b
     405                     ((#t . b1)  (cdr  (bbZip z (Tree color a xk x b1))))
     406                     ((#f . b1)  (zip z (Tree color a xk x b1))))))))
     407 
     408  (define (del tree key z)
     409    (match tree
     410           (($ tree 'Empty)  #f)
     411           (($ tree 'Tree color a yk y b) 
     412            (dispatch-on-key key-compare
     413             key yk
     414             (del a key (Left color yk y b z))
     415             (cons (cons yk y) (join color a b z))
     416             (del b key (Right color a yk y z))))))
     417
     418  (lambda (key) (del root key (Top))))
     419
     420
     421(define (get-min root)
     422  (define (f root)
     423    (match root
     424           (($ tree 'Empty)  #f)
     425           (($ tree 'Tree _ _ ($ tree 'Empty) xk x _)  (cons xk x))
     426           (($ tree 'Tree _ a _ _ _)   (f a))))
     427  (f root))
     428
     429
     430(define (get-max root)
     431  (define (f root)
     432    (match root
     433           (($ tree 'Empty)  #f)
     434           (($ tree 'Tree _ _ xk x ($ tree 'Empty))  (cons xk x))
     435           (($ tree 'Tree _ _ _ _ b)   (f b))))
     436  (f root))
     437
     438
     439(define (foldv-limit root)
     440  (lambda (p f init)
     441    (define (foldf tree ax)
     442      (match tree
     443             (($ tree 'Empty)  ax)
     444             (($ tree 'Tree _ a _ x b) 
     445              (if (p ax) ax (foldf b (f x (foldf a ax)))))))
     446    (foldf root init)))
     447
     448
     449(define (foldv-right-limit root)
     450  (lambda (p f init)
     451    (define (foldf tree ax)
     452      (match tree
     453             (($ tree 'Empty)  ax)
     454             (($ tree 'Tree _ a _ x b) 
     455              (if (p ax) ax (foldf a (f x (foldf b ax)))))))
     456    (foldf root init)))
     457
     458
     459(define (foldv-partial root)
     460  (lambda (p f init)
     461    (define (foldf tree ax)
     462      (match tree
     463             (($ tree 'Empty)  ax)
     464             (($ tree 'Tree _ a _ x b) 
     465              (if (p x) (foldf b (f x (foldf a ax))) ax))))
     466    (foldf root init)))
     467
     468
     469(define (foldi-partial root)
     470  (lambda (p f init)
     471    (define (foldf tree ax)
     472      (match tree
     473             (($ tree 'Empty)  ax)
     474             (($ tree 'Tree _ a xk x b) 
     475              (if (p xk x) (foldf b (f xk x (foldf a ax))) ax))))
     476    (foldf root init)))
     477
     478
     479(define (foldv-right-partial root )
     480  (lambda (p f init)
     481    (define (foldf tree ax)
     482      (match tree
     483             (($ tree 'Empty)  ax)
     484             (($ tree 'Tree _ a _ x b) 
     485              (if (p x) (foldf a (f x (foldf b ax))) ax))))
     486    (foldf root init)))
     487
     488
     489(define (foldi-right-partial root)
     490  (lambda (p f init)
     491    (define (foldf tree ax)
     492      (match tree
     493             (($ tree 'Empty)  ax)
     494             (($ tree 'Tree _ a xk x b) 
     495              (if (p xk x) (foldf a (f xk x (foldf b ax))) ax))))
     496    (foldf root init)))
     497
     498
     499(define (foldv root)
     500  (lambda (f init)
     501    (define (foldf tree ax)
     502      (match tree
     503             (($ tree 'Empty)  ax)
     504             (($ tree 'Tree _ a _ x b)  (foldf b (f x (foldf a ax))))))
     505    (foldf root init)))
     506
     507
     508(define (foldi root)
     509  (lambda (f init)
     510    (define (foldf tree ax)
     511      (match tree
     512             (($ tree 'Empty)  ax)
     513             (($ tree 'Tree _ a xk x b)  (foldf b (f xk x (foldf a ax))))))
     514    (foldf root init)))
     515
     516
     517(define (foldv-right root)
     518  (lambda (f init)
     519    (define (foldf tree ax)
     520      (match tree
     521             (($ tree 'Empty)  ax)
     522             (($ tree 'Tree _ a _ x b)  (foldf a (f x (foldf b ax))))))
     523    (foldf root init)))
     524
     525
     526(define (foldi-right root)
     527  (lambda (f init)
     528    (define (foldf tree ax)
     529      (match tree
     530             (($ tree 'Empty)  ax)
     531             (($ tree 'Tree _ a xk x b)  (foldf a (f xk x (foldf b ax))))))
     532    (foldf root init)))
     533
     534
     535(define (get-depth root)
     536  (let loop ((node root) (level 0))
     537    (match node
     538           (($ tree 'Empty)  level)
     539           (($ tree 'Tree _ a _ _ b) 
     540            (max (loop a (+ 1 level))
     541                 (loop b (+ 1 level)))))))
     542
     543
     544;; Returns an ordered list of the keys in the tree
     545(define (list-keys foldi-right)
     546  (foldi-right (lambda (k x l) (cons k l)) (list)))
     547
     548
     549;; Returns an ordered list of the (key . item) pairs in the tree
     550(define (list-items foldi-right)
     551  (foldi-right (lambda (k x l) (cons (cons k x) l)) (list)))
     552
     553
     554(define (for-each-ascending root )
     555  (define (appf f tree)
     556    (match tree
     557           (($ tree 'Empty)  (void))
     558           (($ tree 'Tree _ a k x b)  (begin (appf f a) (f (cons k x)) (appf f b)))))
     559  (lambda (f) (appf f root)))
     560
     561
     562(define (for-each-descending root)
     563  (define (appf f tree)
     564    (match tree
     565           (($ tree 'Empty)  (void))
     566           (($ tree 'Tree _ a k x b)  (begin (appf f b) (f (cons k x)) (appf f a)))))
     567  (lambda (f) (appf f root)))
     568 
     569
     570(define (mapv root)
     571  (define (mapf f tree)
     572    (match tree
     573           (($ tree 'Empty)  (Empty))
     574           (($ tree 'Tree color a xk x b) 
     575            (Tree color (mapf f a) xk (f x) (mapf f b)))))
     576  (lambda (f) (mapf f root)))
     577
     578
     579(define (mapi root)
     580  (define (mapf f tree)
     581    (match tree
     582           (($ tree 'Empty)   (Empty))
     583           (($ tree 'Tree color a xk x b) 
     584            (Tree color (mapf f a) xk (f xk x) (mapf f b)))))
     585  (lambda (f) (mapf f root) ))
     586
     587
     588(define (apply-default-clause label key default-clause)
     589  (cond
     590   ((null? default-clause)
     591    (rb-tree:error label "key " key " was not found in the tree"))
     592   ((pair? (cdr default-clause))
     593    (rb-tree:error label "default argument must be a single clause"))
     594   ((procedure? (car default-clause)) ((car default-clause)))
     595   (else (car default-clause))))
     596
     597(define (make-ephemeral-map key-compare #!key (insdel-key-compare key-compare))
     598  (ephemeral-map-operations (make-tree-map 0 (Empty) key-compare insdel-key-compare)))
     599
     600(define (ephemeral-map-operations m)
     601 
     602  (let* ((key-compare (map-key-compare m))
     603         (insdel-key-compare (map-insdel-key-compare m))
     604         (size (make-parameter (map-size m)))
     605         (root (make-parameter (map-root m)))
     606         (delete!
     607          (lambda (key)
     608            (let ((item+tree  ((delete-assoc insdel-key-compare (root)) key)))
     609              (and item+tree
     610                   (begin
     611                     (size (- (size) 1))
     612                     (root (cdr item+tree))
     613                     (car item+tree))))))
     614         )
     615
     616      ;; Message dispatcher
     617      (lambda (selector)
     618        (case selector
     619         
     620          ((get)
     621             (lambda (key . default-clause)
     622               (let ((find-assoc1 (find-assoc key-compare (root))))
     623                 (or (find-assoc1 key) (apply-default-clause 'get key default-clause)))))
     624         
     625         
     626          ((get-value)
     627             (lambda (key . default-clause)
     628               (let ((find-ref1 (find-ref key-compare (root))))
     629                 (or (find-ref1 key) (apply-default-clause 'get-value key default-clause)))))
     630         
     631         
     632          ((put)
     633             (lambda (key value)
     634               (let ((insert1 (insert insdel-key-compare (root))))
     635                 (let-values (((found? new-root)  (insert1 key value)))
     636                   (let ((new-map (make-tree-map (if found? size (+ 1 (size))) new-root
     637                                                 key-compare insdel-key-compare)))
     638                     (ephemeral-map-operations new-map))))))
     639         
     640          ((get-min) (get-min (root)))
     641          ((get-max) (get-max (root)))
     642         
     643         
     644          ((delete)
     645           (lambda (key . default-clause)
     646             (or (let ((item+tree ((delete-assoc insdel-key-compare (root)) key)))
     647                   (and item+tree
     648                        (let ((new-map (make-tree-map (- (size) 1) (cdr item+tree)
     649                                                      key-compare insdel-key-compare)))
     650                          (ephemeral-map-operations new-map))) )
     651                 (apply-default-clause 'delete key default-clause))))
     652
     653          ((put!)
     654             (lambda (key value)
     655               (let ((insert1 (insert insdel-key-compare (root))))
     656                 (let-values (((found? new-root)  (insert1 key value)))
     657                   (root new-root)
     658                   (if (not found?)  (size (+ 1 (size))))
     659                   found?))))
     660
     661          ((delete!)
     662           (lambda (key . default-clause)
     663             (or (delete! key)
     664                 (apply-default-clause 'delete! key default-clause))))
     665         
     666         
     667          ((delete-min!)   (delete! (car (get-min (root)))))
     668          ((delete-max!)   (delete! (car (get-max (root)))))
     669         
     670          ((clear!)  (begin
     671                       (root (Empty))
     672                       (size 0)))
     673          ((empty?)  (cases tree (root)
     674                            (Empty () #t)
     675                            (else #f)))
     676         
     677          ((size)    (size))
     678         
     679          ((depth)   (get-depth (root)))
     680         
     681          ((for-each-ascending)         (for-each-ascending (root)))
     682          ((for-each-descending)        (for-each-descending (root)))
     683         
     684          ((list-keys)                   (list-keys (foldi-right (root))))
     685          ((list-items)                  (list-items (foldi-right (root))))
     686         
     687          ((map)                         (lambda (f) (let ((mapv1 (mapv (root))))
     688                                                       (ephemeral-map-operations
     689                                                        (make-tree-map size (mapv1 f)
     690                                                                       key-compare insdel-key-compare)))))
     691          ((mapi)                        (lambda (f) (let ((mapi1 (mapi root)))
     692                                                       (ephemeral-map-operations
     693                                                        (make-tree-map size (mapi1 f)
     694                                                                       key-compare insdel-key-compare)))))
     695         
     696          ((fold)                        (foldv (root)))
     697          ((foldi)                       (foldi (root)))
     698          ((fold-right)                  (foldv-right (root)))
     699          ((foldi-right)                 foldi-right)
     700         
     701          ((fold-partial)                (foldv-partial (root)))
     702          ((foldi-partial)               (foldi-partial (root)))
     703          ((fold-right-partial)          (foldv-right-partial (root)))
     704          ((foldi-right-partial)         (foldi-right-partial (root)))
     705         
     706          ((fold-limit)                  (foldv-limit (root)))
     707          ((fold-right-limit)            (foldv-right-limit (root)))
     708         
     709          ((tree-map)                    (make-tree-map (size) (root) key-compare insdel-key-compare))
     710         
     711          (else
     712           (rb-tree:error 'selector "unknown message " selector " sent to a red-black tree"))
     713         
     714          ))))
     715
     716
     717(define (make-persistent-map key-compare
     718                             #!key (insdel-key-compare key-compare) )
     719  (persistent-map-operations (make-tree-map 0 (Empty) key-compare insdel-key-compare)))
     720
     721
     722(define (persistent-map-operations m)
     723
     724    (let* ((key-compare (map-key-compare m))
     725           (insdel-key-compare (map-insdel-key-compare m))
     726           (size (map-size m))
     727           (root (map-root m))
     728           (foldi-right (foldi-right root)))
     729
     730      ;; Message dispatcher
     731      (lambda (selector)
     732        (case selector
     733         
     734          ((get)
     735           (let ((find-assoc1 (find-assoc key-compare root)))
     736             (lambda (key . default-clause)
     737               (or (find-assoc1 key) (apply-default-clause 'get key default-clause)))))
     738         
     739         
     740          ((get-value)
     741           (let ((find-ref1 (find-ref key-compare root)))
     742             (lambda (key . default-clause)
     743               (or (find-ref1 key) (apply-default-clause 'get-value key default-clause)))))
     744         
     745         
     746          ((put)
     747           (let ((insert1 (insert insdel-key-compare root)))
     748             (lambda (key value)
     749               (let-values (((found? new-root)  (insert1 key value)))
     750                 (let ((new-map (make-tree-map (if found? size (+ 1 size)) new-root
     751                                               key-compare insdel-key-compare)))
     752                   (persistent-map-operations new-map))))))
     753         
     754
     755          ((get-min) (get-min root))
     756          ((get-max) (get-max root))
     757         
     758         
     759          ((delete)
     760           (let ((delete1 (delete-assoc insdel-key-compare root)))
     761             (lambda (key . default-clause)
     762               (or (let ((item+tree  (delete1 key)))
     763                     (and item+tree
     764                          (let ((new-map (make-tree-map (- size 1) (cdr item+tree)
     765                                                        key-compare insdel-key-compare)))
     766                            (persistent-map-operations new-map))) )
     767                   (apply-default-clause 'delete key default-clause)))))
     768         
     769         
     770          ((empty?)  (cases tree root
     771                            (Empty () #t)
     772                            (else #f)))
     773         
     774          ((size)    size)
     775         
     776          ((depth)   (get-depth root))
     777         
     778          ((for-each-ascending)         (for-each-ascending root))
     779          ((for-each-descending)        (for-each-descending root))
     780         
     781          ((list-keys)                   (list-keys foldi-right))
     782          ((list-items)                  (list-items foldi-right))
     783         
     784          ((map)                         (let ((mapv1 (mapv root)))
     785                                           (lambda (f) (persistent-map-operations (make-tree-map size (mapv1 f)
     786                                                                                                 key-compare insdel-key-compare)))))
     787          ((mapi)                        (let ((mapi1 (mapi root)))
     788                                           (lambda (f) (persistent-map-operations (make-tree-map size (mapi1 f)
     789                                                                                                 key-compare insdel-key-compare)))))
     790         
     791          ((fold)                        (foldv root))
     792          ((foldi)                       (foldi root))
     793          ((fold-right)                  (foldv-right root))
     794          ((foldi-right)                 foldi-right)
     795         
     796          ((fold-partial)                (foldv-partial root))
     797          ((foldi-partial)               (foldi-partial root))
     798          ((fold-right-partial)          (foldv-right-partial root))
     799          ((foldi-right-partial)         (foldi-right-partial root))
     800         
     801          ((fold-limit)                  (foldv-limit root))
     802          ((fold-right-limit)            (foldv-right-limit root))
     803
     804          ((tree-map)                    m)
     805         
     806          (else
     807           (rb-tree:error 'selector "unknown message " selector " sent to a red-black tree"))
     808         
     809          ))))
     810
     811;; functions for walking the tree while keeping a stack of parents to
     812;; be visited.
     813
     814
     815(define (next lst)
     816  (match lst
     817         (((and t ($ tree 'Tree _ _ _ _ b)) . rest) 
     818          (list t (left b rest)))
     819         
     820         (else (list (Empty) '()))))
     821
     822(define (left t rest)
     823  (match t
     824         (($ tree 'Empty) rest)
     825         ((and t ($ tree 'Tree _ a _ _ _))
     826          (left a (cons t rest)))))
     827
     828(define (start t) (left t '()))
     829
     830
     831;; Support for constructing red-black trees in linear time from
     832;; increasing ordered sequences (based on a description by R. Hinze).
     833;; Note that the elements in the digits are ordered with the largest
     834;; on the left, whereas the elements of the trees are ordered with the
     835;; largest on the right.
     836
     837(define-datatype digit digit?
     838  (Zero)
     839  (One (key identity)  (value identity) (tree tree?) (digit digit?))
     840  (Two (key1 identity) (value1 identity) (tree1 tree?)
     841       (key2 identity) (value2 identity) (tree2 tree?) (digit digit?)))
     842
     843;; add an item that is guaranteed to be larger than any in l
     844(define (add-item ak a l)
     845  (define (incr ak1 a1 t1 d)
     846    (match d
     847           (($ digit 'Zero)
     848            (One ak1 a1 t1 (Zero)))
     849           (($ digit 'One ak2 a2 t2 r)
     850            (Two ak1 a1 t1 ak2 a2 t2 r))
     851           (($ digit 'Two ak2 a2 t2 ak3 a3 t3 r)
     852            (One ak1 a1 t1 (incr ak2 a2 (Tree B t3 ak3 a3 t2) r)))))
     853  (incr ak a (Empty) l))
     854
     855
     856;; link the digits into a tree
     857(define (link-all t)
     858  (define (link t d)
     859    (match d
     860           (($ digit 'Zero)  t)
     861           (($ digit 'One ak a t2 r)
     862            (link (Tree B t2 ak a t) r))
     863           (($ digit 'Two ak1 a1 t1 ak2 a2 t2 r)
     864            (link (Tree B (Tree R t2 ak2 a2 t1) ak1 a1 t) r))))
     865  (link (Empty) t))
     866           
     867           
     868(define (wrap f)
     869  (lambda (m1 m2)
     870    (let ((m1 (m1 'tree-map))
     871          (m2 (m2 'tree-map)))
     872      (let ((key-compare (map-key-compare m1))
     873            (insdel-key-compare (map-insdel-key-compare m1))
     874            (t1 (map-root m1))
     875            (t2 (map-root m2)))
     876        (let ((f1 (f insdel-key-compare)))
     877          (match-let (((n result) (f1 (start t1) (start t2) 0 (Zero))))
     878                     (make-tree-map n (link-all result) key-compare insdel-key-compare)))))))
     879
     880 
     881(define (map-insert t n result)
     882  (match t
     883         ((($ tree 'Empty) _) 
     884          (list n result))
     885         ((($ tree 'Tree _ _ xk x _) r)
     886          (map-insert (next r) (+ 1 n) (add-item xk x result)))))
     887
     888
     889;; Creates a map whose domain is the union of the domains of the two
     890;; input maps, using the supplied function to define the map on
     891;; elements that are in both domains.
     892
     893(define (union-with merge-fn)
     894  (define (union key-compare)
     895    (lambda (t1 t2 n result)
     896      (let recur ((t1 t1) (t2 t2) (n n) (result result))
     897        (match (list (next t1) (next t2))
     898               
     899               (((($ tree 'Empty) _) (($ tree 'Empty) _))
     900                (list n result))
     901               
     902               (((($ tree 'Empty) _) t2)
     903                (map-insert t2 n result))
     904               
     905               ((t1 (($ tree 'Empty) _))
     906                (map-insert t1 n result))
     907               
     908               (((($ tree 'Tree _ _ xk x _) r1) (($ tree 'Tree _ _ yk y _) r2))
     909                (let ((c (key-compare xk yk)))
     910                  (cond ((negative? c)   (recur r1 t2 (+ 1 n) (add-item xk x result)))
     911                        ((zero? c)       (recur r1 r2 (+ 1 n) (add-item xk (merge-fn x y) result)))
     912                        ((positive? c)   (recur t1 r2 (+ 1 n) (add-item yk y result))))))
     913               
     914               ))))
     915  (wrap union))
     916
     917
     918(define (union-withi merge-fn)
     919  (define (union key-compare)
     920    (lambda (t1 t2 n result)
     921      (let recur ((t1 t1) (t2 t2) (n n) (result result))
     922        (match (list (next t1) (next t2))
     923               
     924               (((($ tree 'Empty) _) (($ tree 'Empty) _))
     925                (list n result))
     926               
     927               (((($ tree 'Empty) _) t2)
     928                (map-insert t2 n result))
     929               
     930               ((t1 (($ tree 'Empty) _))
     931                (map-insert t1 n result))
     932               
     933               (((($ tree 'Tree _ _ xk x _) r1) (($ tree 'Tree_ _ yk y _) r2))
     934                (let ((c (key-compare xk yk)))
     935                  (cond ((negative? c)   (recur r1 t2 (+ 1 n) (add-item xk x result)))
     936                        ((zero? c)       (recur r1 r2 (+ 1 n) (add-item xk (merge-fn xk x y) result)))
     937                        ((positive? c)   (recur t1 r2 (+ 1 n) (add-item yk y result))))))
     938               
     939               ))))
     940    (wrap union))
    655941
    656942)
  • release/4/rb-tree/trunk/rb-tree.setup

    r20529 r20634  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -d0 -s rb-tree.scm -j rb-tree)
     6(compile -O3 -d0 -S -s rb-tree.scm -j rb-tree)
    77(compile -O2 -d0 -s rb-tree.import.scm)
    88
     
    1616 
    1717  ; Assoc list with properties for your extension:
    18   '((version 3.1)
     18  '((version 4.0)
    1919    (documentation "rb-tree.html")
    2020    ))
  • release/4/rb-tree/trunk/tests/run.scm

    r20498 r20634  
    44;;
    55
    6 (require-library srfi-1 srfi-13 rb-tree test)
    7 (import srfi-1 srfi-13 rb-tree test)
     6(require-library srfi-1 rb-tree test)
     7(import srfi-1 rb-tree test)
    88
    99(define (++ x) (fx+ 1 x))
     
    1212(define min-key 1)
    1313(define max-key 1000)
     14
     15(define (key-compare x y) (- x y))
     16
     17(define ephemeral-map (make-ephemeral-map key-compare))
    1418           
    15 (define rb-tree (make-rb-tree (lambda (x y) (- x y))))
    16        
     19(define (new-persistent-map) (make-persistent-map key-compare))
     20
    1721;; a hard-wired association between a key and a value"   
    1822(define compute-assoc (lambda (key) (cons key (++ key))))
    19            
    20 (test-group "rb-tree-test initial"
    2123
    22             (test-assert (rb-tree 'empty?))
    23             (test-assert (zero? (rb-tree 'size))))
    2424
    25 (test-group (string-concatenate (list "loading a sequence ["
    26                                       (number->string min-key) ", "
    27                                       (number->string max-key) "] in ascending order"))
     25(test-group "map union"
     26
     27
     28            (let* ((compute-assoc1 (lambda (key) (cons key (* 10 key))))
     29                   
     30                   (m1
     31                    (let recur  ((m (new-persistent-map)) (i min-key))
     32                      (let ((m1 ((m 'put) i (cdr (compute-assoc1 i)))))
     33                        (if (< i max-key) (recur m1 (++ i)) m1))))
     34                   
     35                   (compute-assoc2 (lambda (key) (cons key (* 20 key))))
     36                   
     37                   (m2
     38                    (let recur  ((m (new-persistent-map)) (i min-key))
     39                      (let ((m1 ((m 'put) i (cdr (compute-assoc2 i)))))
     40                        (if (< i max-key) (recur m1 (++ i)) m1))))
     41                   
     42                   (m12 (ephemeral-map-operations ((union-with list) m1 m2))))
     43             
     44              (let recur  ((i min-key))
     45                (test (sprintf "get element ~A" i)
     46                      (list i (cdr (compute-assoc1 i)) (cdr (compute-assoc2 i)))
     47                      ((m12 'get) i) )
     48                (if (< i max-key) (recur (++ i))))
     49                 
     50              ))
     51
     52
     53(test-group "ephemeral map"
     54
     55  (test-group "verify the map is empty"
     56
     57            (test-assert (ephemeral-map 'empty?))
     58            (test-assert (zero? (ephemeral-map 'size))))
     59
     60  (test-group  (sprintf "loading a sequence [~A,~A] in ascending order" min-key max-key)
    2861
    2962    (do ((i min-key (++ i))) ((> i max-key))
    30       (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
    31       (test (compute-assoc i)((rb-tree 'get) i) ))
     63      (test-assert (sprintf "put element ~A" i) (not ((ephemeral-map 'put!) i (cdr (compute-assoc i)))))
     64      (test (sprintf "get element ~A" i) (compute-assoc i) ((ephemeral-map 'get) i) ))
    3265
    33      (test (rb-tree 'size) (++ (- max-key min-key)))
    34      (test-assert (not (rb-tree 'empty?)))
     66     (test (ephemeral-map 'size) (++ (- max-key min-key)))
     67     (test-assert (not (ephemeral-map 'empty?)))
    3568           
    36      (test (compute-assoc (++ min-key)) ((rb-tree 'get) (++ min-key)) )
    37      (test (compute-assoc (++ min-key)) ((rb-tree 'get) (++ min-key) #f)  )
     69     (test (compute-assoc (++ min-key)) ((ephemeral-map 'get) (++ min-key)) )
     70     (test (compute-assoc (++ min-key)) ((ephemeral-map 'get) (++ min-key) #f)  )
    3871           
    3972     (test-assert "check looking up of non-existing keys"
    40                   (not ((rb-tree 'get) (-- min-key) #f)))
     73                  (not ((ephemeral-map 'get) (-- min-key) #f)))
    4174           
    42      (rb-tree 'clear!)
     75     (ephemeral-map 'clear!)
    4376     )
    4477
    45 (test-group "reloading the same seq in descending order and then deleting"
     78  (test-group "reloading the same sequence in descending order and then deleting"
    4679           
    47     (test-assert (rb-tree 'empty?))
    48     (test-assert (zero? (rb-tree 'size)))
     80    (test-assert (ephemeral-map 'empty?))
     81    (test-assert (zero? (ephemeral-map 'size)))
    4982           
    5083    (do ((i max-key (-- i))) ((< i min-key))
    51       (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
    52       (test  (compute-assoc i) ((rb-tree 'get) i))
    53       (test-assert ((rb-tree 'delete!) i))))
     84      (test-assert (sprintf "put element ~A" i) (not ((ephemeral-map 'put!) i (cdr (compute-assoc i)))))
     85      (test (sprintf "get element ~A" i) (compute-assoc i) ((ephemeral-map 'get) i))
     86      (test-assert (sprintf "delete element ~A" i) ((ephemeral-map 'delete!) i))))
    5487
    55 (test-group "loading the rb-tree again in a \"random\" order"
     88  (test-group "loading the ephemeral-map again in a \"random\" order"
    5689
    57      (test-assert (zero? (rb-tree 'size)))
     90     (test-assert (zero? (ephemeral-map 'size)))
    5891           
    5992     (do ((i min-key) (j max-key) (direction #t (not direction)))
     
    6194       (cond
    6295        (direction
    63          (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
     96         (test-assert (not ((ephemeral-map 'put!) i (cdr (compute-assoc i)))))
    6497         (set! i (++ i)))
    6598        (else
    66          (test-assert (not ((rb-tree 'put!) j (cdr (compute-assoc j)))))
     99         (test-assert (not ((ephemeral-map 'put!) j (cdr (compute-assoc j)))))
    67100         (set! j (-- j))))))
    68101   
    69 (test-group "looking up the elements in  the rb-tree"
    70     (do ((i min-key (++ i))) ((> i max-key))
    71             (test (compute-assoc i) ((rb-tree 'get) i) )))
     102  (test-group "looking up the elements in  the ephemeral-map"
     103              (do ((i min-key (++ i))) ((> i max-key))
     104                (test (sprintf "element ~A" i) (compute-assoc i) ((ephemeral-map 'get) i) )))
    72105
    73 (test "using fold to sum the elements in the rb-tree
    74       (* 500 (+ (+ 1 min-key) (+ 1 max-key)))
    75       ((rb-tree 'fold) (lambda (x sum) (+ x sum)) 0))
     106  (test "using fold to sum the elements in the ephemeral-map
     107        (* 500 (+ (+ 1 min-key) (+ 1 max-key)))
     108        ((ephemeral-map 'fold) (lambda (x sum) (+ x sum)) 0))
    76109
    77 (test-group "using 'map to create a copy of tree with each element x mapped to x*10"
    78     (let ((rb-tree-x10 ((rb-tree 'map) (lambda (x) (* x 10))))
    79           (compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key))))))
    80       (do ((i min-key (++ i))) ((> i max-key))
    81         (test (compute-assoc-x10 i) ((rb-tree-x10 'get) i) ))))
     110  (test-group "using 'map to create a copy of tree with each element x mapped to x*10"
     111              (let ((ephemeral-map-x10 ((ephemeral-map 'map) (lambda (x) (* x 10))))
     112                    (compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key))))))
     113                (do ((i min-key (++ i))) ((> i max-key))
     114                  (test (sprintf "element ~A" i)
     115                        (compute-assoc-x10 i)
     116                        ((ephemeral-map-x10 'get) i) ))))
     117  )
     118           
     119(test-group "persistent map"
    82120
     121  (test-group "the empty and size predicates on an empty map"
     122
     123   (let ((m (new-persistent-map)))
     124     (test-assert (m 'empty?))
     125     (test-assert (zero? (m 'size)))))
     126
     127  (test-group (sprintf "loading a sequence [~A,~A] in ascending order" min-key max-key)
     128
     129              (let ((m
     130                     (let recur  ((m (new-persistent-map)) (i min-key))
     131                       (let ((m1 ((m 'put) i (cdr (compute-assoc i)))))
     132                         (test (sprintf "get element ~A" i) (compute-assoc i) ((m1 'get) i))
     133                         (if (< i max-key) (recur m1 (++ i)) m1)))))
     134               
     135                (test (++ (- max-key min-key)) (m 'size))
     136                (test-assert (not (m 'empty?)))
     137               
     138                (test (compute-assoc (++ min-key)) ((m 'get) (++ min-key)) )
     139                (test (compute-assoc (++ min-key)) ((m 'get) (++ min-key) #f)  )
     140               
     141                (test-assert "looking up of non-existing keys"
     142                             (not ((m 'get) (-- min-key) #f)))
     143     ))
     144
     145  (test-group "reloading the same sequence in descending order and then deleting"
     146             
     147              (let ((m
     148                     (let recur  ((m (new-persistent-map)) (i max-key))
     149                       (let ((m1 ((m 'put) i (cdr (compute-assoc i)))))
     150                         (test (sprintf "get element ~A" i) (compute-assoc i) ((m1 'get) i))
     151                         (let ((m2 ((m1 'delete) i)))
     152                           (if (< min-key i) (recur m2 (- i)) m2))))))
     153
     154                (test-assert (zero? (m 'size)))))
     155
     156
     157  (test-group "fold and map"
     158              (let ((m
     159                     (let recur  ((m (new-persistent-map)) (i min-key))
     160                       (let ((m1 ((m 'put) i (cdr (compute-assoc i)))))
     161                         (if (< i max-key) (recur m1 (++ i)) m1)))))
     162
     163                (test "using fold to sum the elements in the persistent-map" 
     164                 (* 500 (+ (+ 1 min-key) (+ 1 max-key)))
     165                 ((m 'fold) (lambda (x sum) (+ x sum)) 0))
     166
     167                (test-group "using map to multiply each elements by 10"
     168                            (let ((m-x10 ((m 'map) (lambda (x) (* x 10))))
     169                                  (compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key))))))
     170                              (do ((i min-key (++ i))) ((> i max-key))
     171                                (test (sprintf "element ~A" i)
     172                                 (compute-assoc-x10 i)
     173                                 ((m-x10 'get) i) ))))))
     174)
     175
Note: See TracChangeset for help on using the changeset viewer.