Add full contracts to red-black.rkt, with extensive documention in red-black.scrbl.
A submodule called "uncontracted" provides the contract-free bindings, as I suspect we'll need them for the token tree for maximum performance.OB
This commit is contained in:
Danny Yoo
parent
0936d8c20b
commit
e4c9ad484e
|
|
@ -1,3 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings '(("syntax-color.scrbl" () (gui-library))))
|
||||
(define scribblings '(("syntax-color.scrbl" () (gui-library))
|
||||
("red-black.scrbl")))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax racket/base)
|
||||
racket/contract)
|
||||
|
||||
;; Implementation of an augmented red-black tree, where extra
|
||||
;; information supports position-based queries.
|
||||
|
|
@ -47,46 +48,68 @@
|
|||
;;
|
||||
|
||||
|
||||
(provide tree?
|
||||
tree-root
|
||||
tree-first
|
||||
tree-last
|
||||
node?
|
||||
nil
|
||||
nil?
|
||||
node-data
|
||||
node-self-width
|
||||
node-subtree-width
|
||||
node-parent
|
||||
node-left
|
||||
node-right
|
||||
node-color
|
||||
red?
|
||||
black?
|
||||
|
||||
new-tree
|
||||
new-node
|
||||
insert-first!
|
||||
insert-before!
|
||||
insert-after!
|
||||
insert-first/data!
|
||||
insert-last/data!
|
||||
insert-before/data!
|
||||
insert-after/data!
|
||||
|
||||
delete!
|
||||
join!
|
||||
split!
|
||||
|
||||
search
|
||||
;; TODO: defensively check whether the node being deleted or split off
|
||||
;; actually exists in the tree.
|
||||
|
||||
minimum
|
||||
maximum
|
||||
successor
|
||||
predecessor
|
||||
position
|
||||
|
||||
(provide [contract-out
|
||||
[tree? (any/c . -> . boolean?)]
|
||||
[tree-root (tree? . -> . node?)]
|
||||
[tree-first (tree? . -> . node?)]
|
||||
[tree-last (tree? . -> . node?)]
|
||||
[node? (any/c . -> . boolean?)]
|
||||
[singleton-node? (any/c . -> . boolean?)]
|
||||
[non-nil-node? (any/c . -> . boolean?)]
|
||||
[nil node?]
|
||||
[rename public:nil? nil-node? (any/c . -> . boolean?)]
|
||||
[node-data (node? . -> . any)]
|
||||
[set-node-data! (node? any/c . -> . any)]
|
||||
[node-self-width (node? . -> . natural-number/c)]
|
||||
[update-node-self-width! (non-nil-node? natural-number/c . -> . any)]
|
||||
[node-subtree-width (node? . -> . natural-number/c)]
|
||||
|
||||
[node-parent (node? . -> . node?)]
|
||||
[node-left (node? . -> . node?)]
|
||||
[node-right (node? . -> . node?)]
|
||||
[node-color (node? . -> . (or/c 'red 'black))]
|
||||
[rename public:red? red? (node? . -> . boolean?)]
|
||||
[rename public:black? black? (node? . -> . boolean?)]
|
||||
|
||||
[new-tree (-> tree?)]
|
||||
[new-node (any/c natural-number/c . -> . node?)]
|
||||
[insert-first! (tree? singleton-node? . -> . any)]
|
||||
[insert-last! (tree? singleton-node? . -> . any)]
|
||||
[insert-before! (tree? non-nil-node? singleton-node? . -> . any)]
|
||||
[insert-after! (tree? non-nil-node? singleton-node? . -> . any)]
|
||||
[insert-first/data! (tree? any/c natural-number/c . -> . any)]
|
||||
[insert-last/data! (tree? any/c natural-number/c . -> . any)]
|
||||
[insert-before/data! (tree? non-nil-node? any/c natural-number/c . -> . any)]
|
||||
[insert-after/data! (tree? non-nil-node? any/c natural-number/c . -> . any)]
|
||||
|
||||
[delete! (->i ([t tree?]
|
||||
[n (t) (non-nil-node-in-tree? t)])
|
||||
[result any/c])]
|
||||
[join! (tree? tree? . -> . tree?)]
|
||||
[concat! (tree? singleton-node? tree? . -> . any)]
|
||||
[split! (->i ([t tree?]
|
||||
[n (t) (non-nil-node-in-tree? t)])
|
||||
(values [t1 tree?] [t2 tree?]))]
|
||||
|
||||
|
||||
[search (tree? natural-number/c . -> . node?)]
|
||||
[search/residual (tree? natural-number/c . -> . (values node? natural-number/c))]
|
||||
|
||||
[minimum (node? . -> . node?)]
|
||||
[maximum (node? . -> . node?)]
|
||||
[successor (node? . -> . node?)]
|
||||
[predecessor (node? . -> . node?)]
|
||||
[position (node? . -> . natural-number/c)]
|
||||
|
||||
tree-items)
|
||||
[tree-items (tree? . -> . list?)]
|
||||
[tree-fold-inorder (tree? (node? any/c . -> . any) any/c . -> . any)]
|
||||
[tree-fold-preorder (tree? (node? any/c . -> . any) any/c . -> . any)]
|
||||
[tree-fold-postorder (tree? (node? any/c . -> . any) any/c . -> . any)]])
|
||||
|
||||
|
||||
|
||||
;; First, our data structures:
|
||||
|
|
@ -119,21 +142,63 @@
|
|||
(set-node-right! v v)
|
||||
v))
|
||||
|
||||
;; singleton-node?: any -> boolean
|
||||
;; Returns true if n is a singleton node that is unattached to
|
||||
;; any other tree. We've carefully designed the operations
|
||||
;; so that the only way to get a singleton node is either through
|
||||
;; the new-node constructor, split!, or delete!. Similarly,
|
||||
;; the public-accessible tree-insertion functions will check that
|
||||
;; they receive singleton nodes. This way, we avoid the potential
|
||||
;; construction of cycles.
|
||||
(define (singleton-node? n)
|
||||
(and (node? n)
|
||||
(red? n)
|
||||
(nil? (node-parent n))))
|
||||
|
||||
|
||||
;; non-nil-node?: any -> boolean
|
||||
;; Returns true if n is a non-nil node.
|
||||
(define (non-nil-node? n)
|
||||
(and (node? n)
|
||||
(not (nil? n))))
|
||||
|
||||
|
||||
|
||||
;; We use this function for contract checking with delete! and split!,
|
||||
;; where the node being deleted must be in the tree in the first place.
|
||||
(define (non-nil-node-in-tree? t)
|
||||
(flat-named-contract 'node-in-tree
|
||||
(lambda (n)
|
||||
(and (node? n)
|
||||
(not (nil? n))
|
||||
(let loop ([n n])
|
||||
(define p (node-parent n))
|
||||
(cond [(nil? p)
|
||||
(eq? (tree-root t) n)]
|
||||
[else
|
||||
(loop p)]))))))
|
||||
|
||||
|
||||
|
||||
;; nil?: node -> boolean
|
||||
;; Tell us if we're at the distinguished nil node.
|
||||
(define-syntax-rule (nil? x) (eq? x nil))
|
||||
(define public:nil? (procedure-rename (lambda (x) (nil? x)) 'nil?))
|
||||
|
||||
;; red?: node -> boolean
|
||||
;; Is the node red?
|
||||
(define-syntax-rule (red? x)
|
||||
(let ([v x])
|
||||
(eq? (node-color v) red)))
|
||||
(define public:red? (procedure-rename (lambda (x) (red? x)) 'red?))
|
||||
|
||||
|
||||
;; black?: node -> boolean
|
||||
;; Is the node black?
|
||||
(define-syntax-rule (black? x)
|
||||
(let ([v x])
|
||||
(eq? (node-color v) black)))
|
||||
(define public:black? (procedure-rename (lambda (x) (black? x)) 'black?))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -243,6 +308,7 @@
|
|||
|
||||
|
||||
|
||||
|
||||
;; insert-first!: tree (and/c (not nil?) node?) -> void
|
||||
;; Insert node x as the first element in the tree.
|
||||
;; x is assumed to be a singleton element whose fields
|
||||
|
|
@ -505,6 +571,13 @@
|
|||
;; at z.p.
|
||||
(when (not (nil? z.p))
|
||||
(update-subtree-width-up-to-root! z.p))
|
||||
|
||||
; Turn z singleton:
|
||||
(set-node-parent! z nil)
|
||||
(set-node-left! z nil)
|
||||
(set-node-right! z nil)
|
||||
(set-node-color! z red)
|
||||
|
||||
(values x y-original-color nil-parent)]
|
||||
|
||||
;; This case is symmetric with the previous case.
|
||||
|
|
@ -514,6 +587,10 @@
|
|||
(define nil-parent (transplant-for-delete! a-tree z x))
|
||||
(when (not (nil? z.p))
|
||||
(update-subtree-width-up-to-root! z.p))
|
||||
(set-node-parent! z nil)
|
||||
(set-node-left! z nil)
|
||||
(set-node-right! z nil)
|
||||
(set-node-color! z red)
|
||||
(values x y-original-color nil-parent)]
|
||||
|
||||
;; The hardest case is when z has non-nil left and right.
|
||||
|
|
@ -556,6 +633,13 @@
|
|||
(set-node-color! y (node-color z))
|
||||
(update-subtree-width-up-to-root!
|
||||
(if (nil? x) nil-parent (node-parent x)))
|
||||
|
||||
;; Turn z singleton:
|
||||
(set-node-parent! z nil)
|
||||
(set-node-left! z nil)
|
||||
(set-node-right! z nil)
|
||||
(set-node-color! z red)
|
||||
|
||||
(values x y-original-color nil-parent))])])
|
||||
(cond [(eq? black y-original-color)
|
||||
(fix-after-delete! a-tree x nil-parent)]
|
||||
|
|
@ -690,10 +774,21 @@
|
|||
;; The total length of the left subtree will be at least offset, if possible.
|
||||
;; Returns nil if the offset is not within the tree.
|
||||
(define (search a-tree offset)
|
||||
(define-values (result residual) (search/residual a-tree offset))
|
||||
result)
|
||||
|
||||
|
||||
;; search/residual: tree natural -> (values (U node nil) natural)
|
||||
;; Search for the node closest to offset. Also returns the residual left
|
||||
;; after searching.
|
||||
;; The total length of the left subtree will be at least offset, if possible.
|
||||
;; Returns nil if the offset is not within the tree.
|
||||
(define (search/residual a-tree offset)
|
||||
(let loop ([offset offset]
|
||||
[a-node (tree-root a-tree)])
|
||||
(cond
|
||||
[(nil? a-node) nil]
|
||||
[(nil? a-node)
|
||||
(values nil offset)]
|
||||
[else
|
||||
(define left (node-left a-node))
|
||||
(define left-subtree-width (node-subtree-width left))
|
||||
|
|
@ -704,12 +799,13 @@
|
|||
(define self-width (node-self-width a-node))
|
||||
(cond
|
||||
[(< residual-offset self-width)
|
||||
a-node]
|
||||
(values a-node residual-offset)]
|
||||
[else
|
||||
(loop (- residual-offset self-width)
|
||||
(node-right a-node))])])])))
|
||||
|
||||
|
||||
|
||||
;; position: node -> (or natural -1)
|
||||
;; Given a node in the tree, returns its position such that
|
||||
;; a search in the tree with that position will return the node.
|
||||
|
|
@ -886,20 +982,32 @@
|
|||
|
||||
;; split!: tree node -> (values tree tree)
|
||||
;; Partitions the tree into two trees: the predecessors of x, and the
|
||||
;; successors of x.
|
||||
;; successors of x. Also mutates x into a singleton node.
|
||||
;;
|
||||
;; Note: during the loop, the L and R trees do not necessarily have
|
||||
;; a valid tree-first or tree-last. I want to avoid recomputing
|
||||
;; it for each fresh subtree I construct.
|
||||
(define (split! a-tree x)
|
||||
(define x-child-bh (computed-black-height (node-left x)))
|
||||
(define ancestor (node-parent x))
|
||||
(define ancestor-child-bh (if (black? x) (add1 x-child-bh) x-child-bh))
|
||||
(define coming-from-the-right? (eq? (node-right (node-parent x)) x))
|
||||
(define L (node->tree/bh (node-left x) x-child-bh))
|
||||
(define R (node->tree/bh (node-right x) x-child-bh))
|
||||
|
||||
;; Turn x into a singleton node:
|
||||
(detach! x)
|
||||
(set-node-right! x nil)
|
||||
(set-node-left! x nil)
|
||||
(set-node-color! x red)
|
||||
|
||||
;; The loop walks the ancestors of x, adding the left and right
|
||||
;; elements appropriately.
|
||||
(let loop ([ancestor (node-parent x)]
|
||||
[ancestor-child-bh (if (black? x) (add1 x-child-bh) x-child-bh)]
|
||||
[coming-from-the-right? (eq? (node-right (node-parent x)) x)]
|
||||
[L (node->tree/bh (node-left x) x-child-bh)]
|
||||
[R (node->tree/bh (node-right x) x-child-bh)])
|
||||
(let loop ([ancestor ancestor]
|
||||
[ancestor-child-bh ancestor-child-bh]
|
||||
[coming-from-the-right? coming-from-the-right?]
|
||||
[L L]
|
||||
[R R])
|
||||
(cond
|
||||
[(nil? ancestor)
|
||||
;; Now that we have our L and R, fix up their last and first
|
||||
|
|
@ -939,6 +1047,15 @@
|
|||
(concat! R ancestor subtree))])])))
|
||||
|
||||
|
||||
;; update-node-self-width!: node exact-nonnegative-integer -> void Updates
|
||||
;; the node's self width, and propagates that change up the tree.
|
||||
;; Internal note: do not confuse this with the similarly-named
|
||||
;; update-node-subtree-width, which does something different.
|
||||
(define (update-node-self-width! n w)
|
||||
(set-node-self-width! n w)
|
||||
(update-subtree-width-up-to-root! n))
|
||||
|
||||
|
||||
;; force-tree-first!: tree -> void
|
||||
;; INTERNAL
|
||||
;; Force tree-first's value.
|
||||
|
|
@ -1012,6 +1129,7 @@
|
|||
|
||||
|
||||
;; tree-items: tree -> (listof (list X natural))
|
||||
;; PUBLIC
|
||||
;; Returns the list of items in the tree.
|
||||
(define (tree-items t)
|
||||
(let loop ([n (tree-root t)]
|
||||
|
|
@ -1026,6 +1144,107 @@
|
|||
(loop (node-right n) acc)))])))
|
||||
|
||||
|
||||
;; tree-fold-inorder: tree (node X) X -> X
|
||||
;; Folds an accumulating function across the tree.
|
||||
(define (tree-fold-inorder t f acc)
|
||||
(let loop ([n (tree-root t)]
|
||||
[acc acc])
|
||||
(cond
|
||||
[(nil? n)
|
||||
acc]
|
||||
[else
|
||||
(define acc-1 (loop (node-left n) acc))
|
||||
(define acc-2 (f n acc-1))
|
||||
(loop (node-right n) acc-2)])))
|
||||
|
||||
|
||||
;; tree-fold-postorder: tree (node X) X -> X
|
||||
;; Folds an accumulating function across the tree.
|
||||
(define (tree-fold-postorder t f acc)
|
||||
(let loop ([n (tree-root t)]
|
||||
[acc acc])
|
||||
(cond
|
||||
[(nil? n)
|
||||
acc]
|
||||
[else
|
||||
(define acc-1 (loop (node-left n) acc))
|
||||
(define acc-2 (loop (node-right n) acc-1))
|
||||
(f n acc-2)])))
|
||||
|
||||
;; tree-fold-preorder: tree (node X) X -> X
|
||||
;; Folds an accumulating function across the tree.
|
||||
(define (tree-fold-preorder t f acc)
|
||||
(let loop ([n (tree-root t)]
|
||||
[acc acc])
|
||||
(cond
|
||||
[(nil? n)
|
||||
acc]
|
||||
[else
|
||||
(define acc-1 (f n acc))
|
||||
(define acc-2 (loop (node-left n) acc-1))
|
||||
(loop (node-right n) acc-2)])))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; The following are re-exports of the internals. The only difference
|
||||
;; is that they are the uncontracted forms.
|
||||
(module+ uncontracted
|
||||
(provide tree?
|
||||
tree-root
|
||||
tree-first
|
||||
tree-last
|
||||
node?
|
||||
singleton-node?
|
||||
non-nil-node?
|
||||
nil
|
||||
[rename-out [public:nil? nil-node?]]
|
||||
node-data
|
||||
set-node-data!
|
||||
node-self-width
|
||||
node-subtree-width
|
||||
node-parent
|
||||
node-left
|
||||
node-right
|
||||
node-color
|
||||
[rename-out [public:red? red?]
|
||||
[public:black? black?]]
|
||||
new-tree
|
||||
new-node
|
||||
insert-first!
|
||||
insert-last!
|
||||
insert-before!
|
||||
insert-after!
|
||||
insert-first/data!
|
||||
insert-last/data!
|
||||
insert-before/data!
|
||||
insert-after/data!
|
||||
|
||||
delete!
|
||||
join!
|
||||
concat!
|
||||
split!
|
||||
|
||||
update-node-self-width!
|
||||
|
||||
search
|
||||
search/residual
|
||||
|
||||
minimum
|
||||
maximum
|
||||
successor
|
||||
predecessor
|
||||
position
|
||||
|
||||
tree-items
|
||||
tree-fold-inorder
|
||||
tree-fold-preorder
|
||||
tree-fold-postorder))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -1034,6 +1253,9 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
rackunit/text-ui
|
||||
|
|
@ -1573,7 +1795,39 @@
|
|||
(check-equal? (node-data (search t 15)) "the")
|
||||
(check-equal? (node-data (search t 16)) "emergency")
|
||||
(check-equal? (node-data (search t 25)) "broadcast")
|
||||
(check-equal? (node-data (search t 34)) "system"))))
|
||||
(check-equal? (node-data (search t 34)) "system"))
|
||||
|
||||
(test-case
|
||||
"searching with residuals"
|
||||
(define t (new-tree))
|
||||
(define words (string-split "This is a test of the emergency broadcast system"))
|
||||
(for ([word (in-list words)])
|
||||
(insert-last/data! t word (string-length word)))
|
||||
(define (s t p)
|
||||
(define-values (n r) (search/residual t p))
|
||||
(list (node-data n) r))
|
||||
(check-equal? (s t 0) '("This" 0))
|
||||
(check-equal? (s t 1) '("This" 1))
|
||||
(check-equal? (s t 2) '("This" 2))
|
||||
(check-equal? (s t 3) '("This" 3))
|
||||
(check-equal? (s t 4) '("is" 0))
|
||||
(check-equal? (s t 5) '("is" 1))
|
||||
(check-equal? (s t 6) '("a" 0))
|
||||
(check-equal? (s t 7) '("test" 0))
|
||||
(check-equal? (s t 8) '("test" 1))
|
||||
(check-equal? (s t 9) '("test" 2))
|
||||
(check-equal? (s t 10) '("test" 3))
|
||||
(check-equal? (s t 11) '("of" 0))
|
||||
(check-equal? (s t 12) '("of" 1))
|
||||
(check-equal? (s t 13) '("the" 0))
|
||||
(check-equal? (s t 14) '("the" 1))
|
||||
(check-equal? (s t 15) '("the" 2))
|
||||
(check-equal? (s t 16) '("emergency" 0))
|
||||
(check-equal? (s t 17) '("emergency" 1))
|
||||
(check-equal? (s t 24) '("emergency" 8))
|
||||
(check-equal? (s t 25) '("broadcast" 0))
|
||||
(check-equal? (s t 33) '("broadcast" 8))
|
||||
(check-equal? (s t 34) '("system" 0)))))
|
||||
|
||||
|
||||
(define position-tests
|
||||
|
|
@ -1748,7 +2002,9 @@
|
|||
"(a) ---split-a--> () ()"
|
||||
(define t (new-tree))
|
||||
(insert-last/data! t "a" 1)
|
||||
(define-values (l r) (split! t (search t 0)))
|
||||
(define n (search t 0))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '())
|
||||
(check-equal? (map first (tree-items r)) '())
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1759,7 +2015,9 @@
|
|||
(define t (new-tree))
|
||||
(insert-last/data! t "a" 1)
|
||||
(insert-last/data! t "b" 1)
|
||||
(define-values (l r) (split! t (search t 0)))
|
||||
(define n (search t 0))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '())
|
||||
(check-equal? (map first (tree-items r)) '("b"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1770,7 +2028,9 @@
|
|||
(define t (new-tree))
|
||||
(insert-last/data! t "a" 1)
|
||||
(insert-last/data! t "b" 1)
|
||||
(define-values (l r) (split! t (search t 1)))
|
||||
(define n (search t 1))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '("a"))
|
||||
(check-equal? (map first (tree-items r)) '())
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1782,7 +2042,9 @@
|
|||
(insert-last/data! t "a" 1)
|
||||
(insert-last/data! t "b" 1)
|
||||
(insert-last/data! t "c" 1)
|
||||
(define-values (l r) (split! t (search t 1)))
|
||||
(define n (search t 1))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '("a"))
|
||||
(check-equal? (map first (tree-items r)) '("c"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1795,7 +2057,9 @@
|
|||
(insert-last/data! t "b" 1)
|
||||
(insert-last/data! t "c" 1)
|
||||
(insert-last/data! t "d" 1)
|
||||
(define-values (l r) (split! t (search t 0)))
|
||||
(define n (search t 0))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '())
|
||||
(check-equal? (map first (tree-items r)) '("b" "c" "d"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1809,7 +2073,9 @@
|
|||
(insert-last/data! t "b" 1)
|
||||
(insert-last/data! t "c" 1)
|
||||
(insert-last/data! t "d" 1)
|
||||
(define-values (l r) (split! t (search t 1)))
|
||||
(define n (search t 1))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '("a"))
|
||||
(check-equal? (map first (tree-items r)) '("c" "d"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1823,7 +2089,9 @@
|
|||
(insert-last/data! t "b" 1)
|
||||
(insert-last/data! t "c" 1)
|
||||
(insert-last/data! t "d" 1)
|
||||
(define-values (l r) (split! t (search t 2)))
|
||||
(define n (search t 2))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '("a" "b"))
|
||||
(check-equal? (map first (tree-items r)) '("d"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1836,7 +2104,9 @@
|
|||
(insert-last/data! t "b" 1)
|
||||
(insert-last/data! t "c" 1)
|
||||
(insert-last/data! t "d" 1)
|
||||
(define-values (l r) (split! t (search t 3)))
|
||||
(define n (search t 3))
|
||||
(define-values (l r) (split! t n))
|
||||
(check-true (singleton-node? n))
|
||||
(check-equal? (map first (tree-items l)) '("a" "b" "c"))
|
||||
(check-equal? (map first (tree-items r)) '())
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1850,6 +2120,7 @@
|
|||
1))
|
||||
(define letter-m (search t 12))
|
||||
(define-values (l r) (split! t letter-m))
|
||||
(check-true (singleton-node? letter-m))
|
||||
(check-equal? (map first (tree-items l)) '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l"))
|
||||
(check-equal? (map first (tree-items r)) '("n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"))
|
||||
(check-rb-structure! l)
|
||||
|
|
@ -1863,7 +2134,9 @@
|
|||
(define t (new-tree))
|
||||
(for ([w (in-list letters)])
|
||||
(insert-last/data! t w 1))
|
||||
(define-values (l r) (split! t (search t n)))
|
||||
(define a-letter (search t n))
|
||||
(define-values (l r) (split! t a-letter))
|
||||
(check-true (singleton-node? a-letter))
|
||||
(define-values (expected-l 1+expected-r) (split-at letters n))
|
||||
(check-equal? (map first (tree-items l)) expected-l)
|
||||
(check-equal? (map first (tree-items r)) (rest 1+expected-r))
|
||||
|
|
@ -1908,7 +2181,85 @@
|
|||
(check-eq? (successor nil) nil)
|
||||
(check-eq? (maximum nil) nil)
|
||||
(check-eq? (minimum nil) nil))))
|
||||
|
||||
|
||||
(define fold-tests
|
||||
(test-suite
|
||||
"fold-inorder, fold-preorder, fold-postorder tests"
|
||||
(printf "fold tests...\n")
|
||||
(test-case
|
||||
"nil case"
|
||||
(define t (new-tree))
|
||||
(check-eq? (tree-fold-inorder t values 'foo) 'foo)
|
||||
(check-eq? (tree-fold-preorder t values 'bar) 'bar)
|
||||
(check-eq? (tree-fold-postorder t values 'baz) 'baz))
|
||||
|
||||
(test-case
|
||||
"simple case"
|
||||
(define one (new-node 1 1))
|
||||
(define two (new-node 2 1))
|
||||
(define seven (new-node 7 1))
|
||||
(define five (new-node 5 1))
|
||||
(define eight (new-node 8 1))
|
||||
(define eleven (new-node 11 1))
|
||||
(define fourteen (new-node 14 1))
|
||||
(define fifteen (new-node 15 1))
|
||||
(define t (new-tree))
|
||||
(insert-first! t one)
|
||||
(insert-after! t one two)
|
||||
(insert-after! t two seven)
|
||||
(insert-before! t seven five)
|
||||
(insert-after! t seven eight)
|
||||
(insert-last! t eleven)
|
||||
(insert-after! t eleven fourteen)
|
||||
(insert-after! t fourteen fifteen)
|
||||
;; After this sequence, the constructed tree has the following shape:
|
||||
;;
|
||||
;; (7 (2 (1 () ())
|
||||
;; (5 () ()))
|
||||
;; (11 (8 () ())
|
||||
;; (14 ()
|
||||
;; (15 () ()))))
|
||||
(define (f n acc)
|
||||
(cons (node-data n) acc))
|
||||
(check-equal? (reverse (tree-fold-inorder t f '()))
|
||||
'(1 2 5 7 8 11 14 15))
|
||||
(check-equal? (reverse (tree-fold-preorder t f '()))
|
||||
'(7 2 1 5 11 8 14 15))
|
||||
(check-equal? (reverse (tree-fold-postorder t f '()))
|
||||
'(1 5 2 8 15 14 11 7)))))
|
||||
|
||||
|
||||
(define update-width-tests
|
||||
(test-suite
|
||||
"update-node-self-width! tests"
|
||||
(test-case
|
||||
"one node"
|
||||
(define t (new-tree))
|
||||
(insert-last/data! t "foo" 3)
|
||||
(update-node-self-width! (tree-first t) 17)
|
||||
(check-equal? (node-self-width (tree-root t)) 17)
|
||||
(check-equal? (node-subtree-width (tree-root t)) 17))
|
||||
|
||||
(test-case
|
||||
"two nodes"
|
||||
(define t (new-tree))
|
||||
(insert-last/data! t "foo" 3)
|
||||
(insert-last/data! t "bar" 3)
|
||||
(set-node-data! (tree-first t)
|
||||
"generally, foo and bar are terrible names")
|
||||
(update-node-self-width! (tree-first t) 41)
|
||||
(check-equal? (node-subtree-width (tree-root t)) 44)
|
||||
(check-equal? (node-self-width (tree-root t)) 41)
|
||||
(check-equal? (node-subtree-width (tree-last t)) 3)
|
||||
(check-equal? (node-self-width (tree-last t)) 3))
|
||||
|
||||
(test-case
|
||||
"on a singleton node" ;; being single is hard.
|
||||
(define n (new-node "so lonely" 9))
|
||||
(set-node-data! n "soooo lovely")
|
||||
(update-node-self-width! n 12)
|
||||
(check-equal? (node-self-width n) 12)
|
||||
(check-equal? (node-subtree-width n) 12))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1945,6 +2296,7 @@
|
|||
(define offset (kth-offset k))
|
||||
(define node (search t offset))
|
||||
(delete! t node)
|
||||
(check-true (singleton-node? node))
|
||||
(set! known-model (let-values ([(a b) (split-at known-model k)])
|
||||
(append a (rest b)))))
|
||||
|
||||
|
|
@ -1985,6 +2337,20 @@
|
|||
(set! known-model (append (take known-model (add1 k))
|
||||
(list new-word)
|
||||
(drop known-model (add1 k))))))
|
||||
|
||||
;; replace an old word with a new one.
|
||||
(define/public (replace-at-random!)
|
||||
(when (not (empty? known-model))
|
||||
(define k (random (length known-model)))
|
||||
(define offset (kth-offset k))
|
||||
(define node (search t offset))
|
||||
(define new-word (random-word))
|
||||
(set-node-data! node new-word)
|
||||
(update-node-self-width! node (string-length new-word))
|
||||
(set! known-model (append (take known-model k)
|
||||
(list new-word)
|
||||
(drop known-model (add1 k))))))
|
||||
|
||||
|
||||
|
||||
;; Concatenation. Drop our existing tree and throw it at the
|
||||
|
|
@ -2003,6 +2369,7 @@
|
|||
(define offset (kth-offset k))
|
||||
(define node (search t offset))
|
||||
(define-values (l r) (split! t node))
|
||||
(check-true (singleton-node? node))
|
||||
(set! t l)
|
||||
(send m2 catch-and-concat-at-front r (drop known-model (add1 k)))
|
||||
(set! known-model (take known-model k))))
|
||||
|
|
@ -2032,7 +2399,7 @@
|
|||
(for ([i (in-range number-of-iterations)])
|
||||
(define m (new angry-monkey%))
|
||||
(for ([i (in-range number-of-operations)])
|
||||
(case (random 12)
|
||||
(case (random 13)
|
||||
[(0 1 2)
|
||||
(send m insert-front!)]
|
||||
[(3 4 5)
|
||||
|
|
@ -2041,7 +2408,9 @@
|
|||
(send m insert-after/random!)]
|
||||
[(8 9)
|
||||
(send m insert-before/random!)]
|
||||
[(10 11)
|
||||
[(10)
|
||||
(send m replace-at-random!)]
|
||||
[(11 12)
|
||||
(send m delete-random!)]))
|
||||
(send m check-consistency!)))))
|
||||
|
||||
|
|
@ -2057,7 +2426,7 @@
|
|||
(for ([i (in-range number-of-iterations)])
|
||||
(define m (new angry-monkey%))
|
||||
(for ([i (in-range number-of-operations)])
|
||||
(case (random 12)
|
||||
(case (random 13)
|
||||
[(0 1)
|
||||
(send m insert-front!)]
|
||||
[(2 3)
|
||||
|
|
@ -2066,7 +2435,9 @@
|
|||
(send m insert-after/random!)]
|
||||
[(6 7)
|
||||
(send m insert-before/random!)]
|
||||
[(8 9 10 11)
|
||||
[(8)
|
||||
(send m replace-at-random!)]
|
||||
[(9 10 11 12)
|
||||
(send m delete-random!)]))
|
||||
(send m check-consistency!)))))
|
||||
|
||||
|
|
@ -2083,7 +2454,7 @@
|
|||
(define m2 (new angry-monkey%))
|
||||
(for ([i (in-range number-of-operations)])
|
||||
(define random-monkey (if (= 0 (random 2)) m1 m2))
|
||||
(case (random 11)
|
||||
(case (random 12)
|
||||
[(0 1 2)
|
||||
(send random-monkey insert-front!)]
|
||||
[(3 4 5)
|
||||
|
|
@ -2091,12 +2462,14 @@
|
|||
[(6)
|
||||
(send random-monkey delete-random!)]
|
||||
[(7)
|
||||
(send m1 throw-all-at-monkey m2)]
|
||||
(send random-monkey replace-at-random!)]
|
||||
[(8)
|
||||
(send m2 throw-all-at-monkey m1)]
|
||||
(send m1 throw-all-at-monkey m2)]
|
||||
[(9)
|
||||
(send m1 throw-some-at-monkey m2)]
|
||||
(send m2 throw-all-at-monkey m1)]
|
||||
[(10)
|
||||
(send m1 throw-some-at-monkey m2)]
|
||||
[(11)
|
||||
(send m2 throw-some-at-monkey m1)]))
|
||||
(send m1 check-consistency!)
|
||||
(send m2 check-consistency!)))))
|
||||
|
|
@ -2118,7 +2491,7 @@
|
|||
(for ([i (in-range number-of-iterations)])
|
||||
(define m (new angry-monkey%))
|
||||
(for ([i (in-range number-of-operations)])
|
||||
(case (random 11)
|
||||
(case (random 6)
|
||||
[(0)
|
||||
(send m insert-front!)]
|
||||
[(1)
|
||||
|
|
@ -2126,8 +2499,10 @@
|
|||
[(2)
|
||||
(send m delete-random!)]
|
||||
[(3)
|
||||
(send m insert-after/random!)]
|
||||
(send m replace-at-random!)]
|
||||
[(4)
|
||||
(send m insert-after/random!)]
|
||||
[(5)
|
||||
(send m insert-before/random!)]))
|
||||
(send m check-consistency!))))))
|
||||
(for ([t (in-list threads)])
|
||||
|
|
@ -2150,11 +2525,12 @@
|
|||
(define t (new-tree))
|
||||
(for ([w (in-list elts)])
|
||||
(insert-last/data! t w 1))
|
||||
(define pivot (search t n))
|
||||
(define-values (l r)
|
||||
(let ([pivot (search t n)])
|
||||
(time-acc
|
||||
total-splitting-time
|
||||
(split! t pivot))))
|
||||
(time-acc
|
||||
total-splitting-time
|
||||
(split! t pivot)))
|
||||
(check-true (singleton-node? pivot))
|
||||
(define-values (expected-l 1+expected-r) (split-at elts n))
|
||||
(check-equal? (map first (tree-items l)) expected-l)
|
||||
(check-equal? (map first (tree-items r)) (rest 1+expected-r)))
|
||||
|
|
@ -2172,6 +2548,8 @@
|
|||
position-tests
|
||||
concat-tests
|
||||
predecessor-successor-min-max-tests
|
||||
fold-tests
|
||||
update-width-tests
|
||||
split-tests
|
||||
mixed-tests
|
||||
|
||||
|
|
|
|||
778
collects/syntax-color/red-black.scrbl
Normal file
778
collects/syntax-color/red-black.scrbl
Normal file
|
|
@ -0,0 +1,778 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/eval
|
||||
(for-label syntax-color/private/red-black
|
||||
racket/base
|
||||
racket/string))
|
||||
|
||||
@(define my-eval (make-base-eval))
|
||||
@(my-eval '(require syntax-color/private/red-black racket/string))
|
||||
|
||||
@title{Ordered Red-Black Trees}
|
||||
@author+email["Danny Yoo" "dyoo@hashcollision.org"]
|
||||
|
||||
|
||||
@defmodule[syntax-color/private/red-black]
|
||||
|
||||
This is an implementation of an augmented red-black tree with extra information
|
||||
to support position-based queries.
|
||||
|
||||
The intended usage case of this structure is to maintain an ordered sequence of
|
||||
items, where each item has an internal length. Given such a sequence, we want
|
||||
to support quick lookup by position and in-place insertions and deletions.
|
||||
We also want to support the catenation and splitting of sequences.
|
||||
|
||||
For example:
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(for ([w (in-list '("This" " " "is" " " "a" " " "test"))])
|
||||
(insert-last/data! a-tree w (string-length w)))
|
||||
(node-data (search a-tree 0))
|
||||
(node-data (search a-tree 10))
|
||||
(define at-test-node (search a-tree 10))
|
||||
(insert-before/data! a-tree at-test-node "small" 5)
|
||||
(tree-items a-tree)
|
||||
@code:comment{Split at the node holding "small":}
|
||||
(define at-small-node (search a-tree 10))
|
||||
(define-values (left-side right-side) (split! a-tree at-small-node))
|
||||
(tree-items left-side)
|
||||
(tree-items right-side)
|
||||
(define joined-tree (join! left-side right-side))
|
||||
(tree-items joined-tree)
|
||||
]
|
||||
|
||||
|
||||
This implementation follows the basic outline for order-statistic red-black
|
||||
trees described in @cite{clrs2009} and incorporates a few extensions suggsted
|
||||
in @cite{wein2005}. As a red-black tree, the structure ensures that the tree's
|
||||
height is never greater than @math{2*lg(#-of-nodes + 1)}, guaranteeing good
|
||||
worst-case behavior for its operations.
|
||||
|
||||
The main types of values used in the library are @emph{trees} and @emph{nodes}.
|
||||
A tree has a @emph{root} node, and each node has holds arbitrary @emph{data}
|
||||
and a natural @emph{self-width}, along with a reference to the elements smaller
|
||||
(@racket[node-left]) and larger (@racket[node-right]). Each node also
|
||||
remembers the entire width of its subtree, which can be accessed with
|
||||
@racket[node-subtree-width]. The tree holds first and last pointers into the
|
||||
structure to allow for fast access to the beginning and end of the sequence. A
|
||||
distinguished @racket[nil] node lies at the leaves of the tree.
|
||||
|
||||
|
||||
|
||||
@section{API}
|
||||
@declare-exporting[syntax-color/private/red-black]
|
||||
|
||||
|
||||
@subsection{Data types}
|
||||
|
||||
@defproc[(new-tree) tree?]{
|
||||
Constructs a new tree. The tree's root is initially @racket[nil].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
a-tree
|
||||
(nil-node? (tree-root a-tree))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(tree? [x any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[x] is a tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(tree? a-tree)
|
||||
(tree? "not a tree")
|
||||
(tree? (new-node '(not a tree either) 0))
|
||||
]}
|
||||
|
||||
|
||||
|
||||
@defproc[(tree-root [t tree?]) node?]{
|
||||
Returns the root node of the tree @racket[t].
|
||||
If the tree is empty, returns the distinguished @racket[nil] node.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(nil-node? (tree-root (new-tree)))
|
||||
(define a-node (new-node "first node!" 11))
|
||||
(insert-first! a-tree a-node)
|
||||
(eq? a-node (tree-root a-tree))]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(tree-first [t tree?]) node?]{
|
||||
Returns the first node in the tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(nil-node? (tree-first (new-tree)))
|
||||
(define a-node (new-node "first node!" 11))
|
||||
(define another-node (new-node "last node!" 11))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-last! a-tree another-node)
|
||||
(eq? a-node (tree-first a-tree))]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(tree-last [t tree?]) node?]{
|
||||
Returns the last node in the tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(nil-node? (tree-first (new-tree)))
|
||||
(define a-node (new-node "first node!" 11))
|
||||
(define another-node (new-node "last node!" 11))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-last! a-tree another-node)
|
||||
(eq? another-node (tree-last a-tree))]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(new-node [data any/c] [width natural-number/c]) singleton-node?]{
|
||||
Constructs a new singleton node. This node can be inserted into a tree with
|
||||
@racket[insert-first!], @racket[insert-last!], @racket[insert-before!], or
|
||||
@racket[insert-after!].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(new-node #("a" "node") 7)]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(node? [x any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[x] is a node.
|
||||
@interaction[#:eval my-eval
|
||||
(node? (new-node #("a" "node") 7))
|
||||
@code:comment{Trees are not nodes: they _have_ nodes.}
|
||||
(node? (new-tree))
|
||||
(node? (tree-root (new-tree)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(singleton-node? [x any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[x] is a @emph{singleton node}. A singleton node
|
||||
is unattached to any tree, and is not the @racket[nil] node.
|
||||
@interaction[#:eval my-eval
|
||||
(singleton-node? (new-node #("a" "node") 7))
|
||||
(singleton-node? nil)
|
||||
|
||||
@code:comment{Create a fresh node:}
|
||||
(define a-node (new-node "about to attach" 0))
|
||||
(singleton-node? a-node)
|
||||
@code:comment{After attachment, it is no longer singleton:}
|
||||
(define a-tree (new-tree))
|
||||
(insert-first! a-tree a-node)
|
||||
(singleton-node? a-node)
|
||||
@code:comment{Operations such as delete! or split! will break}
|
||||
@code:comment{off nodes as singletons again:}
|
||||
(delete! a-tree a-node)
|
||||
(singleton-node? a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defthing[nil node?]{
|
||||
|
||||
The distinguished @racket[nil] node. By definition, @racket[nil] is colored
|
||||
black, and its @racket[node-parent], @racket[node-left], and
|
||||
@racket[node-right] are pointed to itself.}
|
||||
|
||||
|
||||
@defproc[(non-nil-node? [x any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[x] is a non-nil node.
|
||||
@interaction[#:eval my-eval
|
||||
(non-nil-node? nil)
|
||||
(non-nil-node? (new-node "I am not a number" 1))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(nil-node? [x any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[x] is the nil node.
|
||||
@interaction[#:eval my-eval
|
||||
(nil-node? nil)
|
||||
(nil-node? (new-node "I am not a number" 1))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(node-data [n node?]) any/c]{
|
||||
Returns the data associated to node @racket[n]. Note that the
|
||||
@racket[node-data] and @racket[node-self-width] are entirely independent.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-node (new-node "utah" 4))
|
||||
(node-data a-node)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(set-node-data! [n node?] [v any/c]) void?]{
|
||||
Assigns the data associated to node @racket[n]. Note that the
|
||||
@racket[node-data] and @racket[node-self-width] are entirely independent.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-node (new-node "utah" 4))
|
||||
(set-node-data! a-node "rhode island")
|
||||
(node-data a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(node-self-width [n node?]) any/c]{
|
||||
Returns the self-width associated to node @racket[n]. Note that the
|
||||
@racket[node-data] and @racket[node-self-width] are entirely independent.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-node (new-node "utah" 4))
|
||||
(node-self-width a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(update-node-self-width! [n node?] [w natural-number/c]) any/c]{
|
||||
Updates the self-width associated to node @racket[n]. When attached to a tree,
|
||||
also propagates the width's change to the widths of subtrees, upward through
|
||||
its parents to the root. Note that the @racket[node-data] and
|
||||
@racket[node-self-width] are entirely independent.
|
||||
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "hello" 5)
|
||||
(insert-last/data! a-tree "world" 1)
|
||||
@code:comment{The tree as a whole has width 6:}
|
||||
(node-subtree-width (tree-root a-tree))
|
||||
@code:comment{Updates will propagate to the root:}
|
||||
(update-node-self-width! (tree-last a-tree) 5)
|
||||
(node-self-width (tree-last a-tree))
|
||||
(node-subtree-width (tree-root a-tree))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(node-subtree-width [n node?]) any/c]{
|
||||
Returns the width of the entire subtree at node @racket[n]. This sums the
|
||||
width of the left and right child subtrees, as well as its self-width.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "berkeley" 1)
|
||||
(insert-last/data! a-tree "stanford" 1)
|
||||
(insert-last/data! a-tree "wpi" 1)
|
||||
(insert-last/data! a-tree "brown" 1)
|
||||
(insert-last/data! a-tree "utah" 1)
|
||||
@code:comment{The entire tree should sum to five, since each element contributes one.}
|
||||
(node-subtree-width (tree-root a-tree))
|
||||
(node-subtree-width (node-left (tree-root a-tree)))
|
||||
(node-subtree-width (node-right (tree-root a-tree)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(node-parent [n node?]) node?]{
|
||||
Returns the parent of the node @racket[n].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
|
||||
(insert-last/data! a-tree "the matrix" 1)
|
||||
(insert-last/data! a-tree "speed" 1)
|
||||
(define p (node-parent (tree-last a-tree)))
|
||||
(node-data p)]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(node-left [n node?]) node?]{
|
||||
Returns the left child of the node @racket[n].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
|
||||
(insert-last/data! a-tree "the matrix" 1)
|
||||
(insert-last/data! a-tree "speed" 1)
|
||||
(define p (node-left (tree-root a-tree)))
|
||||
(node-data p)]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(node-right [n node?]) node?]{
|
||||
Returns the right child of the node @racket[n].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
|
||||
(insert-last/data! a-tree "the matrix" 1)
|
||||
(insert-last/data! a-tree "speed" 1)
|
||||
(define p (node-right (tree-root a-tree)))
|
||||
(node-data p)]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(node-color [n node?]) (or/c 'red 'black)]{
|
||||
Returns the color of the node @racket[n]. The red-black tree structure uses
|
||||
this value to maintain balance.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "the color purple" 1)
|
||||
(insert-last/data! a-tree "pretty in pink" 1)
|
||||
(insert-last/data! a-tree "the thin red line" 1)
|
||||
(insert-last/data! a-tree "clockwork orange" 1)
|
||||
(insert-last/data! a-tree "fried green tomatoes" 1)
|
||||
(node-color (tree-root a-tree))
|
||||
(tree-fold-inorder a-tree
|
||||
(lambda (n acc)
|
||||
(cons (list (node-data n) (node-color n))
|
||||
acc))
|
||||
'())]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(red? [n node?]) boolean?]{
|
||||
Returns @racket[#t] if node @racket[n] is red.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "the hobbit" 1)
|
||||
(insert-last/data! a-tree "the fellowship of the ring" 1)
|
||||
(red? (tree-root a-tree))
|
||||
(red? (node-right (tree-root a-tree)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(black? [n node?]) boolean?]{
|
||||
Returns @racket[#t] if node @racket[n] is black.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(insert-last/data! a-tree "the fellowship of the ring" 1)
|
||||
(insert-last/data! a-tree "the two towers" 1)
|
||||
(insert-last/data! a-tree "return of the king" 1)
|
||||
@code:comment{The root is always black.}
|
||||
(black? (tree-root a-tree))
|
||||
@code:comment{The tree should have towers as the root, with}
|
||||
@code:comment{the fellowship and king as left and right respectively.}
|
||||
(map node-data
|
||||
(list (tree-root a-tree)
|
||||
(node-left (tree-root a-tree))
|
||||
(node-right (tree-root a-tree))))
|
||||
(black? (tree-root a-tree))
|
||||
(black? (node-left (tree-root a-tree)))
|
||||
(black? (node-right (tree-root a-tree)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@subsection{Operations}
|
||||
|
||||
@defproc[(insert-first! [t tree?] [n singleton-node?]) void?]{
|
||||
Adds node @racket[n] as the first element in tree @racket[t].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "pear" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(eq? (tree-root a-tree) a-node)
|
||||
]
|
||||
|
||||
Note that attempting to add an attached, non-singleton node to a tree will
|
||||
raise a contract error.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "persimmon" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-first! a-tree a-node)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(insert-last! [t tree?] [n singleton-node?]) void?]{
|
||||
Adds node @racket[n] as the last element in tree @racket[t].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "apple" 1))
|
||||
(insert-last! a-tree a-node)
|
||||
(eq? (tree-root a-tree) a-node)
|
||||
]
|
||||
|
||||
Note that attempting to add an attached, non-singleton node to a tree will
|
||||
raise a contract error.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "orange" 1))
|
||||
(insert-last! a-tree a-node)
|
||||
(insert-last! a-tree a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(insert-before! [t tree?] [n1 node?] [n2 node?]) void?]{
|
||||
Adds node @racket[n2] before node @racket[n1] in tree @racket[t]. This effectively
|
||||
makes @racket[n2] the @racket[predecessor] of @racket[n1].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "banana" 1))
|
||||
(define b-node (new-node "mango" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-before! a-tree a-node b-node)
|
||||
(eq? (predecessor a-node) b-node)
|
||||
(eq? (successor b-node) a-node)
|
||||
]
|
||||
|
||||
Note that attempting to add an attached, non-singleton node to a tree will
|
||||
raise a contract error.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "peach" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-before! a-tree a-node a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(insert-after! [t tree?] [n1 node?] [n2 node?]) void?]{
|
||||
Adds node @racket[n2] after node @racket[n1] in tree @racket[t]. This effectively
|
||||
makes @racket[n2] the @racket[successor] of @racket[n1].
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "cherry" 1))
|
||||
(define b-node (new-node "pawpaw" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-after! a-tree a-node b-node)
|
||||
(eq? (successor a-node) b-node)
|
||||
(eq? (predecessor b-node) a-node)
|
||||
]
|
||||
|
||||
Note that attempting to add an attached, non-singleton node to a tree will
|
||||
raise a contract error.
|
||||
@interaction[#:eval my-eval
|
||||
(define a-tree (new-tree))
|
||||
(define a-node (new-node "grapefruit" 1))
|
||||
(insert-first! a-tree a-node)
|
||||
(insert-after! a-tree a-node a-node)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@deftogether[
|
||||
(
|
||||
@defproc[(insert-first/data! [t tree?] [data any/c] [width natural-number/c]) void?]{}
|
||||
@defproc[(insert-last/data! [t tree?] [data any/c] [width natural-number/c]) void?]{}
|
||||
@defproc[(insert-before/data! [t tree?] [n node?] [data any/c] [width natural-number/c]) void?]{}
|
||||
@defproc[(insert-after/data! [t tree?] [n node?] [data any/c] [width natural-number/c]) void?]{})
|
||||
]{
|
||||
|
||||
For user convenience, the functions @racket[insert-first/data!],
|
||||
@racket[insert-last/data!], @racket[insert-before/data!], and
|
||||
@racket[insert-after/data!] have been provided. These create nodes and insert
|
||||
into the tree structure the same way as @racket[insert-first!],
|
||||
@racket[insert-last!], @racket[insert-before!], and @racket[insert-after!].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(insert-first/data! t "message in a bottle" 1)
|
||||
(insert-last/data! t "don't stand so close to me" 1)
|
||||
(insert-before/data! t (tree-first t) "everything she does is magic" 1)
|
||||
(insert-after/data! t (tree-last t) "king of pain" 1)
|
||||
(tree-items t)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(delete! [t tree?] [n non-nil-node?]) void?]{
|
||||
Deletes node @racket[n] from the tree @racket[t]. After deletion, @racket[n]
|
||||
will become a singleton node.
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(define n1 (new-node "George, George, George of the Jungle," 1))
|
||||
(define n2 (new-node "strong as he can be..." 1))
|
||||
(define n3 (new-node "aaaaaaaaaaah!" 1))
|
||||
(define n4 (new-node "watch out for that..." 1))
|
||||
(define n5 (new-node "<thump!>" 1))
|
||||
(define n6 (new-node "treeeeeeeeee!, " 1))
|
||||
(for ([n (in-list (list n1 n2 n3 n4 n5 n6))])
|
||||
(insert-last! t n))
|
||||
(delete! t n5)
|
||||
(tree-items t)
|
||||
]
|
||||
|
||||
Note that @racket[n] must be attached to tree @racket[t] or else an
|
||||
error will be raised:
|
||||
@interaction[#:eval my-eval
|
||||
(define t1 (new-tree))
|
||||
(define t2 (new-tree))
|
||||
(insert-first/data! t1 "tricky" 1)
|
||||
(insert-first/data! t2 "tricky" 1)
|
||||
@code:comment{This should raise an error:}
|
||||
(delete! t1 (tree-root t2))
|
||||
]}
|
||||
|
||||
|
||||
@defproc[(join! [t1 tree?] [t2 tree?]) tree?]{
|
||||
Destructively joins trees @racket[t1] and @racket[t2], returning a tree that
|
||||
has the contents of both. Every element in @racket[t1] is treated less than
|
||||
the elements in @racket[t2].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t1 (new-tree))
|
||||
(for ([name (in-list '(goku gohan krillin piccolo vegeta))])
|
||||
(insert-last/data! t1 name 1))
|
||||
@code:comment{Tier two characters:}
|
||||
(define t2 (new-tree))
|
||||
(for ([name (in-list '(yamcha tien chiaotzu bulma chi-chi
|
||||
oolong puar master-roshi))])
|
||||
(insert-last/data! t2 name 1))
|
||||
(define tree-of-mighty-z-warriors (join! t1 t2))
|
||||
(tree-items tree-of-mighty-z-warriors)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(concat! [t1 tree?] [n singleton-node?] [t2 tree?]) tree?]{
|
||||
Destructively joins tree @racket[t1], singleton node @racket[n], and tree
|
||||
@racket[t2], returning a tree that has the contents of both. Every element in
|
||||
@racket[t1] is treated less than @racket[x], and @racket[x] is treated smaller than all
|
||||
the elements in @racket[t2].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t1 (new-tree))
|
||||
(define t2 (new-tree))
|
||||
(insert-last/data! t1 "inigo" 50)
|
||||
(define x (new-node "vizzini" 1))
|
||||
(insert-last/data! t2 "fezzik" 100)
|
||||
(define poor-lost-circus-performers (concat! t1 x t2))
|
||||
(tree-items poor-lost-circus-performers)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(split! [t tree?] [n non-nil-node?]) (values tree? tree?)]{
|
||||
Destructively splits tree @racket[t] into two trees, the first containing the
|
||||
elements smaller than node @racket[n], and the second containing those larger.
|
||||
Afterwards, @racket[n] becomes a singleton node.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([name '(melchior caspar bob balthazar)])
|
||||
(insert-last/data! t name 1))
|
||||
(define bob-node (search t 2))
|
||||
(singleton-node? bob-node)
|
||||
(define-values (l r) (split! t bob-node))
|
||||
@code:comment{We tree kings of orient are:}
|
||||
(append (tree-items l) (tree-items r))
|
||||
(singleton-node? bob-node)
|
||||
]
|
||||
|
||||
Note that @racket[n] must be attached to tree @racket[t] or else
|
||||
an error will be raised.
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([name '(melchior caspar bob balthazar)])
|
||||
(insert-last/data! t name 1))
|
||||
@code:comment{This should raise an error:}
|
||||
(define t2 (new-tree))
|
||||
(insert-last! t2 (new-node "bob" 1))
|
||||
(split! t (tree-root t2))
|
||||
]}
|
||||
|
||||
|
||||
@defproc[(search [t tree?] [p natural-number/c]) node?]{
|
||||
Searches for the node at or within the given position @racket[p] of the tree.
|
||||
If the position is out of bounds, returns @racket[nil].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([word '("alpha" "beta" "gamma" "delta" "epsilon" "zeta")])
|
||||
(insert-last/data! t word (string-length word)))
|
||||
(node-data (search t 0))
|
||||
(node-data (search t 5))
|
||||
(node-data (search t 6))
|
||||
(node-data (search t 7))
|
||||
(node-data (search t 8))
|
||||
(node-data (search t 9))
|
||||
(nil-node? (search t 100))
|
||||
]
|
||||
|
||||
Note: nodes with a self-width of zero are effectively invisible to
|
||||
@racket[search], and will be skipped over.
|
||||
}
|
||||
|
||||
|
||||
@defproc[(search/residual [t tree?] [p natural-number/c]) (values node? natural-number/c)]{
|
||||
Searches for the node at or within the given position @racket[p] of the tree.
|
||||
This is an extension of @racket[search] that returns a second value: the offset
|
||||
into the element where the search has terminated. If the position is out of
|
||||
bounds of any element, the first component of the returned value is
|
||||
@racket[nil].
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([word '("alpha" "beta" "gamma" "delta" "epsilon" "zeta")])
|
||||
(insert-last/data! t word (string-length word)))
|
||||
(search/residual t 5)
|
||||
(search/residual t 6)
|
||||
(search/residual t 7)
|
||||
(define-values (a-node residual)
|
||||
(search/residual t 100))
|
||||
(nil-node? a-node)
|
||||
residual
|
||||
(+ residual (node-subtree-width (tree-root t)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(minimum [n node?]) node?]{
|
||||
Given a node @racket[n], returns the minimum element of the subtree rooted at
|
||||
@racket[n].
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([x (in-list '("ftl" "xcom" "civ"))])
|
||||
(insert-first/data! t x (string-length x)))
|
||||
(node-data (minimum (tree-root t)))
|
||||
]
|
||||
Note: to get the minimum of the whole tree, it's faster to use
|
||||
@racket[tree-first].
|
||||
}
|
||||
|
||||
|
||||
@defproc[(maximum [n node?]) node?]{
|
||||
Given a node @racket[n], returns the maximum element of the subtree rooted at
|
||||
@racket[n].
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(for ([x (in-list '("ftl" "xcom" "civ"))])
|
||||
(insert-first/data! t x (string-length x)))
|
||||
(node-data (maximum (tree-root t)))
|
||||
]
|
||||
Note: to get the maximum of the whole tree, it's faster to use
|
||||
@racket[tree-last].
|
||||
}
|
||||
|
||||
|
||||
@defproc[(successor [n node?]) node?]{
|
||||
Given a node @racket[n] contained in some tree, returns the immediate
|
||||
successor of @racket[n] in an inorder traversal of that tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define partial-alien-tree (new-tree))
|
||||
(for ([name '("sectoid" "floater" "thin man" "chryssalid"
|
||||
"muton" "cyberdisk")])
|
||||
(insert-last/data! partial-alien-tree name 1))
|
||||
(define first-alien (tree-first partial-alien-tree))
|
||||
(node-data (successor first-alien))
|
||||
(node-data (successor (successor first-alien)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(predecessor [n node?]) node?]{
|
||||
Given a node @racket[n] contained in some tree, returns the immediate
|
||||
predecessor of @racket[n] in an inorder traversal of that tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define partial-alien-tree (new-tree))
|
||||
(for ([name '("sectoid" "floater" "thin man" "chryssalid"
|
||||
"muton" "cyberdisk")])
|
||||
(insert-last/data! partial-alien-tree name 1))
|
||||
(define last-alien (tree-last partial-alien-tree))
|
||||
(node-data (predecessor last-alien))
|
||||
(node-data (predecessor (predecessor last-alien)))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(position [n node?]) natural-number/c]{
|
||||
Given a node @racket[n] contained in some tree, returns the immediate
|
||||
position of @racket[n] in that tree.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define story-tree (new-tree))
|
||||
(for ([word (string-split "if you give a mouse a cookie")])
|
||||
(insert-last/data! story-tree word (string-length word)))
|
||||
(define a-pos (position (tree-last story-tree)))
|
||||
a-pos
|
||||
(node-data (search story-tree a-pos))
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(tree-items [t tree?]) (listof/c (list/c any/c natural-number/c))]{
|
||||
Given a tree, returns a list of its data and width pairs.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(insert-last/data! t "rock" 4)
|
||||
(insert-last/data! t "paper" 5)
|
||||
(insert-last/data! t "scissors" 8)
|
||||
(tree-items t)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@deftogether[
|
||||
(@defproc[(tree-fold-inorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{}
|
||||
@defproc[(tree-fold-preorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{}
|
||||
@defproc[(tree-fold-postorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{})]{
|
||||
|
||||
Iterates a function @racket[f] across the nodes of the tree, in inorder, preorder,
|
||||
and postorder respectively.
|
||||
|
||||
@interaction[#:eval my-eval
|
||||
(define t (new-tree))
|
||||
(insert-last/data! t "three" 1)
|
||||
(insert-last/data! t "blind" 1)
|
||||
(insert-last/data! t "mice" 1)
|
||||
@code:comment{"blind" should be the root, with}
|
||||
@code:comment{"three" and "mice" as left and right.}
|
||||
(define (f n acc) (cons (node-data n) acc))
|
||||
(reverse (tree-fold-inorder t f '()))
|
||||
(reverse (tree-fold-preorder t f '()))
|
||||
(reverse (tree-fold-postorder t f '()))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
|
||||
@section{Uncontracted library}
|
||||
|
||||
This library uses contracts extensively to prevent the user from messing up;
|
||||
however, the contract checking may be prohibitively
|
||||
expensive for certain applications.
|
||||
|
||||
The uncontracted bindings of this library can be accessed through:
|
||||
|
||||
@racketblock[(require (submod syntax-color/private/red-black uncontracted))]
|
||||
|
||||
This provides the same bindings as the regular API, but with no contract
|
||||
checks. Use this with extreme care: Improper use of the uncontracted form of
|
||||
this library may lead to breaking the red-black invariants, or (even worse)
|
||||
introducing cycles in the structure. If you don't know whether you should be
|
||||
using the uncontracted forms or not, you probably should not.
|
||||
|
||||
|
||||
@section{Bibliography}
|
||||
|
||||
@bibliography[
|
||||
@bib-entry[#:key "clrs2009"
|
||||
#:title "Introduction to Algorithms, Third Edition"
|
||||
#:is-book? #t
|
||||
#:author "Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest, Clifford Stein"
|
||||
#:date "2009"
|
||||
#:url "http://mitpress.mit.edu/books/introduction-algorithms"]
|
||||
|
||||
@bib-entry[#:key "wein2005"
|
||||
#:title "Efficient implementation of red-black trees with split and catenate operations"
|
||||
#:author "Ron Wein"
|
||||
#:date "2005"
|
||||
#:url "http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.109.4875"]
|
||||
]
|
||||
|
||||
|
||||
|
||||
|
||||
@close-eval[my-eval]
|
||||
Loading…
Reference in New Issue
Block a user