Changeset 8915 in project
- Timestamp:
- 02/25/08 16:39:29 (13 years ago)
- Files:
-
- 4 edited
-
nondescript/binary-tree/tests/binary-tree-test.scm (modified) (2 diffs)
-
release/3/binary-tree/avltree.scm (modified) (19 diffs)
-
release/3/binary-tree/binary-tree-eggdoc.scm (modified) (10 diffs)
-
release/3/binary-tree/binary-tree.setup (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
nondescript/binary-tree/tests/binary-tree-test.scm
r5064 r8915 5 5 (use srfi-1 srfi-13) 6 6 7 ;; 7 ;;; 8 8 9 9 (define-inline (->boolean obj) 10 ( not (not obj)) )10 (and obj #t) ) 11 11 12 12 (define (random-alist n #!optional (lim (* n 10))) 13 13 (let loop ([n n] [al '()]) 14 14 (if (zero? n) 15 16 15 al 16 (loop (sub1 n) (alist-cons (random lim) (gensym) al)) ) ) ) 17 17 18 18 (define (alist-same? al1 al2) 19 19 (every 20 (lambda (pa ir)21 (and-let* ([v2 (alist-ref (car pa ir) al2 equal?)])22 (equal? v2 (cdr pa ir)) ) )20 (lambda (pare) 21 (and-let* ([v2 (alist-ref (car pare) al2 equal?)]) 22 (equal? v2 (cdr pare)) ) ) 23 23 al1) ) 24 25 (define-expect-binary alist-same? alist-same "alist same key-value pairs, w/o ordering")26 24 27 25 (define (list-same? l1 l2) 28 26 (every (lambda (x) (->boolean (member x l2))) l1) ) 29 27 30 (define-expect-binary list-same? list-same "list same values, w/o ordering")31 32 28 (define (random-tree n) 33 29 (alist->avltree (random-alist n) <) ) 34 30 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 ;;; 36 38 37 39 (define-test avltree-test "Avl-Tree" … … 130 132 (test::styler-set! avltree-test test::output-style-human) 131 133 (run-test "AVL Tree Tests") 134 135 (test::forget!) -
release/3/binary-tree/avltree.scm
r5442 r8915 1 ;;;; avltree.scm2 ;;;; Kon Lovett, Oct '063 ;;;; Stephen J. Bevan<bevan@cs.man.ac.uk> Oct 23 19931 ;;;;; avltree.scm 2 ;;;;; Kon Lovett, Oct '06 3 ;;;;; Stephen J. Bevan <bevan@cs.man.ac.uk> Oct 23 1993 4 4 5 5 ;; Issues 6 6 ;; 7 7 ;; - Only re-uses deleted nodes when keys match 8 9 (use srfi-1)10 (use misc-extn-record)11 8 12 9 (eval-when (compile) … … 47 44 avltree-bifold) ) ) 48 45 46 (use srfi-1) 47 (use misc-extn-record) 48 49 49 ;;; 50 50 … … 80 80 81 81 (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) ) ) 83 85 84 86 ;;; 85 87 86 88 (define-inline (avltree::max a b) 87 ( +1 (max a b)) )89 (add1 (max a b)) ) 88 90 89 91 ;; Insert an element with the given KEY into TREE. If an element with … … 99 101 [middle-tree-height (*node-height middle-tree)] 100 102 [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) 128 129 (let loop ([t t]) 129 130 (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) 153 153 (let ([merge 154 154 (lambda (t) … … 156 156 (%node-left t) 157 157 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))) 159 159 (%node-height t) 160 160 (%node-right t)))] 161 161 [add 162 162 (lambda () 163 (make-leaf k ( if-not-found)))])163 (make-leaf k (not-found)))]) 164 164 (avltree::add t k less-than merge add) ) ) 165 165 … … 175 175 (let ([r (%node-right t)]) 176 176 (if (%empty-node? r) 177 178 179 180 181 182 183 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 ) ) ) ) 184 184 185 185 (define-inline (avltree::rotate-right! t) 186 186 (let ([r (%node-left t)]) 187 187 (if (%empty-node? r) 188 189 190 191 192 193 194 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 ) ) ) ) 195 195 196 196 (define-inline (avltree::rotate! t) … … 198 198 [rht (*node-height (%node-right t))]) 199 199 (%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) 209 208 (let loop ([t t]) 210 209 (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) 226 224 (let ([merge 227 225 (lambda (t) 228 226 (if (%node-deleted? t) 229 230 (%node-value-set! t (if-not-found))231 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)))) 233 231 t)] 234 232 [add 235 233 (lambda () 236 (make-leaf k ( if-not-found)))])234 (make-leaf k (not-found)))]) 237 235 (avltree::add! t k less-than merge add) ) ) 238 236 … … 243 241 ;; Marks the node! 244 242 245 (define (avltree:delete t k less-than if-found if-not-found)243 (define (avltree:delete t k less-than found not-found) 246 244 (let loop ([t t]) 247 245 (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)]) ) ) ) ) 260 257 261 258 ;; Look for an element with the given KEY in TREE. If a matching … … 263 260 ;; matching element is found, IF-NOT-FOUND is called with no arguments. 264 261 265 (define (avltree:find t k less-than if-found if-not-found)262 (define (avltree:find t k less-than found not-found) 266 263 (let loop ([t t]) 267 264 (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)) ] ) ) ) ) ) 279 275 280 276 ;; Applies ACTION to each KEY DATA element in TREE in order, but requires … … 283 279 (define (avltree:for-each-in-order t f s) 284 280 (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))) ] ) ) ) 293 288 294 289 ;; Applies BEFORE and AFTER to all KEY DATA elements in TREE in order. … … 298 293 (define (avltree:for-all-in-order t b a s) 299 294 (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))))) ] ) ) ) 309 303 310 304 ;; … … 312 306 (define (avltree:fold t func init) 313 307 (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))) ] ) ) ) 324 316 325 317 ;; … … 327 319 (define (avltree:copy t less-than) 328 320 (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*) ) 332 326 333 327 ;; … … 353 347 ;; 354 348 355 (define (avltree:from-alist l less-than if-dup)356 (let loop ([t *empty-node*] [l l])357 (cond358 359 t]360 361 362 (loop 363 (avltree:merge-insert t (caar l) less-than 364 (lambda (o) (if-dup o value))(lambda () value))365 (cdr l)))]366 367 368 (loop 369 (avltree:merge-insert t value less-than 370 (lambda (o) (if-dup o value))(lambda () value))371 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) ] ) ) ) 373 367 374 368 ;; … … 383 377 (define (avltree:print out t indent) 384 378 (if (%empty-node? t) 385 386 387 388 389 390 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)))) ) 391 385 |# 392 386 393 387 (define (avltree:print nod out) 394 388 (if (%empty-node? nod) 395 396 397 398 (write nod out)399 400 (avltree:print (%node-left nod) out)401 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))) ) 404 398 405 399 ;;; … … 435 429 (%make-tree *empty-node* less-than) ) 436 430 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))) 438 432 (check-list lst 'alist->avltree) 439 433 (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) ) 442 436 443 437 (define (avltree? obj) … … 468 462 (avltree:to-alist (%tree-root tree)) ) 469 463 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)) 471 465 (check-tree tree 'avltree-find) 472 (check-procedure if-not-found 'avltree-ref)466 (check-procedure not-found 'avltree-ref) 473 467 (avltree:find (%tree-root tree) key (%tree-less-than tree) 474 identity if-not-found) )468 identity not-found) ) 475 469 476 470 (define (avltree-ref/default tree key def) … … 484 478 true false) ) 485 479 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)) 487 481 (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!) 490 484 (%tree-root-set! tree 491 485 (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) 495 489 (check-tree tree 'avltree-update!/default) 496 (check-procedure if-found 'avltree-update!/default)490 (check-procedure found 'avltree-update!/default) 497 491 (%tree-root-set! tree 498 492 (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))) 502 496 (check-tree tree 'avltree-set!) 503 (check-procedure if-found 'avltree-set!)497 (check-procedure found 'avltree-set!) 504 498 (%tree-root-set! tree 505 499 (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)) 509 503 (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!) 512 506 (avltree:delete (%tree-root tree) key (%tree-less-than tree) 513 if-found if-not-found) )507 found not-found) ) 514 508 515 509 (define (avltree-vacuum! tree) … … 527 521 (%tree-root tree1))) ) ) 528 522 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)) 530 524 (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) 533 527 (%make-tree 534 528 (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree) 535 if-found if-not-found)529 found not-found) 536 530 (%tree-less-than tree)) ) 537 531 538 (define (avltree-update/default tree key if-found def)532 (define (avltree-update/default tree key found def) 539 533 (check-tree tree 'avltree-update/default) 540 (check-procedure if-found 'avltree-update/default)534 (check-procedure found 'avltree-update/default) 541 535 (%make-tree 542 536 (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree) 543 if-found (lambda () def))537 found (lambda () def)) 544 538 (%tree-less-than tree)) ) 545 539 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))) 547 541 (check-tree tree 'avltree-set) 548 (check-procedure if-found 'avltree-set)542 (check-procedure found 'avltree-set) 549 543 (%make-tree 550 544 (avltree:merge-insert (%tree-root tree) key (%tree-less-than tree) 551 if-found (lambda () value))545 found (lambda () value)) 552 546 (%tree-less-than tree)) ) 553 547 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)) 555 549 (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) 558 552 (let* ([less-than (%tree-less-than tree)] 559 553 [ntree (%make-tree (avltree:copy (%tree-root tree) less-than) less-than)]) 560 554 (avltree:delete (%tree-root ntree) key less-than 561 if-found if-not-found)555 found not-found) 562 556 ntree ) ) 563 557 -
release/3/binary-tree/binary-tree-eggdoc.scm
r2104 r8915 3 3 (use eggdoc) 4 4 5 (define license #<<EO F5 (define license #<<EOS 6 6 Copyright (c) 2006, Kon Lovett. All rights reserved. 7 7 … … 23 23 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 24 OTHER DEALINGS IN THE SOFTWARE. 25 EO F25 EOS 26 26 ) 27 27 … … 31 31 (description (p "Provides some binary tree objects")) 32 32 (author (url "mailto:klovett@pacbell.net" "Kon Lovett")) 33 (history34 (version "1.0" "Initial release"))35 33 (requires 36 34 (url "misc-extn.html" "misc-extn")) … … 45 43 (p "The procedures without a trailing '!' are pure. Those with a '!' are impure.") 46 44 47 (procedure "(make-avltree LESS-THAN -PROCEDURE)"45 (procedure "(make-avltree LESS-THAN)" 48 46 (p "Returns a new avltree object.") ) 49 47 50 (procedure "(alist->avltree ALIST LESS-THAN -PROCEDURE [IF-DUPLICATE (-> ORIGINAL NEWOBJECT)])"48 (procedure "(alist->avltree ALIST LESS-THAN [DUPLICATE (ORIGINAL NEW -> OBJECT)])" 51 49 (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 " 53 51 "a duplicate item.") ) 54 52 … … 74 72 (p "Returns the keys & values for " (tt "AVL-TREE") " as an association list.") ) 75 73 76 (procedure "(avltree-ref AVL-TREE KEY [ IF-NOT-FOUND (-> OBJECT)])"74 (procedure "(avltree-ref AVL-TREE KEY [NOT-FOUND (-> OBJECT)])" 77 75 (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. " 79 77 "The default will signal an error.") ) 80 78 … … 86 84 (p "Does the " (tt "KEY") " exist in " (tt "AVL-TREE") "?") ) 87 85 88 (procedure "(avltree-update! AVL-TREE KEY IF-FOUND [IF-NOT-FOUND (-> OBJECT)])"86 (procedure "(avltree-update! AVL-TREE KEY FOUND [NOT-FOUND (-> OBJECT)])" 89 87 (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 " 92 90 "a new entry. The default will signal an error.") ) 93 91 94 (procedure "(avltree-update!/default AVL-TREE KEY IF-FOUND DEFAULT)"92 (procedure "(avltree-update!/default AVL-TREE KEY FOUND DEFAULT)" 95 93 (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 " 97 95 "the value to use for an existing entry, and uses the " (tt "DEFAULT") " value for " 98 96 "a new entry.") ) 99 97 100 (procedure "(avltree-set! AVL-TREE KEY VALUE [ IF-FOUND (-> ORIGINALOBJECT)])"98 (procedure "(avltree-set! AVL-TREE KEY VALUE [FOUND (ORIGINAL -> OBJECT)])" 101 99 (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 " 103 101 "the value to use for an existing entry. The default uses the new value.") ) 104 102 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)])" 106 104 (p "Deletes the entry for " (tt "KEY") " from " (tt "AVL-TREE") ".") 107 105 (p "Entries are flagged as deleted, not actually removed.") ) … … 114 112 "using overwrite semantics.") ) 115 113 116 (procedure "(avltree-update AVL-TREE KEY IF-FOUND [IF-NOT-FOUND (-> OBJECT)])"114 (procedure "(avltree-update AVL-TREE KEY FOUND [NOT-FOUND (-> OBJECT)])" 117 115 (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 " 120 118 "a new entry. The default will signal an error.") ) 121 119 122 (procedure "(avltree-update/default AVL-TREE KEY IF-FOUND DEFAULT)"120 (procedure "(avltree-update/default AVL-TREE KEY FOUND DEFAULT)" 123 121 (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 " 125 123 "the value to use for an existing entry, and uses the " (tt "DEFAULT") " value for " 126 124 "a new entry.") ) 127 125 128 (procedure "(avltree-set AVL-TREE KEY VALUE [ IF-FOUND (-> ORIGINALOBJECT)])"126 (procedure "(avltree-set AVL-TREE KEY VALUE [FOUND (ORIGINAL -> OBJECT)])" 129 127 (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 " 131 129 "the value to use for an existing entry. The default uses the new value.") ) 132 130 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)])" 134 132 (p "Returns a new avltree object with the entry for " (tt "KEY") " deleted from " 135 133 " a copy of " (tt "AVL-TREE") ".") … … 145 143 146 144 (procedure "(avltree-walk AVL-TREE PROC)" 147 (p "Invoke the procedure " (tt "PROC") ", '( -> KEY VALUEUNDEFINED)', "145 (p "Invoke the procedure " (tt "PROC") ", '(KEY VALUE -> UNDEFINED)', " 148 146 "for every key & value in " (tt "AVL-TREE") ". Return value is undefined.") ) 149 147 150 148 (procedure "(avltree-fold AVL-TREE FUNC INITIAL-VALUE)" 151 (p "Invoke the procedure " (tt "FUNC") ", '( -> KEY VALUE ACCUMOBJECT)', "149 (p "Invoke the procedure " (tt "FUNC") ", '(KEY VALUE ACCUM -> OBJECT)', " 152 150 "for every key & value in " (tt "AVL-TREE") ". Returns the last result of " 153 151 "the procedure.") ) … … 155 153 (procedure "(avltree-enfold AVL-TREE FUNC INITIAL-VALUE)" 156 154 (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 " 158 156 (tt "AVL-TREE") ". The fourth argument to " (tt "FUNC") ", termed " (tt "NEXT") ", " 159 157 "must be called to continue the fold operation. Usually the function will return " … … 161 159 162 160 (procedure "(avltree-bifold AVL-TREE BEFORE AFTER INITIAL-VALUE)" 163 (p "Invoke the procedure " (tt "BEFORE") ", '( -> KEY VALUE ACCUMOBJECT)', "161 (p "Invoke the procedure " (tt "BEFORE") ", '(KEY VALUE ACCUM -> OBJECT)', " 164 162 "for every key & value in " (tt "AVL-TREE") " on the way \"down\", " 165 "and the procedure " (tt "AFTER") ", '( -> KEY VALUE ACCUMOBJECT)', on the way \"up\". "163 "and the procedure " (tt "AFTER") ", '(KEY VALUE ACCUM -> OBJECT)', on the way \"up\". " 166 164 "Returns the last result of the after procedure.") ) 167 165 ) 168 166 ) 167 168 (history 169 (version "1.0" "Initial release")) 169 170 170 171 (section "License" (pre ,license)) -
release/3/binary-tree/binary-tree.setup
r5442 r8915 3 3 (required-extension-version 'misc-extn "3.0") 4 4 5 (install-dynld avltree "1.0")5 (install-dynld avltree *version*) 6 6 7 7 (install-test "binary-tree-test.scm")
Note: See TracChangeset
for help on using the changeset viewer.
