suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implements a rb-tree based version of the token tree, and fixes bugs in red-black.rkt.

Browse Source 
A few invariants involving subtree-width and black-height balance
could break if singleton nodes were reused; bugs were due to stale
data in the nodes.

The token tree implements the implicit interface in the original
splay-based token tree module in syntax-color/token-tree.  However, it
does not appear to perform significantly differently in the case of
indentation yet.  It needs some additional profiling and analysis to
see if we can take advantage of the richer structure in the rb tree.
This commit is contained in:
Danny Yoo 2012-11-26 10:39:19 -07:00
parent f8793c0cc2
commit 90714fbd5e
3 changed files with 700 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

478
collects/syntax-color/private/rb-token-tree.rkt Normal file
View File

@ -0,0 +1,478 @@
#lang racket/base
;; rbtree implementation of the token-tree% interface.
;;
;; We have to adapt a few things:
;;
;; * rb-trees don't move around their root on search, so we need
;; to keep a separate "focus".
;;
;; * We use rb:nil, but the original client uses #f to indicate
;; empty trees.
;; For speed, we use the uncontracted forms in red-black.rkt.
(require (prefix-in rb: (submod "red-black.rkt" uncontracted))
racket/class)
(provide token-tree%
insert-first!
insert-last!
insert-last-spec!
insert-first-spec!
node? node-token-length node-token-data
node-left-subtree-length node-left node-right)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-local-member-name
get-rb
set-rb!
set-focus!)
(define token-tree%
(class object%
(init (length #f) (data #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; state initialization
(define rb (rb:new-tree)) ;; rb is an instance of rb:tree.
(define focus rb:nil) ;; focus is an instance of rb:node.
(define focus-pos -1) ;; optimization: the position of the focus.
(when length
(rb:insert-last/data! rb data length)
(set-focus! (rb:tree-root rb) 0))
(super-new)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; rb->token-tree: rb:tree -> token-tree%
;; Wraps a red-black tree into a token tree.
(define (rb->token-tree an-rb)
(define t (new token-tree%))
(send t set-rb! an-rb)
(send t set-focus!
(rb:tree-first an-rb)
(if (rb:nil-node? (rb:tree-root an-rb)) -1 0))
t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; private methods:
(define/public (get-rb)
rb)
(define/public (set-rb! new-rb)
(set! rb new-rb))
(define/public (set-focus! new-focus new-pos)
(set! focus new-focus)
(set! focus-pos new-pos))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; public methods:
;; reset-tree: -> void
;; Empty the contents of the tree.
(define/public (reset-tree)
(rb:reset! rb)
(set-focus! rb:nil -1))
(define/public (get-root)
(nil->false focus))
(define/public (is-empty?)
(rb:nil-node? focus))
(define/public (get-root-length)
(cond
[(rb:nil-node? focus)
0]
[else
(rb:node-self-width focus)]))
(define/public (get-root-data)
(cond
[(rb:nil-node? focus)
#f]
[else
(rb:node-data focus)]))
(define/public (get-root-start-position)
(cond
[(rb:nil-node? focus)
0]
[else
focus-pos]))
(define/public (get-root-end-position)
(cond
[(rb:nil-node? focus)
0]
[else
(+ focus-pos (rb:node-self-width focus))]))
(define/public (add-to-root-length inc)
(unless (rb:nil-node? focus)
(rb:update-node-self-width! focus (+ (rb:node-self-width focus) inc))))
(define/public (search! key-position)
;; TODO: add unit test that makes sure search works. If there is no
;; token, the original just jumps to the closest node.
(unless (rb:nil-node? focus)
(cond
[(<= key-position 0)
(set-focus! (rb:tree-first rb)
(first-pos rb))]
[(>= key-position (rb:node-subtree-width (rb:tree-root rb)))
(set-focus! (rb:tree-last rb)
(last-pos rb))]
[else
(cond
;; optimization: are we already where we're searching?
[(= focus-pos key-position)
(void)]
;; optimization: are we searching for the immediate successor?
[(= key-position (+ focus-pos (rb:node-self-width focus)))
(define succ (rb:successor focus))
(cond [(rb:nil-node? succ)
(void)]
[else
(set-focus! succ key-position)])]
[else
(define-values (found-node residue) (rb:search/residual rb key-position))
(set-focus! found-node (- key-position residue))])])))
;; last-pos: rb:tree -> natural
;; Returns the starting position of the last element in rb.
(define (last-pos rb)
(cond
[(rb:nil-node? (rb:tree-root rb))
-1]
[else
(define pos (- (rb:node-subtree-width (rb:tree-root rb))
(rb:node-self-width (rb:tree-last rb))))
pos]))
(define (first-pos rb)
(cond
[(rb:nil-node? (rb:tree-root rb))
-1]
[else
0]))
(define/public (search-max!)
(unless (rb:nil-node? focus)
(set-focus! (rb:tree-last rb) (last-pos rb))))
(define/public (search-min!)
(unless (rb:nil-node? focus)
(set-focus! (rb:tree-first rb) 0)))
(define/public (remove-root!)
(unless (rb:nil-node? focus)
(define node-to-delete focus)
(define pred (rb:predecessor focus))
(cond [(rb:nil-node? pred)
(define succ (rb:successor focus))
(set-focus! succ (if (rb:nil-node? succ) -1 0))]
[else
(set-focus! pred (- focus-pos (rb:node-self-width pred)))])
(rb:delete! rb node-to-delete)))
;; split/data: natural -> (values natural natural token-tree% token-tree% boolean)
;; Splits the tree into 2 trees, invalidating our own to nil.
;;
;; The first two returned values represent the start and end
;; position of the token(s) at pos. The next two values represent
;; the tokens before pos and after pos, not including any tokens
;; adjacent to pos.
;;
;; Thus if pos is on a token boundary, 2 tokens will be dropped.
;;
;; In this case, the start will be for the first dropped
;; token and the stop will be for the second.
;;
;; The last value is the data at the searched position.
;;
;; The two tree's foci will be at the edges adjacent to where the split occurred.
(define/public (split/data pos)
(cond
[(rb:nil-node? focus)
(values 0 0 (new token-tree%) (new token-tree%) #f)]
[else
;; We have a few cases to check for:
;; Is the pivot on the edge boundary of the first or last tokens?
;; Is the pivot on the boundary between two tokens?
(cond
;; Case 1.
;; At the start-edge of the first token?
[(<= pos 0)
;; If so, just delete the first token.
(define first-token (rb:tree-first rb))
(rb:delete! rb first-token)
(define right-tree (rb->token-tree rb))
(send right-tree set-focus!
(rb:tree-first rb)
(first-pos rb))
(set-focus! rb:nil -1)
(values 0
(rb:node-self-width first-token)
(new token-tree%)
right-tree
(rb:node-data first-token))]
;; Case 2.
;; At the end-edge of the last token?
[(>= pos (rb:node-subtree-width (rb:tree-root rb)))
(define total-width (rb:node-subtree-width (rb:tree-root rb)))
(define last-token (rb:tree-last rb))
(rb:delete! rb last-token)
(define left-tree (rb->token-tree rb))
(send left-tree set-focus! (rb:tree-last rb) (last-pos rb))
(set-focus! rb:nil -1)
(values (- total-width (rb:node-self-width last-token))
total-width
left-tree
(new token-tree%)
(rb:node-data last-token))]
[else
;; Otherwise, pos is somewhere inside the range, and we're
;; guaranteed to find the pivot somewhere.
(search! pos)
(cond
;; If the residue after searching is zero, then we're right
;; on the boundary between two tokens, and must delete both.
[(= focus-pos pos)
(define pivot-node focus)
(define-values (left right) (rb:split! rb pivot-node))
;; We know the left is non-empty, since otherwise we would
;; have hit case 1.
(define left-last (rb:tree-last left))
(rb:delete! left left-last)
(set-focus! rb:nil -1)
(define-values (left-tree right-tree)
(values (rb->token-tree left)
(rb->token-tree right)))
(send left-tree set-focus! (rb:tree-last left) (last-pos left))
(send right-tree set-focus! (rb:tree-first right) (first-pos right))
(values (- pos (rb:node-self-width left-last))
(+ pos (rb:node-self-width pivot-node))
left-tree
right-tree
(rb:node-data pivot-node))]
[else
;; Otherwise, the position is inside just one token.
(define pivot-node focus)
(define start-pos focus-pos)
(define end-pos (+ start-pos (rb:node-self-width pivot-node)))
(define-values (left right) (rb:split! rb pivot-node))
(set-focus! rb:nil -1)
(define-values (left-tree right-tree)
(values (rb->token-tree left)
(rb->token-tree right)))
(send left-tree set-focus! (rb:tree-last left) (last-pos left))
(send right-tree set-focus! (rb:tree-first right) (first-pos right))
(values start-pos end-pos
left-tree
right-tree
(rb:node-data pivot-node))])])]))
(define/public (split pos)
(define-values (start-pos end-pos left-tree right-tree data)
(split/data pos))
(values start-pos end-pos left-tree right-tree))
;; split-after: -> token-tree% * token-tree%
;; splits the tree into 2 trees, setting root to #f
;; returns a tree including the focus and its predecessors
;; then the focus's successors
;;
;; The left tree's focus is defined to be at its last,
;; and the right tree's focus is defined to be at its first.
;;
;; FIXME: add test case checking semantics of focus after a split-after.
(define/public (split-after)
(cond
[(rb:nil-node? focus)
(values (new token-tree%) (new token-tree%))]
[else
(define-values (left right) (rb:split! rb focus))
(rb:insert-last! left focus)
(set-focus! rb:nil -1)
(define-values (left-tree right-tree)
(values (rb->token-tree left) (rb->token-tree right)))
(send right-tree set-focus! (rb:tree-first right) (first-pos right))
(send left-tree set-focus! (rb:tree-last left) (last-pos left))
(values left-tree right-tree)]))
;; split-before: -> token-tree% * token-tree%
;; splits the tree into 2 trees, setting root to #f
;; returns the focus's predecessors, and then a tree including the focus
;; and its successors.
;;
;; The left tree's focus is defined to be at its last,
;; and the right tree's focus is defined to be at its first.
;;
;; FIXME: add test case checking semantics of focus after a split-before.
(define/public (split-before)
(cond
[(rb:nil-node? focus)
(values (new token-tree%) (new token-tree%))]
[else
(define-values (left right) (rb:split! rb focus))
(rb:insert-first! right focus)
(set-focus! rb:nil -1)
(define-values (left-tree right-tree)
(values (rb->token-tree left) (rb->token-tree right)))
(send left-tree set-focus! (rb:tree-last left) (last-pos left))
(send right-tree set-focus! (rb:tree-first right) (first-pos right))
(values left-tree right-tree)]))
(define/public (to-list)
(cond
[(rb:nil-node? focus) '()]
[else
(reverse
(rb:tree-fold-inorder rb
(lambda (n acc)
(cons (vector (rb:node-self-width n)
(node-left-subtree-length n)
(rb:node-data n))
acc))
'()))]))
(define/public (for-each f)
(cond
[(rb:nil-node? focus)
(void)]
[else
(rb:tree-fold-inorder rb
(lambda (n acc)
(f acc
(rb:node-self-width n)
(rb:node-data n))
(+ acc (rb:node-self-width n)))
0)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; insert-first!: token-tree% * token-tree% -> void
;; insert tree2 into tree1 as the first thing.
;;
;; Effects:
;;
;; 1. tree1 will contain the contents of tree2 + tree1
;; 2. tree2 will be reset to the empty tree.
;;
;; I'm not exactly sure if the behavior of where the tree is focused
;; is something defined.
(define (insert-first! tree1 tree2)
(define-values (rb1 rb2)
(values (send tree1 get-rb) (send tree2 get-rb)))
(define rb-joined (rb:join! rb2 rb1))
(send tree1 set-rb! rb-joined)
(send tree1 set-focus!
(rb:tree-root rb-joined)
(node-left-subtree-length (rb:tree-root rb-joined)))
(send tree2 reset-tree))
;; insert-last!: token-tree% * token-tree% -> void
;; insert tree2 into tree1 as the last thing.
;;
;; Effects:
;;
;; 1. tree1 will contain the contents of tree1 + tree2
;; 2. tree2 will be reset to the empty tree.
;;
;; I'm not exactly sure if the behavior of where the tree is focused
;; is something defined.
(define (insert-last! tree1 tree2)
(define-values (rb1 rb2)
(values (send tree1 get-rb) (send tree2 get-rb)))
(define rb-joined (rb:join! rb1 rb2))
(send tree1 set-rb! rb-joined)
(send tree1 set-focus!
(rb:tree-root rb-joined)
(node-left-subtree-length (rb:tree-root rb-joined)))
(send tree2 reset-tree))
;; insert-last-spec!: tree natural any -> void
;; Inserts content at the end of the tree.
;;
;; I'm not exactly sure if the behavior of where the tree is focused
;; is something defined.
(define (insert-last-spec! tree length data)
;; TODO: add unit test that makes sure insert-last-spec! works. It's missing
;; from the test suite.
(define the-rb (send tree get-rb))
(rb:insert-last/data! the-rb data length)
(send tree set-focus!
(rb:tree-root the-rb)
(node-left-subtree-length (rb:tree-root the-rb))))
;; insert-first-spec!: tree natural any -> void
;; Inserts content at the beginning of the tree.
(define (insert-first-spec! tree length data)
;; TODO: add unit test that makes sure insert-last-spec! works. It's missing
;; from the test suite.
(define the-rb (send tree get-rb))
(rb:insert-first/data! the-rb data length)
(send tree set-focus!
(rb:tree-root the-rb)
(node-left-subtree-length (rb:tree-root the-rb))))
(define node?
(procedure-rename rb:node? 'node?))
(define node-token-data
(procedure-rename rb:node-data 'node-token-data))
(define node-token-length
(procedure-rename rb:node-self-width 'node-token-length))
(define (node-left-subtree-length n)
(rb:node-subtree-width (rb:node-left n)))
(define (node-left n)
(cond [(eq? n #f)
#f]
[else
(nil->false (rb:node-left n))]))
(define (node-right n)
(cond [(eq? n #f)
#f]
[else
(nil->false (rb:node-right n))]))
(define-syntax-rule (nil->false n)
(if (eq? n rb:nil)
#f
n))

216
collects/syntax-color/private/red-black.rkt
View File

@ -54,6 +54,7 @@
(provide [contract-out (provide [contract-out
[tree? (any/c . -> . boolean?)] [tree? (any/c . -> . boolean?)]
[tree-root (tree? . -> . node?)] [tree-root (tree? . -> . node?)]
[tree-first (tree? . -> . node?)] [tree-first (tree? . -> . node?)]
[tree-last (tree? . -> . node?)] [tree-last (tree? . -> . node?)]
@ -87,14 +88,18 @@
[insert-after/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?] [delete! (->i ([t tree?]
[n (t) (non-nil-node-in-tree? t)]) [n (t) (attached-in-tree/c t)])
[result any/c])] [result any/c])]
[join! (tree? tree? . -> . tree?)] [join! (->i ([t1 tree?] [t2 (t1) (and/c tree? (not-eq?/c t1))])
[concat! (tree? singleton-node? tree? . -> . any)] [result tree?])]
[rename public:concat! concat!
(->i ([t1 tree?] [n singleton-node?] [t2 (t1) (and/c tree? (not-eq?/c t1))])
[result any/c])]
[split! (->i ([t tree?] [split! (->i ([t tree?]
[n (t) (non-nil-node-in-tree? t)]) [n (t) (attached-in-tree/c t)])
(values [t1 tree?] [t2 tree?]))] (values [t1 tree?] [t2 tree?]))]
[reset! (tree? . -> . any)]
[search (tree? natural-number/c . -> . node?)] [search (tree? natural-number/c . -> . node?)]
[search/residual (tree? natural-number/c . -> . (values node? natural-number/c))] [search/residual (tree? natural-number/c . -> . (values node? natural-number/c))]
@ -164,10 +169,12 @@
;; attached-in-tree/c: tree -> contract
;;
;; We use this function for contract checking with delete! and split!, ;; 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. ;; where the node being deleted must be in the tree in the first place.
(define (non-nil-node-in-tree? t) (define (attached-in-tree/c t)
(flat-named-contract 'node-in-tree (flat-named-contract 'attached-in-tree/c
(lambda (n) (lambda (n)
(and (node? n) (and (node? n)
(not (nil? n)) (not (nil? n))
@ -179,6 +186,15 @@
(loop p)])))))) (loop p)]))))))
;; not-eq?/c: any -> flat-contract
;; Returns a flat contract that checks that the value isn't eq? to x.
(define (not-eq?/c x)
(flat-named-contract 'not-eq?/c
(lambda (y)
(not (eq? x y)))))
;; nil?: node -> boolean ;; nil?: node -> boolean
;; Tell us if we're at the distinguished nil node. ;; Tell us if we're at the distinguished nil node.
@ -308,6 +324,16 @@
;; update-node-self-width!: node exact-nonnegative-integer -> void Updates
;; the node's self width, and propagates that change up the tree.
;; Internal note: do not confuse this with the similarly-named
;; update-node-subtree-width, which does something different.
(define (update-node-self-width! n w)
(set-node-self-width! n w)
(update-subtree-width-up-to-root! n))
;; insert-first!: tree (and/c (not nil?) node?) -> void ;; insert-first!: tree (and/c (not nil?) node?) -> void
;; Insert node x as the first element in the tree. ;; Insert node x as the first element in the tree.
@ -577,6 +603,7 @@
(set-node-left! z nil) (set-node-left! z nil)
(set-node-right! z nil) (set-node-right! z nil)
(set-node-color! z red) (set-node-color! z red)
(set-node-subtree-width! z (node-self-width z))
(values x y-original-color nil-parent)] (values x y-original-color nil-parent)]
@ -591,6 +618,7 @@
(set-node-left! z nil) (set-node-left! z nil)
(set-node-right! z nil) (set-node-right! z nil)
(set-node-color! z red) (set-node-color! z red)
(set-node-subtree-width! z (node-self-width z))
(values x y-original-color nil-parent)] (values x y-original-color nil-parent)]
;; The hardest case is when z has non-nil left and right. ;; The hardest case is when z has non-nil left and right.
@ -639,7 +667,8 @@
(set-node-left! z nil) (set-node-left! z nil)
(set-node-right! z nil) (set-node-right! z nil)
(set-node-color! z red) (set-node-color! z red)
(set-node-subtree-width! z (node-self-width z))
(values x y-original-color nil-parent))])]) (values x y-original-color nil-parent))])])
(cond [(eq? black y-original-color) (cond [(eq? black y-original-color)
(fix-after-delete! a-tree x nil-parent)] (fix-after-delete! a-tree x nil-parent)]
@ -841,9 +870,13 @@
(define (join! t1 t2) (define (join! t1 t2)
(cond (cond
[(nil? (tree-root t2)) [(nil? (tree-root t2))
t1] (define result (clone! t1))
(reset! t1)
result]
[(nil? (tree-root t1)) [(nil? (tree-root t1))
t2] (define result (clone! t2))
(reset! t2)
result]
[else [else
;; First, remove element x from t2. x will act as the ;; First, remove element x from t2. x will act as the
;; pivot point. ;; pivot point.
@ -851,7 +884,31 @@
(delete! t2 x) (delete! t2 x)
;; Next, delegate to the more general concat! function, using ;; Next, delegate to the more general concat! function, using
;; x as the pivot. ;; x as the pivot.
(concat! t1 x t2)])) (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 ;; concat!: tree node tree -> tree
@ -869,7 +926,6 @@
;; to how this is used by split!. ;; to how this is used by split!.
(define (concat! t1 x t2) (define (concat! t1 x t2)
(cond (cond
[(nil? (tree-root t1)) [(nil? (tree-root t1))
(set-node-left! x nil) (set-node-left! x nil)
(set-node-right! x nil) (set-node-right! x nil)
@ -893,7 +949,7 @@
(define t1-bh (tree-bh t1)) (define t1-bh (tree-bh t1))
(define t2-bh (tree-bh t2)) (define t2-bh (tree-bh t2))
(cond (cond
[(>= t1-bh t2-bh) [(>= t1-bh t2-bh)
;; Note: even if tree-last is invalid, nothing gets hurt here. ;; Note: even if tree-last is invalid, nothing gets hurt here.
(set-tree-last! t1 (tree-last t2)) (set-tree-last! t1 (tree-last t2))
@ -983,6 +1039,7 @@
;; split!: tree node -> (values tree tree) ;; split!: tree node -> (values tree tree)
;; Partitions the tree into two trees: the predecessors of x, and the ;; Partitions the tree into two trees: the predecessors of x, and the
;; successors of x. Also mutates x into a singleton node. ;; 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 ;; 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 ;; a valid tree-first or tree-last. I want to avoid recomputing
@ -1000,6 +1057,10 @@
(set-node-right! x nil) (set-node-right! x nil)
(set-node-left! x nil) (set-node-left! x nil)
(set-node-color! x red) (set-node-color! x red)
(set-node-subtree-width! x (node-self-width x))
;; Clear out a-tree so it's unusable.
(reset! a-tree)
;; The loop walks the ancestors of x, adding the left and right ;; The loop walks the ancestors of x, adding the left and right
;; elements appropriately. ;; elements appropriately.
@ -1047,13 +1108,27 @@
(concat! R ancestor subtree))])]))) (concat! R ancestor subtree))])])))
;; update-node-self-width!: node exact-nonnegative-integer -> void Updates ;; reset!: tree -> void
;; the node's self width, and propagates that change up the tree. ;; Resets a tree to empty.
;; Internal note: do not confuse this with the similarly-named (define (reset! a-tree)
;; update-node-subtree-width, which does something different. (set-tree-root! a-tree nil)
(define (update-node-self-width! n w) (set-tree-first! a-tree nil)
(set-node-self-width! n w) (set-tree-last! a-tree nil)
(update-subtree-width-up-to-root! n)) (set-tree-bh! a-tree 0))
;; clone!: tree -> tree
;; Shallow copy of the components of the tree.
(define (clone! a-tree)
(tree (tree-root a-tree)
(tree-first a-tree)
(tree-last a-tree)
(tree-bh a-tree)))
;; force-tree-first!: tree -> void ;; force-tree-first!: tree -> void
@ -1224,8 +1299,9 @@
delete! delete!
join! join!
concat! [rename-out [public:concat! concat!]]
split! split!
reset!
update-node-self-width! update-node-self-width!
@ -1263,6 +1339,13 @@
racket/list racket/list
racket/class racket/class
racket/promise) racket/promise)
(define (singleton-node? n)
(and (node? n)
(red? n)
(nil? (node-parent n))
(= (node-subtree-width n)
(node-self-width n))))
;; tree-items: tree -> (listof (list X number)) ;; tree-items: tree -> (listof (list X number))
@ -1658,7 +1741,19 @@
(delete! t (search t 1)) (delete! t (search t 1))
(check-rb-structure! t) (check-rb-structure! t)
(delete! t (search t 0)) (delete! t (search t 0))
(check-rb-structure! t))
(test-case
"does deletion get subtree width right?"
(define t (new-tree))
(insert-last/data! t "hello" 5)
(insert-last/data! t "dyoo" 4)
(define r (tree-root t))
(delete! t r)
(insert-last! t r)
(check-rb-structure! t)))) (check-rb-structure! t))))
@ -1883,6 +1978,8 @@
(define t1 (new-tree)) (define t1 (new-tree))
(define t2 (new-tree)) (define t2 (new-tree))
(define t1+t2 (join! t1 t2)) (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-true (nil? (tree-root t1+t2)))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1892,6 +1989,8 @@
(define t2 (new-tree)) (define t2 (new-tree))
(insert-last/data! t2 "hello" 5) (insert-last/data! t2 "hello" 5)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) (check-equal? (map first (tree-items t1+t2))
'("hello")) '("hello"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1902,6 +2001,8 @@
(define t2 (new-tree)) (define t2 (new-tree))
(insert-last/data! t1 "hello" 5) (insert-last/data! t1 "hello" 5)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) (check-equal? (map first (tree-items t1+t2))
'("hello")) '("hello"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1913,8 +2014,30 @@
(insert-last/data! t1 "append" 5) (insert-last/data! t1 "append" 5)
(insert-last/data! t2 "this" 4) (insert-last/data! t2 "this" 4)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) '("append" "this")) (check-equal? (map first (tree-items t1+t2)) '("append" "this"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
(test-case
"joining back and forth"
(define t (new-tree))
(for ([i (in-range 20)])
(define t2 (new-tree))
(insert-last/data! t2 i i)
(cond
[(even? i)
(set! t (join! t t2))
(check-true (nil? (tree-root t2)))]
[else
(set! t (join! t2 t))
(check-true (nil? (tree-root t2)))]))
(check-equal? (tree-items t)
'((19 19) (17 17) (15 15) (13 13) (11 11) (9 9)
(7 7) (5 5) (3 3) (1 1) (0 0) (2 2) (4 4) (6 6)
(8 8) (10 10) (12 12) (14 14) (16 16) (18 18)))
(check-rb-structure! t))
(test-case (test-case
@ -1925,6 +2048,8 @@
(insert-last/data! t1 "and" 3) (insert-last/data! t1 "and" 3)
(insert-last/data! t2 "peace" 5) (insert-last/data! t2 "peace" 5)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) '("love" "and" "peace")) (check-equal? (map first (tree-items t1+t2)) '("love" "and" "peace"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1936,6 +2061,8 @@
(insert-last/data! t2 "and" 3) (insert-last/data! t2 "and" 3)
(insert-last/data! t2 "war" 3) (insert-last/data! t2 "war" 3)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) '("love" "and" "war")) (check-equal? (map first (tree-items t1+t2)) '("love" "and" "war"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1951,6 +2078,8 @@
(insert-last/data! t2 "years" 5) (insert-last/data! t2 "years" 5)
(insert-last/data! t2 "ago" 3) (insert-last/data! t2 "ago" 3)
(define t1+t2 (join! t1 t2)) (define t1+t2 (join! t1 t2))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-equal? (map first (tree-items t1+t2)) '("four" "score" "and" "seven" "years" "ago")) (check-equal? (map first (tree-items t1+t2)) '("four" "score" "and" "seven" "years" "ago"))
(check-rb-structure! t1+t2)) (check-rb-structure! t1+t2))
@ -1990,6 +2119,9 @@
(for ([word (in-list (string-split m3))]) (for ([word (in-list (string-split m3))])
(insert-last/data! t3 word (string-length word))) (insert-last/data! t3 word (string-length word)))
(define speech-tree (join! (join! t1 t2) t3)) (define speech-tree (join! (join! t1 t2) t3))
(check-true (nil? (tree-root t1)))
(check-true (nil? (tree-root t2)))
(check-true (nil? (tree-root t3)))
(check-equal? (map first (tree-items speech-tree)) (check-equal? (map first (tree-items speech-tree))
(string-split (string-append m1 " " m2 " " m3))) (string-split (string-append m1 " " m2 " " m3)))
(check-rb-structure! speech-tree)))) (check-rb-structure! speech-tree))))
@ -2004,11 +2136,13 @@
(insert-last/data! t "a" 1) (insert-last/data! t "a" 1)
(define n (search t 0)) (define n (search t 0))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '()) (check-equal? (map first (tree-items l)) '())
(check-equal? (map first (tree-items r)) '()) (check-equal? (map first (tree-items r)) '())
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a b) ---split-a--> () (b)" "(a b) ---split-a--> () (b)"
@ -2017,11 +2151,13 @@
(insert-last/data! t "b" 1) (insert-last/data! t "b" 1)
(define n (search t 0)) (define n (search t 0))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '()) (check-equal? (map first (tree-items l)) '())
(check-equal? (map first (tree-items r)) '("b")) (check-equal? (map first (tree-items r)) '("b"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a b) ---split-b--> (a) ()" "(a b) ---split-b--> (a) ()"
@ -2030,11 +2166,13 @@
(insert-last/data! t "b" 1) (insert-last/data! t "b" 1)
(define n (search t 1)) (define n (search t 1))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '("a")) (check-equal? (map first (tree-items l)) '("a"))
(check-equal? (map first (tree-items r)) '()) (check-equal? (map first (tree-items r)) '())
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a b c) ---split-b--> (a) (c)" "(a b c) ---split-b--> (a) (c)"
@ -2044,11 +2182,13 @@
(insert-last/data! t "c" 1) (insert-last/data! t "c" 1)
(define n (search t 1)) (define n (search t 1))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '("a")) (check-equal? (map first (tree-items l)) '("a"))
(check-equal? (map first (tree-items r)) '("c")) (check-equal? (map first (tree-items r)) '("c"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a b c d) ---split-a--> () (b c d)" "(a b c d) ---split-a--> () (b c d)"
@ -2059,11 +2199,13 @@
(insert-last/data! t "d" 1) (insert-last/data! t "d" 1)
(define n (search t 0)) (define n (search t 0))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '()) (check-equal? (map first (tree-items l)) '())
(check-equal? (map first (tree-items r)) '("b" "c" "d")) (check-equal? (map first (tree-items r)) '("b" "c" "d"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
@ -2075,11 +2217,13 @@
(insert-last/data! t "d" 1) (insert-last/data! t "d" 1)
(define n (search t 1)) (define n (search t 1))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '("a")) (check-equal? (map first (tree-items l)) '("a"))
(check-equal? (map first (tree-items r)) '("c" "d")) (check-equal? (map first (tree-items r)) '("c" "d"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
@ -2091,11 +2235,13 @@
(insert-last/data! t "d" 1) (insert-last/data! t "d" 1)
(define n (search t 2)) (define n (search t 2))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '("a" "b")) (check-equal? (map first (tree-items l)) '("a" "b"))
(check-equal? (map first (tree-items r)) '("d")) (check-equal? (map first (tree-items r)) '("d"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a b c d) ---split-d--> (a b c) ()" "(a b c d) ---split-d--> (a b c) ()"
@ -2106,11 +2252,13 @@
(insert-last/data! t "d" 1) (insert-last/data! t "d" 1)
(define n (search t 3)) (define n (search t 3))
(define-values (l r) (split! t n)) (define-values (l r) (split! t n))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? n)) (check-true (singleton-node? n))
(check-equal? (map first (tree-items l)) '("a" "b" "c")) (check-equal? (map first (tree-items l)) '("a" "b" "c"))
(check-equal? (map first (tree-items r)) '()) (check-equal? (map first (tree-items r)) '())
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a ... z) ---split-m--> (a ... l) (n ...z)" "(a ... z) ---split-m--> (a ... l) (n ...z)"
@ -2120,11 +2268,13 @@
1)) 1))
(define letter-m (search t 12)) (define letter-m (search t 12))
(define-values (l r) (split! t letter-m)) (define-values (l r) (split! t letter-m))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? 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 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-equal? (map first (tree-items r)) '("n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r)) (check-rb-structure! r)
(check-rb-structure! t))
(test-case (test-case
"(a ... z) ---split-n--> (a ... l) (n ...z)" "(a ... z) ---split-n--> (a ... l) (n ...z)"
@ -2136,12 +2286,14 @@
(insert-last/data! t w 1)) (insert-last/data! t w 1))
(define a-letter (search t n)) (define a-letter (search t n))
(define-values (l r) (split! t a-letter)) (define-values (l r) (split! t a-letter))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? a-letter)) (check-true (singleton-node? a-letter))
(define-values (expected-l 1+expected-r) (split-at letters n)) (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 l)) expected-l)
(check-equal? (map first (tree-items r)) (rest 1+expected-r)) (check-equal? (map first (tree-items r)) (rest 1+expected-r))
(check-rb-structure! l) (check-rb-structure! l)
(check-rb-structure! r))))) (check-rb-structure! r)
(check-rb-structure! t)))))
@ -2313,6 +2465,7 @@
;; Delete a random word if we can. ;; Delete a random word if we can.
(define k (random (length known-model))) (define k (random (length known-model)))
(delete-kth! k))) (delete-kth! k)))
(define/public (insert-before/random!) (define/public (insert-before/random!)
(when (not (empty? known-model)) (when (not (empty? known-model))
@ -2369,6 +2522,7 @@
(define offset (kth-offset k)) (define offset (kth-offset k))
(define node (search t offset)) (define node (search t offset))
(define-values (l r) (split! t node)) (define-values (l r) (split! t node))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? node)) (check-true (singleton-node? node))
(set! t l) (set! t l)
(send m2 catch-and-concat-at-front r (drop known-model (add1 k))) (send m2 catch-and-concat-at-front r (drop known-model (add1 k)))
@ -2377,6 +2531,7 @@
;; private ;; private
(define/public (catch-and-concat-at-front other-t other-known-model) (define/public (catch-and-concat-at-front other-t other-known-model)
(set! t (join! other-t t)) (set! t (join! other-t t))
(check-true (nil? (tree-root other-t)))
(set! known-model (append other-known-model known-model))) (set! known-model (append other-known-model known-model)))
@ -2530,6 +2685,7 @@
(time-acc (time-acc
total-splitting-time total-splitting-time
(split! t pivot))) (split! t pivot)))
(check-true (nil? (tree-root t)))
(check-true (singleton-node? pivot)) (check-true (singleton-node? pivot))
(define-values (expected-l 1+expected-r) (split-at elts n)) (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 l)) expected-l)

45
collects/syntax-color/red-black.scrbl
View File

@ -498,15 +498,14 @@ will become a singleton node.
(tree-items t) (tree-items t)
] ]
Note that @racket[n] must be attached to tree @racket[t] or else an Note that @racket[n] must be attached to tree @racket[t] or else will raise
error will be raised: a contract error:
@interaction[#:eval my-eval @interaction[#:eval my-eval
(define t1 (new-tree)) (define t1 (new-tree))
(define t2 (new-tree))
(insert-first/data! t1 "tricky" 1) (insert-first/data! t1 "tricky" 1)
(insert-first/data! t2 "tricky" 1) (define n (new-node "tricky" 1))
@code:comment{This should raise an error:} @code:comment{This should raise an error:}
(delete! t1 (tree-root t2)) (delete! t1 n)
]} ]}
@ -522,10 +521,17 @@ the elements in @racket[t2].
@code:comment{Tier two characters:} @code:comment{Tier two characters:}
(define t2 (new-tree)) (define t2 (new-tree))
(for ([name (in-list '(yamcha tien chiaotzu bulma chi-chi (for ([name (in-list '(yamcha tien chiaotzu bulma chi-chi
oolong puar master-roshi))]) roshi))])
(insert-last/data! t2 name 1)) (insert-last/data! t2 name 1))
(define tree-of-mighty-z-warriors (join! t1 t2)) (define tree-of-mighty-z-warriors (join! t1 t2))
(tree-items tree-of-mighty-z-warriors) (map car (tree-items tree-of-mighty-z-warriors))
]
Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise
a contract error.
@interaction[#:eval my-eval
(define t1 (new-tree))
(join! t1 t1)
] ]
} }
@ -545,6 +551,14 @@ the elements in @racket[t2].
(define poor-lost-circus-performers (concat! t1 x t2)) (define poor-lost-circus-performers (concat! t1 x t2))
(tree-items poor-lost-circus-performers) (tree-items poor-lost-circus-performers)
] ]
Note that @racket[t1] should not be @racket[eq?] to @racket[t2] or else will raise
a contract error.
@interaction[#:eval my-eval
(define t1 (new-tree))
(define n (new-node "a-node" 1))
(concat! t1 n t1)
]
} }
@ -565,8 +579,8 @@ Afterwards, @racket[n] becomes a singleton node.
(singleton-node? bob-node) (singleton-node? bob-node)
] ]
Note that @racket[n] must be attached to tree @racket[t] or else Note that @racket[n] must be attached to tree @racket[t] or else raise
an error will be raised. a contract error.
@interaction[#:eval my-eval @interaction[#:eval my-eval
(define t (new-tree)) (define t (new-tree))
(for ([name '(melchior caspar bob balthazar)]) (for ([name '(melchior caspar bob balthazar)])
@ -578,6 +592,19 @@ an error will be raised.
]} ]}
@defproc[(reset! [t tree?]) void?]{
Resets the contents of the tree to the empty state.
@interaction[#:eval my-eval
(define t (new-tree))
(insert-last/data! t "house" 5)
(insert-last/data! t "cleaning" 8)
(tree-items t)
(reset! t)
(tree-items t)]
}
@defproc[(search [t tree?] [p natural-number/c]) node?]{ @defproc[(search [t tree?] [p natural-number/c]) node?]{
Searches for the node at or within the given position @racket[p] of the tree. 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]. If the position is out of bounds, returns @racket[nil].