1 | ; Treaps in Scheme |
---|
2 | ; |
---|
3 | ; An implementation of an ordered dictionary data structure, based |
---|
4 | ; on randomized search trees (treaps) by Seidel and Aragon: |
---|
5 | ; |
---|
6 | ; R. Seidel and C. R. Aragon. Randomized Search Trees. |
---|
7 | ; Algorithmica, 16(4/5):464-497, 1996. |
---|
8 | ; |
---|
9 | ; This code defines a treap object that implements an ordered dictionary |
---|
10 | ; mapping of keys to values. The object responds to a variety of query and |
---|
11 | ; update messages, including efficient methods for finding the minimum and |
---|
12 | ; maximum keys and their associated values as well as traversing of a |
---|
13 | ; treap in an ascending or descending order of keys. Looking up an arbitrary |
---|
14 | ; or the min/max keys, and deleting the min/max keys require no more |
---|
15 | ; key comparisons than the depth of the treap, which is O(log n) where |
---|
16 | ; n is the total number of keys in the treap. Arbitrary key deletion and |
---|
17 | ; insertions run in O(log n) _amortized_ time. |
---|
18 | ; |
---|
19 | ; This code is inspired by a Stefan Nilsson's article "Treaps in Java" |
---|
20 | ; (Dr.Dobb's Journal, July 1997, p.40-44) and by the Java implementation |
---|
21 | ; of treaps described in the article. Yet this Scheme code has been |
---|
22 | ; developed completely from scratch, using the description of the algorithm |
---|
23 | ; given in the article, and insight gained from examining the Java source |
---|
24 | ; code. As a matter of fact, treap insertion and deletion algorithms |
---|
25 | ; implemented in this code differ from the ones described in the article |
---|
26 | ; and implemented in the Java code; this Scheme implementation uses fewer |
---|
27 | ; assignments and comparisons (see below for details). Some insight as |
---|
28 | ; to a generic tree interface gleaned from wttree.scm, "Weight balanced |
---|
29 | ; trees" by Stephen Adams (a part of The Scheme Library, slib2b1). |
---|
30 | ; |
---|
31 | ; A treap is a regular binary search tree, with one extension. The extension |
---|
32 | ; is that every node in a tree, beside a key, a value, and references to |
---|
33 | ; its left and right children, has an additional constant field, a priority. |
---|
34 | ; The value of this field is set (to a random integer number) when the node |
---|
35 | ; is constructed, and is not changed afterwards. At any given moment, |
---|
36 | ; the priority of every non-leaf node never exceeds the priorities of its |
---|
37 | ; children. When a new node is inserted, we check that this invariant holds; |
---|
38 | ; otherwise, we perform a right or left rotation that swaps a parent and |
---|
39 | ; its kid, keeping the ordering of keys intact; the changes may need to be |
---|
40 | ; propagated recursively up. The priority property, and the fact they are |
---|
41 | ; chosen at random, makes a treap look like a binary search tree built by |
---|
42 | ; a random sequence of insertions. As the article shows, this makes a treap |
---|
43 | ; a balanced tree: the expected length of an average search path is roughly |
---|
44 | ; 1.4log2(n)-1, and the expected length of the longest search path is about |
---|
45 | ; 4.3log2(n). See the Stefan Nilsson's article for more details. |
---|
46 | ; |
---|
47 | ; The treap object is created by a make-treap function, the only user-visible |
---|
48 | ; function defined in this code: |
---|
49 | ; procedure: make-treap KEY-COMPARE-PROC |
---|
50 | ; where KEY-COMPARE-PROC is a user-supplied function |
---|
51 | ; KEY-COMPARE-PROC key1 key2 |
---|
52 | ; that takes two keys and returns a negative, positive, or zero number |
---|
53 | ; depending on how the first key compares to the second. |
---|
54 | ; |
---|
55 | ; The treap object responds to the following messages (methods): |
---|
56 | ; 'get |
---|
57 | ; returns a procedure LAMBDA KEY . DEFAULT-CLAUSE |
---|
58 | ; which searches the treap for an association with a given |
---|
59 | ; KEY, and returns a (key . value) pair of the found association. |
---|
60 | ; If an association with the KEY cannot be located in the treap, |
---|
61 | ; the PROC returns the result of evaluating the DEFAULT-CLAUSE. |
---|
62 | ; If the default clause is omitted, an error is signalled. |
---|
63 | ; The KEY must be comparable to the keys in the treap |
---|
64 | ; by a key-compare predicate (which has been specified |
---|
65 | ; when the treap was created) |
---|
66 | ; |
---|
67 | ; 'get-min |
---|
68 | ; returns a (key . value) pair for an association in the |
---|
69 | ; treap with the smallest key. If the treap is empty, an error |
---|
70 | ; is signalled. |
---|
71 | ; 'delete-min! |
---|
72 | ; removes the min key and the corresponding association |
---|
73 | ; from the treap. Returns a (key . value) pair of the |
---|
74 | ; removed association. |
---|
75 | ; If the treap is empty, an error is signalled. |
---|
76 | ; 'get-max |
---|
77 | ; returns a (key . value) pair for an association in the |
---|
78 | ; treap with the largest key. If the treap is empty, an error |
---|
79 | ; is signalled. |
---|
80 | ; 'delete-max! |
---|
81 | ; removes the max key and the corresponding association |
---|
82 | ; from the treap. Returns a (key . value) pair of the |
---|
83 | ; removed association. |
---|
84 | ; If the treap is empty, an error is signalled. |
---|
85 | ; |
---|
86 | ; empty? |
---|
87 | ; returns #t if the treap is empty |
---|
88 | ; |
---|
89 | ; size |
---|
90 | ; returns the size (the number of associations) in the treap |
---|
91 | ; |
---|
92 | ; depth |
---|
93 | ; returns the depth of the tree. It requires the complete |
---|
94 | ; traversal of the tree, so use sparingly |
---|
95 | ; |
---|
96 | ; clear! |
---|
97 | ; removes all associations from the treap (thus making it empty) |
---|
98 | ; |
---|
99 | ; 'put! |
---|
100 | ; returns a procedure LAMBDA KEY VALUE |
---|
101 | ; which, given a KEY and a VALUE, adds the corresponding |
---|
102 | ; association to the treap. If an association with the same |
---|
103 | ; KEY already exists, its value is replaced with the VALUE |
---|
104 | ; (and the old (key . value) association is returned). Otherwise, |
---|
105 | ; the return value is #f. |
---|
106 | ; |
---|
107 | ; 'delete! |
---|
108 | ; returns a procedure LAMBDA KEY . DEFAULT-CLAUSE |
---|
109 | ; which searches the treap for an association with a given KEY, |
---|
110 | ; deletes it, and returns a (key . value) pair of the found |
---|
111 | ; and deleted association. |
---|
112 | ; If an association with the KEY cannot be located in the treap, |
---|
113 | ; the PROC returns the result of evaluating the DEFAULT-CLAUSE. |
---|
114 | ; If the default clause is omitted, an error is signalled. |
---|
115 | ; |
---|
116 | ; for-each-ascending |
---|
117 | ; returns a procedure LAMBDA PROC that will apply the given |
---|
118 | ; procedure PROC to each (key . value) association of the treap, |
---|
119 | ; from the one with the smallest key all the way to the one with |
---|
120 | ; the max key, in an ascending order of keys. |
---|
121 | ; The treap must not be empty. |
---|
122 | ; |
---|
123 | ; for-each-descending |
---|
124 | ; returns a procedure LAMBDA PROC that will apply the given |
---|
125 | ; procedure PROC to each (key . value) association of the treap, |
---|
126 | ; in the descending order of keys. |
---|
127 | ; The treap must not be empty. |
---|
128 | ; |
---|
129 | ; debugprint |
---|
130 | ; prints out all the nodes in the treap, for debug purposes |
---|
131 | ; |
---|
132 | ; ;;alist-> |
---|
133 | ; |
---|
134 | ; |
---|
135 | ; Notes on the algorithm |
---|
136 | ; As the DDJ paper shows, insertion of a node into a treap is a simple |
---|
137 | ; recursive algorithm, Example 1 of the paper. This algorithm is implemented |
---|
138 | ; in the accompanying source [Java] code as |
---|
139 | ; <BLOCKQUOTE> |
---|
140 | ; private Tree insert(Tree node, Tree tree) { |
---|
141 | ; if (tree == null) return node; |
---|
142 | ; int comp = node.key.compareTo(tree.key); |
---|
143 | ; if (comp < 0) { |
---|
144 | ; tree.left = insert(node, tree.left); |
---|
145 | ; if (tree.prio > tree.left.prio) |
---|
146 | ; tree = tree.rotateRight(); |
---|
147 | ; } else if (comp > 0) { |
---|
148 | ; tree.right = insert(node, tree.right); |
---|
149 | ; if (tree.prio > tree.right.prio) |
---|
150 | ; tree = tree.rotateLeft(); |
---|
151 | ; } else { |
---|
152 | ; keyFound = true; |
---|
153 | ; prevValue = tree.value; |
---|
154 | ; tree.value = node.value; |
---|
155 | ; } |
---|
156 | ; return tree; |
---|
157 | ; } |
---|
158 | ; </BLOCKQUOTE> |
---|
159 | ; |
---|
160 | ; This algorithm, however, is not as efficient as it could be. Suppose we |
---|
161 | ; try to insert a node which turns out to already exist in the tree, |
---|
162 | ; at a depth D. The algorithm above would descend into this node in the |
---|
163 | ; winding phase of the algorithm, replace the node's value, and, in the |
---|
164 | ; unwinding phase of the recursion, would perform D assignments of the kind |
---|
165 | ; tree.left = insert(node, tree.left); |
---|
166 | ; and D comparisons of nodes' priorities. None of these priority checks and |
---|
167 | ; assignments are actually necessary: as we haven't added any new node, |
---|
168 | ; the tree structure hasn't changed. |
---|
169 | ; |
---|
170 | ; Therefore, the present Scheme code implements a different insertion |
---|
171 | ; algorithm, which avoids doing unnecessary operations. The idea is simple: |
---|
172 | ; if we insert a new node into some particular branch of the treap and verify |
---|
173 | ; that this branch conforms to the treap priority invariant, we are certain |
---|
174 | ; the invariant holds throughout the entire treap, and no further checks |
---|
175 | ; (up the tree to the root) are necessary. In more detail: |
---|
176 | ; - Starting from the root, we recursively descend until we find |
---|
177 | ; a node with a given key, or a place a new node can be inserted. |
---|
178 | ; - We insert the node and check to see if its priority is less than |
---|
179 | ; that of its parent. If this is the case, we left- or right-rotate |
---|
180 | ; the tree to make the old parent a child of the new node, and the |
---|
181 | ; new node a new root of this particular branch. We return this new |
---|
182 | ; parent as an indication that further checks up the tree are |
---|
183 | ; necessary. If the new node conforms to the parent's priority, we |
---|
184 | ; insert it and return #f |
---|
185 | ; - On the way up, we check the priorities again and rotate the tree |
---|
186 | ; to restore the priority invariant at the current level if needed. |
---|
187 | ; - If no changes are made at the current level, we return a flag #f |
---|
188 | ; meaning that no further changes or checks are necessary at the |
---|
189 | ; higher levels. |
---|
190 | ; Thus, if a new node was originally inserted at a level D in the tree (level |
---|
191 | ; 0 being the root) but then migrated up by L levels (because of its priority), |
---|
192 | ; the original insertion algorithm would perform (D-1) assignments, |
---|
193 | ; (D-1) priority checks, plus L rotations (at a cost of 2 assignments in the |
---|
194 | ; treap each). Our algorithm does only (L+1) node priority checks and |
---|
195 | ; max(2(L-1)+2,1) assignments. |
---|
196 | ; Note if priorities are really (uniformly) random, L is uniformly distributed |
---|
197 | ; over [0,D], so the average cost of our algorithm is |
---|
198 | ; D/2 +1 checks and D assignments |
---|
199 | ; compared to |
---|
200 | ; D-1 checks and 2D-1 assignments |
---|
201 | ; for the original algorithm described in the DDJ paper. |
---|
202 | ; |
---|
203 | ; The similar gripe applies to the Java implementation of a node deletion |
---|
204 | ; algorithm: |
---|
205 | ; <BLOCKQUOTE> |
---|
206 | ; private Tree delete(Ordered key, Tree t) { |
---|
207 | ; if (t == null) return null; |
---|
208 | ; int comp = key.compareTo(t.key); |
---|
209 | ; if (comp < 0) |
---|
210 | ; t.left = delete(key, t.left); |
---|
211 | ; else if (comp > 0) |
---|
212 | ; t.right = delete(key, t.right); |
---|
213 | ; else { |
---|
214 | ; keyFound = true; |
---|
215 | ; prevValue = t.value; |
---|
216 | ; t = t.deleteRoot(); |
---|
217 | ; } |
---|
218 | ; return t; |
---|
219 | ; } |
---|
220 | ; </BLOCKQUOTE> |
---|
221 | ; |
---|
222 | ; The algorithm as implemented looks fully-recursive. Furthermore, |
---|
223 | ; deletion of a node at a level D in the treap involves at least D |
---|
224 | ; assignments, most of them being unnecessary. Indeed, if a node being |
---|
225 | ; deleted is a leaf, only one change to the tree is needed to detach |
---|
226 | ; the node. Deleting a node obviously requires a left- or a right-kid |
---|
227 | ; field of the node's parent be modified (cleared). This change, |
---|
228 | ; however does NOT need to be propagated up: deleting of a node does |
---|
229 | ; not violate neither ordering nor priority invariants of the treap; |
---|
230 | ; all changes are confined to a branch rooted at the parent of the |
---|
231 | ; deleted node. |
---|
232 | ; |
---|
233 | ; This Scheme code implements node deletion algorithm in the optimal |
---|
234 | ; way, performing only those assignments which are absolutely |
---|
235 | ; necessary, and replacing full recursions with tail recursions (which |
---|
236 | ; are simply iterations). Our implementation is also simpler and |
---|
237 | ; clearer, making use of a helper procedure join! to join two treap |
---|
238 | ; branches (while keeping both treap invariants intact). The deletion |
---|
239 | ; algorithm can then be expressed as replacing a node with a join of |
---|
240 | ; its two kids; compare this explanation to the one given in the DDJ |
---|
241 | ; paper! |
---|
242 | ; |
---|
243 | ; $Id: treap.scm,v 1.3 2004/07/08 21:00:24 oleg Exp $ |
---|
244 | ; |
---|
245 | ; Packaged for Chicken Scheme by Ivan Raikov. |
---|
246 | ; |
---|
247 | |
---|
248 | (module treap |
---|
249 | |
---|
250 | (make-treap) |
---|
251 | |
---|
252 | (import scheme chicken data-structures) |
---|
253 | |
---|
254 | ; Treaps package needs a random number generator to generate values of |
---|
255 | ; nodes' priorities. Here is the most primitive linear congruential |
---|
256 | ; generator, which is equivalent to the "standard" UNIX rand() It |
---|
257 | ; returns an integral random number uniformly distributed within |
---|
258 | ; [0,2^15-1] All bad words that have been said about rand() equally |
---|
259 | ; apply here. Still, for this present application, less than perfect |
---|
260 | ; spectral properties of this generator aren't too important. |
---|
261 | (define random |
---|
262 | (let ((state 5)) |
---|
263 | (lambda () |
---|
264 | (set! state (modulo (+ (* state 1103515245) 12345) #x7fff)) |
---|
265 | state))) |
---|
266 | |
---|
267 | ; Introduce a 'put! funtion to act as insert in STL? std::map::insert |
---|
268 | ; inserts association with a new key in a map. It does not modify the |
---|
269 | ; map if the key is already in the map. The insert function returns a |
---|
270 | ; pair. The second element is a boolean: #t if the actual insertion |
---|
271 | ; took place. The first element is an iterator that points to the |
---|
272 | ; key-value pair in the map that has the given key, regardless of |
---|
273 | ; whether that pair has just been inserted or it was already there. |
---|
274 | |
---|
275 | |
---|
276 | |
---|
277 | (define (make-treap key-compare) |
---|
278 | |
---|
279 | ; a node of a tree, a vector of |
---|
280 | ; slot 0 - key, anything that key-compare could be applied to |
---|
281 | ; slot 1 - value, any object associated with the key |
---|
282 | ; slot 2 - left-kid, #f if absent |
---|
283 | ; slot 3 - right-kid |
---|
284 | ; slot 4 - prio, a priority of the node (a FIXNUM random number) |
---|
285 | |
---|
286 | (define-syntax inc! |
---|
287 | (lambda (exp r c) |
---|
288 | (let ((x (cadr exp)) (%set! (r 'set!)) (%fx+ (r 'fx+))) |
---|
289 | `(,%set! ,x (,%fx+ 1 ,x))))) |
---|
290 | |
---|
291 | (define-syntax inc |
---|
292 | (lambda (exp r c) |
---|
293 | (let ((x (cadr exp)) (%fx+ (r 'fx+))) |
---|
294 | `(,%fx+ 1 ,x)))) |
---|
295 | |
---|
296 | (define-syntax dec! |
---|
297 | (lambda (exp r c) |
---|
298 | (let ((x (cadr exp)) (%set! (r 'set!)) (%fx- (r 'fx-))) |
---|
299 | `(,%set! ,x (,%fx- ,x 1))))) |
---|
300 | |
---|
301 | (define-syntax dec |
---|
302 | (lambda (exp r c) |
---|
303 | (let ((x (cadr exp) ) (%fx- (r 'fx-))) |
---|
304 | `(,%fx- ,x 1)))) |
---|
305 | |
---|
306 | |
---|
307 | (define-syntax node:left-kid |
---|
308 | (lambda (x r c) |
---|
309 | (let ((node (cadr x)) |
---|
310 | (%vector-ref (r 'vector-ref))) |
---|
311 | `(,%vector-ref ,node 2)))) |
---|
312 | |
---|
313 | (define-syntax node:right-kid |
---|
314 | (lambda (x r c) |
---|
315 | (let ((node (cadr x)) (%vector-ref (r 'vector-ref))) |
---|
316 | `(,%vector-ref ,node 3)))) |
---|
317 | |
---|
318 | (define-syntax node:priority |
---|
319 | (lambda (x r c) |
---|
320 | (let ((node (cadr x)) |
---|
321 | (%vector-ref (r 'vector-ref))) |
---|
322 | `(,%vector-ref ,node 4)))) |
---|
323 | |
---|
324 | (define-syntax node:left-kid-set! |
---|
325 | (lambda (x r c) |
---|
326 | (let ((node (cadr x)) |
---|
327 | (new-kid (caddr x)) |
---|
328 | (%vector-set! (r 'vector-set!))) |
---|
329 | `(,%vector-set! ,node 2 ,new-kid)))) |
---|
330 | |
---|
331 | |
---|
332 | (define-syntax node:right-kid-set! |
---|
333 | (lambda (x r c) |
---|
334 | (let ((node (cadr x)) |
---|
335 | (new-kid (caddr x)) |
---|
336 | (%vector-set! (r 'vector-set!))) |
---|
337 | `(,%vector-set! ,node 3 ,new-kid)))) |
---|
338 | |
---|
339 | |
---|
340 | (define-syntax node:unsubordination? |
---|
341 | (lambda (x r c) |
---|
342 | (let ((parent (cadr x)) |
---|
343 | (kid (caddr x)) |
---|
344 | (%node:priority (r 'node:priority)) |
---|
345 | (%> (r '>))) |
---|
346 | `(,%> (,%node:priority ,parent) (,%node:priority ,kid))))) |
---|
347 | |
---|
348 | (define-syntax node:dispatch-on-key |
---|
349 | (lambda (x r c) |
---|
350 | (let ((node (second x)) (key (third x)) |
---|
351 | (on-less (fourth x)) (on-equal (fifth x)) (on-greater (sixth x))) |
---|
352 | (let ((%let (r 'let)) |
---|
353 | (%cond (r 'cond)) |
---|
354 | (%else (r 'else)) |
---|
355 | (%zero? (r 'zero?)) |
---|
356 | (%positive? (r 'positive?)) |
---|
357 | (%vector-ref (r 'vector-ref)) |
---|
358 | (result (r 'result))) |
---|
359 | `(,%let ((,result (key-compare ,key (,%vector-ref ,node 0) ))) |
---|
360 | (,%cond |
---|
361 | ((,%zero? ,result) ,on-equal) |
---|
362 | ((,%positive? ,result) ,on-greater) |
---|
363 | (,%else ,on-less))))))) |
---|
364 | |
---|
365 | |
---|
366 | (define-syntax node:key |
---|
367 | (lambda (x r c) |
---|
368 | (let ((node (cadr x)) (%vector-ref (r 'vector-ref))) |
---|
369 | `(,%vector-ref ,node 0)))) |
---|
370 | |
---|
371 | (define-syntax node:key-value |
---|
372 | (lambda (x r c) |
---|
373 | (let ((node (cadr x)) |
---|
374 | (%cons (r 'cons)) |
---|
375 | (%vector-ref (r 'vector-ref))) |
---|
376 | `(,%cons (,%vector-ref ,node 0) (,%vector-ref ,node 1))))) |
---|
377 | |
---|
378 | (define-syntax node:value-set! |
---|
379 | (lambda (x r c) |
---|
380 | (let ((node (cadr x)) (value (caddr x)) |
---|
381 | (%vector-set! (r 'vector-set!))) |
---|
382 | `(,%vector-set! ,node 1 ,value)))) |
---|
383 | |
---|
384 | (define (new-leaf key value) |
---|
385 | (vector key value #f #f (random))) |
---|
386 | |
---|
387 | (define (node:debugprint node) |
---|
388 | (print " " (node:key-value node) ", kids " |
---|
389 | (cons (not (not (node:left-kid node))) |
---|
390 | (not (not (node:right-kid node)))) |
---|
391 | ", prio " (node:priority node) #\newline)) |
---|
392 | |
---|
393 | |
---|
394 | (let ((root #f) (size 0)) |
---|
395 | |
---|
396 | ; Looking up assocaitions in a treap: just like in any search tree |
---|
397 | ; Given a key, return the corresponding (key . value) association |
---|
398 | ; in the treap, or #f if the treap does not contain an association |
---|
399 | ; with that key |
---|
400 | ; This procedure takes as many comparisons (evaluations of the |
---|
401 | ; key-compare procedure) as the depth of the found node |
---|
402 | (define (locate-assoc key) |
---|
403 | (let loop ((node root)) |
---|
404 | (and node |
---|
405 | (node:dispatch-on-key node key |
---|
406 | (loop (node:left-kid node)) |
---|
407 | (node:key-value node) |
---|
408 | (loop (node:right-kid node)))))) |
---|
409 | |
---|
410 | (define-syntax locate-extremum-node |
---|
411 | (lambda (x r c) |
---|
412 | (let ((branch-selector (cadr x)) |
---|
413 | (%if (r 'if)) |
---|
414 | (%let (r 'let)) |
---|
415 | (%error (r 'error)) |
---|
416 | (%not (r 'not)) |
---|
417 | (loop (r 'loop)) |
---|
418 | (node (r 'node)) |
---|
419 | (parent (r 'parent)) |
---|
420 | (node:key-value (r 'node:key-value))) |
---|
421 | `(,%if (,%not root) (error "empty tree") |
---|
422 | (,%let ,loop ((,node root) (,parent #f)) |
---|
423 | (,%if ,node (,loop (,branch-selector ,node) ,node) |
---|
424 | (,node:key-value ,parent))))))) |
---|
425 | |
---|
426 | ;; in-order traversal of the treap |
---|
427 | (define-syntax for-each-inorder |
---|
428 | (lambda (x r c) |
---|
429 | (let ((primary-branch-selector (cadr x)) |
---|
430 | (secondary-branch-selector (caddr x)) |
---|
431 | (%if (r 'if)) |
---|
432 | (%let (r 'let)) |
---|
433 | (%not (r 'not)) |
---|
434 | (%error (r 'error)) |
---|
435 | (%when (r 'when)) |
---|
436 | (%lambda (r 'lambda)) |
---|
437 | (loop (r 'loop)) |
---|
438 | (node (r 'node)) |
---|
439 | (node:key-value (r 'node:key-value))) |
---|
440 | `(,%lambda (proc) |
---|
441 | (,%if (,%not root) (,%error "empty tree") |
---|
442 | (,%let ,loop ((,node root)) |
---|
443 | (,%when ,node |
---|
444 | (,loop (,primary-branch-selector ,node)) |
---|
445 | (proc (,node:key-value ,node)) |
---|
446 | (,loop (,secondary-branch-selector ,node))))))))) |
---|
447 | |
---|
448 | (define (get-depth) |
---|
449 | (let loop ((node root) (level 0)) |
---|
450 | (if (not node) level |
---|
451 | (max (loop (node:left-kid node) (inc level)) |
---|
452 | (loop (node:right-kid node) (inc level)))))) |
---|
453 | |
---|
454 | ; debug printing of all nodes of the tree in-order |
---|
455 | ; in an ascending order of keys |
---|
456 | (define (debugprint) |
---|
457 | (print #\newline "The treap contains " size " nodes" #\newline) |
---|
458 | (let loop ((node root) (level 0)) |
---|
459 | (when node |
---|
460 | (loop (node:left-kid node) (inc level)) |
---|
461 | (print " level " level) |
---|
462 | (node:debugprint node) |
---|
463 | (loop (node:right-kid node) (inc level)))) |
---|
464 | (print #\newline #\newline )) |
---|
465 | |
---|
466 | ; Adding a new association to the treap (or replacing the old one |
---|
467 | ; if existed). Return the (key . value) pair of an old (existed |
---|
468 | ; and replaced association), or #f if a new association was really |
---|
469 | ; added |
---|
470 | (define (insert! key value) |
---|
471 | (letrec ((new-node (new-leaf key value)) |
---|
472 | (old-key-value #f) |
---|
473 | ; If the left branch of parent is empty, insert the |
---|
474 | ; new node there, check priorities |
---|
475 | ; Otherwise, descend recursively |
---|
476 | ; If the parent got inverted due to a right rotation, |
---|
477 | ; return the new parent of the branch; otherwise, |
---|
478 | ; return #f (indicating no further checks are necessary) |
---|
479 | (insert-into-left-branch |
---|
480 | (lambda (key parent) |
---|
481 | (let ((old-left-kid (node:left-kid parent))) |
---|
482 | ; Found a place to insert the 'new-node': as the left |
---|
483 | ; leaf of the parent |
---|
484 | (if (not old-left-kid) |
---|
485 | (cond |
---|
486 | ((node:unsubordination? parent new-node) |
---|
487 | ; Right rotation over the new-leaf |
---|
488 | (node:right-kid-set! new-node parent) |
---|
489 | new-node) ; becomes a new parent |
---|
490 | (else |
---|
491 | (node:left-kid-set! parent new-node) |
---|
492 | #f)) |
---|
493 | ; Insert the new-leaf into a branch rooted |
---|
494 | ; on old-left-kid |
---|
495 | (let ((new-left-kid |
---|
496 | (node:dispatch-on-key old-left-kid key |
---|
497 | (insert-into-left-branch key old-left-kid) |
---|
498 | (update-existing-node old-left-kid) |
---|
499 | (insert-into-right-branch key old-left-kid)))) |
---|
500 | (and new-left-kid |
---|
501 | ; That branch got a new root |
---|
502 | (cond |
---|
503 | ((node:unsubordination? parent new-left-kid) |
---|
504 | ; Right rotation over the new-left-kid |
---|
505 | (node:left-kid-set! parent |
---|
506 | (node:right-kid new-left-kid)) |
---|
507 | (node:right-kid-set! new-left-kid parent) |
---|
508 | new-left-kid) ; becomes a new parent |
---|
509 | (else |
---|
510 | (node:left-kid-set! parent new-left-kid) |
---|
511 | #f)))) |
---|
512 | )))) |
---|
513 | |
---|
514 | ; If the right branch of parent is empty, insert the |
---|
515 | ; new node there, check priorities |
---|
516 | ; Otherwise, descend recursively |
---|
517 | ; If the parent got inverted due to a left rotation, |
---|
518 | ; return the new parent of the branch; otherwise, |
---|
519 | ; return #f (indicating no further checks are necessary) |
---|
520 | (insert-into-right-branch |
---|
521 | (lambda (key parent) |
---|
522 | (let ((old-right-kid (node:right-kid parent))) |
---|
523 | ; Found a place to insert the 'new-node': as the right |
---|
524 | ; leaf of the parent |
---|
525 | (if (not old-right-kid) |
---|
526 | (cond |
---|
527 | ((node:unsubordination? parent new-node) |
---|
528 | ; Left rotation over the new-leaf |
---|
529 | (node:left-kid-set! new-node parent) |
---|
530 | new-node) ; becomes a new parent |
---|
531 | (else |
---|
532 | (node:right-kid-set! parent new-node) |
---|
533 | #f)) |
---|
534 | ; Insert the new-leaf into a branch rooted |
---|
535 | ; on old-right-kid |
---|
536 | (let ((new-right-kid |
---|
537 | (node:dispatch-on-key old-right-kid key |
---|
538 | (insert-into-left-branch key old-right-kid) |
---|
539 | (update-existing-node old-right-kid) |
---|
540 | (insert-into-right-branch key old-right-kid)))) |
---|
541 | (and new-right-kid |
---|
542 | ; That branch got a new root |
---|
543 | (cond |
---|
544 | ((node:unsubordination? parent new-right-kid) |
---|
545 | ; Left rotation over the new-right-kid |
---|
546 | (node:right-kid-set! parent |
---|
547 | (node:left-kid new-right-kid)) |
---|
548 | (node:left-kid-set! new-right-kid parent) |
---|
549 | new-right-kid) ; becomes a new parent |
---|
550 | (else |
---|
551 | (node:right-kid-set! parent new-right-kid) |
---|
552 | #f)))) |
---|
553 | )))) |
---|
554 | |
---|
555 | (update-existing-node |
---|
556 | (lambda (node) |
---|
557 | (set! old-key-value (node:key-value node)) |
---|
558 | (node:value-set! node value) |
---|
559 | #f)) |
---|
560 | ) ; end of letrec |
---|
561 | |
---|
562 | ; insert's body |
---|
563 | (cond |
---|
564 | ; insert into an empty tree |
---|
565 | ((not root) (set! root new-node)) |
---|
566 | |
---|
567 | (else |
---|
568 | (let ((new-root |
---|
569 | (node:dispatch-on-key root key |
---|
570 | (insert-into-left-branch key root) |
---|
571 | (update-existing-node root) |
---|
572 | (insert-into-right-branch key root)))) |
---|
573 | (if new-root |
---|
574 | (set! root new-root))))) |
---|
575 | (if (not old-key-value) |
---|
576 | (inc! size)) ; if the insertion has really occurred |
---|
577 | old-key-value)) |
---|
578 | |
---|
579 | |
---|
580 | ; Deleting existing associations from the treap |
---|
581 | |
---|
582 | (define-syntax delete-extremum-node! |
---|
583 | (lambda (x r c) |
---|
584 | (let ((branch-selector (cadr x)) |
---|
585 | (branch-setter (caddr x)) |
---|
586 | (the-other-branch-selector (cadddr x)) |
---|
587 | (%if (r 'if)) |
---|
588 | (%let (r 'let)) |
---|
589 | (%not (r 'not)) |
---|
590 | (%error (r 'error)) |
---|
591 | (%when (r 'when)) |
---|
592 | (%cond (r 'cond)) |
---|
593 | (%else (r 'else)) |
---|
594 | (%set! (r 'set!)) |
---|
595 | (%dec! (r 'dec!)) |
---|
596 | (result (r 'result)) |
---|
597 | (loop (r 'loop)) |
---|
598 | (node (r 'node)) |
---|
599 | (parent (r 'parent)) |
---|
600 | (kid (r 'kid)) |
---|
601 | (node:key-value (r 'node:key-value))) |
---|
602 | `(,%cond |
---|
603 | ((,%not root) (,%error "empty tree")) |
---|
604 | ((,%not (,branch-selector root)) ; root is the extreme node |
---|
605 | (,%let ((,result (,node:key-value root))) |
---|
606 | (,%set! root (,the-other-branch-selector root)) |
---|
607 | (,%dec! size) |
---|
608 | ,result)) |
---|
609 | (,%else |
---|
610 | (,%let ,loop ((,node (,branch-selector root)) (,parent root)) |
---|
611 | (,%let ((,kid (,branch-selector ,node))) |
---|
612 | (,%if ,kid (,loop ,kid ,node) |
---|
613 | (,%let ((,result (,node:key-value ,node))) |
---|
614 | (,branch-setter ,parent (,the-other-branch-selector ,node)) |
---|
615 | (,%dec! size) |
---|
616 | ,result))))))))) |
---|
617 | |
---|
618 | ; Given two treap branches (both of which could be empty) |
---|
619 | ; which satisfy both the order invariant and the priority invariant |
---|
620 | ; (all keys of all the nodes in the right branch are strictly bigger |
---|
621 | ; than the keys of left branch nodes), join them |
---|
622 | ; while keeping the sorted and priority orders intact |
---|
623 | (define (join! left-branch right-branch) |
---|
624 | (cond |
---|
625 | ((not left-branch) right-branch) ; left-branch was empty |
---|
626 | ((not right-branch) left-branch) ; right-branch was empty |
---|
627 | ((node:unsubordination? left-branch right-branch) |
---|
628 | ; the root of the right-branch should be the new root |
---|
629 | (node:left-kid-set! right-branch |
---|
630 | (join! left-branch (node:left-kid right-branch))) |
---|
631 | right-branch) |
---|
632 | (else |
---|
633 | ; the root of the left-branch should be the new root |
---|
634 | (node:right-kid-set! left-branch |
---|
635 | (join! (node:right-kid left-branch) right-branch)) |
---|
636 | left-branch))) |
---|
637 | |
---|
638 | |
---|
639 | ; Find an association with a given KEY, and delete it. |
---|
640 | ; Return the (key . value) pair of the deleted association, or |
---|
641 | ; #f if it couldn't be found |
---|
642 | (define (delete! key) |
---|
643 | (define (delete-node! node parent from-left?) |
---|
644 | (let ((old-assoc (node:key-value node)) |
---|
645 | (new-kid (join! (node:left-kid node) (node:right-kid node)))) |
---|
646 | (dec! size) |
---|
647 | (if parent |
---|
648 | (if from-left? |
---|
649 | (node:left-kid-set! parent new-kid) |
---|
650 | (node:right-kid-set! parent new-kid)) |
---|
651 | ; Deleting of the root node |
---|
652 | (set! root new-kid)) |
---|
653 | old-assoc)) |
---|
654 | |
---|
655 | (let loop ((node root) (parent #f) (from-left? #t)) |
---|
656 | (and node |
---|
657 | (node:dispatch-on-key node key |
---|
658 | (loop (node:left-kid node) node #t) |
---|
659 | (delete-node! node parent from-left?) |
---|
660 | (loop (node:right-kid node) node #f)))) |
---|
661 | ) |
---|
662 | |
---|
663 | (define (apply-default-clause key default-clause) |
---|
664 | (cond |
---|
665 | ((null? default-clause) |
---|
666 | (error "key " key " was not found in the treap ")) |
---|
667 | ((pair? (cdr default-clause)) |
---|
668 | (error "default argument must be a single clause")) |
---|
669 | ((procedure? (car default-clause)) ((car default-clause))) |
---|
670 | (else (car default-clause)))) |
---|
671 | |
---|
672 | ; Dispatcher |
---|
673 | (lambda (selector) |
---|
674 | (case selector |
---|
675 | ((get) |
---|
676 | (lambda (key . default-clause) |
---|
677 | (or (locate-assoc key) (apply-default-clause key default-clause)))) |
---|
678 | |
---|
679 | ((delete!) |
---|
680 | (lambda (key . default-clause) |
---|
681 | (or (delete! key) (apply-default-clause key default-clause)))) |
---|
682 | |
---|
683 | ((get-min) (locate-extremum-node node:left-kid)) |
---|
684 | ((get-max) (locate-extremum-node node:right-kid)) |
---|
685 | ((delete-min!) |
---|
686 | (delete-extremum-node! node:left-kid node:left-kid-set! |
---|
687 | node:right-kid)) |
---|
688 | ((delete-max!) |
---|
689 | (delete-extremum-node! node:right-kid node:right-kid-set! |
---|
690 | node:left-kid)) |
---|
691 | ((empty?) (not root)) |
---|
692 | ((size) size) |
---|
693 | ((depth) (get-depth)) |
---|
694 | ((clear!) (set! root #f) (set! size 0)) |
---|
695 | ((put!) insert!) |
---|
696 | ((for-each-ascending) (for-each-inorder node:left-kid node:right-kid)) |
---|
697 | ((for-each-descending) (for-each-inorder node:right-kid node:left-kid)) |
---|
698 | ((debugprint) (debugprint)) |
---|
699 | (else |
---|
700 | (error "Unknown message " selector " sent to a treap")))))) |
---|
701 | ) |
---|
702 | |
---|