source: project/release/4/treap/trunk/treap.scm @ 14465

Last change on this file since 14465 was 14465, checked in by Ivan Raikov, 10 years ago

treap and rb-tree copied to release/4 branch and ported to Chicken 4

File size: 27.2 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.