Changeset 8915 in project


Ignore:
Timestamp:
02/25/08 16:39:29 (12 years ago)
Author:
Kon Lovett
Message:

Save.

Files:
4 edited

Legend:

Unmodified
Added
Removed
  • nondescript/binary-tree/tests/binary-tree-test.scm

    r5064 r8915  
    55(use srfi-1 srfi-13)
    66
    7 ;;
     7;;;
    88
    99(define-inline (->boolean obj)
    10         (not (not obj)) )
     10        (and obj #t) )
    1111
    1212(define (random-alist n #!optional (lim (* n 10)))
    1313        (let loop ([n n] [al '()])
    1414                (if (zero? n)
    15                         al
    16                         (loop (sub1 n) (alist-cons (random lim) (gensym) al)) ) ) )
     15        al
     16        (loop (sub1 n) (alist-cons (random lim) (gensym) al)) ) ) )
    1717
    1818(define (alist-same? al1 al2)
    1919        (every
    20                 (lambda (pair)
    21                         (and-let* ([v2 (alist-ref (car pair) al2 equal?)])
    22                                 (equal? v2 (cdr pair)) ) )
     20                (lambda (pare)
     21                        (and-let* ([v2 (alist-ref (car pare) al2 equal?)])
     22                                (equal? v2 (cdr pare)) ) )
    2323                al1) )
    24 
    25 (define-expect-binary alist-same? alist-same "alist same key-value pairs, w/o ordering")
    2624
    2725(define (list-same? l1 l2)
    2826        (every (lambda (x) (->boolean (member x l2))) l1) )
    2927
    30 (define-expect-binary list-same? list-same "list same values, w/o ordering")
    31 
    3228(define (random-tree n)
    3329        (alist->avltree (random-alist n) <) )
    3430
    35 ;;
     31;;;
     32
     33(define-expect-binary alist-same? alist-same "alist same key-value pairs, w/o ordering")
     34
     35(define-expect-binary list-same? list-same "list same values, w/o ordering")
     36
     37;;;
    3638
    3739(define-test avltree-test "Avl-Tree"
     
    130132(test::styler-set! avltree-test test::output-style-human)
    131133(run-test "AVL Tree Tests")
     134
     135(test::forget!)
  • release/3/binary-tree/avltree.scm

    r5442 r8915  
    1 ;;;; avltree.scm
    2 ;;;; Kon Lovett, Oct '06
    3 ;;;; Stephen J. Bevan   <bevan@cs.man.ac.uk> Oct 23 1993
     1;;;;; avltree.scm
     2;;;;; Kon Lovett, Oct '06
     3;;;;; Stephen J. Bevan <bevan@cs.man.ac.uk> Oct 23 1993
    44
    55;; Issues
    66;;
    77;; - Only re-uses deleted nodes when keys match
    8 
    9 (use srfi-1)
    10 (use misc-extn-record)
    118
    129(eval-when (compile)
     
    4744                        avltree-bifold) ) )
    4845
     46(use srfi-1)
     47(use misc-extn-record)
     48
    4949;;;
    5050
     
    8080
    8181(define-inline (*node-height nd)
    82         (if (%empty-node? nd) 0 (%node-height nd) ) )
     82        (if (%empty-node? nd)
     83            0
     84            (%node-height nd) ) )
    8385
    8486;;;
    8587
    8688(define-inline (avltree::max a b)
    87   (+ 1 (max a b)) )
     89  (add1 (max a b)) )
    8890
    8991;; Insert an element with the given KEY into TREE.  If an element with
     
    99101                                [middle-tree-height (*node-height middle-tree)]
    100102                                [right-tree-height (*node-height right-tree)])
    101                 (cond
    102                         [(and (> middle-tree-height left-tree-height)
    103                                                 (> middle-tree-height right-tree-height))
    104                                 (%make-node
    105                                         (%make-node left-tree ak av ad (+ 1 left-tree-height) (%node-left middle-tree))
    106                                         (%node-key middle-tree) (%node-value middle-tree) (%node-deleted? middle-tree)
    107                                         (+ 2 left-tree-height)
    108                                         (%make-node (%node-right middle-tree) ck cv cd (+ 1 right-tree-height) right-tree))]
    109                         [(and (>= left-tree-height middle-tree-height)
    110                                                 (>= left-tree-height right-tree-height))
    111                                 (let* ([middle-right-max (avltree::max middle-tree-height right-tree-height)]
    112                                                          [left-middle-right-max (avltree::max middle-right-max left-tree-height)])
    113                                         (%make-node
    114                                                 left-tree
    115                                                 ak av ad
    116                                                 left-middle-right-max
    117                                                 (%make-node middle-tree ck cv cd middle-right-max right-tree)))]
    118                         [else
    119                                 (let* ([left-middle-max (avltree::max left-tree-height middle-tree-height)]
    120                                                          [left-middle-right-max (avltree::max left-middle-max right-tree-height)])
    121                                         (%make-node
    122                                                 (%make-node left-tree ak av ad left-middle-max middle-tree)
    123                                                 ck cv cd
    124                                                 left-middle-right-max
    125                                                 right-tree))]) ) )
    126 
    127 (define (avltree::add t k less-than if-found if-not-found)
     103                (cond [(and (> middle-tree-height left-tree-height)
     104                (> middle-tree-height right-tree-height))
     105            (%make-node
     106              (%make-node left-tree ak av ad (+ 1 left-tree-height) (%node-left middle-tree))
     107              (%node-key middle-tree) (%node-value middle-tree) (%node-deleted? middle-tree)
     108              (+ 2 left-tree-height)
     109              (%make-node (%node-right middle-tree) ck cv cd (+ 1 right-tree-height) right-tree))]
     110          [(and (>= left-tree-height middle-tree-height)
     111                (>= left-tree-height right-tree-height))
     112            (let* ([middle-right-max (avltree::max middle-tree-height right-tree-height)]
     113                   [left-middle-right-max (avltree::max middle-right-max left-tree-height)])
     114              (%make-node
     115                left-tree
     116                ak av ad
     117                left-middle-right-max
     118                (%make-node middle-tree ck cv cd middle-right-max right-tree)))]
     119          [else
     120            (let* ([left-middle-max (avltree::max left-tree-height middle-tree-height)]
     121                   [left-middle-right-max (avltree::max left-middle-max right-tree-height)])
     122              (%make-node
     123                (%make-node left-tree ak av ad left-middle-max middle-tree)
     124                ck cv cd
     125                left-middle-right-max
     126                right-tree))]) ) )
     127
     128(define (avltree::add t k less-than found not-found)
    128129        (let loop ([t t])
    129130                (if (%empty-node? t)
    130                         (if-not-found)
    131                         (let ([ck (%node-key t)])
    132                                 (cond
    133                                         [(less-than ck k)
    134                                                 (let ([n (loop (%node-right t))])
    135                                                         (avltree::combine
    136                                                                 (%node-left t)
    137                                                                 (%node-key t) (%node-value t) (%node-deleted? t)
    138                                                                 (%node-left n)
    139                                                                 (%node-key n) (%node-value n) (%node-deleted? n)
    140                                                                 (%node-right n)))]
    141                                         [(less-than k ck)
    142                                                 (let ([n (loop (%node-left t))])
    143                                                         (avltree::combine
    144                                                                 (%node-left n)
    145                                                                 (%node-key n) (%node-value n) (%node-deleted? n)
    146                                                                 (%node-right n)
    147                                                                 (%node-key t) (%node-value t) (%node-deleted? t)
    148                                                                 (%node-right t)))]
    149                                         [else
    150                                                 (if-found t)] ) ) ) ) )
    151 
    152 (define (avltree:merge-insert t k less-than if-found if-not-found)
     131        (not-found)
     132        (let ([ck (%node-key t)])
     133          (cond [(less-than ck k)
     134                  (let ([n (loop (%node-right t))])
     135                    (avltree::combine
     136                      (%node-left t)
     137                      (%node-key t) (%node-value t) (%node-deleted? t)
     138                      (%node-left n)
     139                      (%node-key n) (%node-value n) (%node-deleted? n)
     140                      (%node-right n)))]
     141                [(less-than k ck)
     142                  (let ([n (loop (%node-left t))])
     143                    (avltree::combine
     144                      (%node-left n)
     145                      (%node-key n) (%node-value n) (%node-deleted? n)
     146                      (%node-right n)
     147                      (%node-key t) (%node-value t) (%node-deleted? t)
     148                      (%node-right t)))]
     149                [else
     150                  (found t)] ) ) ) ) )
     151
     152(define (avltree:merge-insert t k less-than found not-found)
    153153        (let ([merge
    154154                                        (lambda (t)
     
    156156                                                        (%node-left t)
    157157                                                        k
    158                                                         (if (%node-deleted? t) (if-not-found) (if-found (%node-value t)))
     158                                                        (if (%node-deleted? t) (not-found) (found (%node-value t)))
    159159                                                        (%node-height t)
    160160                                                        (%node-right t)))]
    161161                                [add
    162162                                        (lambda ()
    163                                                 (make-leaf k (if-not-found)))])
     163                                                (make-leaf k (not-found)))])
    164164                (avltree::add t k less-than merge add) ) )
    165165
     
    175175        (let ([r (%node-right t)])
    176176                (if (%empty-node? r)
    177                         t
    178                         (begin
    179                                 (%node-right-set! t (%node-left r))
    180                                 (%node-height-set! t (+ -1 (%node-height t)))
    181                                 (%node-left-set! r t)
    182                                 (%node-height-set! r (+ 1 (%node-height r)))
    183                                 r ) ) ) )
     177        t
     178        (begin
     179          (%node-right-set! t (%node-left r))
     180          (%node-height-set! t (+ -1 (%node-height t)))
     181          (%node-left-set! r t)
     182          (%node-height-set! r (+ 1 (%node-height r)))
     183          r ) ) ) )
    184184
    185185(define-inline (avltree::rotate-right! t)
    186186        (let ([r (%node-left t)])
    187187                (if (%empty-node? r)
    188                         t
    189                         (begin
    190                                 (%node-left-set! t (%node-right r))
    191                                 (%node-height-set! t (+ -1 (%node-height t)))
    192                                 (%node-right-set! r t)
    193                                 (%node-height-set! r (+ 1 (%node-height r)))
    194                                 r ) ) ) )
     188        t
     189        (begin
     190          (%node-left-set! t (%node-right r))
     191          (%node-height-set! t (+ -1 (%node-height t)))
     192          (%node-right-set! r t)
     193          (%node-height-set! r (+ 1 (%node-height r)))
     194          r ) ) ) )
    195195
    196196(define-inline (avltree::rotate! t)
     
    198198                                [rht (*node-height (%node-right t))])
    199199                (%node-height-set! t (avltree::max lht rht))
    200                 (cond
    201                         [(> lht rht)
    202                                 (avltree::rotate-right! t)]
    203                         [(< lht rht)
    204                                 (avltree::rotate-left! t)]
    205                         [else
    206                                 t]) ) )
    207 
    208 (define (avltree::add! t k less-than if-found if-not-found)
     200                (cond [(> lht rht)
     201            (avltree::rotate-right! t)]
     202          [(< lht rht)
     203            (avltree::rotate-left! t)]
     204          [else
     205            t]) ) )
     206
     207(define (avltree::add! t k less-than found not-found)
    209208        (let loop ([t t])
    210209                (if (%empty-node? t)
    211                         (if-not-found)
    212                         (let ([ck (%node-key t)])
    213                                 (cond
    214                                         [(less-than ck k)
    215                                                 (let ([n (loop (%node-right t))])
    216                                                         (%node-right-set! t n)
    217                                                         (avltree::rotate! t))]
    218                                         [(less-than k ck)
    219                                                 (let ([n (loop (%node-left t))])
    220                                                         (%node-left-set! t n)
    221                                                         (avltree::rotate! t))]
    222                                         [else
    223                                                 (if-found t)] ) ) ) ) )
    224 
    225 (define (avltree:merge-insert! t k less-than if-found if-not-found)
     210        (not-found)
     211        (let ([ck (%node-key t)])
     212          (cond [(less-than ck k)
     213                  (let ([n (loop (%node-right t))])
     214                    (%node-right-set! t n)
     215                    (avltree::rotate! t))]
     216                [(less-than k ck)
     217                  (let ([n (loop (%node-left t))])
     218                    (%node-left-set! t n)
     219                    (avltree::rotate! t))]
     220                [else
     221                  (found t)] ) ) ) ) )
     222
     223(define (avltree:merge-insert! t k less-than found not-found)
    226224        (let ([merge
    227225                                        (lambda (t)
    228226                                                (if (%node-deleted? t)
    229                                                         (begin
    230                                                                 (%node-value-set! t (if-not-found))
    231                                                                 (%node-deleted-set! t #f))
    232                                                         (%node-value-set! t (if-found (%node-value t))))
     227                (begin
     228                  (%node-value-set! t (not-found))
     229                  (%node-deleted-set! t #f))
     230                (%node-value-set! t (found (%node-value t))))
    233231                                                t)]
    234232                                [add
    235233                                        (lambda ()
    236                                                 (make-leaf k (if-not-found)))])
     234                                                (make-leaf k (not-found)))])
    237235                (avltree::add! t k less-than merge add) ) )
    238236
     
    243241;; Marks the node!
    244242
    245 (define (avltree:delete t k less-than if-found if-not-found)
     243(define (avltree:delete t k less-than found not-found)
    246244        (let loop ([t t])
    247245                (if (%empty-node? t)
    248                         (if-not-found)
    249                         (let ([ck (%node-key t)])
    250                                 (cond
    251                                         [(less-than k ck)
    252                                                 (loop (%node-left t))]
    253                                         [(less-than ck k)
    254                                                 (loop (%node-right t))]
    255                                         [(%node-deleted? t)
    256                                                 (if-not-found)]
    257                                         [else
    258                                                 (if-found (%node-value t))
    259                                                 (%node-deleted-set! t #t)]) ) ) ) )
     246        (not-found)
     247        (let ([ck (%node-key t)])
     248          (cond [(less-than k ck)
     249                  (loop (%node-left t))]
     250                [(less-than ck k)
     251                  (loop (%node-right t))]
     252                [(%node-deleted? t)
     253                  (not-found)]
     254                [else
     255                  (found (%node-value t))
     256                  (%node-deleted-set! t #t)]) ) ) ) )
    260257
    261258;; Look for an element with the given KEY in TREE.  If a matching
     
    263260;; matching element is found, IF-NOT-FOUND is called with no arguments.
    264261
    265 (define (avltree:find t k less-than if-found if-not-found)
     262(define (avltree:find t k less-than found not-found)
    266263        (let loop ([t t])
    267264                (if (%empty-node? t)
    268                         (if-not-found)
    269                         (let ([ck (%node-key t)])
    270                                 (cond
    271                                         [(less-than k ck)
    272                                                 (loop (%node-left t))]
    273                                         [(less-than ck k)
    274                                                 (loop (%node-right t))]
    275                                         [(%node-deleted? t)
    276                                                 (if-not-found)]
    277                                         [else
    278                                                 (if-found (%node-value t))]) ) ) ) )
     265        (not-found)
     266        (let ([ck (%node-key t)])
     267          (cond [(less-than k ck)
     268                  (loop (%node-left t)) ]
     269                [(less-than ck k)
     270                  (loop (%node-right t)) ]
     271                [(%node-deleted? t)
     272                  (not-found) ]
     273                [else
     274                  (found (%node-value t)) ] ) ) ) ) )
    279275
    280276;; Applies ACTION to each KEY DATA element in TREE in order, but requires
     
    283279(define (avltree:for-each-in-order t f s)
    284280        (let loop ([t t] [s s])
    285                 (cond
    286                         [(%empty-node? t)
    287                                 s]
    288                         [(%node-deleted? t)
    289                                 (loop (%node-right t) (loop (%node-left t) s))]
    290                         [else
    291                                 (f (%node-key t) (%node-value t) (loop (%node-left t) s)
    292                                         (lambda (s) (loop (%node-right t) s)))]) ) )
     281                (cond [(%empty-node? t)
     282            s ]
     283          [(%node-deleted? t)
     284            (loop (%node-right t) (loop (%node-left t) s)) ]
     285          [else
     286            (f (%node-key t) (%node-value t) (loop (%node-left t) s)
     287              (lambda (s) (loop (%node-right t) s))) ] ) ) )
    293288
    294289;; Applies BEFORE and AFTER to all KEY DATA elements in TREE in order.
     
    298293(define (avltree:for-all-in-order t b a s)
    299294        (let loop ([t t] [s s])
    300                 (cond
    301                         [(%empty-node? t)
    302                                 s]
    303                         [(%node-deleted? t)
    304                                 (loop (%node-right t) (loop (%node-left t) s))]
    305                         [else
    306                                 (let ([k (%node-key t)]
    307                                                         [v (%node-value t)])
    308                                         (loop (%node-right t) (a k v (loop (%node-left t) (b k v s)))))]) ) )
     295                (cond [(%empty-node? t)
     296            s ]
     297          [(%node-deleted? t)
     298            (loop (%node-right t) (loop (%node-left t) s)) ]
     299          [else
     300            (let ([k (%node-key t)]
     301                  [v (%node-value t)])
     302              (loop (%node-right t) (a k v (loop (%node-left t) (b k v s))))) ] ) ) )
    309303
    310304;;
     
    312306(define (avltree:fold t func init)
    313307        (let loop ([t t] [r init])
    314                 (cond
    315                         [(%empty-node? t)
    316                                 r]
    317                         [(%node-deleted? t)
    318                                 (loop (%node-right t)
    319                                         (loop (%node-left t) r))]
    320                         [else
    321                                 (loop (%node-right t)
    322                                         (func (%node-key t) (%node-value t)
    323                                                 (loop (%node-left t) r)))]) ) )
     308                (cond [(%empty-node? t)
     309            r ]
     310          [(%node-deleted? t)
     311            (loop (%node-right t)
     312              (loop (%node-left t) r)) ]
     313          [else
     314            (loop (%node-right t)
     315                  (func (%node-key t) (%node-value t) (loop (%node-left t) r))) ] ) ) )
    324316
    325317;;
     
    327319(define (avltree:copy t less-than)
    328320        (avltree:fold t
    329                 (lambda (key val nt)
    330                         (avltree:merge-insert nt key less-than (lambda (k v) v) (lambda () val)))
    331                 *empty-node*) )
     321                (lambda (key val nt)
     322                  (avltree:merge-insert nt key less-than
     323                                        (lambda (k v) v)
     324                                        (lambda () val)))
     325                *empty-node*) )
    332326
    333327;;
     
    353347;;
    354348
    355 (define (avltree:from-alist l less-than if-dup)
    356         (let loop ([t *empty-node*] [l l])
    357                 (cond
    358                         [(null? l)
    359                                 t]
    360                         [(pair? (car l))
    361                                 (let ([value (cdar l)])
    362                                         (loop
    363                                                 (avltree:merge-insert t (caar l) less-than
    364                                                         (lambda (o) (if-dup o value)) (lambda () value))
    365                                                 (cdr l)))]
    366                         [else
    367                                 (let ([value (car l)])
    368                                         (loop
    369                                                 (avltree:merge-insert t value less-than
    370                                                         (lambda (o) (if-dup o value)) (lambda () value))
    371                                                 (cdr l)))
    372                                 #;(error 'alist->avltree "invalid association list" l)]) ) )
     349(define (avltree:from-alist l less-than dup)
     350        (let loop ([t *empty-node*]
     351                   [l l])
     352                (cond [(null? l)
     353            t ]
     354          [(pair? (car l))
     355            (let ([value (cdar l)])
     356              (loop (avltree:merge-insert t (caar l) less-than
     357                                          (lambda (o) (dup o value))
     358                                          (lambda () value))
     359                    (cdr l))) ]
     360          [else
     361            (let ([value (car l)])
     362              (loop (avltree:merge-insert t value less-than
     363                                          (lambda (o) (dup o value))
     364                                          (lambda () value))
     365                    (cdr l)))
     366            #;(error 'alist->avltree "invalid association list" l) ] ) ) )
    373367
    374368;;
     
    383377(define (avltree:print out t indent)
    384378        (if (%empty-node? t)
    385                 (begin
    386                         (spaces out indent) (fprintf out "()~%"))
    387                 (begin
    388                         (spaces out indent) (fprintf out "~A~%" t)
    389                         (avltree:print out (%node-left t) (+ 2 indent))
    390                         (avltree:print out (%node-right t) (+ 2 indent)))) )
     379      (begin
     380        (spaces out indent) (fprintf out "()~%"))
     381      (begin
     382        (spaces out indent) (fprintf out "~A~%" t)
     383        (avltree:print out (%node-left t) (+ 2 indent))
     384        (avltree:print out (%node-right t) (+ 2 indent)))) )
    391385|#
    392386
    393387(define (avltree:print nod out)
    394388        (if (%empty-node? nod)
    395                 (write '() out)
    396                 (begin
    397                   (display #\( out)
    398       (write nod out)
    399                   (display #\space out)
    400       (avltree:print (%node-left nod) out)
    401                   (display #\space out)
    402       (avltree:print (%node-right nod) out)
    403       (display #\) out))) )
     389      (write '() out)
     390      (begin
     391        (display #\( out)
     392        (write nod out)
     393        (display #\space out)
     394        (avltree:print (%node-left nod) out)
     395        (display #\space out)
     396        (avltree:print (%node-right nod) out)
     397        (display #\) out))) )
    404398
    405399;;;
     
    435429        (%make-tree *empty-node* less-than) )
    436430
    437 (define (alist->avltree lst less-than #!optional (if-dup (lambda (o n) n)))
     431(define (alist->avltree lst less-than #!optional (dup (lambda (o n) n)))
    438432        (check-list lst 'alist->avltree)
    439433        (check-procedure less-than 'alist->avltree)
    440         (check-procedure if-dup 'alist->avltree)
    441         (%make-tree (avltree:from-alist lst less-than if-dup) less-than) )
     434        (check-procedure dup 'alist->avltree)
     435        (%make-tree (avltree:from-alist lst less-than dup) less-than) )
    442436
    443437(define (avltree? obj)
     
    468462        (avltree:to-alist (%tree-root tree)) )
    469463
    470 (define (avltree-ref tree key #!optional (if-not-found not-found-error))
     464(define (avltree-ref tree key #!optional (not-found not-found-error))
    471465        (check-tree tree 'avltree-find)
    472         (check-procedure if-not-found 'avltree-ref)
     466        (check-procedure not-found 'avltree-ref)
    473467        (avltree:find (%tree-root tree) key (%tree-less-than tree)
    474                 identity if-not-found) )
     468                identity not-found) )
    475469
    476470(define (avltree-ref/default tree key def)
     
    484478                true false) )
    485479
    486 (define (avltree-update! tree key if-found #!optional (if-not-found not-found-error))
     480(define (avltree-update! tree key found #!optional (not-found not-found-error))
    487481        (check-tree tree 'avltree-update!)
    488         (check-procedure if-found 'avltree-update!)
    489         (check-procedure if-not-found 'avltree-update!)
     482        (check-procedure found 'avltree-update!)
     483        (check-procedure not-found 'avltree-update!)
    490484        (%tree-root-set! tree
    491485                (avltree:merge-insert! (%tree-root tree) key (%tree-less-than tree)
    492                         if-found if-not-found)) )
    493 
    494 (define (avltree-update!/default tree key if-found def)
     486                        found not-found)) )
     487
     488(define (avltree-update!/default tree key found def)
    495489        (check-tree tree 'avltree-update!/default)
    496         (check-procedure if-found 'avltree-update!/default)
     490        (check-procedure found 'avltree-update!/default)
    497491        (%tree-root-set! tree
    498492                (avltree:merge-insert! (%tree-root tree) key (%tree-less-than tree)
    499                         if-found (lambda () def))) )
    500 
    501 (define (avltree-set! tree key value #!optional (if-found (lambda (v) value)))
     493                        found (lambda () def))) )
     494
     495(define (avltree-set! tree key value #!optional (found (lambda (v) value)))
    502496        (check-tree tree 'avltree-set!)
    503         (check-procedure if-found 'avltree-set!)
     497        (check-procedure found 'avltree-set!)
    504498        (%tree-root-set! tree
    505499                (avltree:merge-insert! (%tree-root tree) key (%tree-less-than tree)
    506                         if-found (lambda () value))) )
    507 
    508 (define (avltree-delete! tree key #!optional (if-found identity) (if-not-found false))
     500                        found (lambda () value))) )
     501
     502(define (avltree-delete! tree key #!optional (found identity) (not-found false))
    509503        (check-tree tree 'avltree-delete!)
    510         (check-procedure if-found 'avltree-delete!)
    511         (check-procedure if-not-found 'avltree-delete!)
     504        (check-procedure found 'avltree-delete!)
     505        (check-procedure not-found 'avltree-delete!)
    512506        (avltree:delete (%tree-root tree) key (%tree-less-than tree)
    513                 if-found if-not-found) )
     507                found not-found) )
    514508
    515509(define (avltree-vacuum! tree)
     
    527521                                (%tree-root tree1))) ) )
    528522
    529 (define (avltree-update tree key if-found #!optional (if-not-found not-found-error))
     523(define (avltree-update tree key found #!optional (not-found not-found-error))
    530524        (check-tree tree 'avltree-update)
    531         (check-procedure if-found 'avltree-update)
    532         (check-procedure if-not-found 'avltree-update)
     525        (check-procedure found 'avltree-update)
     526        (check-procedure not-found 'avltree-update)
    533527        (%make-tree
    534528                (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree)
    535                         if-found if-not-found)
     529                        found not-found)
    536530                (%tree-less-than tree)) )
    537531
    538 (define (avltree-update/default tree key if-found def)
     532(define (avltree-update/default tree key found def)
    539533        (check-tree tree 'avltree-update/default)
    540         (check-procedure if-found 'avltree-update/default)
     534        (check-procedure found 'avltree-update/default)
    541535        (%make-tree
    542536                (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree)
    543                         if-found (lambda () def))
     537                        found (lambda () def))
    544538                (%tree-less-than tree)) )
    545539
    546 (define (avltree-set tree key value #!optional (if-found (lambda (v) value)))
     540(define (avltree-set tree key value #!optional (found (lambda (v) value)))
    547541        (check-tree tree 'avltree-set)
    548         (check-procedure if-found 'avltree-set)
     542        (check-procedure found 'avltree-set)
    549543        (%make-tree
    550544                (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree)
    551                         if-found (lambda () value))
     545                        found (lambda () value))
    552546                (%tree-less-than tree)) )
    553547
    554 (define (avltree-delete tree key #!optional (if-found identity) (if-not-found false))
     548(define (avltree-delete tree key #!optional (found identity) (not-found false))
    555549        (check-tree tree 'avltree-delete)
    556         (check-procedure if-found 'avltree-delete)
    557         (check-procedure if-not-found 'avltree-delete)
     550        (check-procedure found 'avltree-delete)
     551        (check-procedure not-found 'avltree-delete)
    558552        (let* ([less-than (%tree-less-than tree)]
    559553                                 [ntree (%make-tree (avltree:copy (%tree-root tree) less-than) less-than)])
    560554                (avltree:delete (%tree-root ntree) key less-than
    561                         if-found if-not-found)
     555                        found not-found)
    562556                ntree ) )
    563557
  • release/3/binary-tree/binary-tree-eggdoc.scm

    r2104 r8915  
    33(use eggdoc)
    44
    5 (define license #<<EOF
     5(define license #<<EOS
    66Copyright (c) 2006, Kon Lovett.  All rights reserved.
    77
     
    2323ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
    2424OTHER DEALINGS IN THE SOFTWARE.
    25 EOF
     25EOS
    2626)
    2727
     
    3131                (description (p "Provides some binary tree objects"))
    3232                (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    33                 (history
    34                         (version "1.0" "Initial release"))
    3533                (requires
    3634                        (url "misc-extn.html" "misc-extn"))
     
    4543                                (p "The procedures without a trailing '!' are pure. Those with a '!' are impure.")
    4644
    47                                 (procedure "(make-avltree LESS-THAN-PROCEDURE)"
     45                                (procedure "(make-avltree LESS-THAN)"
    4846                                        (p "Returns a new avltree object.") )
    4947
    50                                 (procedure "(alist->avltree ALIST LESS-THAN-PROCEDURE [IF-DUPLICATE (-> ORIGINAL NEW OBJECT)])"
     48                                (procedure "(alist->avltree ALIST LESS-THAN [DUPLICATE (ORIGINAL NEW -> OBJECT)])"
    5149                                        (p "Returns a new avltree object built from the assocication list " (tt "ALIST") ". "
    52                                         "The " (tt "IF-DUPLICATE") " procedure is invoked to determine the value for "
     50                                        "The " (tt "DUPLICATE") " procedure is invoked to determine the value for "
    5351                                        "a duplicate item.") )
    5452
     
    7472                                        (p "Returns the keys & values for " (tt "AVL-TREE") " as an association list.") )
    7573
    76                                 (procedure "(avltree-ref AVL-TREE KEY [IF-NOT-FOUND (-> OBJECT)])"
     74                                (procedure "(avltree-ref AVL-TREE KEY [NOT-FOUND (-> OBJECT)])"
    7775                                        (p "Returns the value for " (tt "KEY") " in " (tt "AVL-TREE") ". "
    78                                         "When the key is not found the " (tt "IF-NOT-FOUND") " procedure is invoked. "
     76                                        "When the key is not found the " (tt "NOT-FOUND") " procedure is invoked. "
    7977                                        "The default will signal an error.") )
    8078
     
    8684                                        (p "Does the " (tt "KEY") " exist in " (tt "AVL-TREE") "?") )
    8785
    88                                 (procedure "(avltree-update! AVL-TREE KEY IF-FOUND [IF-NOT-FOUND (-> OBJECT)])"
     86                                (procedure "(avltree-update! AVL-TREE KEY FOUND [NOT-FOUND (-> OBJECT)])"
    8987                                        (p "Updates the entry for " (tt "KEY") " in " (tt "AVL-TREE") ". "
    90                                         "Invokes the " (tt "IF-FOUND") " procedure to determine "
    91                                         "the value to use for an existing entry, and the " (tt "IF-NOT-FOUND") " procedure for "
     88                                        "Invokes the " (tt "FOUND") " procedure to determine "
     89                                        "the value to use for an existing entry, and the " (tt "NOT-FOUND") " procedure for "
    9290                                        "a new entry. The default will signal an error.") )
    9391
    94                                 (procedure "(avltree-update!/default AVL-TREE KEY IF-FOUND DEFAULT)"
     92                                (procedure "(avltree-update!/default AVL-TREE KEY FOUND DEFAULT)"
    9593                                        (p "Updates the entry for " (tt "KEY") " in " (tt "AVL-TREE") ". "
    96                                         "Invokes the " (tt "IF-FOUND") " procedure to determine "
     94                                        "Invokes the " (tt "FOUND") " procedure to determine "
    9795                                        "the value to use for an existing entry, and uses the " (tt "DEFAULT") " value for "
    9896                                        "a new entry.") )
    9997
    100                                 (procedure "(avltree-set! AVL-TREE KEY VALUE [IF-FOUND (-> ORIGINAL OBJECT)])"
     98                                (procedure "(avltree-set! AVL-TREE KEY VALUE [FOUND (ORIGINAL -> OBJECT)])"
    10199                                        (p "Adds the entry for " (tt "KEY VALUE") " to " (tt "AVL-TREE") ". "
    102                                         "Invokes the " (tt "IF-FOUND") " procedure to determine "
     100                                        "Invokes the " (tt "FOUND") " procedure to determine "
    103101                                        "the value to use for an existing entry. The default uses the new value.") )
    104102
    105                                 (procedure "(avltree-delete! AVL-TREE KEY [IF-FOUND (-> ORIGINAL OBJECT)] [IF-NOT-FOUND (-> OBJECT)])"
     103                                (procedure "(avltree-delete! AVL-TREE KEY [FOUND (ORIGINAL -> OBJECT)] [NOT-FOUND (-> OBJECT)])"
    106104                                        (p "Deletes the entry for " (tt "KEY") " from " (tt "AVL-TREE") ".")
    107105                                        (p "Entries are flagged as deleted, not actually removed.") )
     
    114112                                        "using overwrite semantics.") )
    115113
    116                                 (procedure "(avltree-update AVL-TREE KEY IF-FOUND [IF-NOT-FOUND (-> OBJECT)])"
     114                                (procedure "(avltree-update AVL-TREE KEY FOUND [NOT-FOUND (-> OBJECT)])"
    117115                                        (p "Returns a new avltree object with the entry for " (tt "KEY") " updated "
    118                                         " in a copy of " (tt "AVL-TREE") ". Invokes the " (tt "IF-FOUND") " procedure to determine "
    119                                         "the value to use for an existing entry, and the " (tt "IF-NOT-FOUND") " procedure for "
     116                                        " in a copy of " (tt "AVL-TREE") ". Invokes the " (tt "FOUND") " procedure to determine "
     117                                        "the value to use for an existing entry, and the " (tt "NOT-FOUND") " procedure for "
    120118                                        "a new entry. The default will signal an error.") )
    121119
    122                                 (procedure "(avltree-update/default AVL-TREE KEY IF-FOUND DEFAULT)"
     120                                (procedure "(avltree-update/default AVL-TREE KEY FOUND DEFAULT)"
    123121                                        (p "Returns a new avltree object with the entry for " (tt "KEY") " updated "
    124                                         " in a copy of " (tt "AVL-TREE") ". Invokes the " (tt "IF-FOUND") " procedure to determine "
     122                                        " in a copy of " (tt "AVL-TREE") ". Invokes the " (tt "FOUND") " procedure to determine "
    125123                                        "the value to use for an existing entry, and uses the " (tt "DEFAULT") " value for "
    126124                                        "a new entry.") )
    127125
    128                                 (procedure "(avltree-set AVL-TREE KEY VALUE [IF-FOUND (-> ORIGINAL OBJECT)])"
     126                                (procedure "(avltree-set AVL-TREE KEY VALUE [FOUND (ORIGINAL -> OBJECT)])"
    129127                                        (p "Returns a new avltree object with the entry for " (tt "KEY VALUE") " added to "
    130                                         " a copy of " (tt "AVL-TREE") ". Invokes the " (tt "IF-FOUND") " procedure to determine "
     128                                        " a copy of " (tt "AVL-TREE") ". Invokes the " (tt "FOUND") " procedure to determine "
    131129                                        "the value to use for an existing entry. The default uses the new value.") )
    132130
    133                                 (procedure "(avltree-delete AVL-TREE KEY [IF-FOUND (-> ORIGINAL OBJECT)] [IF-NOT-FOUND (-> OBJECT)])"
     131                                (procedure "(avltree-delete AVL-TREE KEY [FOUND (ORIGINAL -> OBJECT)] [NOT-FOUND (-> OBJECT)])"
    134132                                        (p "Returns a new avltree object with the entry for " (tt "KEY") " deleted from "
    135133                                        " a copy of " (tt "AVL-TREE") ".")
     
    145143
    146144                                (procedure "(avltree-walk AVL-TREE PROC)"
    147                                         (p "Invoke the procedure " (tt "PROC") ", '(-> KEY VALUE UNDEFINED)', "
     145                                        (p "Invoke the procedure " (tt "PROC") ", '(KEY VALUE -> UNDEFINED)', "
    148146                                        "for every key & value in " (tt "AVL-TREE") ". Return value is undefined.") )
    149147
    150148                                (procedure "(avltree-fold AVL-TREE FUNC INITIAL-VALUE)"
    151                                         (p "Invoke the procedure " (tt "FUNC") ", '(-> KEY VALUE ACCUM OBJECT)', "
     149                                        (p "Invoke the procedure " (tt "FUNC") ", '(KEY VALUE ACCUM -> OBJECT)', "
    152150                                        "for every key & value in " (tt "AVL-TREE") ". Returns the last result of "
    153151                                        "the procedure.") )
     
    155153                                (procedure "(avltree-enfold AVL-TREE FUNC INITIAL-VALUE)"
    156154                                        (p "Invokes the procedure " (tt "FUNC") ", "
    157                                         "'(-> KEY VALUE ACCUM (-> OBJECT OBJECT) OBJECT)', for every key & value in "
     155                                        "'(KEY VALUE ACCUM (OBJECT -> OBJECT) -> OBJECT)', for every key & value in "
    158156                                        (tt "AVL-TREE") ". The fourth argument to " (tt "FUNC") ", termed " (tt "NEXT") ", "
    159157                                        "must be called to continue the fold operation. Usually the function will return "
     
    161159
    162160                                (procedure "(avltree-bifold AVL-TREE BEFORE AFTER INITIAL-VALUE)"
    163                                         (p "Invoke the procedure " (tt "BEFORE") ", '(-> KEY VALUE ACCUM OBJECT)', "
     161                                        (p "Invoke the procedure " (tt "BEFORE") ", '(KEY VALUE ACCUM -> OBJECT)', "
    164162                                        "for every key & value in " (tt "AVL-TREE") " on the way \"down\", "
    165                                         "and the procedure " (tt "AFTER") ", '(-> KEY VALUE ACCUM OBJECT)', on the way \"up\". "
     163                                        "and the procedure " (tt "AFTER") ", '(KEY VALUE ACCUM -> OBJECT)', on the way \"up\". "
    166164                                        "Returns the last result of the after procedure.") )
    167165                        )
    168166                )
     167
     168    (history
     169                        (version "1.0" "Initial release"))
    169170
    170171                (section "License" (pre ,license))
  • release/3/binary-tree/binary-tree.setup

    r5442 r8915  
    33(required-extension-version 'misc-extn "3.0")
    44
    5 (install-dynld avltree "1.0")
     5(install-dynld avltree *version*)
    66
    77(install-test "binary-tree-test.scm")
Note: See TracChangeset for help on using the changeset viewer.