From 2f94e17e6ad6196e92393b39ca6bb26975984ae3 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 30 Nov 2012 13:22:20 -0700 Subject: [PATCH] Add an abstracted red-black tree that can take a custom node combinator. --- .../syntax-color/augmented-red-black.scrbl | 807 +++++ .../private/augmented-red-black.rkt | 2755 +++++++++++++++++ collects/syntax-color/private/red-black.rkt | 61 +- 3 files changed, 3607 insertions(+), 16 deletions(-) create mode 100644 collects/syntax-color/augmented-red-black.scrbl create mode 100644 collects/syntax-color/private/augmented-red-black.rkt diff --git a/collects/syntax-color/augmented-red-black.scrbl b/collects/syntax-color/augmented-red-black.scrbl new file mode 100644 index 0000000000..ddf4fe14ff --- /dev/null +++ b/collects/syntax-color/augmented-red-black.scrbl @@ -0,0 +1,807 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + (for-label syntax-color/private/augmented-red-black + racket/base + racket/string)) + +@(define my-eval (make-base-eval)) +@(my-eval '(require syntax-color/private/augmented-red-black racket/string)) + +@title{Augmented Red-Black Trees} +@author+email["Danny Yoo" "dyoo@hashcollision.org"] + + +@defmodule[syntax-color/private/augmented-red-black] + +This is an implementation of an augmented red-black tree that extends the nodes +of a basic red-black tree with attached metadata at every node. The metadata +at a node should be a function of the data of the current node and the left and +right children. + +One 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 +@code:comment{Here, the metadata represents the length of the contents} +@code:comment{of the entire subtree:} +(define (size-of-data data) + (string-length data)) +(define (new-catenated-string-tree) + (new-tree #:metadata-f (lambda (data left right) + (+ (size-of-data data) + (or (node-metadata left) 0) + (or (node-metadata right) 0))))) +(define a-tree (new-catenated-string-tree)) +(for ([w (in-list '("This" " " "is" " " "a" " " "test"))]) + (insert-last/data! a-tree w)) + +@code:comment{Assuming the metadata is correct at every node, we can search} +@code:comment{for a node by its "position" by using the metadata:} +(define (search a-tree offset) + (let loop ([offset offset] [a-node (tree-root a-tree)]) + (cond + [(nil-node? a-node) nil] + [else + (define left (node-left a-node)) + (define left-subtree-width (or (node-metadata left) 0)) + (cond [(< offset left-subtree-width) + (loop offset left)] + [else + (define residual-offset (- offset left-subtree-width)) + (define len (size-of-data (node-data a-node))) + (cond + [(< residual-offset len) + a-node] + [else + (loop (- residual-offset len) + (node-right a-node))])])]))) +@code:comment{Now we can search:} +(node-data (search a-tree 0)) +(node-data (search a-tree 10)) +(define at-test-node (search a-tree 10)) +@code:comment{We can also insert within the tree,} +(insert-before/data! a-tree at-test-node "small") +(tree-items a-tree) +@code:comment{and 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) +] + + +The interpretation of the metadata is up to clients. Another approprate +metadata may hold subtree @emph{size} rather than string length, in which case +the tree acts as an container where items can be found through their index: + +@interaction[#:eval my-eval +@code:comment{The definitions above depend on the value of} +@code:comment{size-of-data. Let's mutate it to be evil.} +@code:comment{(Note: don't do this in production code.)} +(set! size-of-data (lambda (data) 1)) +@code:comment{And now we get a different kind of search altogether:} +(define t (new-catenated-string-tree)) +(insert-last/data! t "rock") +(insert-last/data! t "scissors") +(insert-after/data! t (tree-first t) "paper") +(node-data (search t 0)) +(node-data (search t 1)) +(node-data (search t 2)) +] + + +This augmented red-black tree implementation follows the basic outline 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 (@racket[tree-root]), and each node has holds +arbitrary @emph{data} (@racket[node-data]) and @emph{metadata} +(@racket[node-metadata]), along with a reference to the elements smaller +(@racket[node-left]) and larger (@racket[node-right]). 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/augmented-red-black] + + +@subsection{Data types} + +@defproc[(new-tree [#:metadata-f metadata-f #f (or/c #f (any/c node? node? . -> . any))]) 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)) +] + + +When provided a @racket[#:metadata-f], each node in the tree will +have an associated @racket[node-metadata] that is computed through its +@racket[node-data], @racket[node-left] and @racket[node-right]. + +The @racket[#:metadata-f] must not mutate the tree as a side effect; contracts +currently do not enforce this requirement, but may in the future.} + + + +@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))) +]} + + + +@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 +(nil-node? (tree-root (new-tree))) +(define a-tree (new-tree)) +(define a-node (new-node "first node!")) +(insert-first! a-tree a-node) +(eq? a-node (tree-root a-tree))] +} + + +@defproc[(tree-metadata-f [t tree?]) (or/c #f (any/c node? node? . -> . any))]{ +Returns the metadata-computing function for the tree @racket[t]. + +@interaction[#:eval my-eval +(define a-tree (new-tree)) +(tree-metadata-f a-tree) +(define (indexed-metadata-f data left right) + (+ 1 (or (node-metadata left) 0) (or (node-metadata right) 0))) +(define another-tree (new-tree #:metadata-f indexed-metadata-f)) +(tree-metadata-f another-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!")) +(define another-node (new-node "last node!")) +(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!")) +(define another-node (new-node "last node!")) +(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]) 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!], and spliced with @racket[concat!]. + +@interaction[#:eval my-eval +(new-node #("a" "node"))] +} + + +@defproc[(node? [x any/c]) boolean?]{ +Returns @racket[#t] if @racket[x] is a node. +@interaction[#:eval my-eval +(node? (new-node #("a" "node"))) +@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"))) +(singleton-node? nil) + +@code:comment{Create a fresh node:} +(define a-node (new-node "about to attach")) +(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 +@racket['black], its @racket[node-metadata] is @racket[#f], 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")) +] +} + + +@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")) +] +} + + +@defproc[(node-data [n node?]) any/c]{ +Returns the data associated to node @racket[n]. +@interaction[#:eval my-eval +(define a-node (new-node "utah")) +(node-data a-node) +] +} + +@defproc[(update-node-data! [t tree?] [n node?] [v any/c]) void?]{ + +Assigns the data associated to node @racket[n]. Note that this also may update +the metadata of the tree if the tree has been constructed with a +@racket[#:metadata-f]. + +@interaction[#:eval my-eval +(define a-tree (new-tree)) +(define a-node (new-node "utah")) +(insert-first! a-tree a-node) +(update-node-data! a-tree a-node "rhode island") +(node-data a-node) +] +} + + + +@defproc[(node-metadata [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 (size-metadata str left right) + (+ 1 + (or (node-metadata left) 0) + (or (node-metadata right) 0))) +(define a-tree (new-tree #:metadata-f size-metadata)) +(insert-last/data! a-tree "berkeley") +(insert-last/data! a-tree "stanford") +(insert-last/data! a-tree "wpi") +(insert-last/data! a-tree "brown") +(insert-last/data! a-tree "utah") +@code:comment{The entire tree should have a metadata of five, the size of the tree.} +(node-metadata (tree-root a-tree)) +(node-metadata (node-left (tree-root a-tree))) +(node-metadata (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") +(insert-last/data! a-tree "the matrix") +(insert-last/data! a-tree "speed") +(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") +(insert-last/data! a-tree "the matrix") +(insert-last/data! a-tree "speed") +(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") +(insert-last/data! a-tree "the matrix") +(insert-last/data! a-tree "speed") +(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 internally to maintain binary tree balance; most users will not need +to inspect this value. + +@interaction[#:eval my-eval +(define a-tree (new-tree)) +(insert-last/data! a-tree "the color purple") +(insert-last/data! a-tree "pretty in pink") +(insert-last/data! a-tree "the thin red line") +(insert-last/data! a-tree "clockwork orange") +(insert-last/data! a-tree "fried green tomatoes") +(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") +(insert-last/data! a-tree "the fellowship of the ring") +(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") +(insert-last/data! a-tree "the two towers") +(insert-last/data! a-tree "return of the king") +@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")) +(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")) +(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")) +(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")) +(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")) +(define b-node (new-node "mango")) +(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")) +(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")) +(define b-node (new-node "pawpaw")) +(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")) +(insert-first! a-tree a-node) +(insert-after! a-tree a-node a-node) +] +} + + + +@deftogether[ +( +@defproc[(insert-first/data! [t tree?] [data any/c]) void?]{} +@defproc[(insert-last/data! [t tree?] [data any/c]) void?]{} +@defproc[(insert-before/data! [t tree?] [n node?] [data any/c]) void?]{} +@defproc[(insert-after/data! [t tree?] [n node?] [data any/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") +(insert-last/data! t "don't stand so close to me") +(insert-before/data! t (tree-first t) "everything she does is magic") +(insert-after/data! t (tree-last t) "king of pain") +(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,")) +(define n2 (new-node "strong as he can be...")) +(define n3 (new-node "aaaaaaaaaaah!")) +(define n4 (new-node "watch out for that...")) +(define n5 (new-node "")) +(define n6 (new-node "treeeeeeeeee!, ")) +(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") +(define n (new-node "tricky")) +@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)) +@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)) +(define tree-of-mighty-z-warriors (join! t1 t2)) +(tree-items tree-of-mighty-z-warriors) +] + +Note that @racket[t1] and @racket[t2] should share the same +@racket[tree-metadata-f] and neither tree should be @racket[eq?] to the other. +Violations of either condition 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") +(define x (new-node "vizzini")) +(insert-last/data! t2 "fezzik") +(define poor-lost-circus-performers (concat! t1 x t2)) +(tree-items poor-lost-circus-performers) +] + + +Note that @racket[t1] and @racket[t2] should share the same +@racket[tree-metadata-f] and neither tree should be @racket[eq?] to the other. +Violations of either condition will raise a contract error. + +@interaction[#:eval my-eval +(define (f1 data left right) 1) +(define (f2 data left right) 1) +@code:comment{f1 and f2 are distinct function values: they won't compare the same.} +(define t1 (new-tree #:metadata-f f1)) +(define t2 (new-tree #:metadata-f f2)) +(define n (new-node "a-node")) +(concat! t1 n t2) +] +} + + +@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)) +(define bob-node (predecessor (tree-last t))) +(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)) +@code:comment{This should raise an error:} +(define t2 (new-tree)) +(insert-last! t2 (new-node "bob")) +(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") +(insert-last/data! t "cleaning") +(tree-items t) +(reset! t) +(tree-items 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)) +(node-data (minimum (tree-root t))) +] +Note: to get the minimum of a 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)) +(node-data (maximum (tree-root t))) +] +Note: to get the maximum of a 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)) +(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)) +(define last-alien (tree-last partial-alien-tree)) +(node-data (predecessor last-alien)) +(node-data (predecessor (predecessor last-alien))) +] +} + + + +@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") +(insert-last/data! t "paper") +(insert-last/data! t "scissors") +(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") +(insert-last/data! t "blind") +(insert-last/data! t "mice") +@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 diff --git a/collects/syntax-color/private/augmented-red-black.rkt b/collects/syntax-color/private/augmented-red-black.rkt new file mode 100644 index 0000000000..2b4c6ba780 --- /dev/null +++ b/collects/syntax-color/private/augmented-red-black.rkt @@ -0,0 +1,2755 @@ +#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/red-black.rkt b/collects/syntax-color/private/red-black.rkt index 7a28d6eb15..79cac6cf1a 100644 --- a/collects/syntax-color/private/red-black.rkt +++ b/collects/syntax-color/private/red-black.rkt @@ -62,7 +62,7 @@ [singleton-node? (any/c . -> . boolean?)] [non-nil-node? (any/c . -> . boolean?)] [nil node?] - [rename public:nil? nil-node? (any/c . -> . boolean?)] + [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)] @@ -73,8 +73,8 @@ [node-left (node? . -> . node?)] [node-right (node? . -> . node?)] [node-color (node? . -> . (or/c 'red 'black))] - [rename public:red? red? (node? . -> . boolean?)] - [rename public:black? black? (node? . -> . boolean?)] + [rename red?/proc red? (node? . -> . boolean?)] + [rename black?/proc black? (node? . -> . boolean?)] [new-tree (-> tree?)] [new-node (any/c natural-number/c . -> . node?)] @@ -198,23 +198,52 @@ ;; nil?: node -> boolean ;; Tell us if we're at the distinguished nil node. -(define-syntax-rule (nil? x) (eq? x nil)) -(define public:nil? (procedure-rename (lambda (x) (nil? x)) 'nil?)) +(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-rule (red? x) - (let ([v x]) - (eq? (node-color v) red))) -(define public:red? (procedure-rename (lambda (x) (red? x)) '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-rule (black? x) - (let ([v x]) - (eq? (node-color v) black))) -(define public:black? (procedure-rename (lambda (x) (black? x)) '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?)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1275,7 +1304,7 @@ singleton-node? non-nil-node? nil - [rename-out [public:nil? nil-node?]] + [rename-out [nil? nil-node?]] node-data set-node-data! node-self-width @@ -1284,8 +1313,8 @@ node-left node-right node-color - [rename-out [public:red? red?] - [public:black? black?]] + red? + black? new-tree new-node insert-first!