Add full contracts to red-black.rkt, with extensive documention in red-black.scrbl.

A submodule called "uncontracted" provides the contract-free bindings,
as I suspect we'll need them for the token tree for maximum performance.OB

collects/syntax-color/info.rkt

@@ -1,3 +1,4 @@
 #lang setup/infotab
 
-(define scribblings '(("syntax-color.scrbl" () (gui-library))))
+(define scribblings '(("syntax-color.scrbl" () (gui-library))
+                      ("red-black.scrbl")))

collects/syntax-color/private/red-black.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base))
+(require (for-syntax racket/base)
+         racket/contract)
 
 ;; Implementation of an augmented red-black tree, where extra
 ;; information supports position-based queries.
@@ -47,46 +48,68 @@
 ;;
 
 
-(provide tree?
+;; TODO: defensively check whether the node being deleted or split off
-         tree-root
+;; actually exists in the tree.
-         tree-first
-         tree-last
-         node?
-         nil
-         nil?
-         node-data
-         node-self-width
-         node-subtree-width
-         node-parent
-         node-left
-         node-right
-         node-color
-         red?
-         black?
 
-         new-tree
-         new-node
-         insert-first!
-         insert-before!
-         insert-after!
-         insert-first/data!
-         insert-last/data!
-         insert-before/data!
-         insert-after/data!
 
-         delete!
+(provide [contract-out 
-         join!
+          [tree? (any/c . -> . boolean?)]
-         split!
+          [tree-root (tree? . -> . node?)]
+          [tree-first (tree? . -> . node?)]
+          [tree-last (tree? . -> . node?)]
+          [node? (any/c . -> . boolean?)]
+          [singleton-node? (any/c . -> . boolean?)]
+          [non-nil-node? (any/c . -> . boolean?)]
+          [nil node?]
+          [rename public:nil? nil-node? (any/c . -> . boolean?)]
+          [node-data (node? . -> . any)]
+          [set-node-data! (node? any/c . -> . any)]
+          [node-self-width (node? . -> . natural-number/c)]
+          [update-node-self-width! (non-nil-node? natural-number/c . -> . any)]
+          [node-subtree-width (node? . -> . natural-number/c)]
 
-         search
+          [node-parent (node? . -> . node?)]
+          [node-left (node? . -> . node?)]
+          [node-right (node? . -> . node?)]
+          [node-color (node? . -> . (or/c 'red 'black))]
+          [rename public:red? red? (node? . -> . boolean?)]
+          [rename public:black? black? (node? . -> . boolean?)]
 
-         minimum
+          [new-tree (-> tree?)]
-         maximum
+          [new-node (any/c natural-number/c . -> . node?)]
-         successor
+          [insert-first! (tree? singleton-node? . -> . any)]
-         predecessor
+          [insert-last! (tree? singleton-node? . -> . any)]
-         position
+          [insert-before! (tree? non-nil-node? singleton-node? . -> . any)]
+          [insert-after! (tree? non-nil-node? singleton-node? . -> . any)]
+          [insert-first/data! (tree? any/c natural-number/c . -> . any)]
+          [insert-last/data! (tree? any/c natural-number/c . -> . any)]
+          [insert-before/data! (tree? non-nil-node? any/c natural-number/c . -> . any)]
+          [insert-after/data! (tree? non-nil-node? any/c natural-number/c . -> . any)]
+                       
+          [delete! (->i ([t tree?] 
+                         [n (t) (non-nil-node-in-tree? t)])
+                        [result any/c])]
+          [join! (tree? tree? . -> . tree?)]
+          [concat! (tree? singleton-node? tree? . -> . any)]
+          [split! (->i ([t tree?] 
+                         [n (t) (non-nil-node-in-tree? t)])
+                        (values [t1 tree?] [t2 tree?]))]
+
+                       
+          [search (tree? natural-number/c . -> . node?)]
+          [search/residual (tree? natural-number/c . -> . (values node? natural-number/c))]
+                       
+          [minimum (node? . -> . node?)]
+          [maximum (node? . -> . node?)]
+          [successor (node? . -> . node?)]
+          [predecessor (node? . -> . node?)]
+          [position (node? . -> . natural-number/c)]
+         
+          [tree-items (tree? . -> . 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)]])
 
-         tree-items)
 
 
 ;; First, our data structures:
@@ -119,21 +142,63 @@
               (set-node-right! v v)
               v))
 
+;; singleton-node?: any -> boolean
+;; Returns true if n is a singleton node that is unattached to
+;; any other tree.  We've carefully designed the operations
+;; so that the only way to get a singleton node is either through
+;; the new-node constructor, split!, or delete!.  Similarly,
+;; the public-accessible tree-insertion functions will check that
+;; they receive singleton nodes.  This way, we avoid the potential
+;; construction of cycles.
+(define (singleton-node? n)
+  (and (node? n)
+       (red? n)
+       (nil? (node-parent n))))
+
+
+;; non-nil-node?: any -> boolean
+;; Returns true if n is a non-nil node.
+(define (non-nil-node? n)
+  (and (node? n)
+       (not (nil? n))))
+
+
+
+;; We use this function for contract checking with delete! and split!,
+;; where the node being deleted must be in the tree in the first place.
+(define (non-nil-node-in-tree? t)
+  (flat-named-contract 'node-in-tree
+                       (lambda (n)
+                         (and (node? n)
+                              (not (nil? n))
+                              (let loop ([n n])
+                                (define p (node-parent n))
+                                (cond [(nil? p)
+                                       (eq? (tree-root t) n)]
+                                      [else
+                                       (loop p)]))))))
+
+
+
 ;; nil?: node -> boolean
 ;; Tell us if we're at the distinguished nil node.
 (define-syntax-rule (nil? x) (eq? x nil))
+(define public:nil? (procedure-rename (lambda (x) (nil? x)) 'nil?))
 
 ;; red?: node -> boolean
 ;; Is the node red?
 (define-syntax-rule (red? x) 
   (let ([v x])
     (eq? (node-color v) red)))
+(define public:red? (procedure-rename (lambda (x) (red? x)) 'red?))
+
 
 ;; black?: node -> boolean
 ;; Is the node black?
 (define-syntax-rule (black? x) 
   (let ([v x])
     (eq? (node-color v) black)))
+(define public:black? (procedure-rename (lambda (x) (black? x)) 'black?))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -243,6 +308,7 @@
 
 
 
+
 ;; insert-first!: tree (and/c (not nil?) node?) -> void
 ;; Insert node x as the first element in the tree.
 ;; x is assumed to be a singleton element whose fields
@@ -505,6 +571,13 @@
                    ;; at z.p.
                    (when (not (nil? z.p))
                      (update-subtree-width-up-to-root! z.p))
+
+                   ; Turn z singleton:
+                   (set-node-parent! z nil)
+                   (set-node-left! z nil)
+                   (set-node-right! z nil)
+                   (set-node-color! z red)
+
                    (values x y-original-color nil-parent)]
                   
                   ;; This case is symmetric with the previous case.
@@ -514,6 +587,10 @@
                    (define nil-parent (transplant-for-delete! a-tree z x))
                    (when (not (nil? z.p))
                      (update-subtree-width-up-to-root! z.p))
+                   (set-node-parent! z nil)
+                   (set-node-left! z nil)
+                   (set-node-right! z nil)
+                   (set-node-color! z red)
                    (values x y-original-color nil-parent)]
                   
                   ;; The hardest case is when z has non-nil left and right.
@@ -556,6 +633,13 @@
                      (set-node-color! y (node-color z))
                      (update-subtree-width-up-to-root! 
                       (if (nil? x) nil-parent (node-parent x)))
+                     
+                     ;; Turn z singleton:
+                     (set-node-parent! z nil)
+                     (set-node-left! z nil)
+                     (set-node-right! z nil)
+                     (set-node-color! z red)
+ 
                      (values x y-original-color nil-parent))])])
     (cond [(eq? black y-original-color)
            (fix-after-delete! a-tree x nil-parent)]
@@ -690,10 +774,21 @@
 ;; The total length of the left subtree will be at least offset, if possible.
 ;; Returns nil if the offset is not within the tree.
 (define (search a-tree offset)
+  (define-values (result residual) (search/residual a-tree offset))
+  result)
+
+
+;; search/residual: tree natural -> (values (U node nil) natural)
+;; Search for the node closest to offset.  Also returns the residual left
+;; after searching.
+;; The total length of the left subtree will be at least offset, if possible.
+;; Returns nil if the offset is not within the tree.
+(define (search/residual a-tree offset)
   (let loop ([offset offset]
              [a-node (tree-root a-tree)])
     (cond
-      [(nil? a-node) nil]
+      [(nil? a-node) 
+       (values nil offset)]
       [else
        (define left (node-left a-node))
        (define left-subtree-width (node-subtree-width left))
@@ -704,12 +799,13 @@
               (define self-width (node-self-width a-node))
               (cond
                 [(< residual-offset self-width)
-                 a-node]
+                 (values a-node residual-offset)]
                 [else
                  (loop (- residual-offset self-width)
                        (node-right a-node))])])])))
 
 
+
 ;; position: node -> (or natural -1)
 ;; Given a node in the tree, returns its position such that
 ;; a search in the tree with that position will return the node.
@@ -886,20 +982,32 @@
 
 ;; split!: tree node -> (values tree tree)
 ;; Partitions the tree into two trees: the predecessors of x, and the
-;; successors of x.
+;; successors of x.  Also mutates x into a singleton node.
 ;;
 ;; Note: during the loop, the L and R trees do not necessarily have
 ;; a valid tree-first or tree-last.  I want to avoid recomputing
 ;; it for each fresh subtree I construct.
 (define (split! a-tree x)
   (define x-child-bh (computed-black-height (node-left x)))
+  (define ancestor (node-parent x))
+  (define ancestor-child-bh (if (black? x) (add1 x-child-bh) x-child-bh))
+  (define coming-from-the-right? (eq? (node-right (node-parent x)) x))
+  (define L (node->tree/bh (node-left x) x-child-bh))
+  (define R (node->tree/bh (node-right x) x-child-bh))
+
+  ;; Turn x into a singleton node:
+  (detach! x)
+  (set-node-right! x nil)
+  (set-node-left! x nil)
+  (set-node-color! x red)
+
   ;; The loop walks the ancestors of x, adding the left and right
   ;; elements appropriately.
-  (let loop ([ancestor (node-parent x)]
+  (let loop ([ancestor ancestor]
-             [ancestor-child-bh (if (black? x) (add1 x-child-bh) x-child-bh)]
+             [ancestor-child-bh ancestor-child-bh]
-             [coming-from-the-right? (eq? (node-right (node-parent x)) x)]
+             [coming-from-the-right? coming-from-the-right?]
-             [L (node->tree/bh (node-left x) x-child-bh)]
+             [L L]
-             [R (node->tree/bh (node-right x) x-child-bh)])
+             [R R])
     (cond
       [(nil? ancestor)
        ;; Now that we have our L and R, fix up their last and first
@@ -939,6 +1047,15 @@
                (concat! R ancestor subtree))])])))
 
 
+;; update-node-self-width!: node exact-nonnegative-integer -> void Updates
+;; the node's self width, and propagates that change up the tree.
+;; Internal note: do not confuse this with the similarly-named
+;; update-node-subtree-width, which does something different.
+(define (update-node-self-width! n w)
+  (set-node-self-width! n w)
+  (update-subtree-width-up-to-root! n))
+
+
 ;; force-tree-first!: tree -> void
 ;; INTERNAL
 ;; Force tree-first's value.
@@ -1012,6 +1129,7 @@
 
 
 ;; tree-items: tree -> (listof (list X natural))
+;; PUBLIC
 ;; Returns the list of items in the tree.
 (define (tree-items t)
   (let loop ([n (tree-root t)]
@@ -1026,6 +1144,107 @@
                    (loop (node-right n) acc)))])))
 
 
+;; tree-fold-inorder: tree (node X) X -> X
+;; Folds an accumulating function across the tree.
+(define (tree-fold-inorder t f acc)
+  (let loop ([n (tree-root t)]
+             [acc acc])
+    (cond
+      [(nil? n)
+       acc]
+      [else
+       (define acc-1 (loop (node-left n) acc))
+       (define acc-2 (f n acc-1))
+       (loop (node-right n) acc-2)])))
+
+
+;; tree-fold-postorder: tree (node X) X -> X
+;; Folds an accumulating function across the tree.
+(define (tree-fold-postorder t f acc)
+  (let loop ([n (tree-root t)]
+             [acc acc])
+    (cond
+      [(nil? n)
+       acc]
+      [else
+       (define acc-1 (loop (node-left n) acc))
+       (define acc-2 (loop (node-right n) acc-1))
+       (f n acc-2)])))
+
+;; tree-fold-preorder: tree (node X) X -> X
+;; Folds an accumulating function across the tree.
+(define (tree-fold-preorder t f acc)
+  (let loop ([n (tree-root t)]
+             [acc acc])
+    (cond
+      [(nil? n)
+       acc]
+      [else
+       (define acc-1 (f n acc))
+       (define acc-2 (loop (node-left n) acc-1))
+       (loop (node-right n) acc-2)])))
+
+
+
+
+
+
+;; The following are re-exports of the internals.  The only difference
+;; is that they are the uncontracted forms.
+(module+ uncontracted
+  (provide tree?
+           tree-root
+           tree-first
+           tree-last
+           node?
+           singleton-node?
+           non-nil-node?
+           nil
+           [rename-out [public:nil? nil-node?]]
+           node-data
+           set-node-data!
+           node-self-width
+           node-subtree-width
+           node-parent
+           node-left
+           node-right
+           node-color
+           [rename-out [public:red? red?]
+                       [public:black? black?]]
+           new-tree
+           new-node
+           insert-first!
+           insert-last!
+           insert-before!
+           insert-after!
+           insert-first/data!
+           insert-last/data!
+           insert-before/data!
+           insert-after/data!
+           
+           delete!
+           join!
+           concat!
+           split!
+
+           update-node-self-width!
+           
+           search
+           search/residual
+
+           minimum
+           maximum
+           successor
+           predecessor
+           position
+
+           tree-items
+           tree-fold-inorder
+           tree-fold-preorder
+           tree-fold-postorder))
+
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1034,6 +1253,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+
+
+
 (module+ test
   (require rackunit 
            rackunit/text-ui
@@ -1573,7 +1795,39 @@
       (check-equal? (node-data (search t 15)) "the")
       (check-equal? (node-data (search t 16)) "emergency")
       (check-equal? (node-data (search t 25)) "broadcast")
-      (check-equal? (node-data (search t 34)) "system"))))
+      (check-equal? (node-data (search t 34)) "system"))
+
+     (test-case
+      "searching with residuals"
+      (define t (new-tree))
+      (define words (string-split "This is a test of the emergency broadcast system"))
+      (for ([word (in-list words)])
+        (insert-last/data! t word (string-length word)))
+      (define (s t p) 
+        (define-values (n r) (search/residual t p))
+        (list (node-data n) r))
+      (check-equal? (s t 0) '("This" 0))
+      (check-equal? (s t 1) '("This" 1))
+      (check-equal? (s t 2) '("This" 2))
+      (check-equal? (s t 3) '("This" 3))
+      (check-equal? (s t 4) '("is" 0))
+      (check-equal? (s t 5) '("is" 1))
+      (check-equal? (s t 6) '("a" 0))
+      (check-equal? (s t 7) '("test" 0))
+      (check-equal? (s t 8) '("test" 1))
+      (check-equal? (s t 9) '("test" 2))
+      (check-equal? (s t 10) '("test" 3))
+      (check-equal? (s t 11) '("of" 0))
+      (check-equal? (s t 12) '("of" 1))
+      (check-equal? (s t 13) '("the" 0))
+      (check-equal? (s t 14) '("the" 1))
+      (check-equal? (s t 15) '("the" 2))
+      (check-equal? (s t 16) '("emergency" 0))
+      (check-equal? (s t 17) '("emergency" 1))
+      (check-equal? (s t 24) '("emergency" 8))
+      (check-equal? (s t 25) '("broadcast" 0))
+      (check-equal? (s t 33) '("broadcast" 8))
+      (check-equal? (s t 34) '("system" 0)))))
   
   
   (define position-tests
@@ -1748,7 +2002,9 @@
       "(a) ---split-a--> () ()"
       (define t (new-tree))
       (insert-last/data! t "a" 1)
-      (define-values (l r) (split! t (search t 0)))
+      (define n (search t 0))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
@@ -1759,7 +2015,9 @@
       (define t (new-tree))
       (insert-last/data! t "a" 1)
       (insert-last/data! t "b" 1)
-      (define-values (l r) (split! t (search t 0)))
+      (define n (search t 0))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '("b"))
       (check-rb-structure! l)
@@ -1770,7 +2028,9 @@
       (define t (new-tree))
       (insert-last/data! t "a" 1)
       (insert-last/data! t "b" 1)
-      (define-values (l r) (split! t (search t 1)))
+      (define n (search t 1))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
@@ -1782,7 +2042,9 @@
       (insert-last/data! t "a" 1)
       (insert-last/data! t "b" 1)
       (insert-last/data! t "c" 1)
-      (define-values (l r) (split! t (search t 1)))
+      (define n (search t 1))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '("c"))
       (check-rb-structure! l)
@@ -1795,7 +2057,9 @@
       (insert-last/data! t "b" 1)
       (insert-last/data! t "c" 1)
       (insert-last/data! t "d" 1)
-      (define-values (l r) (split! t (search t 0)))
+      (define n (search t 0))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '())
       (check-equal? (map first (tree-items r)) '("b" "c" "d"))
       (check-rb-structure! l)
@@ -1809,7 +2073,9 @@
       (insert-last/data! t "b" 1)
       (insert-last/data! t "c" 1)
       (insert-last/data! t "d" 1)
-      (define-values (l r) (split! t (search t 1)))
+      (define n (search t 1))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a"))
       (check-equal? (map first (tree-items r)) '("c" "d"))
       (check-rb-structure! l)
@@ -1823,7 +2089,9 @@
       (insert-last/data! t "b" 1)
       (insert-last/data! t "c" 1)
       (insert-last/data! t "d" 1)
-      (define-values (l r) (split! t (search t 2)))
+      (define n (search t 2))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a" "b"))
       (check-equal? (map first (tree-items r)) '("d"))
       (check-rb-structure! l)
@@ -1836,7 +2104,9 @@
       (insert-last/data! t "b" 1)
       (insert-last/data! t "c" 1)
       (insert-last/data! t "d" 1)
-      (define-values (l r) (split! t (search t 3)))
+      (define n (search t 3))
+      (define-values (l r) (split! t n))
+      (check-true (singleton-node? n))
       (check-equal? (map first (tree-items l)) '("a" "b" "c"))
       (check-equal? (map first (tree-items r)) '())
       (check-rb-structure! l)
@@ -1850,6 +2120,7 @@
                            1))
       (define letter-m (search t 12))
       (define-values (l r) (split! t letter-m))
+      (check-true (singleton-node? letter-m))
       (check-equal? (map first (tree-items l)) '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l"))
       (check-equal? (map first (tree-items r)) '("n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"))
       (check-rb-structure! l)
@@ -1863,7 +2134,9 @@
         (define t (new-tree))
         (for ([w (in-list letters)])
           (insert-last/data! t w 1))
-        (define-values (l r) (split! t (search t n)))
+        (define a-letter (search t n))
+        (define-values (l r) (split! t a-letter))
+        (check-true (singleton-node? a-letter))
         (define-values (expected-l 1+expected-r) (split-at letters n))
         (check-equal? (map first (tree-items l)) expected-l)
         (check-equal? (map first (tree-items r)) (rest 1+expected-r))
@@ -1909,6 +2182,84 @@
       (check-eq? (maximum nil) nil)
       (check-eq? (minimum nil) nil))))
 
+  (define fold-tests
+    (test-suite
+     "fold-inorder, fold-preorder, fold-postorder tests"
+     (printf "fold tests...\n")
+     (test-case
+      "nil case"
+      (define t (new-tree))
+      (check-eq? (tree-fold-inorder t values 'foo) 'foo)
+      (check-eq? (tree-fold-preorder t values 'bar) 'bar)
+      (check-eq? (tree-fold-postorder t values 'baz) 'baz))
+
+     (test-case
+      "simple case"
+      (define one (new-node 1 1))
+      (define two (new-node 2 1))
+      (define seven (new-node 7 1))
+      (define five (new-node 5 1))
+      (define eight (new-node 8 1))
+      (define eleven (new-node 11 1))
+      (define fourteen (new-node 14 1))
+      (define fifteen (new-node 15 1))
+      (define t (new-tree))
+      (insert-first! t one)
+      (insert-after! t one two)
+      (insert-after! t two seven)
+      (insert-before! t seven five)
+      (insert-after! t seven eight)
+      (insert-last! t eleven)
+      (insert-after! t eleven fourteen)
+      (insert-after! t fourteen fifteen)
+      ;; After this sequence, the constructed tree has the following shape:
+      ;;
+      ;; (7 (2 (1 () ())
+      ;;       (5 () ()))
+      ;;    (11 (8 () ())
+      ;;        (14 () 
+      ;;            (15 () ()))))
+      (define (f n acc)
+        (cons (node-data n) acc))
+      (check-equal? (reverse (tree-fold-inorder t f '()))
+                    '(1 2 5 7 8 11 14 15))
+      (check-equal? (reverse (tree-fold-preorder t f '()))
+                    '(7 2 1 5 11 8 14 15))
+      (check-equal? (reverse (tree-fold-postorder t f '()))
+                    '(1 5 2 8 15 14 11 7)))))
+
+
+  (define update-width-tests
+    (test-suite
+     "update-node-self-width! tests"
+     (test-case
+      "one node"
+      (define t (new-tree))
+      (insert-last/data! t "foo" 3)
+      (update-node-self-width! (tree-first t) 17)
+      (check-equal? (node-self-width (tree-root t)) 17)
+      (check-equal? (node-subtree-width (tree-root t)) 17))
+
+     (test-case
+      "two nodes"
+      (define t (new-tree))
+      (insert-last/data! t "foo" 3)
+      (insert-last/data! t "bar" 3)
+      (set-node-data! (tree-first t)
+                         "generally, foo and bar are terrible names")
+      (update-node-self-width! (tree-first t) 41)
+      (check-equal? (node-subtree-width (tree-root t)) 44)
+      (check-equal? (node-self-width (tree-root t)) 41)
+      (check-equal? (node-subtree-width (tree-last t)) 3)
+      (check-equal? (node-self-width (tree-last t)) 3))
+
+     (test-case
+      "on a singleton node"     ;; being single is hard.
+      (define n (new-node "so lonely" 9))
+      (set-node-data! n "soooo lovely")
+      (update-node-self-width! n 12)
+      (check-equal? (node-self-width n) 12)
+      (check-equal? (node-subtree-width n) 12))))
      
   
   
@@ -1945,6 +2296,7 @@
           (define offset (kth-offset k))
           (define node (search t offset))
           (delete! t node)
+          (check-true (singleton-node? node))
           (set! known-model (let-values ([(a b) (split-at known-model k)])
                               (append a (rest b)))))
         
@@ -1986,6 +2338,20 @@
                                       (list new-word)
                                       (drop known-model (add1 k))))))
 
+        ;; replace an old word with a new one.
+        (define/public (replace-at-random!)
+          (when (not (empty? known-model))
+            (define k (random (length known-model)))
+            (define offset (kth-offset k))
+            (define node (search t offset))
+            (define new-word (random-word))
+            (set-node-data! node new-word)
+            (update-node-self-width! node (string-length new-word))
+            (set! known-model (append (take known-model k)
+                                      (list new-word)
+                                      (drop known-model (add1 k))))))
+
+        
         
         ;; Concatenation.  Drop our existing tree and throw it at the
         ;; other m2 monkey.
@@ -2003,6 +2369,7 @@
             (define offset (kth-offset k))
             (define node (search t offset))
             (define-values (l r) (split! t node))
+            (check-true (singleton-node? node))
             (set! t l)
             (send m2 catch-and-concat-at-front r (drop known-model (add1 k)))
             (set! known-model (take known-model k))))
@@ -2032,7 +2399,7 @@
       (for ([i (in-range number-of-iterations)])
         (define m (new angry-monkey%))
         (for ([i (in-range number-of-operations)])
-          (case (random 12)
+          (case (random 13)
             [(0 1 2)
              (send m insert-front!)]
             [(3 4 5)
@@ -2041,7 +2408,9 @@
              (send m insert-after/random!)]
             [(8 9)
              (send m insert-before/random!)]
-            [(10 11)
+            [(10)
+             (send m replace-at-random!)]
+            [(11 12)
              (send m delete-random!)]))
         (send m check-consistency!)))))
   
@@ -2057,7 +2426,7 @@
       (for ([i (in-range number-of-iterations)])
         (define m (new angry-monkey%))
         (for ([i (in-range number-of-operations)])
-          (case (random 12)
+          (case (random 13)
             [(0 1)
              (send m insert-front!)]
             [(2 3)
@@ -2066,7 +2435,9 @@
              (send m insert-after/random!)]
             [(6 7)
              (send m insert-before/random!)]
-            [(8 9 10 11)
+            [(8)
+             (send m replace-at-random!)]
+            [(9 10 11 12)
              (send m delete-random!)]))
         (send m check-consistency!)))))
   
@@ -2083,7 +2454,7 @@
         (define m2 (new angry-monkey%))
         (for ([i (in-range number-of-operations)])
           (define random-monkey (if (= 0 (random 2)) m1 m2))
-          (case (random 11)
+          (case (random 12)
             [(0 1 2)
              (send random-monkey insert-front!)]
             [(3 4 5)
@@ -2091,12 +2462,14 @@
             [(6)
              (send random-monkey delete-random!)]
             [(7)
-             (send m1 throw-all-at-monkey m2)]
+             (send random-monkey replace-at-random!)]
             [(8)
-             (send m2 throw-all-at-monkey m1)]
+             (send m1 throw-all-at-monkey m2)]
             [(9)
-             (send m1 throw-some-at-monkey m2)]
+             (send m2 throw-all-at-monkey m1)]
             [(10)
+             (send m1 throw-some-at-monkey m2)]
+            [(11)
              (send m2 throw-some-at-monkey m1)]))
         (send m1 check-consistency!)
         (send m2 check-consistency!)))))
@@ -2118,7 +2491,7 @@
                     (for ([i (in-range number-of-iterations)])
                       (define m (new angry-monkey%))
                       (for ([i (in-range number-of-operations)])
-                        (case (random 11)
+                        (case (random 6)
                           [(0)
                            (send m insert-front!)]
                           [(1)
@@ -2126,8 +2499,10 @@
                           [(2)
                            (send m delete-random!)]
                           [(3)
-                           (send m insert-after/random!)]
+                           (send m replace-at-random!)]
                           [(4)
+                           (send m insert-after/random!)]
+                          [(5)
                            (send m insert-before/random!)]))
                       (send m check-consistency!))))))
       (for ([t (in-list threads)])
@@ -2150,11 +2525,12 @@
         (define t (new-tree))
         (for ([w (in-list elts)])
           (insert-last/data! t w 1))
+        (define pivot (search t n))
         (define-values (l r) 
-          (let ([pivot (search t n)])
+          (time-acc 
-            (time-acc 
+           total-splitting-time
-             total-splitting-time
+           (split! t pivot)))
-             (split! t pivot))))
+        (check-true (singleton-node? pivot))
         (define-values (expected-l 1+expected-r) (split-at elts n))
         (check-equal? (map first (tree-items l)) expected-l)
         (check-equal? (map first (tree-items r)) (rest 1+expected-r)))
@@ -2172,6 +2548,8 @@
                 position-tests
                 concat-tests
                 predecessor-successor-min-max-tests
+                fold-tests
+                update-width-tests
                 split-tests
                 mixed-tests
 

collects/syntax-color/red-black.scrbl

@@ -0,0 +1,778 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          (for-label syntax-color/private/red-black
+                     racket/base
+                     racket/string))
+
+@(define my-eval (make-base-eval))
+@(my-eval '(require syntax-color/private/red-black racket/string))
+
+@title{Ordered Red-Black Trees}
+@author+email["Danny Yoo" "dyoo@hashcollision.org"]
+
+
+@defmodule[syntax-color/private/red-black]
+
+This is an implementation of an augmented red-black tree with extra information
+to support position-based queries.
+
+The intended usage case of this structure is to maintain an ordered sequence of
+items, where each item has an internal length.  Given such a sequence, we want
+to support quick lookup by position and in-place insertions and deletions.
+We also want to support the catenation and splitting of sequences.
+
+For example:
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(for ([w (in-list '("This" " " "is" " " "a" " " "test"))])
+  (insert-last/data! a-tree w (string-length w)))
+(node-data (search a-tree 0))
+(node-data (search a-tree 10))
+(define at-test-node (search a-tree 10))
+(insert-before/data! a-tree at-test-node "small" 5)
+(tree-items a-tree)
+@code:comment{Split at the node holding "small":}
+(define at-small-node (search a-tree 10))
+(define-values (left-side right-side) (split! a-tree at-small-node))
+(tree-items left-side)
+(tree-items right-side)
+(define joined-tree (join! left-side right-side))
+(tree-items joined-tree)
+]
+
+
+This implementation follows the basic outline for order-statistic red-black
+trees described in @cite{clrs2009} and incorporates a few extensions suggsted
+in @cite{wein2005}.  As a red-black tree, the structure ensures that the tree's
+height is never greater than @math{2*lg(#-of-nodes + 1)}, guaranteeing good
+worst-case behavior for its operations.
+
+The main types of values used in the library are @emph{trees} and @emph{nodes}.
+A tree has a @emph{root} node, and each node has holds arbitrary @emph{data}
+and a natural @emph{self-width}, along with a reference to the elements smaller
+(@racket[node-left]) and larger (@racket[node-right]).  Each node also
+remembers the entire width of its subtree, which can be accessed with
+@racket[node-subtree-width].  The tree holds first and last pointers into the
+structure to allow for fast access to the beginning and end of the sequence.  A
+distinguished @racket[nil] node lies at the leaves of the tree.
+
+
+
+@section{API}
+@declare-exporting[syntax-color/private/red-black]
+
+
+@subsection{Data types}
+
+@defproc[(new-tree) tree?]{
+Constructs a new tree.  The tree's root is initially @racket[nil].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+a-tree
+(nil-node? (tree-root a-tree))
+]
+}
+
+
+
+@defproc[(tree? [x any/c]) boolean?]{
+Returns @racket[#t] if @racket[x] is a tree.
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(tree? a-tree)
+(tree? "not a tree")
+(tree? (new-node '(not a tree either) 0))
+]}
+
+
+
+@defproc[(tree-root [t tree?]) node?]{
+Returns the root node of the tree @racket[t].
+If the tree is empty, returns the distinguished @racket[nil] node.
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(nil-node? (tree-root (new-tree)))
+(define a-node (new-node "first node!" 11))
+(insert-first! a-tree a-node)
+(eq? a-node (tree-root a-tree))]
+}
+
+
+
+@defproc[(tree-first [t tree?]) node?]{
+Returns the first node in the tree.
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(nil-node? (tree-first (new-tree)))
+(define a-node (new-node "first node!" 11))
+(define another-node (new-node "last node!" 11))
+(insert-first! a-tree a-node)
+(insert-last! a-tree another-node)
+(eq? a-node (tree-first a-tree))]
+}
+
+
+@defproc[(tree-last [t tree?]) node?]{
+Returns the last node in the tree.
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(nil-node? (tree-first (new-tree)))
+(define a-node (new-node "first node!" 11))
+(define another-node (new-node "last node!" 11))
+(insert-first! a-tree a-node)
+(insert-last! a-tree another-node)
+(eq? another-node (tree-last a-tree))]
+}
+
+
+@defproc[(new-node [data any/c] [width natural-number/c]) singleton-node?]{
+Constructs a new singleton node.  This node can be inserted into a tree with
+@racket[insert-first!], @racket[insert-last!], @racket[insert-before!], or
+@racket[insert-after!].
+
+@interaction[#:eval my-eval
+(new-node #("a" "node") 7)]
+}
+
+
+@defproc[(node? [x any/c]) boolean?]{
+Returns @racket[#t] if @racket[x] is a node.
+@interaction[#:eval my-eval
+(node? (new-node #("a" "node") 7))
+@code:comment{Trees are not nodes: they _have_ nodes.}
+(node? (new-tree))
+(node? (tree-root (new-tree)))
+]
+}
+
+
+@defproc[(singleton-node? [x any/c]) boolean?]{
+Returns @racket[#t] if @racket[x] is a @emph{singleton node}.  A singleton node
+is unattached to any tree, and is not the @racket[nil] node.
+@interaction[#:eval my-eval
+(singleton-node? (new-node #("a" "node") 7))
+(singleton-node? nil)
+
+@code:comment{Create a fresh node:}
+(define a-node (new-node "about to attach" 0))
+(singleton-node? a-node)
+@code:comment{After attachment, it is no longer singleton:}
+(define a-tree (new-tree))
+(insert-first! a-tree a-node)
+(singleton-node? a-node)
+@code:comment{Operations such as delete! or split! will break}
+@code:comment{off nodes as singletons again:}
+(delete! a-tree a-node)
+(singleton-node? a-node)
+]
+}
+
+
+@defthing[nil node?]{
+
+The distinguished @racket[nil] node.  By definition, @racket[nil] is colored
+black, and its @racket[node-parent], @racket[node-left], and
+@racket[node-right] are pointed to itself.}
+
+
+@defproc[(non-nil-node? [x any/c]) boolean?]{
+Returns @racket[#t] if @racket[x] is a non-nil node.
+@interaction[#:eval my-eval
+(non-nil-node? nil)
+(non-nil-node? (new-node "I am not a number" 1))
+]
+}
+
+
+@defproc[(nil-node? [x any/c]) boolean?]{
+Returns @racket[#t] if @racket[x] is the nil node.
+@interaction[#:eval my-eval
+(nil-node? nil)
+(nil-node? (new-node "I am not a number" 1))
+]
+}
+
+
+@defproc[(node-data [n node?]) any/c]{
+Returns the data associated to node @racket[n].  Note that the
+@racket[node-data] and @racket[node-self-width] are entirely independent.
+
+@interaction[#:eval my-eval
+(define a-node (new-node "utah" 4))
+(node-data a-node)
+]
+}
+
+@defproc[(set-node-data! [n node?] [v any/c]) void?]{
+Assigns the data associated to node @racket[n].  Note that the
+@racket[node-data] and @racket[node-self-width] are entirely independent.
+
+@interaction[#:eval my-eval
+(define a-node (new-node "utah" 4))
+(set-node-data! a-node "rhode island")
+(node-data a-node)
+]
+}
+
+
+
+@defproc[(node-self-width [n node?]) any/c]{
+Returns the self-width associated to node @racket[n].  Note that the
+@racket[node-data] and @racket[node-self-width] are entirely independent.
+
+@interaction[#:eval my-eval
+(define a-node (new-node "utah" 4))
+(node-self-width a-node)
+]
+}
+
+
+@defproc[(update-node-self-width! [n node?] [w natural-number/c]) any/c]{
+Updates the self-width associated to node @racket[n].  When attached to a tree,
+also propagates the width's change to the widths of subtrees, upward through
+its parents to the root.  Note that the @racket[node-data] and
+@racket[node-self-width] are entirely independent.
+
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "hello" 5)
+(insert-last/data! a-tree "world" 1)
+@code:comment{The tree as a whole has width 6:}
+(node-subtree-width (tree-root a-tree))
+@code:comment{Updates will propagate to the root:}
+(update-node-self-width! (tree-last a-tree) 5)
+(node-self-width (tree-last a-tree))
+(node-subtree-width (tree-root a-tree))
+]
+}
+
+
+@defproc[(node-subtree-width [n node?]) any/c]{
+Returns the width of the entire subtree at node @racket[n].  This sums the
+width of the left and right child subtrees, as well as its self-width.
+
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "berkeley" 1)
+(insert-last/data! a-tree "stanford" 1)
+(insert-last/data! a-tree "wpi" 1)
+(insert-last/data! a-tree "brown" 1)
+(insert-last/data! a-tree "utah" 1)
+@code:comment{The entire tree should sum to five, since each element contributes one.}
+(node-subtree-width (tree-root a-tree))
+(node-subtree-width (node-left (tree-root a-tree)))
+(node-subtree-width (node-right (tree-root a-tree)))
+]
+}
+
+
+
+@defproc[(node-parent [n node?]) node?]{
+Returns the parent of the node @racket[n].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
+(insert-last/data! a-tree "the matrix" 1)
+(insert-last/data! a-tree "speed" 1)
+(define p (node-parent (tree-last a-tree)))
+(node-data p)]
+}
+
+
+@defproc[(node-left [n node?]) node?]{
+Returns the left child of the node @racket[n].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
+(insert-last/data! a-tree "the matrix" 1)
+(insert-last/data! a-tree "speed" 1)
+(define p (node-left (tree-root a-tree)))
+(node-data p)]
+}
+
+
+@defproc[(node-right [n node?]) node?]{
+Returns the right child of the node @racket[n].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "bill and ted's excellent adventure" 1)
+(insert-last/data! a-tree "the matrix" 1)
+(insert-last/data! a-tree "speed" 1)
+(define p (node-right (tree-root a-tree)))
+(node-data p)]
+}
+
+
+
+@defproc[(node-color [n node?]) (or/c 'red 'black)]{
+Returns the color of the node @racket[n].  The red-black tree structure uses
+this value to maintain balance.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "the color purple" 1)
+(insert-last/data! a-tree "pretty in pink" 1)
+(insert-last/data! a-tree "the thin red line" 1)
+(insert-last/data! a-tree "clockwork orange" 1)
+(insert-last/data! a-tree "fried green tomatoes" 1)
+(node-color (tree-root a-tree))
+(tree-fold-inorder a-tree 
+                   (lambda (n acc) 
+                     (cons (list (node-data n) (node-color n))
+                           acc))
+                   '())]
+}
+
+
+@defproc[(red? [n node?]) boolean?]{
+Returns @racket[#t] if node @racket[n] is red.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "the hobbit" 1)
+(insert-last/data! a-tree "the fellowship of the ring" 1)
+(red? (tree-root a-tree))
+(red? (node-right (tree-root a-tree)))
+]
+}
+
+
+@defproc[(black? [n node?]) boolean?]{
+Returns @racket[#t] if node @racket[n] is black.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(insert-last/data! a-tree "the fellowship of the ring" 1)
+(insert-last/data! a-tree "the two towers" 1)
+(insert-last/data! a-tree "return of the king" 1)
+@code:comment{The root is always black.}
+(black? (tree-root a-tree))
+@code:comment{The tree should have towers as the root, with}
+@code:comment{the fellowship and king as left and right respectively.}
+(map node-data
+     (list (tree-root a-tree)
+           (node-left (tree-root a-tree))
+           (node-right (tree-root a-tree))))
+(black? (tree-root a-tree))
+(black? (node-left (tree-root a-tree)))
+(black? (node-right (tree-root a-tree)))
+]
+}
+
+
+@subsection{Operations}
+
+@defproc[(insert-first! [t tree?] [n singleton-node?]) void?]{
+Adds node @racket[n] as the first element in tree @racket[t].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "pear" 1))
+(insert-first! a-tree a-node)
+(eq? (tree-root a-tree) a-node)
+]
+
+Note that attempting to add an attached, non-singleton node to a tree will
+raise a contract error.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "persimmon" 1))
+(insert-first! a-tree a-node)
+(insert-first! a-tree a-node)
+]
+}
+
+@defproc[(insert-last! [t tree?] [n singleton-node?]) void?]{
+Adds node @racket[n] as the last element in tree @racket[t].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "apple" 1))
+(insert-last! a-tree a-node)
+(eq? (tree-root a-tree) a-node)
+]
+
+Note that attempting to add an attached, non-singleton node to a tree will
+raise a contract error.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "orange" 1))
+(insert-last! a-tree a-node)
+(insert-last! a-tree a-node)
+]
+}
+
+
+
+@defproc[(insert-before! [t tree?] [n1 node?] [n2 node?]) void?]{
+Adds node @racket[n2] before node @racket[n1] in tree @racket[t].  This effectively
+makes @racket[n2] the @racket[predecessor] of @racket[n1].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "banana" 1))
+(define b-node (new-node "mango" 1))
+(insert-first! a-tree a-node)
+(insert-before! a-tree a-node b-node)
+(eq? (predecessor a-node) b-node)
+(eq? (successor b-node) a-node)
+]
+
+Note that attempting to add an attached, non-singleton node to a tree will
+raise a contract error.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "peach" 1))
+(insert-first! a-tree a-node)
+(insert-before! a-tree a-node a-node)
+]
+}
+
+
+
+@defproc[(insert-after! [t tree?] [n1 node?] [n2 node?]) void?]{
+Adds node @racket[n2] after node @racket[n1] in tree @racket[t].  This effectively
+makes @racket[n2] the @racket[successor] of @racket[n1].
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "cherry" 1))
+(define b-node (new-node "pawpaw" 1))
+(insert-first! a-tree a-node)
+(insert-after! a-tree a-node b-node)
+(eq? (successor a-node) b-node)
+(eq? (predecessor b-node) a-node)
+]
+
+Note that attempting to add an attached, non-singleton node to a tree will
+raise a contract error.
+@interaction[#:eval my-eval
+(define a-tree (new-tree))
+(define a-node (new-node "grapefruit" 1))
+(insert-first! a-tree a-node)
+(insert-after! a-tree a-node a-node)
+]
+}
+
+
+
+@deftogether[
+(
+@defproc[(insert-first/data! [t tree?] [data any/c] [width natural-number/c]) void?]{}
+@defproc[(insert-last/data! [t tree?] [data any/c] [width natural-number/c]) void?]{}
+@defproc[(insert-before/data! [t tree?] [n node?] [data any/c] [width natural-number/c]) void?]{}
+@defproc[(insert-after/data! [t tree?] [n node?] [data any/c] [width natural-number/c]) void?]{})
+]{
+
+For user convenience, the functions @racket[insert-first/data!],
+@racket[insert-last/data!], @racket[insert-before/data!], and
+@racket[insert-after/data!] have been provided.  These create nodes and insert
+into the tree structure the same way as @racket[insert-first!],
+@racket[insert-last!], @racket[insert-before!], and @racket[insert-after!].
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(insert-first/data! t "message in a bottle" 1)
+(insert-last/data! t "don't stand so close to me" 1)
+(insert-before/data! t (tree-first t) "everything she does is magic" 1)
+(insert-after/data! t (tree-last t) "king of pain" 1)
+(tree-items t)
+]
+}
+
+
+@defproc[(delete! [t tree?] [n non-nil-node?]) void?]{
+Deletes node @racket[n] from the tree @racket[t].  After deletion, @racket[n]
+will become a singleton node.
+@interaction[#:eval my-eval
+(define t (new-tree))
+(define n1 (new-node "George, George, George of the Jungle," 1))
+(define n2 (new-node "strong as he can be..." 1))
+(define n3 (new-node "aaaaaaaaaaah!" 1))
+(define n4 (new-node "watch out for that..." 1))
+(define n5 (new-node "<thump!>" 1))
+(define n6 (new-node "treeeeeeeeee!, " 1))
+(for ([n (in-list (list n1 n2 n3 n4 n5 n6))])
+  (insert-last! t n))
+(delete! t n5)
+(tree-items t)
+]
+
+Note that @racket[n] must be attached to tree @racket[t] or else an
+error will be raised:
+@interaction[#:eval my-eval
+(define t1 (new-tree))
+(define t2 (new-tree))
+(insert-first/data! t1 "tricky" 1)
+(insert-first/data! t2 "tricky" 1)
+@code:comment{This should raise an error:}
+(delete! t1 (tree-root t2))
+]}
+
+
+@defproc[(join! [t1 tree?] [t2 tree?]) tree?]{
+Destructively joins trees @racket[t1] and @racket[t2], returning a tree that
+has the contents of both.  Every element in @racket[t1] is treated less than
+the elements in @racket[t2].
+
+@interaction[#:eval my-eval
+(define t1 (new-tree))
+(for ([name (in-list '(goku gohan krillin piccolo vegeta))])
+  (insert-last/data! t1 name 1))
+@code:comment{Tier two characters:}
+(define t2 (new-tree))
+(for ([name (in-list '(yamcha tien chiaotzu bulma chi-chi
+                       oolong puar master-roshi))])
+  (insert-last/data! t2 name 1))
+(define tree-of-mighty-z-warriors (join! t1 t2))
+(tree-items tree-of-mighty-z-warriors)
+]
+}
+
+
+@defproc[(concat! [t1 tree?] [n singleton-node?] [t2 tree?]) tree?]{
+Destructively joins tree @racket[t1], singleton node @racket[n], and tree
+@racket[t2], returning a tree that has the contents of both.  Every element in
+@racket[t1] is treated less than @racket[x], and @racket[x] is treated smaller than all
+the elements in @racket[t2].
+
+@interaction[#:eval my-eval
+(define t1 (new-tree))
+(define t2 (new-tree))
+(insert-last/data! t1 "inigo" 50)
+(define x (new-node "vizzini" 1))
+(insert-last/data! t2 "fezzik" 100)
+(define poor-lost-circus-performers (concat! t1 x t2))
+(tree-items poor-lost-circus-performers)
+]
+}
+
+
+@defproc[(split! [t tree?] [n non-nil-node?]) (values tree? tree?)]{
+Destructively splits tree @racket[t] into two trees, the first containing the
+elements smaller than node @racket[n], and the second containing those larger.
+Afterwards, @racket[n] becomes a singleton node.
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([name '(melchior caspar bob balthazar)])
+  (insert-last/data! t name 1))
+(define bob-node (search t 2))
+(singleton-node? bob-node)
+(define-values (l r) (split! t bob-node))
+@code:comment{We tree kings of orient are:}
+(append (tree-items l) (tree-items r))
+(singleton-node? bob-node)
+]
+
+Note that @racket[n] must be attached to tree @racket[t] or else
+an error will be raised.
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([name '(melchior caspar bob balthazar)])
+  (insert-last/data! t name 1))
+@code:comment{This should raise an error:}
+(define t2 (new-tree))
+(insert-last! t2 (new-node "bob" 1))
+(split! t (tree-root t2))
+]}
+
+
+@defproc[(search [t tree?] [p natural-number/c]) node?]{
+Searches for the node at or within the given position @racket[p] of the tree.
+If the position is out of bounds, returns @racket[nil].
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([word '("alpha" "beta" "gamma" "delta" "epsilon" "zeta")])
+  (insert-last/data! t word (string-length word)))
+(node-data (search t 0))
+(node-data (search t 5))
+(node-data (search t 6))
+(node-data (search t 7))
+(node-data (search t 8))
+(node-data (search t 9))
+(nil-node? (search t 100))
+]
+
+Note: nodes with a self-width of zero are effectively invisible to
+@racket[search], and will be skipped over.
+}
+
+
+@defproc[(search/residual [t tree?] [p natural-number/c]) (values node? natural-number/c)]{
+Searches for the node at or within the given position @racket[p] of the tree.
+This is an extension of @racket[search] that returns a second value: the offset
+into the element where the search has terminated.  If the position is out of
+bounds of any element, the first component of the returned value is
+@racket[nil].
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([word '("alpha" "beta" "gamma" "delta" "epsilon" "zeta")])
+  (insert-last/data! t word (string-length word)))
+(search/residual t 5)
+(search/residual t 6)
+(search/residual t 7)
+(define-values (a-node residual)
+  (search/residual t 100))
+(nil-node? a-node)
+residual
+(+ residual (node-subtree-width (tree-root t)))
+]
+}
+
+
+@defproc[(minimum [n node?]) node?]{
+Given a node @racket[n], returns the minimum element of the subtree rooted at
+@racket[n].
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([x (in-list '("ftl" "xcom" "civ"))])
+  (insert-first/data! t x (string-length x)))
+(node-data (minimum (tree-root t)))
+]
+Note: to get the minimum of the whole tree, it's faster to use
+@racket[tree-first].
+}
+
+
+@defproc[(maximum [n node?]) node?]{
+Given a node @racket[n], returns the maximum element of the subtree rooted at
+@racket[n].
+@interaction[#:eval my-eval
+(define t (new-tree))
+(for ([x (in-list '("ftl" "xcom" "civ"))])
+  (insert-first/data! t x (string-length x)))
+(node-data (maximum (tree-root t)))
+]
+Note: to get the maximum of the whole tree, it's faster to use
+@racket[tree-last].
+}
+
+
+@defproc[(successor [n node?]) node?]{
+Given a node @racket[n] contained in some tree, returns the immediate
+successor of @racket[n] in an inorder traversal of that tree.
+
+@interaction[#:eval my-eval
+(define partial-alien-tree (new-tree))
+(for ([name '("sectoid" "floater" "thin man" "chryssalid" 
+              "muton" "cyberdisk")])
+  (insert-last/data! partial-alien-tree name 1))
+(define first-alien (tree-first partial-alien-tree))
+(node-data (successor first-alien))
+(node-data (successor (successor first-alien)))
+]
+}
+
+
+
+@defproc[(predecessor [n node?]) node?]{
+Given a node @racket[n] contained in some tree, returns the immediate
+predecessor of @racket[n] in an inorder traversal of that tree.
+
+@interaction[#:eval my-eval
+(define partial-alien-tree (new-tree))
+(for ([name '("sectoid" "floater" "thin man" "chryssalid" 
+              "muton" "cyberdisk")])
+  (insert-last/data! partial-alien-tree name 1))
+(define last-alien (tree-last partial-alien-tree))
+(node-data (predecessor last-alien))
+(node-data (predecessor (predecessor last-alien)))
+]
+}
+
+
+
+@defproc[(position [n node?]) natural-number/c]{
+Given a node @racket[n] contained in some tree, returns the immediate
+position of @racket[n] in that tree.
+
+@interaction[#:eval my-eval
+(define story-tree (new-tree))
+(for ([word (string-split "if you give a mouse a cookie")])
+  (insert-last/data! story-tree word (string-length word)))
+(define a-pos (position (tree-last story-tree)))
+a-pos
+(node-data (search story-tree a-pos))
+]
+}
+
+
+
+@defproc[(tree-items [t tree?]) (listof/c (list/c any/c natural-number/c))]{
+Given a tree, returns a list of its data and width pairs.
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(insert-last/data! t "rock" 4)
+(insert-last/data! t "paper" 5)
+(insert-last/data! t "scissors" 8)
+(tree-items t)
+]
+}
+
+
+@deftogether[
+(@defproc[(tree-fold-inorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{}
+ @defproc[(tree-fold-preorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{}
+ @defproc[(tree-fold-postorder [t tree?] [f (node? any/c . -> . any)] [acc any/c]) any]{})]{
+
+Iterates a function @racket[f] across the nodes of the tree, in inorder, preorder,
+and postorder respectively.
+
+@interaction[#:eval my-eval
+(define t (new-tree))
+(insert-last/data! t "three" 1)
+(insert-last/data! t "blind" 1)
+(insert-last/data! t "mice" 1)
+@code:comment{"blind" should be the root, with}
+@code:comment{"three" and "mice" as left and right.}
+(define (f n acc) (cons (node-data n) acc))
+(reverse (tree-fold-inorder t f '()))
+(reverse (tree-fold-preorder t f '()))
+(reverse (tree-fold-postorder t f '()))
+]
+
+}
+
+
+@section{Uncontracted library}
+
+This library uses contracts extensively to prevent the user from messing up;
+however, the contract checking may be prohibitively
+expensive for certain applications.
+
+The uncontracted bindings of this library can be accessed through:
+
+@racketblock[(require (submod syntax-color/private/red-black uncontracted))]
+
+This provides the same bindings as the regular API, but with no contract
+checks.  Use this with extreme care: Improper use of the uncontracted form of
+this library may lead to breaking the red-black invariants, or (even worse)
+introducing cycles in the structure.  If you don't know whether you should be
+using the uncontracted forms or not, you probably should not.
+
+
+@section{Bibliography}
+
+@bibliography[
+@bib-entry[#:key "clrs2009"
+           #:title "Introduction to Algorithms, Third Edition"
+           #:is-book? #t
+           #:author "Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest, Clifford Stein"
+           #:date "2009"
+           #:url "http://mitpress.mit.edu/books/introduction-algorithms"]
+
+@bib-entry[#:key "wein2005"
+           #:title "Efficient implementation of red-black trees with split and catenate operations"
+           #:author "Ron Wein"
+           #:date "2005"
+           #:url "http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.109.4875"]
+]
+
+
+
+
+@close-eval[my-eval]