suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
adee7494b4
racket/collects/syntax-color/private/augmented-red-black.rkt

2756 lines
93 KiB
Racket
Raw Blame History

#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)))
Reference in New Issue View Git Blame Copy Permalink