diff --git a/collects/syntax-color/info.rkt b/collects/syntax-color/info.rkt index 1e822ad56c..37b75114f2 100644 --- a/collects/syntax-color/info.rkt +++ b/collects/syntax-color/info.rkt @@ -1,4 +1,3 @@ #lang setup/infotab -(define scribblings '(("syntax-color.scrbl" () (gui-library)) - ("red-black.scrbl"))) +(define scribblings '(("syntax-color.scrbl" () (gui-library)))) diff --git a/collects/syntax-color/private/augmented-red-black.rkt b/collects/syntax-color/private/augmented-red-black.rkt deleted file mode 100644 index 2b4c6ba780..0000000000 --- a/collects/syntax-color/private/augmented-red-black.rkt +++ /dev/null @@ -1,2755 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base) - racket/contract) - -;; Implementation of an augmented red-black tree. -;; -;; Author: Danny Yoo (dyoo@hashcollision.org) -;; -;; -;; The usage case of this structure is to maintain an ordered sequence -;; of items, with some augmented metadata attached to each item. The -;; metadata should be a function of the data and the information at -;; the left and right subtrees. -;; -;; We follow the basic outline for augmented red-black trees described in -;; CLRS. -;; -;; Cormen, Leiserson, Rivest, Stein. Introduction to Algorithms, 3rd edition. -;; http://mitpress.mit.edu/books/introduction-algorithms -;; -;; -;; We also incorporate some elements of the design in: -;; -;; Ron Wein. Efficient implemenation of red-black trees with -;; split and catenate operations. (2005) -;; http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.109.4875 -;; -;; where we keep track of the first and last pointers. My implementation of -;; split is, in my opinion, easier to read, as we go bottom-up rather than -;; top-down, without the weird need for two separate pivots. -;; -;; -;; This module has test cases in a test submodule below. -;; -;; Use: -;; -;; raco test augmented-red-black.rkt to execute these tests. -;; - - - -(provide [contract-out - [tree? (any/c . -> . boolean?)] - [tree-root (tree? . -> . node?)] - [tree-metadata-f (tree? . -> . (or/c #f (any/c node? node? . -> . any)))] - [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 nil?/proc nil-node? (any/c . -> . boolean?)] - [node-data (node? . -> . any)] - [update-node-data! (->i ([t tree?] - [n (t) (attached-in-tree/c t)] - [v any/c]) - [result any/c])] - [node-metadata (node? . -> . any)] - - [node-parent (node? . -> . node?)] - [node-left (node? . -> . node?)] - [node-right (node? . -> . node?)] - [node-color (node? . -> . (or/c 'red 'black))] - [rename red?/proc red? (node? . -> . boolean?)] - [rename black?/proc black? (node? . -> . boolean?)] - - [new-tree (->* () - (#:metadata-f (or/c #f (any/c node? node? . -> . any))) - tree?)] - [new-node (any/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 . -> . any)] - [insert-last/data! (tree? any/c . -> . any)] - [insert-before/data! (tree? non-nil-node? any/c . -> . any)] - [insert-after/data! (tree? non-nil-node? any/c . -> . any)] - - [delete! (->i ([t tree?] - [n (t) (attached-in-tree/c t)]) - [result any/c])] - [join! (->i ([t1 tree?] - [t2 (t1) - (and/c tree? - (not-eq?/c t1) - (share-metadata-f/c t1))]) - [result tree?])] - [rename public:concat! concat! - (->i ([t1 tree?] - [n singleton-node?] - [t2 (t1) - (and/c tree? - (not-eq?/c t1) - (share-metadata-f/c t1))]) - [result any/c])] - [split! (->i ([t tree?] - [n (t) (attached-in-tree/c t)]) - (values [t1 tree?] [t2 tree?]))] - - [reset! (tree? . -> . any)] - - [minimum (node? . -> . node?)] - [maximum (node? . -> . node?)] - [successor (node? . -> . node?)] - [predecessor (node? . -> . node?)] - - [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: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define red 'red) -(define black 'black) - - -(struct tree (root ;; node The root node of the tree. - metadata-f ;; (data node node -> metadata) - first ;; node optimization: Points to the first element. - last ;; node optimization: Points to the last element. - bh) ;; natural optimization: The black height of the entire tree. - #:mutable) - - -(struct node (data ;; Any - metadata ;; Any - parent ;; node - left ;; node - right ;; node - color) ;; (U red black) - #:mutable) - - -;; As in CLRS, we use a single nil sentinel node that represents nil. -(define nil (let ([v (node #f #f #f #f #f black)]) - (set-node-parent! v v) - (set-node-left! v v) - (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)))) - - - -;; attached-in-tree/c: tree -> contract -;; -;; 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 (attached-in-tree/c t) - (flat-named-contract 'attached-in-tree/c - (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)])))))) - - -;; not-eq?/c: any -> flat-contract -;; Returns a flat contract that checks that the value isn't eq? to x. -(define (not-eq?/c x) - (flat-named-contract 'not-eq?/c - (lambda (y) - (not (eq? x y))))) - - -;; share-metadata-f/c: tree -> flat-contract -;; Returns a flat contract that checks that the tree t2 shares the -;; same metadata-f as t1. -(define (share-metadata-f/c t1) - (flat-named-contract 'share-metadata-f/c - (lambda (t2) - (equal? (tree-metadata-f t1) - (tree-metadata-f t2))))) - - - - -;; nil?: node -> boolean -;; Tell us if we're at the distinguished nil node. -(define-syntax (nil? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (eq? x nil))] - [(_ . args) - (syntax/loc stx - (nil?/proc . args))] - [_ - (identifier? stx) - #'nil?/proc])) -(define nil?/proc (procedure-rename (lambda (x) (nil? x)) 'nil?)) - - -;; red?: node -> boolean -;; Is the node red? -(define-syntax (red? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (let ([v x]) - (eq? (node-color v) red)))] - [(_ . args) - (syntax/loc stx - (red?/proc . args))] - [_ - (identifier? stx) - #'red?/proc])) -(define red?/proc (procedure-rename (lambda (x) (red? x)) 'red?)) - - -;; black?: node -> boolean -;; Is the node black? -(define-syntax (black? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (let ([v x]) - (eq? (node-color v) black)))] - [(_ . args) - (syntax/loc stx - (black?/proc . args))] - [_ - (identifier? stx) - #'black?/proc])) -(define black?/proc (procedure-rename (lambda (x) (black? x)) 'black?)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; Next, the operations: - - -;; new-tree: -> tree -;; Creates a fresh tree. -(define (new-tree #:metadata-f [metadata-f #f]) - (tree nil metadata-f nil nil 0)) - - -;; new-node: -> node -;; Creates a new singleton node. -(define (new-node data) - (node data #f nil nil nil red)) - - -;; minimum: node -> node -;; Looks for the minimum element of the tree rooted at n. -(define (minimum n) - (let loop ([n n]) - (define left (node-left n)) - (cond - [(nil? left) - n] - [else - (loop left)]))) - -;; maximum: node -> node -;; Looks for the maximum element of the tree rooted at n. -(define (maximum n) - (let loop ([n n]) - (define right (node-right n)) - (cond - [(nil? right) - n] - [else - (loop right)]))) - - -;; successor: node -> node -;; Given a node, walks to the successor node. -;; If there is no successor, returns the nil node. -(define (successor x) - (cond [(not (nil? (node-right x))) - (minimum (node-right x))] - [else - (let loop ([x x] - [y (node-parent x)]) - (cond - [(and (not (nil? y)) (eq? x (node-right y))) - (loop y (node-parent y))] - [else - y]))])) - -;; predecessor: node -> node -;; Given a node, walks to the predecessor node. -;; If there is no predecessor, returns the nil node. -(define (predecessor x) - (cond [(not (nil? (node-left x))) - (maximum (node-left x))] - [else - (let loop ([x x] - [y (node-parent x)]) - (cond - [(and (not (nil? y)) (eq? x (node-left y))) - (loop y (node-parent y))] - [else - y]))])) - - -;; update-node-data!: tree node X -> void -;; Adjusts the data at a-node, and propagates -;; metadata updates up to the root. -(define (update-node-data! a-tree a-node new-data) - (set-node-data! a-node new-data) - (update-node-metadata-up-to-root! a-node (tree-metadata-f a-tree))) - - -;; update-node-metadata!: node (or/c metadata-f #f) -> void -;; INTERNAL -;; Assuming the node-metadata of the left and right are -;; correct, computes the metadata of n and updates a-node. -;; -(define (update-node-metadata! a-node metadata-f) - (when metadata-f - (let* ([n a-node] - [left (node-left n)] - [right (node-right n)]) - (set-node-metadata! a-node - (metadata-f (node-data n) left right))))) - - - -;; update-node-metadata-up-to-root!: node (or/c metadata-f #f) -> void -;; INTERNAL -;; Updates the subtree width statistic from a-node upward to the root. -;; -;; * The subtree width field of a-node and its ancestors should be updated. -(define (update-node-metadata-up-to-root! a-node metadata-f) - (let loop ([n a-node]) - (cond - [(nil? n) - (void)] - [else - (update-node-metadata! n metadata-f) - (loop (node-parent n))]))) - - - - - - - -;; 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 -;; are valid. -(define (insert-first! a-tree x) - (set-node-color! x red) - (cond - [(nil? (tree-root a-tree)) - (set-tree-root! a-tree x) - (set-tree-first! a-tree x) - (set-tree-last! a-tree x)] - [else - (define first (tree-first a-tree)) - (set-node-left! first x) - (set-node-parent! x first) - (set-tree-first! a-tree x)]) - (update-node-metadata-up-to-root! x (tree-metadata-f a-tree)) - (fix-after-insert! a-tree x)) - - - -;; insert-last!: tree (and/c (not nil?) node?) -> void -;; Insert node x as the last element in the tree. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-last! a-tree x) - (set-node-color! x red) - (cond - [(nil? (tree-root a-tree)) - (set-tree-root! a-tree x) - (set-tree-first! a-tree x) - (set-tree-last! a-tree x)] - [else - (define last (tree-last a-tree)) - (set-node-right! last x) - (set-node-parent! x last) - (set-tree-last! a-tree x)]) - (update-node-metadata-up-to-root! x (tree-metadata-f a-tree)) - (fix-after-insert! a-tree x)) - - -;; insert-before!: tree node (and/c (not nil?) node?) -> void -;; Insert node x before element 'before' of the tree. -;; x will be the immmediate predecessor of before upon completion. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-before! a-tree before x) - (cond - [(nil? (node-left before)) - (set-node-left! before x) - (set-node-parent! x before)] - [else - (define y (maximum (node-left before))) - (set-node-right! y x) - (set-node-parent! x y)]) - (set-node-color! x red) - (when (eq? before (tree-first a-tree)) - (set-tree-first! a-tree x)) - (update-node-metadata-up-to-root! x (tree-metadata-f a-tree)) - (fix-after-insert! a-tree x)) - - -;; insert-after!: tree node (and/c (not nil?) node?) -> void -;; Insert node x after element 'after' of the tree. -;; x will be the immmediate successor of after upon completion. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-after! a-tree after x) - (cond - [(nil? (node-right after)) - (set-node-right! after x) - (set-node-parent! x after)] - [else - (define y (minimum (node-right after))) - (set-node-left! y x) - (set-node-parent! x y)]) - (set-node-color! x red) - (when (eq? after (tree-last a-tree)) - (set-tree-last! a-tree x)) - (update-node-metadata-up-to-root! x (tree-metadata-f a-tree)) - (fix-after-insert! a-tree x)) - - -;; insert-first/data!: tree data -> void -;; Insert before the first element of the tree. -(define (insert-first/data! a-tree data) - (define x (new-node data)) - (insert-first! a-tree x)) - - -;; insert-last/data!: tree data -> void -;; Insert after the last element in the tree. -(define (insert-last/data! a-tree data) - (define x (new-node data)) - (insert-last! a-tree x)) - - -;; insert-before/data!: tree data -> void -;; Insert before the first element of the tree. -(define (insert-before/data! a-tree n data) - (define x (new-node data)) - (insert-before! a-tree n x)) - - -;; insert-after/data!: tree node data -> void -;; Insert after the last element in the tree. -(define (insert-after/data! a-tree n data) - (define x (new-node data)) - (insert-after! a-tree n x)) - - - - -;; left-rotate!: tree node natural -> void -;; INTERNAL -;; Rotates the x node node to the left. -;; Preserves the auxiliary information for position queries. -(define (left-rotate! a-tree x) - (define y (node-right x)) - (set-node-right! x (node-left y)) - (unless (nil? (node-left y)) - (set-node-parent! (node-left y) x)) - (set-node-parent! y (node-parent x)) - (cond [(nil? (node-parent x)) - (set-tree-root! a-tree y)] - [(eq? x (node-left (node-parent x))) - (set-node-left! (node-parent x) y)] - [else - (set-node-right! (node-parent x) y)]) - (set-node-left! y x) - (set-node-parent! x y) - - ;; Looking at Figure 13.2 of CLRS: - ;; The change to the statistics can be locally computed after the - ;; rotation: - (update-node-metadata! x (tree-metadata-f a-tree)) - (update-node-metadata! y (tree-metadata-f a-tree))) - - -;; right-rotate!: tree node natural -> void -;; INTERNAL -;; Rotates the y node node to the right. -;; (Symmetric to the left-rotate! function.) -;; Preserves the auxiliary information for position queries. -(define (right-rotate! a-tree y) - (define x (node-left y)) - (set-node-left! y (node-right x)) - (unless (nil? (node-right x)) - (set-node-parent! (node-right x) y)) - (set-node-parent! x (node-parent y)) - (cond [(nil? (node-parent y)) - (set-tree-root! a-tree x)] - [(eq? y (node-right (node-parent y))) - (set-node-right! (node-parent y) x)] - [else - (set-node-left! (node-parent y) x)]) - (set-node-right! x y) - (set-node-parent! y x) - - ;; Looking at Figure 1.32 of CLRS: - ;; The change to the statistics can be locally computed after the - ;; rotation: - (update-node-metadata! y (tree-metadata-f a-tree)) - (update-node-metadata! x (tree-metadata-f a-tree))) - - -;; fix-after-insert!: tree node natural -> void -;; INTERNAL -;; Corrects the red/black tree property via node rotations after an -;; insertion. If there's a violation, then it's at z where both z and -;; its parent are red. -(define (fix-after-insert! a-tree z) - (let loop ([z z]) - (define z.p (node-parent z)) - (when (red? z.p) - (define z.p.p (node-parent z.p)) - (cond [(eq? z.p (node-left z.p.p)) - (define y (node-right z.p.p)) - (cond [(red? y) - (set-node-color! z.p black) - (set-node-color! y black) - (set-node-color! z.p.p red) - (loop z.p.p)] - [else - (cond [(eq? z (node-right z.p)) - (let ([new-z z.p]) - (left-rotate! a-tree new-z) - (set-node-color! (node-parent new-z) black) - (set-node-color! (node-parent (node-parent new-z)) red) - (right-rotate! a-tree (node-parent (node-parent new-z))) - (loop new-z))] - [else - (set-node-color! z.p black) - (set-node-color! z.p.p red) - (right-rotate! a-tree z.p.p) - (loop z)])])] - [else - (define y (node-left z.p.p)) - (cond [(red? y) - (set-node-color! z.p black) - (set-node-color! y black) - (set-node-color! z.p.p red) - (loop z.p.p)] - [else - (cond [(eq? z (node-left z.p)) - (let ([new-z z.p]) - (right-rotate! a-tree new-z) - (set-node-color! (node-parent new-z) black) - (set-node-color! (node-parent (node-parent new-z)) red) - (left-rotate! a-tree - (node-parent (node-parent new-z))) - (loop new-z))] - [else - (set-node-color! z.p black) - (set-node-color! z.p.p red) - (left-rotate! a-tree z.p.p) - (loop z)])])]))) - (when (red? (tree-root a-tree)) - (set-tree-bh! a-tree (add1 (tree-bh a-tree))) - (set-node-color! (tree-root a-tree) black))) - - - - -;; delete!: tree node -> void -;; Removes the node from the tree. -;; Follows the description of CLRS, but with a few extensions: -;; -;; * Importantly, we do not ever mutate the sentinel nil node's parent. -;; This means we takes special care of remembering what it should be, -;; so that the deletion fixup can properly walk the tree. -;; We do this so that we can preserve thread-safety: the nil node is global, -;; so mutating it is a Bad Thing. -;; -;; * Does the statistic update, following the strategy of augmented -;; red-black trees. -(define (delete! a-tree z) - - ;; First, adjust tree-first and tree-last if we end up - ;; removing either from the tree. - (when (eq? z (tree-first a-tree)) - (set-tree-first! a-tree (successor z))) - (when (eq? z (tree-last a-tree)) - (set-tree-last! a-tree (predecessor z))) - - (define y z) - (define y-original-color (node-color y)) - (let-values ([(x y-original-color nil-parent) - (cond - ;; If either the left or right child of z is nil, - ;; deletion is merely replacing z with its other child x. - ;; (Of course, we then have to repair the damage.) - [(nil? (node-left z)) - (define z.p (node-parent z)) - (define x (node-right z)) - (define nil-parent (transplant-for-delete! a-tree z x)) - ;; At this point, we need to repair the statistic where - ;; where the replacement happened, since z's been replaced with x. - ;; The x subtree is ok, so we need to begin the statistic repair - ;; at z.p. - (when (not (nil? z.p)) - (update-node-metadata-up-to-root! z.p (tree-metadata-f a-tree))) - - ; Turn z singleton: - (set-node-parent! z nil) - (set-node-left! z nil) - (set-node-right! z nil) - (set-node-color! z red) - (update-node-metadata! z (tree-metadata-f a-tree)) - - (values x y-original-color nil-parent)] - - ;; This case is symmetric with the previous case. - [(nil? (node-right z)) - (define z.p (node-parent z)) - (define x (node-left z)) - (define nil-parent (transplant-for-delete! a-tree z x)) - (when (not (nil? z.p)) - (update-node-metadata-up-to-root! z.p (tree-metadata-f a-tree))) - (set-node-parent! z nil) - (set-node-left! z nil) - (set-node-right! z nil) - (set-node-color! z red) - (update-node-metadata! z (tree-metadata-f a-tree)) - (values x y-original-color nil-parent)] - - ;; The hardest case is when z has non-nil left and right. - ;; We take the minimum of z's right subtree and replace - ;; z with it. - [else - (let* ([y (minimum (node-right z))] - [y-original-color (node-color y)]) - ;; At this point, y's left is nil by definition of minimum. - (define x (node-right y)) - (define nil-parent - (cond - [(eq? (node-parent y) z) - ;; In CLRS, this is steps 12 and 13 of RB-DELETE. - ;; Be aware that x here can be nil. Rather than - ;; change the contents of nil, we record that value - ;; in nil-parent and pass that along to the rest of - ;; the computation. - (cond [(nil? x) - y] - [else - (set-node-parent! x y) - nil])] - [else - (let ([nil-parent - (transplant-for-delete! a-tree y (node-right y))]) - (set-node-right! y (node-right z)) - (set-node-parent! (node-right y) y) - nil-parent)])) - - ;; y can't be nil here, so has no effect on nil-parent - (transplant-for-delete! a-tree z y) - - (set-node-left! y (node-left z)) - - ;; Similarly, (node-left y) here can't be nil by the case - ;; analysis, so this has no effect on nil-parent. - (set-node-parent! (node-left y) y) - - (set-node-color! y (node-color z)) - (update-node-metadata-up-to-root! - (if (nil? x) nil-parent (node-parent x)) - (tree-metadata-f a-tree)) - - ;; Turn z singleton: - (set-node-parent! z nil) - (set-node-left! z nil) - (set-node-right! z nil) - (set-node-color! z red) - (update-node-metadata! z (tree-metadata-f a-tree)) - - (values x y-original-color nil-parent))])]) - (cond [(eq? black y-original-color) - (fix-after-delete! a-tree x nil-parent)] - [else - (void)]))) - - - - - - - -;; transplant-for-delete: tree node (U node nil) -> (U nil node) -;; INTERNAL -;; Replaces the instance of node u in a-tree with v. -;; -;; If v is nil, then rather than mutate nil, it returns -;; a non-nil node that should be treated as nil's parent. -;; Otherwise, returns nil. -(define (transplant-for-delete! a-tree u v) - (define u.p (node-parent u)) - (cond [(nil? u.p) - (set-tree-root! a-tree v)] - [(eq? u (node-left u.p)) - (set-node-left! u.p v)] - [else - (set-node-right! u.p v)]) - (cond [(nil? v) - u.p] - [else - (set-node-parent! v u.p) - nil])) - - - -;; fix-after-delete!: tree node -> void -;; INTERNAL -;; Correct several possible invariant-breaks after a black node -;; has been removed from the tree. These include: -;; -;; * turning the root red -;; * unbalanced black paths -;; * red-red links -;; -;; Note that this function has been augmented so that it keeps special -;; track of nil-parent. -(define (fix-after-delete! a-tree x nil-parent) - - ;; n-p: node -> node - ;; Should be almost exactly like node-parent, except for one - ;; special case: in the context of this function alone, - ;; if we're navigating the parent of nil, use the nil-parent constant. - (define-syntax-rule (n-p x) - (let ([v x]) - (if (nil? v) - nil-parent - (node-parent v)))) - - (let loop ([x x] - [early-escape? #f]) - (cond [(and (not (eq? x (tree-root a-tree))) - (black? x)) - (cond - [(eq? x (node-left (n-p x))) - (define w (node-right (n-p x))) - (define w-1 (cond [(eq? (node-color w) red) - (set-node-color! w black) - (set-node-color! (n-p x) red) - (left-rotate! a-tree (n-p x)) - (node-right (n-p x))] - [else - w])) - (cond [(and (black? (node-left w-1)) (black? (node-right w-1))) - (set-node-color! w-1 red) - (loop (n-p x) #f)] - [else - (define w-2 (cond [(black? (node-right w-1)) - (set-node-color! (node-left w-1) black) - (set-node-color! w-1 red) - (right-rotate! a-tree w-1) - (node-right (n-p x))] - [else - w-1])) - (set-node-color! w-2 (node-color (n-p x))) - (set-node-color! (n-p x) black) - (set-node-color! (node-right w-2) black) - (left-rotate! a-tree (n-p x)) - (loop (tree-root a-tree) - #t)])] - [else - (define w (node-left (n-p x))) - (define w-1 (cond [(red? w) - (set-node-color! w black) - (set-node-color! (n-p x) red) - (right-rotate! a-tree (n-p x)) - (node-left (n-p x))] - [else - w])) - (cond [(and (black? (node-left w-1)) (black? (node-right w-1))) - (set-node-color! w-1 red) - (loop (n-p x) #f)] - [else - (define w-2 (cond [(black? (node-left w-1)) - (set-node-color! (node-right w-1) black) - (set-node-color! w-1 red) - (left-rotate! a-tree w-1) - (node-left (n-p x))] - [else - w-1])) - (set-node-color! w-2 (node-color (n-p x))) - (set-node-color! (n-p x) black) - (set-node-color! (node-left w-2) black) - (right-rotate! a-tree (n-p x)) - (loop (tree-root a-tree) - #t)])])] - [else - ;; When we get to this point, if x is at the root - ;; and still black, we are discarding the double-black - ;; color, which means the height of the tree should be - ;; decremented. - (when (and (eq? x (tree-root a-tree)) - (black? x) - (not early-escape?)) - (set-tree-bh! a-tree (sub1 (tree-bh a-tree)))) - - (set-node-color! x black)]))) - - - - - - - -;; join!: tree tree -> tree -;; Destructively concatenates trees t1 and t2, and -;; returns a tree that represents the join. -(define (join! t1 t2) - (cond - [(nil? (tree-root t2)) - (define result (clone! t1)) - (reset! t1) - result] - [(nil? (tree-root t1)) - (define result (clone! t2)) - (reset! t2) - result] - [else - ;; First, remove element x from t2. x will act as the - ;; pivot point. - (define x (tree-first t2)) - (delete! t2 x) - ;; Next, delegate to the more general concat! function, using - ;; x as the pivot. - (public:concat! t1 x t2)])) - - - -;; public:concat!: tree node tree -> tree -;; Joins t1, x, and t2 together, returning a new tree. -;; Destructively modifies t1 and t2 to the empty trees. -(define (public:concat! t1 x t2) - (define result (concat! t1 x t2)) - (cond - [(eq? result t1) - (let ([result (clone! t1)]) - (reset! t1) - (reset! t2) - result)] - [(eq? result t2) - (let ([result (clone! t2)]) - (reset! t1) - (reset! t2) - result)] - [else - (reset! t1) - (reset! t2) - result])) - - - -;; concat!: tree node tree -> tree -;; INTERNAL -;; Joins t1, x and t2 together, using x as the pivot. -;; -;; x will be treated as if it were a singleton tree; its x.left and x.right -;; will be overwritten during concatenation. -;; -;; Note that x must NOT be attached to the tree t1 or t2, or else this -;; will introduce an illegal cycle. -;; -;; Also, this should not depend on t1 and t2 having valid -;; tree-first/tree-last pointers on entry; we compute this lazily due -;; to how this is used by split!. -(define (concat! t1 x t2) - (cond - [(nil? (tree-root t1)) - (set-node-left! x nil) - (set-node-right! x nil) - (update-node-metadata! x (tree-metadata-f t2)) - ;; if t2 is lazy about having a tree-first, force it. - ;; This only happens in the context of split! - (force-tree-first! t2) - (insert-first! t2 x) - t2] - - [(nil? (tree-root t2)) - ;; symmetric with the case above: - (set-node-left! x nil) - (set-node-right! x nil) - (update-node-metadata! x (tree-metadata-f t1)) - (force-tree-last! t1) - (insert-last! t1 x) - t1] - - [else - (define t1-bh (tree-bh t1)) - (define t2-bh (tree-bh t2)) - (cond - [(>= t1-bh t2-bh) - ;; Note: even if tree-last is invalid, nothing gets hurt here. - (set-tree-last! t1 (tree-last t2)) - - (define a (find-rightmost-black-node-with-bh t1 t2-bh)) - (define b (tree-root t2)) - (transplant-for-concat! t1 a x) - (set-node-color! x red) - (set-node-left! x a) - (set-node-parent! a x) - (set-node-right! x b) - (set-node-parent! b x) - - ;; Possible TODO: Ron Wein recommends a lazy approach here, - ;; rather than recompute the metadata eagerly. I've tried so, - ;; but in my experiments, the overhead of testing and forcing - ;; actually hurts us. So I do not try to compute subtree-width - ;; lazily. - (update-node-metadata-up-to-root! x (tree-metadata-f t1)) - (fix-after-insert! t1 x) - t1] - - [else - ;; Symmetric case: - (set-tree-first! t2 (tree-first t1)) - (define a (tree-root t1)) - (define b (find-leftmost-black-node-with-bh t2 t1-bh)) - (transplant-for-concat! t2 b x) - (set-node-color! x red) - (set-node-left! x a) - (set-node-parent! a x) - (set-node-right! x b) - (set-node-parent! b x) - (update-node-metadata-up-to-root! x (tree-metadata-f t2)) - (fix-after-insert! t2 x) - t2])])) - - -;; transplant-for-concat!: tree node node -> void -;; INTERNAL -;; Replaces node u in a-tree with v. -(define (transplant-for-concat! a-tree u v) - (define u.p (node-parent u)) - (cond [(nil? u.p) - (set-tree-root! a-tree v)] - [(eq? u (node-left u.p)) - (set-node-left! u.p v)] - [else - (set-node-right! u.p v)]) - (set-node-parent! v u.p)) - - - -;; find-rightmost-black-node-with-bh: tree positive-integer -> node -;; INTERNAL -;; Finds the rightmost black node with the particular black height -;; we're looking for. -(define (find-rightmost-black-node-with-bh a-tree bh) - (let loop ([n (tree-root a-tree)] - [current-height (tree-bh a-tree)]) - (cond - [(black? n) - (cond [(= bh current-height) - n] - [else - (loop (node-right n) (sub1 current-height))])] - [else - (loop (node-right n) current-height)]))) - - -;; find-leftmost-black-node-with-bh: tree positive-integer -> node -;; INTERNAL -;; Finds the rightmost black node with the particular black height -;; we're looking for. -(define (find-leftmost-black-node-with-bh a-tree bh) - (let loop ([n (tree-root a-tree)] - [current-height (tree-bh a-tree)]) - (cond - [(black? n) - (cond [(= bh current-height) - n] - [else - (loop (node-left n) (sub1 current-height))])] - [else - (loop (node-left n) current-height)]))) - - -;; split!: tree node -> (values tree tree) -;; Partitions the tree into two trees: the predecessors of x, and the -;; successors of x. Also mutates x into a singleton node. -;; Finally, modifies a-tree so it looks empty. -;; -;; 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 (tree-metadata-f a-tree))) - (define R (node->tree/bh (node-right x) x-child-bh (tree-metadata-f a-tree))) - - ;; Turn x into a singleton node: - (detach! x) - (set-node-right! x nil) - (set-node-left! x nil) - (set-node-color! x red) - (update-node-metadata! x (tree-metadata-f a-tree)) - - ;; Clear out a-tree so it's unusable. - (reset! a-tree) - - ;; The loop walks the ancestors of x, adding the left and right - ;; elements appropriately. - (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 - ;; pointers, then return. - (force-tree-first! L) - (force-tree-last! L) - (force-tree-first! R) - (force-tree-last! R) - (values L R)] - [else - (define new-ancestor (node-parent ancestor)) - (define new-ancestor-child-bh (if (black? ancestor) - (add1 ancestor-child-bh) - ancestor-child-bh)) - (define new-coming-from-the-right? (eq? (node-right new-ancestor) ancestor)) - - ;; Important! Make sure ancestor is detached. This is - ;; required by concat!, or else Bad Things happen. - (detach! ancestor) - - (cond - [coming-from-the-right? - (define subtree (node->tree/bh (node-left ancestor) - ancestor-child-bh - (tree-metadata-f a-tree))) - (loop new-ancestor - new-ancestor-child-bh - new-coming-from-the-right? - (concat! subtree ancestor L) - R)] - [else - (define subtree (node->tree/bh (node-right ancestor) - ancestor-child-bh - (tree-metadata-f a-tree))) - (loop new-ancestor - new-ancestor-child-bh - new-coming-from-the-right? - L - (concat! R ancestor subtree))])]))) - - -;; reset!: tree -> void -;; Resets a tree to empty. -(define (reset! a-tree) - (set-tree-root! a-tree nil) - (set-tree-first! a-tree nil) - (set-tree-last! a-tree nil) - (set-tree-bh! a-tree 0)) - - - -;; clone!: tree -> tree -;; Shallow copy of the components of the tree. -(define (clone! a-tree) - (tree (tree-root a-tree) - (tree-metadata-f a-tree) - (tree-first a-tree) - (tree-last a-tree) - (tree-bh a-tree))) - - - - - - -;; force-tree-first!: tree -> void -;; INTERNAL -;; Force tree-first's value. -;; For non-empty trees, it's set to nil only in node->tree/bh. -(define (force-tree-first! t) - (when (nil? (tree-first t)) - (set-tree-first! t (minimum (tree-root t))))) - - -;; force-tree-last!: tree -> void -;; INTERNAL -;; Force tree-last's value. -;; For non-empty trees, it's set to nil only in node->tree/bh. -(define (force-tree-last! t) - (when (nil? (tree-last t)) - (set-tree-last! t (maximum (tree-root t))))) - - -;; detach!: node -> void -;; INTERNAL -;; Disconnects n from its parent. -(define (detach! n) - (define p (node-parent n)) - (cond [(nil? p) - (void)] - [(eq? (node-right p) n) - (set-node-right! p nil) - (set-node-parent! n nil)] - [else - (set-node-left! p nil) - (set-node-parent! n nil)])) - - -;; node->tree/bh: node natural metadata-f -> tree -;; INTERNAL: for use by split! only. -;; Create a partially-instantiated node out of a tree, where we should -;; already know the black height of the tree rooted at a-node. -;; -;; Note that the first and last of the tree have not been initialized -;; here yet. split! must eventually force the L and R trees to -;; have valid first/last pointers, or else Bad Things happen. -(define (node->tree/bh a-node bh metadata-f) - (cond - [(nil? a-node) - (new-tree #:metadata-f metadata-f)] - [else - (define new-bh (if (red? a-node) (add1 bh) bh)) - (set-node-parent! a-node nil) - (set-node-color! a-node black) - (tree a-node - metadata-f - nil - nil - new-bh)])) - - -;; computed-black-height: node -> natural -;; INTERNAL: for use by split! only. -;; Computes the black height of the tree rooted at x. -(define (computed-black-height x) - (let loop ([x x] - [acc 0]) - (cond - [(nil? x) - acc] - [else - (cond [(black? x) - (loop (node-right x) (add1 acc))] - [else - (loop (node-right x) acc)])]))) - - - -;; tree-items: tree -> (listof X) -;; PUBLIC -;; Returns the data in the tree in inorder traversal. -(define (tree-items t) - (let loop ([n (tree-root t)] - [acc null]) - (cond - [(nil? n) - acc] - [else - (loop (node-left n) - (cons (node-data n) - (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-metadata-f - tree-first - tree-last - node? - singleton-node? - non-nil-node? - nil - [rename-out [nil? nil-node?]] - node-data - update-node-data! - node-metadata - node-parent - node-left - node-right - node-color - red? - 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! - [rename-out [public:concat! concat!]] - split! - reset! - - minimum - maximum - successor - predecessor - - tree-items - tree-fold-inorder - tree-fold-preorder - tree-fold-postorder)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal tests. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - -(module+ test - (require rackunit - rackunit/text-ui - racket/string - racket/list - racket/class - racket/promise) - - (define (new-string-tree) - (new-tree #:metadata-f string-length-metadata-f)) - - - ;; search: tree natural -> (U node nil) - ;; Search for the node closest to offset. - ;; 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) - (values nil offset)] - [else - (define left (node-left a-node)) - (define left-subtree-width (if (nil? left) 0 (node-metadata left))) - (cond [(< offset left-subtree-width) - (loop offset left)] - [else - (define residual-offset (- offset left-subtree-width)) - (define self-width (string-length (node-data a-node))) - (cond - [(< residual-offset self-width) - (values a-node residual-offset)] - [else - (loop (- residual-offset self-width) - (node-right a-node))])])]))) - - - - - (define (new-offset-tree) - (new-tree #:metadata-f (lambda (data left right) - (+ 1 - (if (nil? left) 0 (node-metadata left)) - (if (nil? right) 0 (node-metadata right)))))) - - - ;; search-offset: tree natural -> (U node nil) - ;; Search for the node closest to offset. - ;; 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-offset a-tree offset) - (define-values (result residual) (search-offset/residual a-tree offset)) - result) - - - ;; search-offset/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-offset/residual a-tree offset) - (let loop ([offset offset] - [a-node (tree-root a-tree)]) - (cond - [(nil? a-node) - (values nil offset)] - [else - (define left (node-left a-node)) - (define left-subtree-width (if (nil? left) 0 (node-metadata left))) - (cond [(< offset left-subtree-width) - (loop offset left)] - [else - (define residual-offset (- offset left-subtree-width)) - (define self-width 1) - (cond - [(< residual-offset self-width) - (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. - ;; Note: (position nil) will return -1. - (define (position n) - (cond - [(nil? n) - -1] - [else - (let loop ([n n] - [came-from-right? #f] - [acc (if (nil? (node-left n)) - 0 - (node-metadata (node-left n)))]) - (cond - [(nil? n) - acc] - [came-from-right? - (loop (node-parent n) - (eq? (node-right (node-parent n)) n) - (+ acc - (if (nil? (node-left n)) - 0 - (node-metadata (node-left n))) - (string-length (node-data n))))] - [else - (loop (node-parent n) - (eq? (node-right (node-parent n)) n) - acc)]))])) - - - - (define (singleton-node? n) - (and (node? n) - (red? n) - (nil? (node-parent n)))) - - - ;; tree-items: tree -> (listof (list X number)) - ;; Returns a list of all the items stored in the tree. - (define (tree-items a-tree) - (let loop ([node (tree-root a-tree)] - [acc null]) - (cond - [(nil? node) - acc] - [else - (loop (node-left node) - (cons (node-data node) - (loop (node-right node) acc)))]))) - - - ;; tree-height: tree -> natural - ;; For debugging: returns the height of the tree. - (define (tree-height a-tree) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - 0] - [else - (+ 1 (max (loop (node-left node)) - (loop (node-right node))))]))) - - ;; tree-node-count: tree -> natural - ;; Counts the nodes of the tree. - (define (tree-node-count a-tree) - (let loop ([node (tree-root a-tree)] - [acc 0]) - (cond - [(nil? node) - acc] - [else - (loop (node-left node) (loop (node-right node) (add1 acc)))]))) - - - ;; Debugging: counts the number of black nodes by manually - ;; traversing both subtrees. - (define (node-count-black a-node) - (let loop ([a-node a-node] - [acc 0]) - (cond - [(nil? a-node) - acc] - [else - (define right-count (loop (node-right a-node) - (+ (if (black? a-node) 1 0) - acc))) - (define left-count (loop (node-left a-node) - (+ (if (black? a-node) 1 0) - acc))) - (check-equal? right-count - left-count - (format "node-count-black: ~a vs ~a" right-count left-count)) - right-count]))) - - - ;; string-length-metadata-f: string node node -> natural - (define (string-length-metadata-f data left right) - (+ (string-length data) - (if (nil? left) 0 (node-metadata left)) - (if (nil? right) 0 (node-metadata right)))) - - - ;; check-rb-structure!: tree -> void - ;; The following is a heavy debugging function to ensure - ;; tree-structure is as expected. Note: this functions is - ;; EXTRAORDINARILY expensive. Do not use this outside of tests. - (define (check-rb-structure! a-tree) - - ;; nil should always be black: algorithms depend on this! - (check-eq? (node-color nil) black) - (check-eq? (node-parent nil) nil) - (check-eq? (node-metadata nil) #f) - (check-eq? (node-left nil) nil) - (check-eq? (node-right nil) nil) - - - ;; The internal linkage between all the nodes should be consistent, - ;; and without cycles! - (let ([ht (make-hasheq)]) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [else - (check-false (hash-has-key? ht node)) - (hash-set! ht node #t) - (define left (node-left node)) - (define right (node-right node)) - (when (not (nil? left)) - (check-eq? (node-parent left) node) - (loop left)) - (when (not (nil? right)) - (check-eq? (node-parent right) node) - (loop right))]))) - - - ;; No two red nodes should be adjacent: - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [(red? node) - (check-false (or (red? (node-left node)) - (red? (node-right node))) - "rb violation: two reds are adjacent") - (loop (node-left node)) - (loop (node-right node))])) - - - ;; The maximum and minimum should be correctly linked - ;; as tree-last and tree-first, respectively: - (let ([correct-tree-first (if (nil? (tree-root a-tree)) - nil - (minimum (tree-root a-tree)))]) - (check-eq? (tree-first a-tree) - correct-tree-first - (format "minimum (~a) is not first (~a)" - (node-data correct-tree-first) - (node-data (tree-first a-tree))))) - (let ([correct-tree-last (if (nil? (tree-root a-tree)) nil (maximum (tree-root a-tree)))]) - (check-eq? (tree-last a-tree) - correct-tree-last - (format "maximum (~a) is not last (~a)" - (node-data correct-tree-last) - (node-data (tree-last a-tree))))) - - - ;; The left and right sides should be black-balanced, for all subtrees. - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [else - (check-equal? (node-count-black (node-left node)) - (node-count-black (node-right node)) - "rb violation: not black-balanced") - (loop (node-left node)) - (loop (node-right node))])) - (define observed-black-height (node-count-black (tree-root a-tree))) - ;; The observed black height should equal that of the recorded one - (check-equal? (tree-bh a-tree) - observed-black-height - (format "rb violation: observed height ~a is not equal to recorded height ~a" - observed-black-height - (tree-bh a-tree))) - - - ;; The overall height must be less than 2 lg(n+1) - (define count (tree-node-count a-tree)) - (define observed-height (tree-height a-tree)) - (define (lg n) (/ (log n) (log 2))) - (check-false (> observed-height (* 2 (lg (add1 count)))) - (format "rb violation: height ~a beyond 2 lg(~a)=~a" - observed-height (add1 count) - (* 2 (log (add1 count))))) - - - - - ;; If metadata-f is string length, then the subtree widths should - ;; be consistent: - (when (equal? (tree-metadata-f a-tree) string-length-metadata-f) - (let loop ([n (tree-root a-tree)]) - (cond - [(nil? n) - 0] - [else - (define left-subtree-size (loop (node-left n))) - (define right-subtree-size (loop (node-right n))) - (check-equal? (node-metadata n) - (+ left-subtree-size right-subtree-size - (string-length (node-data n))) - (format "stale string width: expected ~a, but observe ~a" - (+ left-subtree-size right-subtree-size - (string-length (node-data n))) - (node-metadata n))) - (+ left-subtree-size right-subtree-size - (string-length (node-data n)))])))) - - - - ;; tree->list: tree -> list - ;; For debugging: help visualize what the structure of the tree looks like. - (define (tree->list a-tree) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - null] - [else - (list (format "~a:~a:~a" - (node-data node) - (node-metadata node) - (if (black? node) "black" "red")) - (loop (node-left node)) - (loop (node-right node)))]))) - - - ;; a little macro to help me measure how much time we spend in - ;; the body of an expression. - (define-syntax-rule (time-acc id body ...) - (let ([start (current-inexact-milliseconds)]) - (call-with-values (lambda () - (let () body ...)) - (lambda vals - (let ([stop (current-inexact-milliseconds)]) - (set! id (+ id (- stop start))) - (apply values vals)))))) - - - (define nil-tests - (test-suite - "check properties of nil" - (printf "nil tests...\n") - (test-case - "nil tree should be consistent" - (define t (new-tree)) - (check-rb-structure! t)))) - - (define rotation-tests - (test-suite - "Checking left and right rotation" - (printf "rotation tests...\n") - (test-begin - (define t (new-tree)) - - (define alpha (node "alpha" 5 nil nil nil nil)) - (define beta (node "beta" 4 nil nil nil nil)) - (define gamma (node "gamma" 5 nil nil nil nil)) - - (define x (node "x" 1 nil alpha beta nil)) - (define y (node "y" 1 nil nil gamma nil)) - (set-tree-root! t y) - (set-node-left! y x) - (set-node-parent! x y) - - (right-rotate! t y) - (check-eq? (tree-root t) x) - (check-eq? (node-left (tree-root t)) alpha) - (check-eq? (node-right (tree-root t)) y) - (check-eq? (node-left (node-right (tree-root t))) beta) - (check-eq? (node-right (node-right (tree-root t))) gamma) - - (left-rotate! t x) - (check-eq? (tree-root t) y) - (check-eq? (node-right (tree-root t)) gamma) - (check-eq? (node-left (tree-root t)) x) - (check-eq? (node-left (node-left (tree-root t))) alpha) - (check-eq? (node-right (node-left (tree-root t))) beta)))) - - - - (define insertion-tests - (test-suite - "Insertion tests" - (printf "insertion tests...\n") - (test-case "small beginnings" - (define t (new-string-tree)) - (insert-last/data! t "small world") - (check-rb-structure! t)) - - (test-begin - (define t (new-string-tree)) - (insert-last/data! t "foobar") - (insert-last/data! t "hello") - (insert-last/data! t "world") - (check-equal? (tree-items t) - '("foobar" "hello" "world")) - (check-rb-structure! t)) - - - (test-begin - (define t (new-string-tree)) - (insert-first/data! t "a") - (insert-first/data! t "b") - (insert-first/data! t "c") - (check-equal? (tree-items t) '("c" "b" "a")) - (check-equal? (tree->list t) - '("b:3:black" ("c:1:red" () ()) ("a:1:red" () ()))) - (check-rb-structure! t)) - - - (test-begin - (define t (new-string-tree)) - (insert-first/data! t "alpha") - (insert-first/data! t "beta") - (insert-first/data! t "gamma") - (insert-first/data! t "delta") - (insert-first/data! t "omega") - (check-equal? (tree-items t) - '("omega" "delta" "gamma" "beta" "alpha")) - (check-rb-structure! t)) - - - (test-begin - (define t (new-string-tree)) - (insert-last/data! t "hi") - (insert-last/data! t "bye") - (define the-root (tree-root t)) - (check-equal? (node-left the-root) - nil) - (check-true (black? the-root)) - (check-equal? (node-metadata the-root) 5) - (check-true (red? (node-right the-root))) - - (check-rb-structure! t)) - - (test-begin - (define t (new-string-tree)) - (insert-last/data! t "hi") - (insert-last/data! t "bye") - (insert-last/data! t "again") - (define the-root (tree-root t)) - (check-equal? (node-data (node-left the-root)) - "hi") - (check-equal? (node-data the-root) - "bye") - (check-equal? (node-data (node-right the-root)) - "again") - (check-true (black? the-root)) - (check-true (red? (node-left the-root))) - (check-true (red? (node-right the-root))) - (check-equal? (node-metadata the-root) 10) - (check-rb-structure! t)))) - - - - - (define deletion-tests - (test-suite - "deletion-tests" - (printf "deletion tests...\n") - (test-case - "Deleting the last node in a tree should set us back to the nil case" - (define t (new-string-tree)) - (insert-first/data! t "hello") - (delete! t (tree-root t)) - (check-equal? (tree-root t) nil) - (check-rb-structure! t)) - - (test-case - "Deleting the last node in a tree: first and last should be nil" - (define t (new-string-tree)) - (insert-first/data! t "hello") - (delete! t (tree-root t)) - (check-equal? (tree-first t) nil) - (check-equal? (tree-last t) nil) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: basic structure" - (define t (new-string-tree)) - (insert-last/data! t "dresden") - (insert-last/data! t "files") - (delete! t (node-right (tree-root t))) - (check-equal? (node-data (tree-root t)) "dresden") - (check-equal? (node-left (tree-root t)) nil) - (check-equal? (node-right (tree-root t)) nil) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: check the subtree-width has been updated" - (define t (new-string-tree)) - (insert-last/data! t "dresden") - (insert-last/data! t "files") - (delete! t (node-right (tree-root t))) - (check-equal? (node-metadata (tree-root t)) 7) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: check that tree-first and tree-last are correct" - (define t (new-string-tree)) - (insert-last/data! t "dresden") - (insert-last/data! t "files") - (delete! t (node-right (tree-root t))) - (check-true (node? (tree-root t))) - (check-equal? (tree-first t) (tree-root t)) - (check-equal? (tree-last t) (tree-root t)) - (check-rb-structure! t)) - - - (test-case - "bigger case identified by angry monkey" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (insert-last/data! t "d") - (insert-last/data! t "e") - (check-rb-structure! t) - (delete! t (search t 1)) - (check-rb-structure! t) - (delete! t (search t 1)) - (check-rb-structure! t) - (delete! t (search t 0)) - (check-rb-structure! t)) - - - (test-case - "does deletion get subtree width right?" - (define t (new-string-tree)) - (insert-last/data! t "hello") - (insert-last/data! t "dyoo") - (define r (tree-root t)) - (delete! t r) - (insert-last! t r) - (check-rb-structure! t)))) - - - - - (define mixed-tests - (test-suite - "other miscellaneous tests" - (printf "mixed tests...\n") - (test-case - "Another sequence identified by the random monkey" - ;inserting "A" to front - ;inserting "B" to front - ;Inserting "C" after "A" - ;Inserting "D" after "B" - ;inserting "E" to back - ;inserting "F" to front - ;deleting "F" - ;inserting "G" to back - ;inserting "H" to back - ;inserting "I" to front - ;inserting "J" to back - ;inserting "K" to front - ;inserting "L" before "E" - (define t (new-string-tree)) - - (insert-first/data! t "A") - (check-equal? (tree-items t) '("A")) - (insert-first/data! t "B") - (check-equal? (tree-items t) '("B" "A")) - (insert-after/data! t (search t 1) "C") - (check-equal? (tree-items t) '("B" "A" "C")) - (insert-after/data! t (search t 0) "D") - (check-equal? (tree-items t) '("B" "D" "A" "C")) - (insert-last/data! t "E") - (check-equal? (tree-items t) '("B" "D" "A" "C" "E")) - (insert-first/data! t "F") - (check-equal? (tree-items t) '("F" "B" "D" "A" "C" "E")) - (delete! t (search t 0)) - (check-equal? (tree-items t) '("B" "D" "A" "C" "E")) - (insert-last/data! t "G") - (check-equal? (tree-items t) '("B" "D" "A" "C" "E" "G")) - (insert-last/data! t "H") - (check-equal? (tree-items t) '("B" "D" "A" "C" "E" "G" "H")) - (insert-first/data! t "I") - (check-equal? (tree-items t) '("I" "B" "D" "A" "C" "E" "G" "H")) - (insert-last/data! t "J") - (check-equal? (tree-items t) '("I" "B" "D" "A" "C" "E" "G" "H" "J")) - (insert-first/data! t "K") - (check-equal? (tree-items t) '("K" "I" "B" "D" "A" "C" "E" "G" "H" "J")) - (check-equal? (node-data (search t 6)) "E") - (insert-before/data! t (search t 6) "L") - (check-equal? (tree-items t) '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J")) - - (for/fold ([n (minimum (tree-root t))]) ([w (in-list '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J"))]) - (check-equal? (node-data n) w) - (successor n)) - - (for/fold ([n (maximum (tree-root t))]) ([w (in-list (reverse '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J")))]) - (check-equal? (node-data n) w) - (predecessor n))))) - - - (define search-tests - (test-suite - "search-tests" - (printf "search tests...\n") - (test-begin - (define t (new-string-tree)) - (check-equal? (search t 0) nil) - (check-equal? (search t 129348) nil)) - - (test-begin - (define t (new-string-tree)) - (insert-last/data! t "hello") - (check-equal? (node-data (search t 0)) "hello") - (check-equal? (node-data (search t 1)) "hello") - (check-equal? (node-data (search t 2)) "hello") - (check-equal? (node-data (search t 3)) "hello") - (check-equal? (node-data (search t 4)) "hello") - ;; Edge case: - (check-equal? (search t 5) nil) - ;; Edge case: - (check-equal? (search t -1) nil)) - - - ;; Empty nodes should get skipped over by search, though - ;; the nodes are still there in the tree. - (test-begin - (define t (new-string-tree)) - (insert-last/data! t "hello") - (insert-last/data! t "") - (insert-last/data! t "") - (insert-last/data! t "") - (insert-last/data! t "world") - (insert-last/data! t "") - (insert-last/data! t "") - (insert-last/data! t "") - (insert-last/data! t "test!") - (check-equal? (tree-node-count t) 9) - (check-equal? (node-data (search t 0)) "hello") - (check-equal? (node-data (search t 1)) "hello") - (check-equal? (node-data (search t 2)) "hello") - (check-equal? (node-data (search t 3)) "hello") - (check-equal? (node-data (search t 4)) "hello") - (check-equal? (node-data (search t 5)) "world") - (check-equal? (node-data (search t 6)) "world") - (check-equal? (node-data (search t 7)) "world") - (check-equal? (node-data (search t 8)) "world") - (check-equal? (node-data (search t 9)) "world") - (check-equal? (node-data (search t 10)) "test!")) - - - - - (test-begin - (define t (new-string-tree)) - (define words (string-split "This is a test of the emergency broadcast system")) - (for ([word (in-list words)]) - (insert-last/data! t word)) - (check-equal? (node-data (search t 0)) "This") - (check-equal? (node-data (search t 1)) "This") - (check-equal? (node-data (search t 2)) "This") - (check-equal? (node-data (search t 3)) "This") - (check-equal? (node-data (search t 4)) "is") - (check-equal? (node-data (search t 5)) "is") - (check-equal? (node-data (search t 6)) "a") - (check-equal? (node-data (search t 7)) "test") - (check-equal? (node-data (search t 8)) "test") - (check-equal? (node-data (search t 9)) "test") - (check-equal? (node-data (search t 10)) "test") - (check-equal? (node-data (search t 11)) "of") - (check-equal? (node-data (search t 12)) "of") - (check-equal? (node-data (search t 13)) "the") - (check-equal? (node-data (search t 14)) "the") - (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")) - - (test-case - "searching with residuals" - (define t (new-string-tree)) - (define words (string-split "This is a test of the emergency broadcast system")) - (for ([word (in-list words)]) - (insert-last/data! t 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 - (test-suite - "position tests" - (printf "position tests...\n") - (test-case - "empty case" - (check-equal? (position nil) -1)) - - (test-case - "simple case" - (define t (new-string-tree)) - (insert-last/data! t "foobar") - (check-equal? (position (tree-root t)) 0)) - - (test-case - "simple case of a few random words" - (define t (new-string-tree)) - (insert-last/data! t "uc berkeley") - (insert-last/data! t "wpi") - (insert-last/data! t "brown") - (insert-last/data! t "university of utah") - (check-equal? (position (tree-first t)) 0) - (check-equal? (position (successor (tree-first t))) 11) - (check-equal? (position (successor (successor (tree-first t)))) 14) - (check-equal? (position (successor (successor (successor (tree-first t))))) 19)) - - (test-case - "slightly larger example" - (define t (new-string-tree)) - (define words - (string-split - "In a hole in the ground there lived a hobbit. Not a - nasty, dirty wet hole, filled with the ends of worms and an oozy - smell, nor yet a dry, bare, sandy ole with nothing in it to sit down on - or to eat: it was a hobbit-hole, and that means comfort.")) - (for ([w (in-list words)]) - (insert-last/data! t w)) - (for/fold ([pos 0]) ([w (in-list words)]) - (define n (search t pos)) - (check-equal? (node-data n) w) - (check-equal? (position n) pos) - (+ pos (string-length w)))))) - - - (define concat-tests - (test-suite - "concat tests" - (printf "concat tests...\n") - (test-case - "empty case" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-true (nil? (tree-root t1+t2))) - (check-rb-structure! t1+t2)) - - (test-case - "left is empty" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t2 "hello") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("hello")) - (check-rb-structure! t1+t2)) - - (test-case - "right is empty" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t1 "hello") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("hello")) - (check-rb-structure! t1+t2)) - - (test-case - "two single trees" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t1 "append") - (insert-last/data! t2 "this") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("append" "this")) - (check-rb-structure! t1+t2)) - - - (test-case - "joining back and forth" - (define t (new-tree)) - (for ([i (in-range 20)]) - (define t2 (new-tree)) - (insert-last/data! t2 i) - (cond - [(even? i) - (set! t (join! t t2)) - (check-true (nil? (tree-root t2)))] - [else - (set! t (join! t2 t)) - (check-true (nil? (tree-root t2)))])) - (check-equal? (tree-items t) - '(19 17 15 13 11 9 7 5 3 1 0 2 4 6 - 8 10 12 14 16 18)) - (check-rb-structure! t)) - - - (test-case - "appending 2-1" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t1 "love") - (insert-last/data! t1 "and") - (insert-last/data! t2 "peace") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("love" "and" "peace")) - (check-rb-structure! t1+t2)) - - (test-case - "appending 1-2" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t1 "love") - (insert-last/data! t2 "and") - (insert-last/data! t2 "war") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("love" "and" "war")) - (check-rb-structure! t1+t2)) - - - (test-case - "appending 3-3" - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (insert-last/data! t1 "four") - (insert-last/data! t1 "score") - (insert-last/data! t1 "and") - (insert-last/data! t2 "seven") - (insert-last/data! t2 "years") - (insert-last/data! t2 "ago") - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (tree-items t1+t2) '("four" "score" "and" "seven" "years" "ago")) - (check-rb-structure! t1+t2)) - - - (test-case - "a bigger concatenation example. Gettysburg Address, November 19, 1863." - (define t1 (new-string-tree)) - (define t2 (new-string-tree)) - (define t3 (new-string-tree)) - (define m1 "Four score and seven years ago our fathers - brought forth on this continent a new nation, - conceived in Liberty, and dedicated to the proposition - that all men are created equal.") - (define m2 "Now we are engaged in a great civil war, testing - whether that nation, or any nation so conceived and so dedicated, - can long endure. We are met on a great battle-field of that war. - We have come to dedicate a portion of that field, as a final - resting place for those who here gave their lives that that nation - might live. It is altogether fitting and proper that we should do this.") - (define m3 "But, in a larger sense, we can not dedicate -- we can not consecrate - -- we can not hallow -- this ground. The brave men, living and dead, - who struggled here, have consecrated it, far above our poor power to - add or detract. The world will little note, nor long remember what we - say here, but it can never forget what they did here. It is for us the living, - rather, to be dedicated here to the unfinished work which they who fought here - have thus far so nobly advanced. It is rather for us to be here dedicated to - the great task remaining before us -- that from these honored dead we take - increased devotion to that cause for which they gave the last full measure - of devotion -- that we here highly resolve that these dead shall not have died - in vain -- that this nation, under God, shall have a new birth of freedom -- - and that government of the people, by the people, for the people, - shall not perish from the earth.") - (for ([word (in-list (string-split m1))]) - (insert-last/data! t1 word)) - (for ([word (in-list (string-split m2))]) - (insert-last/data! t2 word)) - (for ([word (in-list (string-split m3))]) - (insert-last/data! t3 word)) - (define speech-tree (join! (join! t1 t2) t3)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-true (nil? (tree-root t3))) - (check-equal? (tree-items speech-tree) - (string-split (string-append m1 " " m2 " " m3))) - (check-rb-structure! speech-tree)))) - - (define split-tests - (test-suite - "splitting" - (printf "split tests...\n") - (test-case - "(a) ---split-a--> () ()" - (define t (new-string-tree)) - (insert-last/data! t "a") - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '()) - (check-equal? (tree-items r) '()) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b) ---split-a--> () (b)" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '()) - (check-equal? (tree-items r) '("b")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b) ---split-b--> (a) ()" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '("a")) - (check-equal? (tree-items r) '()) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c) ---split-b--> (a) (c)" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '("a")) - (check-equal? (tree-items r) '("c")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c d) ---split-a--> () (b c d)" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (insert-last/data! t "d") - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '()) - (check-equal? (tree-items r) '("b" "c" "d")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - - (test-case - "(a b c d) ---split-b--> (a) (c d)" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (insert-last/data! t "d") - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '("a")) - (check-equal? (tree-items r) '("c" "d")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - - (test-case - "(a b c d) ---split-c--> (a b) (d)" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (insert-last/data! t "d") - (define n (search t 2)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '("a" "b")) - (check-equal? (tree-items r) '("d")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c d) ---split-d--> (a b c) ()" - (define t (new-string-tree)) - (insert-last/data! t "a") - (insert-last/data! t "b") - (insert-last/data! t "c") - (insert-last/data! t "d") - (define n (search t 3)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (tree-items l) '("a" "b" "c")) - (check-equal? (tree-items r) '()) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a ... z) ---split-m--> (a ... l) (n ...z)" - (define t (new-string-tree)) - (for ([i (in-range 26)]) - (insert-last/data! - t - (string (integer->char (+ i (char->integer #\a)))))) - (define letter-m (search t 12)) - (define-values (l r) (split! t letter-m)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? letter-m)) - (check-equal? (tree-items l) '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l")) - (check-equal? (tree-items r) '("n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a ... z) ---split-n--> (a ... l) (n ...z)" - (define letters (for/list ([i (in-range 26)]) - (string (integer->char (+ i (char->integer #\a)))))) - (for ([n (in-range 26)]) - (define t (new-string-tree)) - (for ([w (in-list letters)]) - (insert-last/data! t w)) - (define a-letter (search t n)) - (define-values (l r) (split! t a-letter)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? a-letter)) - (define-values (expected-l 1+expected-r) (split-at letters n)) - (check-equal? (tree-items l) expected-l) - (check-equal? (tree-items r) (rest 1+expected-r)) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t))))) - - - - (define predecessor-successor-min-max-tests - (test-suite - "predecesssor, successor, maximum, minimum tests" - (printf "navigation tests\n") - (test-case - "simple predecessor and successor tests" - (define known-model '("this" "is" "yet" "another" "test" "that" "makes" "sure" "we" "can" "walk" - "the" "tree" "reliably" "using" "successor" "and" "predecessor")) - ;; Make sure successor, predecessor are both doing the right thing on it: - (define t (new-string-tree)) - (for ([w (in-list known-model)]) - (insert-last/data! t w)) - (check-equal? (node-data (minimum (tree-root t))) "this") - (check-equal? (node-data (maximum (tree-root t))) "predecessor") - (for/fold ([n (tree-first t)]) ([w (in-list known-model)]) - (check-equal? (node-data n) w) - (successor n)) - (for/fold ([n (tree-last t)]) ([w (in-list (reverse known-model))]) - (check-equal? (node-data n) w) - (predecessor n))) - - (test-case - "one-element tree" - (define t (new-string-tree)) - (insert-last/data! t "unary") - (check-eq? (predecessor (tree-root t)) nil) - (check-eq? (successor (tree-root t)) nil) - (check-eq? (maximum (tree-root t)) (tree-root t)) - (check-eq? (minimum (tree-root t)) (tree-root t))) - - (test-case - "nil cases" - (check-eq? (predecessor nil) nil) - (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-string-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)) - (define two (new-node 2)) - (define seven (new-node 7)) - (define five (new-node 5)) - (define eight (new-node 8)) - (define eleven (new-node 11)) - (define fourteen (new-node 14)) - (define fifteen (new-node 15)) - (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 angry-monkey% - (let () - (define-local-member-name catch-and-concat-at-front) - (class object% - (super-new) - (define known-model '()) - (define t (new-string-tree)) - - (define (random-word) - (build-string (add1 (random 5)) - (lambda (i) - (integer->char (+ (char->integer #\a) (random 26)))))) - (define/public (get-tree) t) - (define/public (get-model) known-model) - - (define/public (insert-front!) - (define new-word (random-word)) - #;(printf "inserting ~s to front\n" new-word) - (set! known-model (cons new-word known-model)) - (insert-first/data! t new-word)) - - (define/public (insert-back!) - (define new-word (random-word)) - #;(printf "inserting ~s to back\n" new-word) - (set! known-model (append known-model (list new-word))) - (insert-last/data! t new-word)) - - (define/public (delete-kth! k) - #;(printf "deleting ~s\n" (list-ref known-model k)) - (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))))) - - ;; kth-offset: natural -> natural - ;; Returns the offset of the kth word in the model. - (define (kth-offset k) - (for/fold ([offset 0]) ([i (in-range k)] - [word (in-list known-model)]) - (+ offset (string-length word)))) - - - (define/public (delete-random!) - (when (not (empty? known-model)) - ;; Delete a random word if we can. - (define k (random (length known-model))) - (delete-kth! k))) - - - (define/public (insert-before/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)) - #;(printf "Inserting ~s before ~s\n" new-word (node-data node)) - (insert-before/data! t node new-word) - (set! known-model (append (take known-model k) - (list new-word) - (drop known-model k))))) - - (define/public (insert-after/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)) - #;(printf "Inserting ~s after ~s\n" new-word (node-data node)) - (insert-after/data! t node new-word) - (set! known-model (append (take known-model (add1 k)) - (list new-word) - (drop known-model (add1 k)))))) - - - - - ;; Concatenation. Drop our existing tree and throw it at the - ;; other m2 monkey. - (define/public (throw-all-at-monkey m2) - (send m2 catch-and-concat-at-front t known-model) - (set! t (new-string-tree)) - (set! known-model '())) - - - ;; Splitting/concatenation. Split what we've got, keep the - ;; left, and throw the right to our friend m2. - (define/public (throw-some-at-monkey m2) - (when (not (empty? known-model)) - (define k (random (length known-model))) - (define offset (kth-offset k)) - (define node (search t offset)) - (define-values (l r) (split! t node)) - (check-true (nil? (tree-root t))) - (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)))) - - ;; private - (define/public (catch-and-concat-at-front other-t other-known-model) - (set! t (join! other-t t)) - (check-true (nil? (tree-root other-t))) - (set! known-model (append other-known-model known-model))) - - - (define/public (check-consistency!) - ;; Check that the structure is consistent with our model. - (check-equal? (tree-items t) known-model) - - ;; And make sure it's still an rb-tree: - (check-rb-structure! t))))) - - - - (define angry-monkey-test-1 - (test-suite - "A simulation of an angry monkey bashing at the tree." - (test-begin - (printf "monkey tests 1...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 12) - [(0 1 2) - (send m insert-front!)] - [(3 4 5) - (send m insert-back!)] - [(6 7) - (send m insert-after/random!)] - [(8 9) - (send m insert-before/random!)] - [(10 11) - (send m delete-random!)])) - (send m check-consistency!))))) - - - (define angry-monkey-test-2 - (test-suite - "Another simulation of an angry monkey bashing at the tree. - (more likely to delete)" - (test-begin - (printf "monkey tests 2...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 12) - [(0 1) - (send m insert-front!)] - [(2 3) - (send m insert-back!)] - [(4 5) - (send m insert-after/random!)] - [(6 7) - (send m insert-before/random!)] - [(8 9 10 11) - (send m delete-random!)])) - (send m check-consistency!))))) - - (define angry-monkey-pair-test - (test-suite - "Simulation of a pair of angry monkeys bashing at the tree. - Occasionally they'll throw things at each other." - (test-begin - (printf "monkey tests paired...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m1 (new angry-monkey%)) - (define m2 (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (define random-monkey (if (= 0 (random 2)) m1 m2)) - (case (random 12) - [(0 1 2) - (send random-monkey insert-front!)] - [(3 4 5) - (send random-monkey insert-back!)] - [(6 7) - (send random-monkey delete-random!)] - [(8) - (send m1 throw-all-at-monkey m2)] - [(9) - (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!))))) - - - (define angry-monkey-pair-test-parallel - (test-suite - ;; What do you call a group of monkeys? A troop! - ;; (http://www.npwrc.usgs.gov/about/faqs/animals/names.htm) - "Simulation of a troop of angry monkeys bashing at the tree. - They should not see each other." - (test-begin - (printf "monkey tests parallel...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (define threads - (for/list ([i (in-range 5)]) - (thread (lambda () - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 6) - [(0) - (send m insert-front!)] - [(1) - (send m insert-back!)] - [(2) - (send m delete-random!)] - [(3) - (send m insert-after/random!)] - [(4) - (send m insert-before/random!)])) - (send m check-consistency!)))))) - (for ([t (in-list threads)]) - (thread-wait t))))) - - - (define exhaustive-split-test - (test-suite - "exhaustive split test..." - ;; Another exhaustive test. Among N elements, split everywhere, - ;; and make sure we get the expected values on the left and right. - ;; Also print out how long it takes to do the actual splitting. - (test-case - "(1 ... n) ---split-k--> (1 ... k-1) (k+1 ...n)" - (printf "exhaustive split test...\n") - (define N 2000) - (define elts (for/list ([i (in-range N)]) i)) - (define total-splitting-time 0) - (for ([n (in-range N)]) - (define t (new-offset-tree)) - (for ([w (in-list elts)]) - (insert-last/data! t w)) - (define pivot - (search-offset t n)) - (define-values (l r) - (time-acc - total-splitting-time - (split! t pivot))) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? pivot)) - (define-values (expected-l 1+expected-r) (split-at elts n)) - (check-equal? (tree-items l) expected-l) - (check-equal? (tree-items r) (rest 1+expected-r))) - (printf "time in split: ~a\n" total-splitting-time)))) - - - - (define all-tests - (test-suite "all-tests" - nil-tests - rotation-tests - insertion-tests - deletion-tests - search-tests - position-tests - concat-tests - predecessor-successor-min-max-tests - fold-tests - split-tests - mixed-tests - - ;; The following tests are a bit more expensive. Wait a while. - angry-monkey-test-1 - angry-monkey-test-2 - angry-monkey-pair-test - angry-monkey-pair-test-parallel - exhaustive-split-test)) - - (void - (printf "Running test suite.\nWarning: this suite can run very slowly under DrRacket when debugging is on.\n") - (run-tests all-tests))) diff --git a/collects/syntax-color/private/rb-token-tree.rkt b/collects/syntax-color/private/rb-token-tree.rkt deleted file mode 100644 index fb6b864b5d..0000000000 --- a/collects/syntax-color/private/rb-token-tree.rkt +++ /dev/null @@ -1,478 +0,0 @@ -#lang racket/base - -;; rbtree implementation of the token-tree% interface. -;; -;; We have to adapt a few things: -;; -;; * rb-trees don't move around their root on search, so we need -;; to keep a separate "focus". -;; -;; * We use rb:nil, but the original client uses #f to indicate -;; empty trees. - -;; For speed, we use the uncontracted forms in red-black.rkt. -(require (prefix-in rb: (submod "red-black.rkt" uncontracted)) - racket/class) - - -(provide token-tree% - insert-first! - insert-last! - insert-last-spec! - insert-first-spec! - node? node-token-length node-token-data - node-left-subtree-length node-left node-right) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-local-member-name - get-rb - set-rb! - set-focus!) - - -(define token-tree% - (class object% - (init (length #f) (data #f)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; state initialization - (define rb (rb:new-tree)) ;; rb is an instance of rb:tree. - (define focus rb:nil) ;; focus is an instance of rb:node. - (define focus-pos -1) ;; optimization: the position of the focus. - (when length - (rb:insert-last/data! rb data length) - (set-focus! (rb:tree-root rb) 0)) - (super-new) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - ;; rb->token-tree: rb:tree -> token-tree% - ;; Wraps a red-black tree into a token tree. - (define (rb->token-tree an-rb) - (define t (new token-tree%)) - (send t set-rb! an-rb) - (send t set-focus! - (rb:tree-first an-rb) - (if (rb:nil-node? (rb:tree-root an-rb)) -1 0)) - t) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; private methods: - (define/public (get-rb) - rb) - - (define/public (set-rb! new-rb) - (set! rb new-rb)) - - (define/public (set-focus! new-focus new-pos) - (set! focus new-focus) - (set! focus-pos new-pos)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; public methods: - - ;; reset-tree: -> void - ;; Empty the contents of the tree. - (define/public (reset-tree) - (rb:reset! rb) - (set-focus! rb:nil -1)) - - (define/public (get-root) - (nil->false focus)) - - (define/public (is-empty?) - (rb:nil-node? focus)) - - (define/public (get-root-length) - (cond - [(rb:nil-node? focus) - 0] - [else - (rb:node-self-width focus)])) - - (define/public (get-root-data) - (cond - [(rb:nil-node? focus) - #f] - [else - (rb:node-data focus)])) - - (define/public (get-root-start-position) - (cond - [(rb:nil-node? focus) - 0] - [else - focus-pos])) - - (define/public (get-root-end-position) - (cond - [(rb:nil-node? focus) - 0] - [else - (+ focus-pos (rb:node-self-width focus))])) - - (define/public (add-to-root-length inc) - (unless (rb:nil-node? focus) - (rb:update-node-self-width! focus (+ (rb:node-self-width focus) inc)))) - - (define/public (search! key-position) - ;; TODO: add unit test that makes sure search works. If there is no - ;; token, the original just jumps to the closest node. - (unless (rb:nil-node? focus) - (cond - [(<= key-position 0) - (set-focus! (rb:tree-first rb) - (first-pos rb))] - [(>= key-position (rb:node-subtree-width (rb:tree-root rb))) - (set-focus! (rb:tree-last rb) - (last-pos rb))] - [else - (cond - ;; optimization: are we already where we're searching? - [(= focus-pos key-position) - (void)] - ;; optimization: are we searching for the immediate successor? - [(= key-position (+ focus-pos (rb:node-self-width focus))) - (define succ (rb:successor focus)) - (cond [(rb:nil-node? succ) - (void)] - [else - (set-focus! succ key-position)])] - [else - (define-values (found-node residue) (rb:search/residual rb key-position)) - (set-focus! found-node (- key-position residue))])]))) - - - ;; last-pos: rb:tree -> natural - ;; Returns the starting position of the last element in rb. - (define (last-pos rb) - (cond - [(rb:nil-node? (rb:tree-root rb)) - -1] - [else - (define pos (- (rb:node-subtree-width (rb:tree-root rb)) - (rb:node-self-width (rb:tree-last rb)))) - pos])) - - (define (first-pos rb) - (cond - [(rb:nil-node? (rb:tree-root rb)) - -1] - [else - 0])) - - - (define/public (search-max!) - (unless (rb:nil-node? focus) - (set-focus! (rb:tree-last rb) (last-pos rb)))) - - (define/public (search-min!) - (unless (rb:nil-node? focus) - (set-focus! (rb:tree-first rb) 0))) - - (define/public (remove-root!) - (unless (rb:nil-node? focus) - (define node-to-delete focus) - (define pred (rb:predecessor focus)) - (cond [(rb:nil-node? pred) - (define succ (rb:successor focus)) - (set-focus! succ (if (rb:nil-node? succ) -1 0))] - [else - (set-focus! pred (- focus-pos (rb:node-self-width pred)))]) - (rb:delete! rb node-to-delete))) - - - - ;; split/data: natural -> (values natural natural token-tree% token-tree% boolean) - ;; Splits the tree into 2 trees, invalidating our own to nil. - ;; - ;; The first two returned values represent the start and end - ;; position of the token(s) at pos. The next two values represent - ;; the tokens before pos and after pos, not including any tokens - ;; adjacent to pos. - ;; - ;; Thus if pos is on a token boundary, 2 tokens will be dropped. - ;; - ;; In this case, the start will be for the first dropped - ;; token and the stop will be for the second. - ;; - ;; The last value is the data at the searched position. - ;; - ;; The two tree's foci will be at the edges adjacent to where the split occurred. - (define/public (split/data pos) - (cond - [(rb:nil-node? focus) - (values 0 0 (new token-tree%) (new token-tree%) #f)] - [else - - ;; We have a few cases to check for: - ;; Is the pivot on the edge boundary of the first or last tokens? - ;; Is the pivot on the boundary between two tokens? - (cond - - ;; Case 1. - ;; At the start-edge of the first token? - [(<= pos 0) - ;; If so, just delete the first token. - (define first-token (rb:tree-first rb)) - (rb:delete! rb first-token) - (define right-tree (rb->token-tree rb)) - (send right-tree set-focus! - (rb:tree-first rb) - (first-pos rb)) - (set-focus! rb:nil -1) - (values 0 - (rb:node-self-width first-token) - (new token-tree%) - right-tree - (rb:node-data first-token))] - - ;; Case 2. - ;; At the end-edge of the last token? - [(>= pos (rb:node-subtree-width (rb:tree-root rb))) - (define total-width (rb:node-subtree-width (rb:tree-root rb))) - (define last-token (rb:tree-last rb)) - - (rb:delete! rb last-token) - (define left-tree (rb->token-tree rb)) - (send left-tree set-focus! (rb:tree-last rb) (last-pos rb)) - (set-focus! rb:nil -1) - (values (- total-width (rb:node-self-width last-token)) - total-width - left-tree - (new token-tree%) - (rb:node-data last-token))] - - [else - ;; Otherwise, pos is somewhere inside the range, and we're - ;; guaranteed to find the pivot somewhere. - (search! pos) - (cond - ;; If the residue after searching is zero, then we're right - ;; on the boundary between two tokens, and must delete both. - [(= focus-pos pos) - (define pivot-node focus) - (define-values (left right) (rb:split! rb pivot-node)) - - ;; We know the left is non-empty, since otherwise we would - ;; have hit case 1. - (define left-last (rb:tree-last left)) - (rb:delete! left left-last) - (set-focus! rb:nil -1) - (define-values (left-tree right-tree) - (values (rb->token-tree left) - (rb->token-tree right))) - (send left-tree set-focus! (rb:tree-last left) (last-pos left)) - (send right-tree set-focus! (rb:tree-first right) (first-pos right)) - (values (- pos (rb:node-self-width left-last)) - (+ pos (rb:node-self-width pivot-node)) - left-tree - right-tree - (rb:node-data pivot-node))] - - [else - ;; Otherwise, the position is inside just one token. - (define pivot-node focus) - (define start-pos focus-pos) - (define end-pos (+ start-pos (rb:node-self-width pivot-node))) - (define-values (left right) (rb:split! rb pivot-node)) - (set-focus! rb:nil -1) - (define-values (left-tree right-tree) - (values (rb->token-tree left) - (rb->token-tree right))) - (send left-tree set-focus! (rb:tree-last left) (last-pos left)) - (send right-tree set-focus! (rb:tree-first right) (first-pos right)) - (values start-pos end-pos - left-tree - right-tree - (rb:node-data pivot-node))])])])) - - - - (define/public (split pos) - (define-values (start-pos end-pos left-tree right-tree data) - (split/data pos)) - (values start-pos end-pos left-tree right-tree)) - - - - ;; split-after: -> token-tree% * token-tree% - ;; splits the tree into 2 trees, setting root to #f - ;; returns a tree including the focus and its predecessors - ;; then the focus's successors - ;; - ;; The left tree's focus is defined to be at its last, - ;; and the right tree's focus is defined to be at its first. - ;; - ;; FIXME: add test case checking semantics of focus after a split-after. - (define/public (split-after) - (cond - [(rb:nil-node? focus) - (values (new token-tree%) (new token-tree%))] - [else - (define-values (left right) (rb:split! rb focus)) - (rb:insert-last! left focus) - (set-focus! rb:nil -1) - (define-values (left-tree right-tree) - (values (rb->token-tree left) (rb->token-tree right))) - (send right-tree set-focus! (rb:tree-first right) (first-pos right)) - (send left-tree set-focus! (rb:tree-last left) (last-pos left)) - (values left-tree right-tree)])) - - - ;; split-before: -> token-tree% * token-tree% - ;; splits the tree into 2 trees, setting root to #f - ;; returns the focus's predecessors, and then a tree including the focus - ;; and its successors. - ;; - ;; The left tree's focus is defined to be at its last, - ;; and the right tree's focus is defined to be at its first. - ;; - ;; FIXME: add test case checking semantics of focus after a split-before. - (define/public (split-before) - (cond - [(rb:nil-node? focus) - (values (new token-tree%) (new token-tree%))] - [else - (define-values (left right) (rb:split! rb focus)) - (rb:insert-first! right focus) - (set-focus! rb:nil -1) - (define-values (left-tree right-tree) - (values (rb->token-tree left) (rb->token-tree right))) - (send left-tree set-focus! (rb:tree-last left) (last-pos left)) - (send right-tree set-focus! (rb:tree-first right) (first-pos right)) - (values left-tree right-tree)])) - - - (define/public (to-list) - (cond - [(rb:nil-node? focus) '()] - [else - (reverse - (rb:tree-fold-inorder rb - (lambda (n acc) - (cons (vector (rb:node-self-width n) - (node-left-subtree-length n) - (rb:node-data n)) - acc)) - '()))])) - - (define/public (for-each f) - (cond - [(rb:nil-node? focus) - (void)] - [else - (rb:tree-fold-inorder rb - (lambda (n acc) - (f acc - (rb:node-self-width n) - (rb:node-data n)) - (+ acc (rb:node-self-width n))) - 0)])))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; insert-first!: token-tree% * token-tree% -> void -;; insert tree2 into tree1 as the first thing. -;; -;; Effects: -;; -;; 1. tree1 will contain the contents of tree2 + tree1 -;; 2. tree2 will be reset to the empty tree. -;; -;; I'm not exactly sure if the behavior of where the tree is focused -;; is something defined. -(define (insert-first! tree1 tree2) - (define-values (rb1 rb2) - (values (send tree1 get-rb) (send tree2 get-rb))) - (define rb-joined (rb:join! rb2 rb1)) - (send tree1 set-rb! rb-joined) - (send tree1 set-focus! - (rb:tree-root rb-joined) - (node-left-subtree-length (rb:tree-root rb-joined))) - (send tree2 reset-tree)) - - -;; insert-last!: token-tree% * token-tree% -> void -;; insert tree2 into tree1 as the last thing. -;; -;; Effects: -;; -;; 1. tree1 will contain the contents of tree1 + tree2 -;; 2. tree2 will be reset to the empty tree. -;; -;; I'm not exactly sure if the behavior of where the tree is focused -;; is something defined. -(define (insert-last! tree1 tree2) - (define-values (rb1 rb2) - (values (send tree1 get-rb) (send tree2 get-rb))) - (define rb-joined (rb:join! rb1 rb2)) - (send tree1 set-rb! rb-joined) - (send tree1 set-focus! - (rb:tree-root rb-joined) - (node-left-subtree-length (rb:tree-root rb-joined))) - (send tree2 reset-tree)) - - - -;; insert-last-spec!: tree natural any -> void -;; Inserts content at the end of the tree. -;; -;; I'm not exactly sure if the behavior of where the tree is focused -;; is something defined. -(define (insert-last-spec! tree length data) - ;; TODO: add unit test that makes sure insert-last-spec! works. It's missing - ;; from the test suite. - (define the-rb (send tree get-rb)) - (rb:insert-last/data! the-rb data length) - (send tree set-focus! - (rb:tree-root the-rb) - (node-left-subtree-length (rb:tree-root the-rb)))) - - -;; insert-first-spec!: tree natural any -> void -;; Inserts content at the beginning of the tree. -(define (insert-first-spec! tree length data) - ;; TODO: add unit test that makes sure insert-last-spec! works. It's missing - ;; from the test suite. - (define the-rb (send tree get-rb)) - (rb:insert-first/data! the-rb data length) - (send tree set-focus! - (rb:tree-root the-rb) - (node-left-subtree-length (rb:tree-root the-rb)))) - - - -(define node? - (procedure-rename rb:node? 'node?)) -(define node-token-data - (procedure-rename rb:node-data 'node-token-data)) -(define node-token-length - (procedure-rename rb:node-self-width 'node-token-length)) -(define (node-left-subtree-length n) - (rb:node-subtree-width (rb:node-left n))) - -(define (node-left n) - (cond [(eq? n #f) - #f] - [else - (nil->false (rb:node-left n))])) - -(define (node-right n) - (cond [(eq? n #f) - #f] - [else - (nil->false (rb:node-right n))])) - -(define-syntax-rule (nil->false n) - (if (eq? n rb:nil) - #f - n)) diff --git a/collects/syntax-color/private/red-black.rkt b/collects/syntax-color/private/red-black.rkt deleted file mode 100644 index 79cac6cf1a..0000000000 --- a/collects/syntax-color/private/red-black.rkt +++ /dev/null @@ -1,2750 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base) - racket/contract) - -;; Implementation of an augmented red-black tree, where extra -;; information supports position-based queries. -;; -;; Author: Danny Yoo (dyoo@hashcollision.org) -;; -;; -;; The usage case of this structure is to maintain an ordered sequence -;; of items. Each item has an internal length. We want to support -;; quick lookup by position, as well as the catenation and splitting -;; of the sequence. -;; -;; These operations are typical of an editor's buffer, which must -;; maintain a sequence of tokens in order, allowing for arbitrary -;; search, insert, and delete into the sequence. -;; -;; -;; -;; We follow the basic outline for order-statistic trees described in -;; CLRS. -;; -;; Cormen, Leiserson, Rivest, Stein. Introduction to Algorithms, 3rd edition. -;; http://mitpress.mit.edu/books/introduction-algorithms -;; -;; In our case, each node remembers the total width of its -;; subtree. This allows us to perform search-by-position very -;; quickly. -;; -;; We also incorporate some elements of the design in: -;; -;; Ron Wein. Efficient implemenation of red-black trees with -;; split and catenate operations. (2005) -;; http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.109.4875 -;; -;; where we keep track of the first and last pointers. My implementation of -;; split is, in my opinion, easier to read, as we go bottom-up rather than -;; top-down, without the weird need for two separate pivots. -;; -;; -;; This module has test cases in a test submodule below. -;; -;; Use: -;; -;; raco test red-black.rkt to execute these tests. -;; - - -;; TODO: defensively check whether the node being deleted or split off -;; actually exists in the tree. - - -(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 nil?/proc 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 red?/proc red? (node? . -> . boolean?)] - [rename black?/proc 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) (attached-in-tree/c t)]) - [result any/c])] - [join! (->i ([t1 tree?] [t2 (t1) (and/c tree? (not-eq?/c t1))]) - [result tree?])] - [rename public:concat! concat! - (->i ([t1 tree?] [n singleton-node?] [t2 (t1) (and/c tree? (not-eq?/c t1))]) - [result any/c])] - [split! (->i ([t tree?] - [n (t) (attached-in-tree/c t)]) - (values [t1 tree?] [t2 tree?]))] - - [reset! (tree? . -> . any)] - - [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? . -> . 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: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define red 'red) -(define black 'black) - - -(struct tree (root ;; node The root node of the tree. - first ;; node optimization: Points to the first element. - last ;; node optimization: Points to the last element. - bh) ;; natural optimization: The black height of the entire tree. - #:mutable) - - -(struct node (data ;; Any - self-width ;; Natural - subtree-width ;; Natural - parent ;; node - left ;; node - right ;; node - color) ;; (U red black) - #:mutable) - - -;; As in CLRS, we use a single nil sentinel node that represents nil. -(define nil (let ([v (node #f 0 0 #f #f #f black)]) - (set-node-parent! v v) - (set-node-left! v v) - (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)))) - - - -;; attached-in-tree/c: tree -> contract -;; -;; 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 (attached-in-tree/c t) - (flat-named-contract 'attached-in-tree/c - (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)])))))) - - -;; not-eq?/c: any -> flat-contract -;; Returns a flat contract that checks that the value isn't eq? to x. -(define (not-eq?/c x) - (flat-named-contract 'not-eq?/c - (lambda (y) - (not (eq? x y))))) - - - - -;; nil?: node -> boolean -;; Tell us if we're at the distinguished nil node. -(define-syntax (nil? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (eq? x nil))] - [(_ . args) - (syntax/loc stx - (nil?/proc . args))] - [_ - (identifier? stx) - #'nil?/proc])) -(define nil?/proc (procedure-rename (lambda (x) (nil? x)) 'nil?)) - - -;; red?: node -> boolean -;; Is the node red? -(define-syntax (red? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (let ([v x]) - (eq? (node-color v) red)))] - [(_ . args) - (syntax/loc stx - (red?/proc . args))] - [_ - (identifier? stx) - #'red?/proc])) -(define red?/proc (procedure-rename (lambda (x) (red? x)) 'red?)) - - -;; black?: node -> boolean -;; Is the node black? -(define-syntax (black? stx) - (syntax-case stx () - [(_ x) - (syntax/loc stx - (let ([v x]) - (eq? (node-color v) black)))] - [(_ . args) - (syntax/loc stx - (black?/proc . args))] - [_ - (identifier? stx) - #'black?/proc])) -(define black?/proc (procedure-rename (lambda (x) (black? x)) 'black?)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; Next, the operations: - - -;; new-tree: -> tree -;; Creates a fresh tree. -(define (new-tree) - (tree nil nil nil 0)) - - -;; new-node: -> node -;; Creates a new singleton node. -(define (new-node data width) - (node data width width nil nil nil red)) - - -;; minimum: node -> node -;; Looks for the minimum element of the tree rooted at n. -(define (minimum n) - (let loop ([n n]) - (define left (node-left n)) - (cond - [(nil? left) - n] - [else - (loop left)]))) - -;; maximum: node -> node -;; Looks for the maximum element of the tree rooted at n. -(define (maximum n) - (let loop ([n n]) - (define right (node-right n)) - (cond - [(nil? right) - n] - [else - (loop right)]))) - - -;; successor: node -> node -;; Given a node, walks to the successor node. -;; If there is no successor, returns the nil node. -(define (successor x) - (cond [(not (nil? (node-right x))) - (minimum (node-right x))] - [else - (let loop ([x x] - [y (node-parent x)]) - (cond - [(and (not (nil? y)) (eq? x (node-right y))) - (loop y (node-parent y))] - [else - y]))])) - -;; predecessor: node -> node -;; Given a node, walks to the predecessor node. -;; If there is no predecessor, returns the nil node. -(define (predecessor x) - (cond [(not (nil? (node-left x))) - (maximum (node-left x))] - [else - (let loop ([x x] - [y (node-parent x)]) - (cond - [(and (not (nil? y)) (eq? x (node-left y))) - (loop y (node-parent y))] - [else - y]))])) - - -;; update-node-subtree-width!: node -> void -;; INTERNAL -;; Assuming the node-subtree-width of the left and right are -;; correct, computes the subtree-width of n and updates a-node. -;; -;; Note: this does not trust the local cache in (node-subtree-width -;; n), but does trust node-subtree-width of the left and right -;; subtrees. -(define (update-node-subtree-width! a-node) - (let* ([n a-node] - [left (node-left n)] - [right (node-right n)]) - (set-node-subtree-width! a-node - (+ (node-subtree-width left) - (node-self-width n) - (node-subtree-width right))))) - - - -;; update-subtree-width-up-to-root!: node -> void -;; INTERNAL -;; Updates the subtree width statistic from a-node upward to the root. -;; -;; * The subtree width field of a-node and its ancestors should be updated. -(define (update-subtree-width-up-to-root! a-node) - (let loop ([n a-node]) - (cond - [(nil? n) - (void)] - [else - (update-node-subtree-width! n) - (loop (node-parent n))]))) - - - -;; 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)) - - - - -;; 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 -;; are valid. -(define (insert-first! a-tree x) - (set-node-color! x red) - (cond - [(nil? (tree-root a-tree)) - (set-tree-root! a-tree x) - (set-tree-first! a-tree x) - (set-tree-last! a-tree x)] - [else - (define first (tree-first a-tree)) - (set-node-left! first x) - (set-node-parent! x first) - (set-tree-first! a-tree x)]) - (update-subtree-width-up-to-root! (node-parent x)) - (fix-after-insert! a-tree x)) - - - -;; insert-last!: tree (and/c (not nil?) node?) -> void -;; Insert node x as the last element in the tree. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-last! a-tree x) - (set-node-color! x red) - (cond - [(nil? (tree-root a-tree)) - (set-tree-root! a-tree x) - (set-tree-first! a-tree x) - (set-tree-last! a-tree x)] - [else - (define last (tree-last a-tree)) - (set-node-right! last x) - (set-node-parent! x last) - (set-tree-last! a-tree x)]) - (update-subtree-width-up-to-root! (node-parent x)) - (fix-after-insert! a-tree x)) - - -;; insert-before!: tree node (and/c (not nil?) node?) -> void -;; Insert node x before element 'before' of the tree. -;; x will be the immmediate predecessor of before upon completion. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-before! a-tree before x) - (cond - [(nil? (node-left before)) - (set-node-left! before x) - (set-node-parent! x before)] - [else - (define y (maximum (node-left before))) - (set-node-right! y x) - (set-node-parent! x y)]) - (set-node-color! x red) - (when (eq? before (tree-first a-tree)) - (set-tree-first! a-tree x)) - (update-subtree-width-up-to-root! (node-parent x)) - (fix-after-insert! a-tree x)) - - -;; insert-after!: tree node (and/c (not nil?) node?) -> void -;; Insert node x after element 'after' of the tree. -;; x will be the immmediate successor of after upon completion. -;; x is assumed to be a singleton element whose fields -;; are valid. -(define (insert-after! a-tree after x) - (cond - [(nil? (node-right after)) - (set-node-right! after x) - (set-node-parent! x after)] - [else - (define y (minimum (node-right after))) - (set-node-left! y x) - (set-node-parent! x y)]) - (set-node-color! x red) - (when (eq? after (tree-last a-tree)) - (set-tree-last! a-tree x)) - (update-subtree-width-up-to-root! (node-parent x)) - (fix-after-insert! a-tree x)) - - -;; insert-first/data!: tree data width -> void -;; Insert before the first element of the tree. -(define (insert-first/data! a-tree data width) - (define x (new-node data width)) - (insert-first! a-tree x)) - - -;; insert-last/data!: tree data width -> void -;; Insert after the last element in the tree. -(define (insert-last/data! a-tree data width) - (define x (new-node data width)) - (insert-last! a-tree x)) - - -;; insert-before/data!: tree data width -> void -;; Insert before the first element of the tree. -(define (insert-before/data! a-tree n data width) - (define x (new-node data width)) - (insert-before! a-tree n x)) - - -;; insert-after/data!: tree node data width -> void -;; Insert after the last element in the tree. -(define (insert-after/data! a-tree n data width) - (define x (new-node data width)) - (insert-after! a-tree n x)) - - - - -;; left-rotate!: tree node natural -> void -;; INTERNAL -;; Rotates the x node node to the left. -;; Preserves the auxiliary information for position queries. -(define (left-rotate! a-tree x) - (define y (node-right x)) - (set-node-right! x (node-left y)) - (unless (nil? (node-left y)) - (set-node-parent! (node-left y) x)) - (set-node-parent! y (node-parent x)) - (cond [(nil? (node-parent x)) - (set-tree-root! a-tree y)] - [(eq? x (node-left (node-parent x))) - (set-node-left! (node-parent x) y)] - [else - (set-node-right! (node-parent x) y)]) - (set-node-left! y x) - (set-node-parent! x y) - - ;; Looking at Figure 1.32 of CLRS: - ;; The change to the statistics can be locally computed after the - ;; rotation: - (set-node-subtree-width! y (node-subtree-width x)) - (update-node-subtree-width! x)) - - -;; right-rotate!: tree node natural -> void -;; INTERNAL -;; Rotates the y node node to the right. -;; (Symmetric to the left-rotate! function.) -;; Preserves the auxiliary information for position queries. -(define (right-rotate! a-tree y) - (define x (node-left y)) - (set-node-left! y (node-right x)) - (unless (nil? (node-right x)) - (set-node-parent! (node-right x) y)) - (set-node-parent! x (node-parent y)) - (cond [(nil? (node-parent y)) - (set-tree-root! a-tree x)] - [(eq? y (node-right (node-parent y))) - (set-node-right! (node-parent y) x)] - [else - (set-node-left! (node-parent y) x)]) - (set-node-right! x y) - (set-node-parent! y x) - - ;; Looking at Figure 1.32 of CLRS: - ;; The change to the statistics can be locally computed after the - ;; rotation: - (set-node-subtree-width! x (node-subtree-width y)) - (update-node-subtree-width! y)) - - -;; fix-after-insert!: tree node natural -> void -;; INTERNAL -;; Corrects the red/black tree property via node rotations after an -;; insertion. If there's a violation, then it's at z where both z and -;; its parent are red. -(define (fix-after-insert! a-tree z) - (let loop ([z z]) - (define z.p (node-parent z)) - (when (red? z.p) - (define z.p.p (node-parent z.p)) - (cond [(eq? z.p (node-left z.p.p)) - (define y (node-right z.p.p)) - (cond [(red? y) - (set-node-color! z.p black) - (set-node-color! y black) - (set-node-color! z.p.p red) - (loop z.p.p)] - [else - (cond [(eq? z (node-right z.p)) - (let ([new-z z.p]) - (left-rotate! a-tree new-z) - (set-node-color! (node-parent new-z) black) - (set-node-color! (node-parent (node-parent new-z)) red) - (right-rotate! a-tree (node-parent (node-parent new-z))) - (loop new-z))] - [else - (set-node-color! z.p black) - (set-node-color! z.p.p red) - (right-rotate! a-tree z.p.p) - (loop z)])])] - [else - (define y (node-left z.p.p)) - (cond [(red? y) - (set-node-color! z.p black) - (set-node-color! y black) - (set-node-color! z.p.p red) - (loop z.p.p)] - [else - (cond [(eq? z (node-left z.p)) - (let ([new-z z.p]) - (right-rotate! a-tree new-z) - (set-node-color! (node-parent new-z) black) - (set-node-color! (node-parent (node-parent new-z)) red) - (left-rotate! a-tree - (node-parent (node-parent new-z))) - (loop new-z))] - [else - (set-node-color! z.p black) - (set-node-color! z.p.p red) - (left-rotate! a-tree z.p.p) - (loop z)])])]))) - (when (red? (tree-root a-tree)) - (set-tree-bh! a-tree (add1 (tree-bh a-tree))) - (set-node-color! (tree-root a-tree) black))) - - - - -;; delete!: tree node -> void -;; Removes the node from the tree. -;; Follows the description of CLRS, but with a few extensions: -;; -;; * Importantly, we do not ever mutate the sentinel nil node's parent. -;; This means we takes special care of remembering what it should be, -;; so that the deletion fixup can properly walk the tree. -;; We do this so that we can preserve thread-safety: the nil node is global, -;; so mutating it is a Bad Thing. -;; -;; * Does the statistic update, following the strategy of augmented -;; red-black trees. -(define (delete! a-tree z) - - ;; First, adjust tree-first and tree-last if we end up - ;; removing either from the tree. - (when (eq? z (tree-first a-tree)) - (set-tree-first! a-tree (successor z))) - (when (eq? z (tree-last a-tree)) - (set-tree-last! a-tree (predecessor z))) - - (define y z) - (define y-original-color (node-color y)) - (let-values ([(x y-original-color nil-parent) - (cond - ;; If either the left or right child of z is nil, - ;; deletion is merely replacing z with its other child x. - ;; (Of course, we then have to repair the damage.) - [(nil? (node-left z)) - (define z.p (node-parent z)) - (define x (node-right z)) - (define nil-parent (transplant-for-delete! a-tree z x)) - ;; At this point, we need to repair the statistic where - ;; where the replacement happened, since z's been replaced with x. - ;; The x subtree is ok, so we need to begin the statistic repair - ;; 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) - (set-node-subtree-width! z (node-self-width z)) - - (values x y-original-color nil-parent)] - - ;; This case is symmetric with the previous case. - [(nil? (node-right z)) - (define z.p (node-parent z)) - (define x (node-left z)) - (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) - (set-node-subtree-width! z (node-self-width z)) - (values x y-original-color nil-parent)] - - ;; The hardest case is when z has non-nil left and right. - ;; We take the minimum of z's right subtree and replace - ;; z with it. - [else - (let* ([y (minimum (node-right z))] - [y-original-color (node-color y)]) - ;; At this point, y's left is nil by definition of minimum. - (define x (node-right y)) - (define nil-parent - (cond - [(eq? (node-parent y) z) - ;; In CLRS, this is steps 12 and 13 of RB-DELETE. - ;; Be aware that x here can be nil. Rather than - ;; change the contents of nil, we record that value - ;; in nil-parent and pass that along to the rest of - ;; the computation. - (cond [(nil? x) - y] - [else - (set-node-parent! x y) - nil])] - [else - (let ([nil-parent - (transplant-for-delete! a-tree y (node-right y))]) - (set-node-right! y (node-right z)) - (set-node-parent! (node-right y) y) - nil-parent)])) - - ;; y can't be nil here, so has no effect on nil-parent - (transplant-for-delete! a-tree z y) - - (set-node-left! y (node-left z)) - - ;; Similarly, (node-left y) here can't be nil by the case - ;; analysis, so this has no effect on nil-parent. - (set-node-parent! (node-left y) y) - - (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) - (set-node-subtree-width! z (node-self-width z)) - - (values x y-original-color nil-parent))])]) - (cond [(eq? black y-original-color) - (fix-after-delete! a-tree x nil-parent)] - [else - (void)]))) - - - - - - - -;; transplant-for-delete: tree node (U node nil) -> (U nil node) -;; INTERNAL -;; Replaces the instance of node u in a-tree with v. -;; -;; If v is nil, then rather than mutate nil, it returns -;; a non-nil node that should be treated as nil's parent. -;; Otherwise, returns nil. -(define (transplant-for-delete! a-tree u v) - (define u.p (node-parent u)) - (cond [(nil? u.p) - (set-tree-root! a-tree v)] - [(eq? u (node-left u.p)) - (set-node-left! u.p v)] - [else - (set-node-right! u.p v)]) - (cond [(nil? v) - u.p] - [else - (set-node-parent! v u.p) - nil])) - - - -;; fix-after-delete!: tree node -> void -;; INTERNAL -;; Correct several possible invariant-breaks after a black node -;; has been removed from the tree. These include: -;; -;; * turning the root red -;; * unbalanced black paths -;; * red-red links -;; -;; Note that this function has been augmented so that it keeps special -;; track of nil-parent. -(define (fix-after-delete! a-tree x nil-parent) - - ;; n-p: node -> node - ;; Should be almost exactly like node-parent, except for one - ;; special case: in the context of this function alone, - ;; if we're navigating the parent of nil, use the nil-parent constant. - (define-syntax-rule (n-p x) - (let ([v x]) - (if (nil? v) - nil-parent - (node-parent v)))) - - (let loop ([x x] - [early-escape? #f]) - (cond [(and (not (eq? x (tree-root a-tree))) - (black? x)) - (cond - [(eq? x (node-left (n-p x))) - (define w (node-right (n-p x))) - (define w-1 (cond [(eq? (node-color w) red) - (set-node-color! w black) - (set-node-color! (n-p x) red) - (left-rotate! a-tree (n-p x)) - (node-right (n-p x))] - [else - w])) - (cond [(and (black? (node-left w-1)) (black? (node-right w-1))) - (set-node-color! w-1 red) - (loop (n-p x) #f)] - [else - (define w-2 (cond [(black? (node-right w-1)) - (set-node-color! (node-left w-1) black) - (set-node-color! w-1 red) - (right-rotate! a-tree w-1) - (node-right (n-p x))] - [else - w-1])) - (set-node-color! w-2 (node-color (n-p x))) - (set-node-color! (n-p x) black) - (set-node-color! (node-right w-2) black) - (left-rotate! a-tree (n-p x)) - (loop (tree-root a-tree) - #t)])] - [else - (define w (node-left (n-p x))) - (define w-1 (cond [(red? w) - (set-node-color! w black) - (set-node-color! (n-p x) red) - (right-rotate! a-tree (n-p x)) - (node-left (n-p x))] - [else - w])) - (cond [(and (black? (node-left w-1)) (black? (node-right w-1))) - (set-node-color! w-1 red) - (loop (n-p x) #f)] - [else - (define w-2 (cond [(black? (node-left w-1)) - (set-node-color! (node-right w-1) black) - (set-node-color! w-1 red) - (left-rotate! a-tree w-1) - (node-left (n-p x))] - [else - w-1])) - (set-node-color! w-2 (node-color (n-p x))) - (set-node-color! (n-p x) black) - (set-node-color! (node-left w-2) black) - (right-rotate! a-tree (n-p x)) - (loop (tree-root a-tree) - #t)])])] - [else - ;; When we get to this point, if x is at the root - ;; and still black, we are discarding the double-black - ;; color, which means the height of the tree should be - ;; decremented. - (when (and (eq? x (tree-root a-tree)) - (black? x) - (not early-escape?)) - (set-tree-bh! a-tree (sub1 (tree-bh a-tree)))) - - (set-node-color! x black)]))) - - - -;; search: tree natural -> (U node nil) -;; Search for the node closest to offset. -;; 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) - (values nil offset)] - [else - (define left (node-left a-node)) - (define left-subtree-width (node-subtree-width left)) - (cond [(< offset left-subtree-width) - (loop offset left)] - [else - (define residual-offset (- offset left-subtree-width)) - (define self-width (node-self-width a-node)) - (cond - [(< residual-offset self-width) - (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. -;; Note: (position nil) will return -1. -(define (position n) - (cond - [(nil? n) - -1] - [else - (let loop ([n n] - [came-from-right? #f] - [acc (node-subtree-width (node-left n))]) - (cond - [(nil? n) - acc] - [came-from-right? - (loop (node-parent n) - (eq? (node-right (node-parent n)) n) - (+ acc - (node-subtree-width (node-left n)) - (node-self-width n)))] - [else - (loop (node-parent n) - (eq? (node-right (node-parent n)) n) - acc)]))])) - - - - -;; join!: tree tree -> tree -;; Destructively concatenates trees t1 and t2, and -;; returns a tree that represents the join. -(define (join! t1 t2) - (cond - [(nil? (tree-root t2)) - (define result (clone! t1)) - (reset! t1) - result] - [(nil? (tree-root t1)) - (define result (clone! t2)) - (reset! t2) - result] - [else - ;; First, remove element x from t2. x will act as the - ;; pivot point. - (define x (tree-first t2)) - (delete! t2 x) - ;; Next, delegate to the more general concat! function, using - ;; x as the pivot. - (public:concat! t1 x t2)])) - - - -;; public:concat!: tree node tree -> tree -;; Joins t1, x, and t2 together, returning a new tree. -;; Destructively modifies t1 and t2 to the empty trees. -(define (public:concat! t1 x t2) - (define result (concat! t1 x t2)) - (cond - [(eq? result t1) - (let ([result (clone! t1)]) - (reset! t1) - (reset! t2) - result)] - [(eq? result t2) - (let ([result (clone! t2)]) - (reset! t1) - (reset! t2) - result)] - [else - (reset! t1) - (reset! t2) - result])) - - - -;; concat!: tree node tree -> tree -;; INTERNAL -;; Joins t1, x and t2 together, using x as the pivot. -;; -;; x will be treated as if it were a singleton tree; its x.left and x.right -;; will be overwritten during concatenation. -;; -;; Note that x must NOT be attached to the tree t1 or t2, or else this -;; will introduce an illegal cycle. -;; -;; Also, this should not depend on t1 and t2 having valid -;; tree-first/tree-last pointers on entry; we compute this lazily due -;; to how this is used by split!. -(define (concat! t1 x t2) - (cond - [(nil? (tree-root t1)) - (set-node-left! x nil) - (set-node-right! x nil) - (set-node-subtree-width! x (node-self-width x)) - ;; if t2 is lazy about having a tree-first, force it. - ;; This only happens in the context of split! - (force-tree-first! t2) - (insert-first! t2 x) - t2] - - [(nil? (tree-root t2)) - ;; symmetric with the case above: - (set-node-left! x nil) - (set-node-right! x nil) - (set-node-subtree-width! x (node-self-width x)) - (force-tree-last! t1) - (insert-last! t1 x) - t1] - - [else - (define t1-bh (tree-bh t1)) - (define t2-bh (tree-bh t2)) - (cond - [(>= t1-bh t2-bh) - ;; Note: even if tree-last is invalid, nothing gets hurt here. - (set-tree-last! t1 (tree-last t2)) - - (define a (find-rightmost-black-node-with-bh t1 t2-bh)) - (define b (tree-root t2)) - (transplant-for-concat! t1 a x) - (set-node-color! x red) - (set-node-left! x a) - (set-node-parent! a x) - (set-node-right! x b) - (set-node-parent! b x) - - ;; Possible TODO: Ron Wein recommends a lazy approach here, - ;; rather than recompute the metadata eagerly. I've tried so, - ;; but in my experiments, the overhead of testing and forcing - ;; actually hurts us. So I do not try to compute subtree-width - ;; lazily. - (update-subtree-width-up-to-root! x) - (fix-after-insert! t1 x) - t1] - - [else - ;; Symmetric case: - (set-tree-first! t2 (tree-first t1)) - (define a (tree-root t1)) - (define b (find-leftmost-black-node-with-bh t2 t1-bh)) - (transplant-for-concat! t2 b x) - (set-node-color! x red) - (set-node-left! x a) - (set-node-parent! a x) - (set-node-right! x b) - (set-node-parent! b x) - (update-subtree-width-up-to-root! x) - (fix-after-insert! t2 x) - t2])])) - - -;; transplant-for-concat!: tree node node -> void -;; INTERNAL -;; Replaces node u in a-tree with v. -(define (transplant-for-concat! a-tree u v) - (define u.p (node-parent u)) - (cond [(nil? u.p) - (set-tree-root! a-tree v)] - [(eq? u (node-left u.p)) - (set-node-left! u.p v)] - [else - (set-node-right! u.p v)]) - (set-node-parent! v u.p)) - - - -;; find-rightmost-black-node-with-bh: tree positive-integer -> node -;; INTERNAL -;; Finds the rightmost black node with the particular black height -;; we're looking for. -(define (find-rightmost-black-node-with-bh a-tree bh) - (let loop ([n (tree-root a-tree)] - [current-height (tree-bh a-tree)]) - (cond - [(black? n) - (cond [(= bh current-height) - n] - [else - (loop (node-right n) (sub1 current-height))])] - [else - (loop (node-right n) current-height)]))) - - -;; find-leftmost-black-node-with-bh: tree positive-integer -> node -;; INTERNAL -;; Finds the rightmost black node with the particular black height -;; we're looking for. -(define (find-leftmost-black-node-with-bh a-tree bh) - (let loop ([n (tree-root a-tree)] - [current-height (tree-bh a-tree)]) - (cond - [(black? n) - (cond [(= bh current-height) - n] - [else - (loop (node-left n) (sub1 current-height))])] - [else - (loop (node-left n) current-height)]))) - - -;; split!: tree node -> (values tree tree) -;; Partitions the tree into two trees: the predecessors of x, and the -;; successors of x. Also mutates x into a singleton node. -;; Finally, modifies a-tree so it looks empty. -;; -;; 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) - (set-node-subtree-width! x (node-self-width x)) - - ;; Clear out a-tree so it's unusable. - (reset! a-tree) - - ;; The loop walks the ancestors of x, adding the left and right - ;; elements appropriately. - (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 - ;; pointers, then return. - (force-tree-first! L) - (force-tree-last! L) - (force-tree-first! R) - (force-tree-last! R) - (values L R)] - [else - (define new-ancestor (node-parent ancestor)) - (define new-ancestor-child-bh (if (black? ancestor) - (add1 ancestor-child-bh) - ancestor-child-bh)) - (define new-coming-from-the-right? (eq? (node-right new-ancestor) ancestor)) - - ;; Important! Make sure ancestor is detached. This is - ;; required by concat!, or else Bad Things happen. - (detach! ancestor) - - (cond - [coming-from-the-right? - (define subtree (node->tree/bh (node-left ancestor) - ancestor-child-bh)) - (loop new-ancestor - new-ancestor-child-bh - new-coming-from-the-right? - (concat! subtree ancestor L) - R)] - [else - (define subtree (node->tree/bh (node-right ancestor) - ancestor-child-bh)) - (loop new-ancestor - new-ancestor-child-bh - new-coming-from-the-right? - L - (concat! R ancestor subtree))])]))) - - -;; reset!: tree -> void -;; Resets a tree to empty. -(define (reset! a-tree) - (set-tree-root! a-tree nil) - (set-tree-first! a-tree nil) - (set-tree-last! a-tree nil) - (set-tree-bh! a-tree 0)) - - - -;; clone!: tree -> tree -;; Shallow copy of the components of the tree. -(define (clone! a-tree) - (tree (tree-root a-tree) - (tree-first a-tree) - (tree-last a-tree) - (tree-bh a-tree))) - - - - - - -;; force-tree-first!: tree -> void -;; INTERNAL -;; Force tree-first's value. -;; For non-empty trees, it's set to nil only in node->tree/bh. -(define (force-tree-first! t) - (when (nil? (tree-first t)) - (set-tree-first! t (minimum (tree-root t))))) - - -;; force-tree-last!: tree -> void -;; INTERNAL -;; Force tree-last's value. -;; For non-empty trees, it's set to nil only in node->tree/bh. -(define (force-tree-last! t) - (when (nil? (tree-last t)) - (set-tree-last! t (maximum (tree-root t))))) - - -;; detach!: node -> void -;; INTERNAL -;; Disconnects n from its parent. -(define (detach! n) - (define p (node-parent n)) - (cond [(nil? p) - (void)] - [(eq? (node-right p) n) - (set-node-right! p nil) - (set-node-parent! n nil)] - [else - (set-node-left! p nil) - (set-node-parent! n nil)])) - - -;; node->tree/bh: node natural -> tree -;; INTERNAL: for use by split! only. -;; Create a partially-instantiated node out of a tree, where we should -;; already know the black height of the tree rooted at a-node. -;; -;; Note that the first and last of the tree have not been initialized -;; here yet. split! must eventually force the L and R trees to -;; have valid first/last pointers, or else Bad Things happen. -(define (node->tree/bh a-node bh) - (cond - [(nil? a-node) - (new-tree)] - [else - (define new-bh (if (red? a-node) (add1 bh) bh)) - (set-node-parent! a-node nil) - (set-node-color! a-node black) - (tree a-node - nil - nil - new-bh)])) - - -;; computed-black-height: node -> natural -;; INTERNAL: for use by split! only. -;; Computes the black height of the tree rooted at x. -(define (computed-black-height x) - (let loop ([x x] - [acc 0]) - (cond - [(nil? x) - acc] - [else - (cond [(black? x) - (loop (node-right x) (add1 acc))] - [else - (loop (node-right x) acc)])]))) - - - -;; 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)] - [acc null]) - (cond - [(nil? n) - acc] - [else - (loop (node-left n) - (cons (list (node-data n) - (node-self-width n)) - (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 [nil? nil-node?]] - node-data - set-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-last! - insert-before! - insert-after! - insert-first/data! - insert-last/data! - insert-before/data! - insert-after/data! - - delete! - join! - [rename-out [public:concat! concat!]] - split! - reset! - - update-node-self-width! - - search - search/residual - - minimum - maximum - successor - predecessor - position - - tree-items - tree-fold-inorder - tree-fold-preorder - tree-fold-postorder)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal tests. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - -(module+ test - (require rackunit - rackunit/text-ui - racket/string - racket/list - racket/class - racket/promise) - - (define (singleton-node? n) - (and (node? n) - (red? n) - (nil? (node-parent n)) - (= (node-subtree-width n) - (node-self-width n)))) - - - ;; tree-items: tree -> (listof (list X number)) - ;; Returns a list of all the items stored in the tree. - (define (tree-items a-tree) - (let loop ([node (tree-root a-tree)] - [acc null]) - (cond - [(nil? node) - acc] - [else - (loop (node-left node) - (cons (list (node-data node) - (node-self-width node)) - (loop (node-right node) acc)))]))) - - - ;; tree-height: tree -> natural - ;; For debugging: returns the height of the tree. - (define (tree-height a-tree) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - 0] - [else - (+ 1 (max (loop (node-left node)) - (loop (node-right node))))]))) - - ;; tree-node-count: tree -> natural - ;; Counts the nodes of the tree. - (define (tree-node-count a-tree) - (let loop ([node (tree-root a-tree)] - [acc 0]) - (cond - [(nil? node) - acc] - [else - (loop (node-left node) (loop (node-right node) (add1 acc)))]))) - - - ;; Debugging: counts the number of black nodes by manually - ;; traversing both subtrees. - (define (node-count-black a-node) - (let loop ([a-node a-node] - [acc 0]) - (cond - [(nil? a-node) - acc] - [else - (define right-count (loop (node-right a-node) - (+ (if (black? a-node) 1 0) - acc))) - (define left-count (loop (node-left a-node) - (+ (if (black? a-node) 1 0) - acc))) - (check-equal? right-count - left-count - (format "node-count-black: ~a vs ~a" right-count left-count)) - right-count]))) - - - - ;; check-rb-structure!: tree -> void - ;; The following is a heavy debugging function to ensure - ;; tree-structure is as expected. Note: this functions is - ;; EXTRAORDINARILY expensive. Do not use this outside of tests. - (define (check-rb-structure! a-tree) - - ;; nil should always be black: algorithms depend on this! - (check-eq? (node-color nil) black) - (check-eq? (node-subtree-width nil) 0) - (check-eq? (node-self-width nil) 0) - (check-eq? (node-parent nil) nil) - (check-eq? (node-left nil) nil) - (check-eq? (node-right nil) nil) - - - ;; The internal linkage between all the nodes should be consistent, - ;; and without cycles! - (let ([ht (make-hasheq)]) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [else - (check-false (hash-has-key? ht node)) - (hash-set! ht node #t) - (define left (node-left node)) - (define right (node-right node)) - (when (not (nil? left)) - (check-eq? (node-parent left) node) - (loop left)) - (when (not (nil? right)) - (check-eq? (node-parent right) node) - (loop right))]))) - - - ;; No two red nodes should be adjacent: - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [(red? node) - (check-false (or (red? (node-left node)) - (red? (node-right node))) - "rb violation: two reds are adjacent") - (loop (node-left node)) - (loop (node-right node))])) - - - ;; The maximum and minimum should be correctly linked - ;; as tree-last and tree-first, respectively: - (let ([correct-tree-first (if (nil? (tree-root a-tree)) - nil - (minimum (tree-root a-tree)))]) - (check-eq? (tree-first a-tree) - correct-tree-first - (format "minimum (~a) is not first (~a)" - (node-data correct-tree-first) - (node-data (tree-first a-tree))))) - (let ([correct-tree-last (if (nil? (tree-root a-tree)) nil (maximum (tree-root a-tree)))]) - (check-eq? (tree-last a-tree) - correct-tree-last - (format "maximum (~a) is not last (~a)" - (node-data correct-tree-last) - (node-data (tree-last a-tree))))) - - - ;; The left and right sides should be black-balanced, for all subtrees. - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - (void)] - [else - (check-equal? (node-count-black (node-left node)) - (node-count-black (node-right node)) - "rb violation: not black-balanced") - (loop (node-left node)) - (loop (node-right node))])) - (define observed-black-height (node-count-black (tree-root a-tree))) - ;; The observed black height should equal that of the recorded one - (check-equal? (tree-bh a-tree) - observed-black-height - (format "rb violation: observed height ~a is not equal to recorded height ~a" - observed-black-height - (tree-bh a-tree))) - - - ;; The overall height must be less than 2 lg(n+1) - (define count (tree-node-count a-tree)) - (define observed-height (tree-height a-tree)) - (define (lg n) (/ (log n) (log 2))) - (check-false (> observed-height (* 2 (lg (add1 count)))) - (format "rb violation: height ~a beyond 2 lg(~a)=~a" - observed-height (add1 count) - (* 2 (log (add1 count))))) - - - ;; The subtree widths should be consistent: - (let loop ([n (tree-root a-tree)]) - (cond - [(nil? n) - 0] - [else - (define left-subtree-size (loop (node-left n))) - (define right-subtree-size (loop (node-right n))) - (check-equal? (node-subtree-width n) - (+ left-subtree-size right-subtree-size - (node-self-width n)) - (format "stale subtree width: expected ~a, but observe ~a" - (+ left-subtree-size right-subtree-size - (node-self-width n)) - (node-subtree-width n))) - (+ left-subtree-size right-subtree-size - (node-self-width n))]))) - - - - ;; tree->list: tree -> list - ;; For debugging: help visualize what the structure of the tree looks like. - (define (tree->list a-tree) - (let loop ([node (tree-root a-tree)]) - (cond - [(nil? node) - null] - [else - (list (format "~a:~a:~a" - (node-data node) - (node-subtree-width node) - (if (black? node) "black" "red")) - (loop (node-left node)) - (loop (node-right node)))]))) - - - ;; a little macro to help me measure how much time we spend in - ;; the body of an expression. - (define-syntax-rule (time-acc id body ...) - (let ([start (current-inexact-milliseconds)]) - (call-with-values (lambda () - (let () body ...)) - (lambda vals - (let ([stop (current-inexact-milliseconds)]) - (set! id (+ id (- stop start))) - (apply values vals)))))) - - - (define nil-tests - (test-suite - "check properties of nil" - (printf "nil tests...\n") - (test-case - "nil tree should be consistent" - (define t (new-tree)) - (check-rb-structure! t)))) - - (define rotation-tests - (test-suite - "Checking left and right rotation" - (printf "rotation tests...\n") - (test-begin - (define t (new-tree)) - - (define alpha (node "alpha" 5 5 nil nil nil nil)) - (define beta (node "beta" 4 5 nil nil nil nil)) - (define gamma (node "gamma" 5 5 nil nil nil nil)) - - (define x (node "x" 1 1 nil alpha beta nil)) - (define y (node "y" 1 1 nil nil gamma nil)) - (set-tree-root! t y) - (set-node-left! y x) - (set-node-parent! x y) - - (right-rotate! t y) - (check-eq? (tree-root t) x) - (check-eq? (node-left (tree-root t)) alpha) - (check-eq? (node-right (tree-root t)) y) - (check-eq? (node-left (node-right (tree-root t))) beta) - (check-eq? (node-right (node-right (tree-root t))) gamma) - - (left-rotate! t x) - (check-eq? (tree-root t) y) - (check-eq? (node-right (tree-root t)) gamma) - (check-eq? (node-left (tree-root t)) x) - (check-eq? (node-left (node-left (tree-root t))) alpha) - (check-eq? (node-right (node-left (tree-root t))) beta)))) - - - - (define insertion-tests - (test-suite - "Insertion tests" - (printf "insertion tests...\n") - (test-case "small beginnings" - (define t (new-tree)) - (insert-last/data! t "small world" 11) - (check-rb-structure! t)) - - (test-begin - (define t (new-tree)) - (insert-last/data! t "foobar" 6) - (insert-last/data! t "hello" 5) - (insert-last/data! t "world" 5) - (check-equal? (tree-items t) - '(("foobar" 6) - ("hello" 5) - ("world" 5))) - (check-rb-structure! t)) - - - (test-begin - (define t (new-tree)) - (insert-first/data! t "a" 1) - (insert-first/data! t "b" 1) - (insert-first/data! t "c" 1) - (check-equal? (tree-items t) - '(("c" 1) ("b" 1) ("a" 1))) - (check-equal? (tree->list t) - '("b:3:black" ("c:1:red" () ()) ("a:1:red" () ()))) - (check-rb-structure! t)) - - - (test-begin - (define t (new-tree)) - (insert-first/data! t "alpha" 5) - (insert-first/data! t "beta" 4) - (insert-first/data! t "gamma" 5) - (insert-first/data! t "delta" 5) - (insert-first/data! t "omega" 5) - (check-equal? (tree-items t) - '(("omega" 5) ("delta" 5) - ("gamma" 5) ("beta" 4) ("alpha" 5))) - (check-rb-structure! t)) - - - (test-begin - (define t (new-tree)) - (insert-last/data! t "hi" 2) - (insert-last/data! t "bye" 3) - (define the-root (tree-root t)) - (check-equal? (node-left the-root) - nil) - (check-true (black? the-root)) - (check-equal? (node-subtree-width the-root) 5) - (check-true (red? (node-right the-root))) - - (check-rb-structure! t)) - - (test-begin - (define t (new-tree)) - (insert-last/data! t "hi" 2) - (insert-last/data! t "bye" 3) - (insert-last/data! t "again" 5) - (define the-root (tree-root t)) - (check-equal? (node-data (node-left the-root)) - "hi") - (check-equal? (node-data the-root) - "bye") - (check-equal? (node-data (node-right the-root)) - "again") - (check-true (black? the-root)) - (check-true (red? (node-left the-root))) - (check-true (red? (node-right the-root))) - (check-equal? (node-subtree-width the-root) 10) - (check-rb-structure! t)))) - - - - - (define deletion-tests - (test-suite - "deletion-tests" - (printf "deletion tests...\n") - (test-case - "Deleting the last node in a tree should set us back to the nil case" - (define t (new-tree)) - (insert-first/data! t "hello" 5) - (delete! t (tree-root t)) - (check-equal? (tree-root t) nil) - (check-rb-structure! t)) - - (test-case - "Deleting the last node in a tree: first and last should be nil" - (define t (new-tree)) - (insert-first/data! t "hello" 5) - (delete! t (tree-root t)) - (check-equal? (tree-first t) nil) - (check-equal? (tree-last t) nil) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: basic structure" - (define t (new-tree)) - (insert-last/data! t "dresden" 6) - (insert-last/data! t "files" 5) - (delete! t (node-right (tree-root t))) - (check-equal? (node-data (tree-root t)) "dresden") - (check-equal? (node-left (tree-root t)) nil) - (check-equal? (node-right (tree-root t)) nil) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: check the subtree-width has been updated" - (define t (new-tree)) - (insert-last/data! t "dresden" 6) - (insert-last/data! t "files" 5) - (delete! t (node-right (tree-root t))) - (check-equal? (node-subtree-width (tree-root t)) 6) - (check-rb-structure! t)) - - (test-case - "Delete the last node in a two-node tree: check that tree-first and tree-last are correct" - (define t (new-tree)) - (insert-last/data! t "dresden" 6) - (insert-last/data! t "files" 5) - (delete! t (node-right (tree-root t))) - (check-true (node? (tree-root t))) - (check-equal? (tree-first t) (tree-root t)) - (check-equal? (tree-last t) (tree-root t)) - (check-rb-structure! t)) - - - (test-case - "bigger case identified by angry monkey" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (insert-last/data! t "d" 1) - (insert-last/data! t "e" 1) - (check-rb-structure! t) - (delete! t (search t 1)) - (check-rb-structure! t) - (delete! t (search t 1)) - (check-rb-structure! t) - (delete! t (search t 0)) - (check-rb-structure! t)) - - - (test-case - "does deletion get subtree width right?" - (define t (new-tree)) - (insert-last/data! t "hello" 5) - (insert-last/data! t "dyoo" 4) - (define r (tree-root t)) - (delete! t r) - (insert-last! t r) - (check-rb-structure! t)))) - - - - - (define mixed-tests - (test-suite - "other miscellaneous tests" - (printf "mixed tests...\n") - (test-case - "Another sequence identified by the random monkey" - ;inserting "A" to front - ;inserting "B" to front - ;Inserting "C" after "A" - ;Inserting "D" after "B" - ;inserting "E" to back - ;inserting "F" to front - ;deleting "F" - ;inserting "G" to back - ;inserting "H" to back - ;inserting "I" to front - ;inserting "J" to back - ;inserting "K" to front - ;inserting "L" before "E" - (define t (new-tree)) - - (insert-first/data! t "A" 1) - (check-equal? (map first (tree-items t)) '("A")) - (insert-first/data! t "B" 1) - (check-equal? (map first (tree-items t)) '("B" "A")) - (insert-after/data! t (search t 1) "C" 1) - (check-equal? (map first (tree-items t)) '("B" "A" "C")) - (insert-after/data! t (search t 0) "D" 1) - (check-equal? (map first (tree-items t)) '("B" "D" "A" "C")) - (insert-last/data! t "E" 1) - (check-equal? (map first (tree-items t)) '("B" "D" "A" "C" "E")) - (insert-first/data! t "F" 1) - (check-equal? (map first (tree-items t)) '("F" "B" "D" "A" "C" "E")) - (delete! t (search t 0)) - (check-equal? (map first (tree-items t)) '("B" "D" "A" "C" "E")) - (insert-last/data! t "G" 1) - (check-equal? (map first (tree-items t)) '("B" "D" "A" "C" "E" "G")) - (insert-last/data! t "H" 1) - (check-equal? (map first (tree-items t)) '("B" "D" "A" "C" "E" "G" "H")) - (insert-first/data! t "I" 1) - (check-equal? (map first (tree-items t)) '("I" "B" "D" "A" "C" "E" "G" "H")) - (insert-last/data! t "J" 1) - (check-equal? (map first (tree-items t)) '("I" "B" "D" "A" "C" "E" "G" "H" "J")) - (insert-first/data! t "K" 1) - (check-equal? (map first (tree-items t)) '("K" "I" "B" "D" "A" "C" "E" "G" "H" "J")) - (check-equal? (node-data (search t 6)) "E") - (insert-before/data! t (search t 6) "L" 1) - (check-equal? (map first (tree-items t)) '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J")) - - (for/fold ([n (minimum (tree-root t))]) ([w (in-list '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J"))]) - (check-equal? (node-data n) w) - (successor n)) - - (for/fold ([n (maximum (tree-root t))]) ([w (in-list (reverse '("K" "I" "B" "D" "A" "C" "L" "E" "G" "H" "J")))]) - (check-equal? (node-data n) w) - (predecessor n))))) - - - (define search-tests - (test-suite - "search-tests" - (printf "search tests...\n") - (test-begin - (define t (new-tree)) - (check-equal? (search t 0) nil) - (check-equal? (search t 129348) nil)) - - (test-begin - (define t (new-tree)) - (insert-last/data! t "hello" 5) - (check-equal? (node-data (search t 0)) "hello") - (check-equal? (node-data (search t 1)) "hello") - (check-equal? (node-data (search t 2)) "hello") - (check-equal? (node-data (search t 3)) "hello") - (check-equal? (node-data (search t 4)) "hello") - ;; Edge case: - (check-equal? (search t 5) nil) - ;; Edge case: - (check-equal? (search t -1) nil)) - - - ;; Empty nodes should get skipped over by search, though - ;; the nodes are still there in the tree. - (test-begin - (define t (new-tree)) - (insert-last/data! t "hello" 5) - (insert-last/data! t "" 0) - (insert-last/data! t "" 0) - (insert-last/data! t "" 0) - (insert-last/data! t "world" 5) - (insert-last/data! t "" 0) - (insert-last/data! t "" 0) - (insert-last/data! t "" 0) - (insert-last/data! t "test!" 5) - (check-equal? (tree-node-count t) 9) - (check-equal? (node-data (search t 0)) "hello") - (check-equal? (node-data (search t 1)) "hello") - (check-equal? (node-data (search t 2)) "hello") - (check-equal? (node-data (search t 3)) "hello") - (check-equal? (node-data (search t 4)) "hello") - (check-equal? (node-data (search t 5)) "world") - (check-equal? (node-data (search t 6)) "world") - (check-equal? (node-data (search t 7)) "world") - (check-equal? (node-data (search t 8)) "world") - (check-equal? (node-data (search t 9)) "world") - (check-equal? (node-data (search t 10)) "test!")) - - - - - (test-begin - (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))) - (check-equal? (node-data (search t 0)) "This") - (check-equal? (node-data (search t 1)) "This") - (check-equal? (node-data (search t 2)) "This") - (check-equal? (node-data (search t 3)) "This") - (check-equal? (node-data (search t 4)) "is") - (check-equal? (node-data (search t 5)) "is") - (check-equal? (node-data (search t 6)) "a") - (check-equal? (node-data (search t 7)) "test") - (check-equal? (node-data (search t 8)) "test") - (check-equal? (node-data (search t 9)) "test") - (check-equal? (node-data (search t 10)) "test") - (check-equal? (node-data (search t 11)) "of") - (check-equal? (node-data (search t 12)) "of") - (check-equal? (node-data (search t 13)) "the") - (check-equal? (node-data (search t 14)) "the") - (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")) - - (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 - (test-suite - "position tests" - (printf "position tests...\n") - (test-case - "empty case" - (check-equal? (position nil) -1)) - - (test-case - "simple case" - (define t (new-tree)) - (insert-last/data! t "foobar" 6) - (check-equal? (position (tree-root t)) 0)) - - (test-case - "simple case of a few random words" - (define t (new-tree)) - (insert-last/data! t "uc berkeley" 11) - (insert-last/data! t "wpi" 3) - (insert-last/data! t "brown" 5) - (insert-last/data! t "university of utah" 18) - (check-equal? (position (tree-first t)) 0) - (check-equal? (position (successor (tree-first t))) 11) - (check-equal? (position (successor (successor (tree-first t)))) 14) - (check-equal? (position (successor (successor (successor (tree-first t))))) 19)) - - (test-case - "slightly larger example" - (define t (new-tree)) - (define words - (string-split - "In a hole in the ground there lived a hobbit. Not a - nasty, dirty wet hole, filled with the ends of worms and an oozy - smell, nor yet a dry, bare, sandy ole with nothing in it to sit down on - or to eat: it was a hobbit-hole, and that means comfort.")) - (for ([w (in-list words)]) - (insert-last/data! t w (string-length w))) - (for/fold ([pos 0]) ([w (in-list words)]) - (define n (search t pos)) - (check-equal? (node-data n) w) - (check-equal? (position n) pos) - (+ pos (string-length w)))))) - - - (define concat-tests - (test-suite - "concat tests" - (printf "concat tests...\n") - (test-case - "empty case" - (define t1 (new-tree)) - (define t2 (new-tree)) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-true (nil? (tree-root t1+t2))) - (check-rb-structure! t1+t2)) - - (test-case - "left is empty" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t2 "hello" 5) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) - '("hello")) - (check-rb-structure! t1+t2)) - - (test-case - "right is empty" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t1 "hello" 5) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) - '("hello")) - (check-rb-structure! t1+t2)) - - (test-case - "two single trees" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t1 "append" 5) - (insert-last/data! t2 "this" 4) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) '("append" "this")) - (check-rb-structure! t1+t2)) - - - (test-case - "joining back and forth" - (define t (new-tree)) - (for ([i (in-range 20)]) - (define t2 (new-tree)) - (insert-last/data! t2 i i) - (cond - [(even? i) - (set! t (join! t t2)) - (check-true (nil? (tree-root t2)))] - [else - (set! t (join! t2 t)) - (check-true (nil? (tree-root t2)))])) - (check-equal? (tree-items t) - '((19 19) (17 17) (15 15) (13 13) (11 11) (9 9) - (7 7) (5 5) (3 3) (1 1) (0 0) (2 2) (4 4) (6 6) - (8 8) (10 10) (12 12) (14 14) (16 16) (18 18))) - (check-rb-structure! t)) - - - (test-case - "appending 2-1" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t1 "love" 4) - (insert-last/data! t1 "and" 3) - (insert-last/data! t2 "peace" 5) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) '("love" "and" "peace")) - (check-rb-structure! t1+t2)) - - (test-case - "appending 1-2" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t1 "love" 4) - (insert-last/data! t2 "and" 3) - (insert-last/data! t2 "war" 3) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) '("love" "and" "war")) - (check-rb-structure! t1+t2)) - - - (test-case - "appending 3-3" - (define t1 (new-tree)) - (define t2 (new-tree)) - (insert-last/data! t1 "four" 4) - (insert-last/data! t1 "score" 5) - (insert-last/data! t1 "and" 3) - (insert-last/data! t2 "seven" 5) - (insert-last/data! t2 "years" 5) - (insert-last/data! t2 "ago" 3) - (define t1+t2 (join! t1 t2)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-equal? (map first (tree-items t1+t2)) '("four" "score" "and" "seven" "years" "ago")) - (check-rb-structure! t1+t2)) - - - (test-case - "a bigger concatenation example. Gettysburg Address, November 19, 1863." - (define t1 (new-tree)) - (define t2 (new-tree)) - (define t3 (new-tree)) - (define m1 "Four score and seven years ago our fathers - brought forth on this continent a new nation, - conceived in Liberty, and dedicated to the proposition - that all men are created equal.") - (define m2 "Now we are engaged in a great civil war, testing - whether that nation, or any nation so conceived and so dedicated, - can long endure. We are met on a great battle-field of that war. - We have come to dedicate a portion of that field, as a final - resting place for those who here gave their lives that that nation - might live. It is altogether fitting and proper that we should do this.") - (define m3 "But, in a larger sense, we can not dedicate -- we can not consecrate - -- we can not hallow -- this ground. The brave men, living and dead, - who struggled here, have consecrated it, far above our poor power to - add or detract. The world will little note, nor long remember what we - say here, but it can never forget what they did here. It is for us the living, - rather, to be dedicated here to the unfinished work which they who fought here - have thus far so nobly advanced. It is rather for us to be here dedicated to - the great task remaining before us -- that from these honored dead we take - increased devotion to that cause for which they gave the last full measure - of devotion -- that we here highly resolve that these dead shall not have died - in vain -- that this nation, under God, shall have a new birth of freedom -- - and that government of the people, by the people, for the people, - shall not perish from the earth.") - (for ([word (in-list (string-split m1))]) - (insert-last/data! t1 word (string-length word))) - (for ([word (in-list (string-split m2))]) - (insert-last/data! t2 word (string-length word))) - (for ([word (in-list (string-split m3))]) - (insert-last/data! t3 word (string-length word))) - (define speech-tree (join! (join! t1 t2) t3)) - (check-true (nil? (tree-root t1))) - (check-true (nil? (tree-root t2))) - (check-true (nil? (tree-root t3))) - (check-equal? (map first (tree-items speech-tree)) - (string-split (string-append m1 " " m2 " " m3))) - (check-rb-structure! speech-tree)))) - - (define split-tests - (test-suite - "splitting" - (printf "split tests...\n") - (test-case - "(a) ---split-a--> () ()" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (map first (tree-items l)) '()) - (check-equal? (map first (tree-items r)) '()) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b) ---split-a--> () (b)" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (map first (tree-items l)) '()) - (check-equal? (map first (tree-items r)) '("b")) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b) ---split-b--> (a) ()" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (check-true (singleton-node? n)) - (check-equal? (map first (tree-items l)) '("a")) - (check-equal? (map first (tree-items r)) '()) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c) ---split-b--> (a) (c)" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c d) ---split-a--> () (b c d)" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (insert-last/data! t "d" 1) - (define n (search t 0)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - - (test-case - "(a b c d) ---split-b--> (a) (c d)" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (insert-last/data! t "d" 1) - (define n (search t 1)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - - (test-case - "(a b c d) ---split-c--> (a b) (d)" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (insert-last/data! t "d" 1) - (define n (search t 2)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a b c d) ---split-d--> (a b c) ()" - (define t (new-tree)) - (insert-last/data! t "a" 1) - (insert-last/data! t "b" 1) - (insert-last/data! t "c" 1) - (insert-last/data! t "d" 1) - (define n (search t 3)) - (define-values (l r) (split! t n)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a ... z) ---split-m--> (a ... l) (n ...z)" - (define t (new-tree)) - (for ([i (in-range 26)]) - (insert-last/data! t (string (integer->char (+ i (char->integer #\a)))) - 1)) - (define letter-m (search t 12)) - (define-values (l r) (split! t letter-m)) - (check-true (nil? (tree-root t))) - (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) - (check-rb-structure! r) - (check-rb-structure! t)) - - (test-case - "(a ... z) ---split-n--> (a ... l) (n ...z)" - (define letters (for/list ([i (in-range 26)]) - (string (integer->char (+ i (char->integer #\a)))))) - (for ([n (in-range 26)]) - (define t (new-tree)) - (for ([w (in-list letters)]) - (insert-last/data! t w 1)) - (define a-letter (search t n)) - (define-values (l r) (split! t a-letter)) - (check-true (nil? (tree-root t))) - (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)) - (check-rb-structure! l) - (check-rb-structure! r) - (check-rb-structure! t))))) - - - - (define predecessor-successor-min-max-tests - (test-suite - "predecesssor, successor, maximum, minimum tests" - (printf "navigation tests\n") - (test-case - "simple predecessor and successor tests" - (define known-model '("this" "is" "yet" "another" "test" "that" "makes" "sure" "we" "can" "walk" - "the" "tree" "reliably" "using" "successor" "and" "predecessor")) - ;; Make sure successor, predecessor are both doing the right thing on it: - (define t (new-tree)) - (for ([w (in-list known-model)]) - (insert-last/data! t w (string-length w))) - (check-equal? (node-data (minimum (tree-root t))) "this") - (check-equal? (node-data (maximum (tree-root t))) "predecessor") - (for/fold ([n (tree-first t)]) ([w (in-list known-model)]) - (check-equal? (node-data n) w) - (successor n)) - (for/fold ([n (tree-last t)]) ([w (in-list (reverse known-model))]) - (check-equal? (node-data n) w) - (predecessor n))) - - (test-case - "one-element tree" - (define t (new-tree)) - (insert-last/data! t "unary" 5) - (check-eq? (predecessor (tree-root t)) nil) - (check-eq? (successor (tree-root t)) nil) - (check-eq? (maximum (tree-root t)) (tree-root t)) - (check-eq? (minimum (tree-root t)) (tree-root t))) - - (test-case - "nil cases" - (check-eq? (predecessor nil) nil) - (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)))) - - - - - (define angry-monkey% - (let () - (define-local-member-name catch-and-concat-at-front) - (class object% - (super-new) - (define known-model '()) - (define t (new-tree)) - - (define (random-word) - (build-string (add1 (random 5)) - (lambda (i) - (integer->char (+ (char->integer #\a) (random 26)))))) - (define/public (get-tree) t) - (define/public (get-model) known-model) - - (define/public (insert-front!) - (define new-word (random-word)) - #;(printf "inserting ~s to front\n" new-word) - (set! known-model (cons new-word known-model)) - (insert-first/data! t new-word (string-length new-word))) - - (define/public (insert-back!) - (define new-word (random-word)) - #;(printf "inserting ~s to back\n" new-word) - (set! known-model (append known-model (list new-word))) - (insert-last/data! t new-word (string-length new-word))) - - (define/public (delete-kth! k) - #;(printf "deleting ~s\n" (list-ref known-model k)) - (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))))) - - ;; kth-offset: natural -> natural - ;; Returns the offset of the kth word in the model. - (define (kth-offset k) - (for/fold ([offset 0]) ([i (in-range k)] - [word (in-list known-model)]) - (+ offset (string-length word)))) - - - (define/public (delete-random!) - (when (not (empty? known-model)) - ;; Delete a random word if we can. - (define k (random (length known-model))) - (delete-kth! k))) - - - (define/public (insert-before/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)) - #;(printf "Inserting ~s before ~s\n" new-word (node-data node)) - (insert-before/data! t node new-word (string-length new-word)) - (set! known-model (append (take known-model k) - (list new-word) - (drop known-model k))))) - - (define/public (insert-after/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)) - #;(printf "Inserting ~s after ~s\n" new-word (node-data node)) - (insert-after/data! t node new-word (string-length new-word)) - (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 - ;; other m2 monkey. - (define/public (throw-all-at-monkey m2) - (send m2 catch-and-concat-at-front t known-model) - (set! t (new-tree)) - (set! known-model '())) - - - ;; Splitting/concatenation. Split what we've got, keep the - ;; left, and throw the right to our friend m2. - (define/public (throw-some-at-monkey m2) - (when (not (empty? known-model)) - (define k (random (length known-model))) - (define offset (kth-offset k)) - (define node (search t offset)) - (define-values (l r) (split! t node)) - (check-true (nil? (tree-root t))) - (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)))) - - ;; private - (define/public (catch-and-concat-at-front other-t other-known-model) - (set! t (join! other-t t)) - (check-true (nil? (tree-root other-t))) - (set! known-model (append other-known-model known-model))) - - - (define/public (check-consistency!) - ;; Check that the structure is consistent with our model. - (check-equal? (map first (tree-items t)) known-model) - - ;; And make sure it's still an rb-tree: - (check-rb-structure! t))))) - - - - (define angry-monkey-test-1 - (test-suite - "A simulation of an angry monkey bashing at the tree." - (test-begin - (printf "monkey tests 1...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 13) - [(0 1 2) - (send m insert-front!)] - [(3 4 5) - (send m insert-back!)] - [(6 7) - (send m insert-after/random!)] - [(8 9) - (send m insert-before/random!)] - [(10) - (send m replace-at-random!)] - [(11 12) - (send m delete-random!)])) - (send m check-consistency!))))) - - - (define angry-monkey-test-2 - (test-suite - "Another simulation of an angry monkey bashing at the tree. - (more likely to delete)" - (test-begin - (printf "monkey tests 2...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 13) - [(0 1) - (send m insert-front!)] - [(2 3) - (send m insert-back!)] - [(4 5) - (send m insert-after/random!)] - [(6 7) - (send m insert-before/random!)] - [(8) - (send m replace-at-random!)] - [(9 10 11 12) - (send m delete-random!)])) - (send m check-consistency!))))) - - (define angry-monkey-pair-test - (test-suite - "Simulation of a pair of angry monkeys bashing at the tree. - Occasionally they'll throw things at each other." - (test-begin - (printf "monkey tests paired...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (for ([i (in-range number-of-iterations)]) - (define m1 (new angry-monkey%)) - (define m2 (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (define random-monkey (if (= 0 (random 2)) m1 m2)) - (case (random 12) - [(0 1 2) - (send random-monkey insert-front!)] - [(3 4 5) - (send random-monkey insert-back!)] - [(6) - (send random-monkey delete-random!)] - [(7) - (send random-monkey replace-at-random!)] - [(8) - (send m1 throw-all-at-monkey m2)] - [(9) - (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!))))) - - - (define angry-monkey-pair-test-parallel - (test-suite - ;; What do you call a group of monkeys? A troop! - ;; (http://www.npwrc.usgs.gov/about/faqs/animals/names.htm) - "Simulation of a troop of angry monkeys bashing at the tree. - They should not see each other." - (test-begin - (printf "monkey tests parallel...\n") - (define number-of-operations 100) - (define number-of-iterations 100) - (define threads - (for/list ([i (in-range 4)]) - (thread (lambda () - (for ([i (in-range number-of-iterations)]) - (define m (new angry-monkey%)) - (for ([i (in-range number-of-operations)]) - (case (random 6) - [(0) - (send m insert-front!)] - [(1) - (send m insert-back!)] - [(2) - (send m delete-random!)] - [(3) - (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)]) - (thread-wait t))))) - - - (define exhaustive-split-test - (test-suite - "exhaustive split test..." - ;; Another exhaustive test. Among N elements, split everywhere, - ;; and make sure we get the expected values on the left and right. - ;; Also print out how long it takes to do the actual splitting. - (test-case - "(1 ... n) ---split-k--> (1 ... k-1) (k+1 ...n)" - (printf "exhaustive split test...\n") - (define N 2000) - (define elts (for/list ([i (in-range N)]) i)) - (define total-splitting-time 0) - (for ([n (in-range N)]) - (define t (new-tree)) - (for ([w (in-list elts)]) - (insert-last/data! t w 1)) - (define pivot (search t n)) - (define-values (l r) - (time-acc - total-splitting-time - (split! t pivot))) - (check-true (nil? (tree-root t))) - (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))) - (printf "time in split: ~a\n" total-splitting-time)))) - - - - (define all-tests - (test-suite "all-tests" - nil-tests - rotation-tests - insertion-tests - deletion-tests - search-tests - position-tests - concat-tests - predecessor-successor-min-max-tests - fold-tests - update-width-tests - split-tests - mixed-tests - - ;; The following tests are a bit more expensive. Wait a while. - angry-monkey-test-1 - angry-monkey-test-2 - angry-monkey-pair-test - angry-monkey-pair-test-parallel - exhaustive-split-test)) - - (void - (printf "Running test suite.\nWarning: this suite can run very slowly under DrRacket when debugging is on.\n") - (run-tests all-tests))) diff --git a/collects/syntax-color/red-black.scrbl b/collects/syntax-color/red-black.scrbl deleted file mode 100644 index 8d81485fee..0000000000 --- a/collects/syntax-color/red-black.scrbl +++ /dev/null @@ -1,805 +0,0 @@ -#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 "" 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 will raise -a contract error: -@interaction[#:eval my-eval -(define t1 (new-tree)) -(insert-first/data! t1 "tricky" 1) -(define n (new-node "tricky" 1)) -@code:comment{This should raise an error:} -(delete! t1 n) -]} - - -@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 - roshi))]) - (insert-last/data! t2 name 1)) -(define tree-of-mighty-z-warriors (join! t1 t2)) -(map car (tree-items tree-of-mighty-z-warriors)) -] - -Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise -a contract error. -@interaction[#:eval my-eval -(define t1 (new-tree)) -(join! t1 t1) -] -} - - -@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) -] - -Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise -a contract error. -@interaction[#:eval my-eval -(define t1 (new-tree)) -(define n (new-node "a-node" 1)) -(concat! t1 n t1) -] -} - - -@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 raise -a contract error. -@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[(reset! [t tree?]) void?]{ -Resets the contents of the tree to the empty state. -@interaction[#:eval my-eval -(define t (new-tree)) -(insert-last/data! t "house" 5) -(insert-last/data! t "cleaning" 8) -(tree-items t) -(reset! t) -(tree-items t)] -} - - - -@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] \ No newline at end of file