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

splay-tree: tried top-down splay, tested, no time advantage

Browse Source
This commit is contained in:
Ryan Culpepper 2010-09-14 22:46:28 -06:00
parent 19be445d89
commit 12e2d6d76a
1 changed files with 72 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

117
collects/data/splay-tree.rkt
View File

@ -99,16 +99,16 @@ In (values status nroot pside pnode):
;; find/root : ... -> (values boolean node/#f) ;; find/root : ... -> (values boolean node/#f)
;; If ok?, then node returned is one sought. ;; If ok?, then node returned is one sought.
(define (find/root cmp tx k x add-v) (define (find/root cmp tx k x add-v)
(SPfinish (find cmp tx k x #f #f add-v))) (SPfinish (findb cmp tx k x #f #f add-v)))
;; find : ... -> SP ;; findb : ... -> SP
(define (find cmp tx k x p-side p add-v) (define (findb cmp tx k x p-side p add-v)
(cond [x (cond [x
(let ([k* (if tx (- k (node-key x)) k)]) (let ([k* (if tx (- k (node-key x)) k)])
(case (cmp k (node-key x)) (case (cmp k (node-key x))
((=) (SPunit tx x)) ((=) (SPunit tx x))
((<) (SPisplay (find cmp tx k* (node-left x) 'left x add-v) 'left x)) ((<) (SPisplay (findb cmp tx k* (node-left x) 'left x add-v) 'left x))
((>) (SPisplay (find cmp tx k* (node-right x) 'right x add-v) 'right x))))] ((>) (SPisplay (findb cmp tx k* (node-right x) 'right x add-v) 'right x))))]
[add-v [add-v
(let ([new-node (node k (car add-v) #f #f)]) (let ([new-node (node k (car add-v) #f #f)])
;; FIXME: link unnecessary? will be done in isplay/finish? ;; FIXME: link unnecessary? will be done in isplay/finish?
@ -117,20 +117,20 @@ In (values status nroot pside pnode):
[else (SPfail tx)])) [else (SPfail tx)]))
(define (find-min tx x) (define (find-min tx x)
(define (find-min-loop x) (define (find-min-loop tx x)
(cond [(and x (node-left x)) (cond [(and x (node-left x))
(SPisplay (find-min-loop (node-left x)) 'left x)] (SPisplay (find-min-loop tx (node-left x)) 'left x)]
[x (SPunit tx x)] [x (SPunit tx x)]
[else (SPfail tx)])) [else (SPfail tx)]))
(SPfinish (find-min-loop x))) (SPfinish (find-min-loop tx x)))
(define (find-max tx x) (define (find-max tx x)
(define (find-max-loop x) (define (find-max-loop tx x)
(cond [(and x (node-right x)) (cond [(and x (node-right x))
(SPisplay (find-max-loop (node-right x)) 'right x)] (SPisplay (find-max-loop tx (node-right x)) 'right x)]
[x (SPunit tx x)] [x (SPunit tx x)]
[else (SPfail tx)])) [else (SPfail tx)]))
(SPfinish (find-max-loop x))) (SPfinish (find-max-loop tx x)))
;; isplay! : ... -> SP ;; isplay! : ... -> SP
;; incremental splay ;; incremental splay
@ -202,45 +202,73 @@ In (values status nroot pside pnode):
#| #|
Top-down splay Top-down splay
Doesn't support parent-relative keys.
No faster than bottom-up splay, surprisingly.
|# |#
#| #|
(define (findt cmp tx k x scratch) (define (findt cmp k x scratch add-v)
(if x (cond [x
(findt* cmp tx k x scratch scratch scratch) (findt* cmp k x scratch scratch scratch add-v)]
(values #f #f))) [add-v
(values 'added (node k (car add-v) #f #f))]
[else
(values #f #f)]))
(define (findt* cmp tx k t scratch l r) (define (findt* cmp k t scratch l r add-v)
(define-syntax-rule (assemble! t) (define-syntax-rule (finish! status t l r)
(set-node-right! l (node-left t)) (assemble! status t scratch l r))
(set-node-left! r (node-right t)) (define-syntax-rule (continue t l r)
(set-node-left! t (node-right scratch)) (findt* cmp k t scratch l r add-v))
(set-node-right! t (node-left scratch)) (define-syntax-rule (rotate&link cmpresult rl l r
t) (node-A set-node-A!)
(define-syntax-rule (continue t) (node-B set-node-B!))
(findt* cmp tx k t scratch l r)) (let ([tA (node-A t)])
(define-syntax-rule (rotate&link cmpresult rl (node-A set-node-A!) (node-B set-node-B!)) (cond [tA
(let ([tsub (node-A t)]) (let ([c (cmp k (node-key tA))])
(cond [tsub (case c
(let-values ([(continue? t) ((cmpresult) ;; k should be on A-side of tA
(case (cmp k (node-key tsub)) (set-node-A! t (node-B tA))
((cmpresult) (set-node-B! tA t)
(set-node-A! t (node-B tsub)) (let ([tAA (node-A tA)])
(set-node-B! tsub t) (cond [tAA
(cond [(node-A tsub) (values #t tsub)] (set-node-A! rl tA)
[else (values #f tsub)])))]) (let ([rl tA]) ;; shadows either l or r
(cond [continue? (continue tAA l r))]
(set-node-A! rl t) [add-v
(continue t)] (let ([tAA (node k (car add-v) #f #f)])
[else (set-node-A! tA tAA)
(assemble! t)]))]))) (set-node-A! rl tA)
(case (cmp k (node-key x)) (let ([rl tA]) ;; shadows either l or r
(finish! 'added tAA l r)))]
[else
(finish! #f tA l r)])))
(else
(set-node-A! rl t)
(let ([rl t]) ;; shadows either l or r
(continue tA l r)))))]
[add-v
(let ([tA (node k (car add-v) #f #f)])
(set-node-A! t tA)
(set-node-A! rl t)
(let ([rl t]) ;; shadows either l or r
(finish! 'added tA l r)))]
[else
(finish! #f t l r)])))
(case (cmp k (node-key t))
((<) ((<)
(rotate&link < r (node-left set-node-left!) (node-right set-node-right!))) (rotate&link < r l r (node-left set-node-left!) (node-right set-node-right!)))
((>) ((>)
(rotate&link > l (node-right set-node-right!) (node-left! set-node-left!))) (rotate&link > l l r (node-right set-node-right!) (node-left set-node-left!)))
(else (else
(assemble t)))) (finish! 'found t l r))))
(define (assemble! status t scratch l r)
(set-node-right! l (node-left t))
(set-node-left! r (node-right t))
(set-node-left! t (node-right scratch))
(set-node-right! t (node-left scratch))
(values status t))
|# |#
;; -------- ;; --------
@ -298,7 +326,6 @@ Top-down splay
(join-left tx left right))) (join-left tx left right)))
(define (remove-range! cmp tx root from to contract?) (define (remove-range! cmp tx root from to contract?)
;; tx = #t... why pass as param?
(let*-values ([(ok? from-node) (find/root cmp tx from root (list #f))] (let*-values ([(ok? from-node) (find/root cmp tx from root (list #f))]
[(left-tree right-tree) [(left-tree right-tree)
(if (eq? ok? 'added) (if (eq? ok? 'added)