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

adjust the splay tree implementation so that it creates fewer cons

Browse Source 
cells when searching in the tree

Two tricks: represent lists of nodes as improper lists so singleton
lists don't allocate a cons and pass around two accumulators that
correspond to the hd & tl of a path, instead of cons'ing that up
into a list and them immediately taking it apart again

measurement: when starting up drracket with
collects/drracket/private/unit.rkt and then waiting for the colorer to
finish, and then inserting an open quote right before the first open
quote in the file (and waiting again for the colorer to finish)
creates 249000 cons cells before this change and 116000 after this
change

After a little more work, I'm pretty much convinced that this was
the wrong approach and that the splaying implementation should just
change to not allocate the paths into lists at all, thus removing
the other 116k cons cells. (I plan to get to this another day;
it should not be difficult now that I roughly understand how these
things work.)

I also looked into top-down splaying and found these notes to
be illuminating:

  http://digital.cs.usu.edu/~allan/DS/Notes/Ch22.pdf

They essentially convinced me that we cannot use top-down splaying
here, since the "reassembling" stage requires moving some arbitrary,
unexplored subtree from a right-child to a left-child, and thus the
left-subtree-length cannot be updated properly.
This commit is contained in:
Robby Findler 2012-04-04 09:08:44 -05:00
parent a984f68a46
commit aa8b280f1c
1 changed files with 108 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/syntax-color/token-tree.rkt
View File

@ -12,45 +12,55 @@
;; ----- The algorithmic implementation of the splay tree for a buffer ------
;; search-max: tree * tree list -> tree
(define (search-max node path)
(cond
((not node)
(end-search path))
(else
(search-max (node-right node) (cons node path)))))
(define (search-max node path) (search-dir node path node-right))
;; search-min: tree * tree list -> tree
(define (search-min node path)
(define (search-min node path) (search-dir node path node-left))
(define (search-dir node path direction)
(cond
((not node)
(end-search path))
(else
(search-min (node-left node) (cons node path)))))
[(not node) #f]
[else
(let loop ([node (direction node)]
[path-hd node]
[path-tl path]
[direction direction])
(cond
[(not node) (bottom-up-splay path-hd path-tl)]
[else
(loop (direction node) node (i-cons path-hd path-tl) direction)]))]))
;; internal-search: tree * NAT * NAT * tree list -> tree
;; key-position is the position in the buffer we are looking for
;; offset is the offset for the whole subtree of node in the buffer.
;; path is the path back to the root
(define (internal-search node key-position offset path)
(define (internal-search node key-position)
(cond
((not node)
(end-search path))
(else
(let* ((node-start (+ offset (node-left-subtree-length node)))
(node-end (+ node-start (node-token-length node))))
[(not node) #f]
[else
(define-values (first-node first-offset) (internal-direction node key-position 0))
(let loop ([node first-node]
[key-position key-position]
[offset first-offset]
[path-hd node]
[path-tl '()])
(cond
((< key-position node-start)
(internal-search (node-left node) key-position offset (cons node path)))
((>= key-position node-end)
(internal-search (node-right node) key-position node-end (cons node path)))
(else
(bottom-up-splay node path)))))))
[(not node)
(bottom-up-splay path-hd path-tl)]
[else
(define-values (next-node next-offset) (internal-direction node key-position offset))
(loop next-node key-position next-offset node (i-cons path-hd path-tl))]))]))
;; end-search: tree list -> tree
(define (end-search path)
(define (internal-direction node key-position offset)
(define node-start (+ offset (node-left-subtree-length node)))
(define node-end (+ node-start (node-token-length node)))
(cond
((null? path) #f)
(else (bottom-up-splay (car path) (cdr path)))))
[(< key-position node-start)
(values (node-left node) offset)]
[(>= key-position node-end)
(values (node-right node) node-end)]
[else
(values #f #f)]))
;; update-subtree-length-left-rotate: tree * tree ->
(define (update-subtree-length-left-rotate self parent)
@ -68,10 +78,11 @@
;; bottom-up-splay: tree * tree list -> tree
(define (bottom-up-splay self path)
(let loop ([self self] [path path])
(cond
((null? path) self) ;; node is root already
((null? (cdr path)) ;; node's parent is root
(let ((parent (car path)))
((null? (i-cdr path)) ;; node's parent is root
(let ((parent (i-car path)))
(cond
((eq? self (node-left parent))
(set-node-left! parent (node-right self))
@ -83,8 +94,8 @@
(update-subtree-length-right-rotate self parent))))
self)
(else
(let ((grand (cadr path))
(parent (car path)))
(let ((grand (i-cadr path))
(parent (i-car path)))
(cond
((eq? self (node-left parent))
(cond
@ -123,11 +134,11 @@
(node-left-subtree-length self)
(node-token-length self)))
(update-subtree-length-right-rotate self parent)))))
(unless (null? (cddr path))
(if (eq? grand (node-left (caddr path)))
(set-node-left! (caddr path) self)
(set-node-right! (caddr path) self)))
(bottom-up-splay self (cddr path))))))
(unless (null? (i-cddr path))
(if (eq? grand (node-left (i-caddr path)))
(set-node-left! (i-caddr path) self)
(set-node-right! (i-caddr path) self)))
(loop self (i-cddr path)))))))
(define (size node acc)
(cond
@ -159,6 +170,14 @@
(f node-start (node-token-length node) (node-token-data node))
(do-splay-tree-for-each f (node-right node) (+ node-start (node-token-length node))))))
;; represent paths as improper lists of nodes
(define (i-cons hd tl) (if (null? tl) hd (cons hd tl)))
(define (i-car pr) (if (node? pr) pr (car pr)))
(define (i-cdr pr) (if (node? pr) '() (cdr pr)))
(define (i-cadr pr) (i-car (i-cdr pr)))
(define (i-cddr pr) (i-cdr (i-cdr pr)))
(define (i-caddr pr) (i-car (i-cddr pr)))
;; --------------------- The interface to the splay tree --------------------
(define-local-member-name set-root)
@ -221,7 +240,7 @@
;; Moves the node at key-position to the root
(define/public (search! key-position)
(when root
(set! root (internal-search root key-position 0 null))))
(set! root (internal-search root key-position))))
;; search-max!: ->
;; moves the maximum node to the root