|
1 ;; Splay trees, partly from Chris Okasaki's "Purely Functional Data |
|
2 ;; Structures" but mostly from Tom Lord's "Hackerlab" C library |
|
3 ;; implementation. |
|
4 ;; |
|
5 ;; The Hackerlab implementation is a bit buggy (eg. the implementation |
|
6 ;; of delete-root and raise) so its been useful mainly as an |
|
7 ;; implementation template - I've had to reverify the actual |
|
8 ;; algorithms from scratch to make sure they're correct here. |
|
9 |
|
10 ;; Algebraic data type; we use '() as the empty tree. |
|
11 (define-record-type bst-node |
|
12 (make-bst-node element left right) |
|
13 bst-node? |
|
14 (element bst-node-element) |
|
15 (left bst-node-left) |
|
16 (right bst-node-right)) |
|
17 |
|
18 (define (bst? t) |
|
19 (or (null? t) |
|
20 (bst-node? t))) |
|
21 |
|
22 (define (binary-curry f a) |
|
23 (lambda (b) |
|
24 (f a b))) |
|
25 |
|
26 ;; Suggested API, from Tom Lord's Hackerlab splay trees: |
|
27 ;; |
|
28 ;; (splay-tree-singleton x) |
|
29 ;; (splay-tree-find-raw predcmp tree) |
|
30 ;; (splay-tree-find-min tree) |
|
31 ;; (splay-tree-find-max tree) |
|
32 ;; (splay-tree-raise predcmp tree) |
|
33 ;; (splay-tree-raise-min tree) |
|
34 ;; (splay-tree-raise-max tree) |
|
35 ;; (splay-tree-insert-after tree x) |
|
36 ;; (splay-tree-insert-before tree x) |
|
37 ;; (splay-tree-delete-root tree) |
|
38 |
|
39 (define (splay-tree-singleton x) |
|
40 (make-bst-node x '() '())) |
|
41 |
|
42 ;; Non-splaying search: returns a bst node, or #f |
|
43 (define (splay-tree-find-raw predcmp tree) |
|
44 (let walk ((tree tree)) |
|
45 (if (null? tree) |
|
46 #f |
|
47 (let ((order (predcmp (bst-node-element tree)))) |
|
48 (cond |
|
49 ((negative? order) (walk (bst-node-left tree))) |
|
50 ((positive? order) (walk (bst-node-right tree))) |
|
51 (else tree)))))) |
|
52 |
|
53 (define (splay-tree-find-min tree) |
|
54 (if (null? tree) |
|
55 #f |
|
56 (let walk ((tree tree)) |
|
57 (let ((left (bst-node-left tree))) |
|
58 (if (null? left) |
|
59 tree |
|
60 (walk left)))))) |
|
61 |
|
62 (define (splay-tree-find-max tree) |
|
63 (if (null? tree) |
|
64 #f |
|
65 (let walk ((tree tree)) |
|
66 (let ((right (bst-node-right tree))) |
|
67 (if (null? right) |
|
68 tree |
|
69 (walk right)))))) |
|
70 |
|
71 (define (splay-tree-raise cmp-pivot tree) |
|
72 (if (null? tree) |
|
73 tree |
|
74 (let walk ((tree tree)) |
|
75 (let* ((element (bst-node-element tree)) |
|
76 (left (bst-node-left tree)) |
|
77 (right (bst-node-right tree)) |
|
78 (order (cmp-pivot element))) |
|
79 (cond |
|
80 ((negative? order) |
|
81 (if (null? left) |
|
82 tree |
|
83 (let* ((element2 (bst-node-element left)) |
|
84 (left2 (bst-node-left left)) |
|
85 (right2 (bst-node-right left)) |
|
86 (order2 (cmp-pivot element2))) |
|
87 (cond |
|
88 ((and (negative? order2) (bst-node? left2)) |
|
89 (let ((new2 (walk left2))) |
|
90 (make-bst-node (bst-node-element new2) |
|
91 (bst-node-left new2) |
|
92 (make-bst-node element2 |
|
93 (bst-node-right new2) |
|
94 (make-bst-node element right2 right))))) |
|
95 ((and (positive? order2) (bst-node? right2)) |
|
96 (let ((new2 (walk right2))) |
|
97 (make-bst-node (bst-node-element new2) |
|
98 (make-bst-node element2 left2 (bst-node-left new2)) |
|
99 (make-bst-node element (bst-node-right new2) right)))) |
|
100 (else (make-bst-node element2 left2 (make-bst-node element right2 right))))))) |
|
101 ((positive? order) |
|
102 (if (null? right) |
|
103 tree |
|
104 (let* ((element2 (bst-node-element right)) |
|
105 (left2 (bst-node-left right)) |
|
106 (right2 (bst-node-right right)) |
|
107 (order2 (cmp-pivot element2))) |
|
108 (cond |
|
109 ((and (negative? order2) (bst-node? left2)) |
|
110 (let ((new2 (walk left2))) |
|
111 (make-bst-node (bst-node-element new2) |
|
112 (make-bst-node element left (bst-node-left new2)) |
|
113 (make-bst-node element2 (bst-node-right new2) right2)))) |
|
114 ((and (positive? order2) (bst-node? right2)) |
|
115 (let ((new2 (walk right2))) |
|
116 (make-bst-node (bst-node-element new2) |
|
117 (make-bst-node element2 |
|
118 (make-bst-node element left left2) |
|
119 (bst-node-left new2)) |
|
120 (bst-node-right new2)))) |
|
121 (else (make-bst-node element2 (make-bst-node element left left2) right2)))))) |
|
122 (else tree)))))) |
|
123 |
|
124 (define (splay-tree-raise-min tree) |
|
125 (splay-tree-raise (lambda (v) -1) tree)) |
|
126 |
|
127 (define (splay-tree-raise-max tree) |
|
128 (splay-tree-raise (lambda (v) 1) tree)) |
|
129 |
|
130 (define (splay-tree-insert-after tree x) |
|
131 (cond |
|
132 ((null? tree) (splay-tree-singleton x)) |
|
133 (else (make-bst-node x |
|
134 (make-bst-node (bst-node-element tree) |
|
135 (bst-node-left tree) |
|
136 '()) |
|
137 (bst-node-right tree))))) |
|
138 |
|
139 (define (splay-tree-insert-before tree x) |
|
140 (cond |
|
141 ((null? tree) (splay-tree-singleton x)) |
|
142 (else (make-bst-node x |
|
143 (bst-node-left tree) |
|
144 (make-bst-node (bst-node-element tree) |
|
145 '() |
|
146 (bst-node-right tree)))))) |
|
147 |
|
148 ;; Well, I invented this algorithm. Chances are it's inefficient, or |
|
149 ;; it doesn't work, or both. |
|
150 (define (splay-tree-delete-root tree) |
|
151 (if (null? tree) |
|
152 (error "Cannot delete root of empty splay tree") |
|
153 (let* ((left (bst-node-left tree)) |
|
154 (right (bst-node-right tree)) |
|
155 (new-left (splay-tree-raise-max left))) |
|
156 (if (null? new-left) |
|
157 right |
|
158 (if (null? (bst-node-right new-left)) |
|
159 (let ((new-tree (make-bst-node (bst-node-element new-left) |
|
160 (bst-node-left new-left) |
|
161 right))) |
|
162 ;;(pretty-print (list 'DEL |
|
163 ;;(bst->alist tree) |
|
164 ;;(bst->alist new-tree))) |
|
165 new-tree) |
|
166 (error "Invariant violation: need null right on max-raised splay tree" |
|
167 (list (bst->alist left) |
|
168 (bst->alist new-left)))))))) |
|
169 |
|
170 (define (splay-tree-insert cmp-pivot tree x) |
|
171 (if (null? tree) |
|
172 (splay-tree-singleton x) |
|
173 (let ((new-tree (splay-tree-raise cmp-pivot tree))) |
|
174 (if (positive? (cmp-pivot (bst-node-element new-tree))) |
|
175 (splay-tree-insert-after new-tree x) |
|
176 (splay-tree-insert-before new-tree x))))) |
|
177 |
|
178 (define (splay-tree-insert/replace cmp-pivot tree x) |
|
179 (if (null? tree) |
|
180 (splay-tree-singleton x) |
|
181 (let* ((new-tree (splay-tree-raise cmp-pivot tree)) |
|
182 (order (cmp-pivot (bst-node-element new-tree)))) |
|
183 (cond |
|
184 ((negative? order) (splay-tree-insert-before new-tree x)) |
|
185 ((positive? order) (splay-tree-insert-after new-tree x)) |
|
186 (else (make-bst-node x (bst-node-left new-tree) (bst-node-right new-tree))))))) |
|
187 |
|
188 (define (splay-tree-find predcmp tree k-found k-notfound) |
|
189 (if (null? tree) |
|
190 (k-notfound tree) |
|
191 (let ((new-tree (splay-tree-raise predcmp tree))) |
|
192 (if (zero? (predcmp (bst-node-element new-tree))) |
|
193 (k-found new-tree) |
|
194 (k-notfound new-tree))))) |
|
195 |
|
196 (define (splay-tree-delete predcmp tree k-found . opt-k-notfound) |
|
197 (let ((k-notfound (if (null? opt-k-notfound) k-found (car opt-k-notfound)))) |
|
198 (if (null? tree) |
|
199 (k-notfound tree) |
|
200 (let ((new-tree (splay-tree-raise predcmp tree))) |
|
201 (if (zero? (predcmp (bst-node-element new-tree))) |
|
202 (k-found (splay-tree-delete-root new-tree)) |
|
203 (k-notfound new-tree)))))) |
|
204 |
|
205 (define (bst->list t) |
|
206 (let walk ((t t) |
|
207 (acc '())) |
|
208 (if (null? t) |
|
209 acc |
|
210 (walk (bst-node-left t) |
|
211 (cons (bst-node-element t) |
|
212 (walk (bst-node-right t) acc)))))) |
|
213 |
|
214 (define (bst->alist t) |
|
215 (let ((v (let walk ((t t)) |
|
216 (if (null? t) |
|
217 (cons 0 t) |
|
218 (let ((l (walk (bst-node-left t))) |
|
219 (r (walk (bst-node-right t)))) |
|
220 (list (+ (max (car l) (car r)) 1) |
|
221 (bst-node-element t) |
|
222 (cdr l) |
|
223 (cdr r))))))) |
|
224 `((height ,(car v)) |
|
225 (tree ,(cdr v))))) |
|
226 |
|
227 (define (bst-height t) |
|
228 (if (null? t) |
|
229 0 |
|
230 (+ (max (bst-height (bst-node-left t)) |
|
231 (bst-height (bst-node-right t))) |
|
232 1))) |
|
233 |
|
234 (define (bst-size t) |
|
235 (if (null? t) |
|
236 0 |
|
237 (+ (bst-size (bst-node-left t)) |
|
238 (bst-size (bst-node-right t)) |
|
239 1))) |
|
240 |
|
241 (define (splay-tree-tests) |
|
242 (define (test) |
|
243 (let ((remove (lambda (i t) |
|
244 (splay-tree-delete (binary-curry - i) t |
|
245 (lambda (t) |
|
246 (pretty-print (list 'FOUND i (bst->alist t))) |
|
247 t) |
|
248 (lambda (t) |
|
249 (pretty-print (list 'NOTFOUND i (bst->alist t))) |
|
250 t))))) |
|
251 (let* ((t '()) |
|
252 (t (do ((i 0 (+ i 1)) |
|
253 (t t (splay-tree-insert (lambda (b) (- (- 50 i) b)) |
|
254 (splay-tree-insert - t i) |
|
255 (- 50 i)))) |
|
256 ((= i 10) |
|
257 (pretty-print (list 'FINALINS (bst->alist t))) |
|
258 t) |
|
259 (pretty-print (list 'INTERIM i (bst->alist t))))) |
|
260 (t (do ((i 0 (+ i 2)) |
|
261 (t t (remove i (remove (- 50 i 1) t)))) |
|
262 ((> i 50) |
|
263 (pretty-print (list 'FINALDEL (bst->alist t))) |
|
264 t)))) |
|
265 'done))) |
|
266 (require 'srfi-1) |
|
267 (define (test2) |
|
268 (let ((t (time (do ((i 0 (+ i 1)) |
|
269 (t '() (let ((v (random 10000))) |
|
270 (splay-tree-insert (lambda (b) (- v b)) t v)))) |
|
271 ((= i 10000) t))))) |
|
272 (pretty-print (bst-height t)) |
|
273 (let* ((oldt t) |
|
274 (t (time (do ((i 0 (+ i 1)) |
|
275 (t t (splay-tree-find (binary-curry - (random 10000)) |
|
276 t |
|
277 (lambda (t) t) |
|
278 (lambda (t) t)))) |
|
279 ((= i 50000) t))))) |
|
280 (pretty-print (bst-height t)) |
|
281 (pretty-print (eq? t oldt)) |
|
282 (time |
|
283 (let loop ((t t)) |
|
284 (if (null? t) |
|
285 (pretty-print (bst-height t)) |
|
286 (let ((new-t (splay-tree-raise-min t))) |
|
287 (loop (splay-tree-delete-root new-t))))))))) |
|
288 (test2)) |