From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Tue, 2 Nov 1993 20:10:55 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~7625
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=31a9dcae679276c928eb1a652bbf30fe85fa5819;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/runtime/wttree.scm b/v7/src/runtime/wttree.scm
new file mode 100644
index 000000000..989c07191
--- /dev/null
+++ b/v7/src/runtime/wttree.scm
@@ -0,0 +1,617 @@
+#| -*-Scheme-*-
+
+$Id: wttree.scm,v 1.1 1993/11/02 20:10:55 adams Exp $
+
+Copyright (c) 1988-93 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Weight-balanced tree (wt-tree) Operations
+;;; package: (runtime wt-tree)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare (usual-integrations))
+
+
+;;;  A tree type is a collection of those procedures that depend on the ordering
+;;;  relation.
+
+(define-structure
+  (tree-type
+   (conc-name tree-type/)
+   (constructor %make-tree-type))
+  key<?
+  alist->tree
+  add
+  insert!
+  delete
+  delete!
+  member?
+  lookup
+  ;;;min        ; ?  also delmin, max, delmax, delmin!, delmax!
+  split-lt
+  split-gt
+  union
+  intersection
+  difference
+  subset?
+  rank
+)  
+
+;;;
+;;;  Tree representation
+;;;
+;;;  WT-TREE is a wrapper for trees of nodes
+;;;
+(define-structure
+  (wt-tree
+   (conc-name tree/)
+   (constructor %make-wt-tree))
+  type
+  root)
+
+;;;
+;;;  Nodes are the real trees - a node is either
+(define-integrable (make-node k v l r w) (vector w l k r v))
+(define-integrable (node/k node) (vector-ref node 2))
+(define-integrable (node/v node) (vector-ref node 4))
+(define-integrable (node/l node) (vector-ref node 1))
+(define-integrable (node/r node) (vector-ref node 3))
+(define-integrable (node/w node) (vector-ref node 0))
+
+(define-integrable empty  'empty)
+(define-integrable (empty? x) (eq? x 'empty))
+
+(define-integrable (node/size node)
+  (if (empty? node) 0  (node/w node)))
+
+(define-integrable (node/singleton k v) (make-node k v empty empty 1))
+
+(define-integrable (with-node node receiver)
+  (receiver (node/k node) (node/v node)
+	    (node/l node) (node/r node) (node/w node)))
+
+(define-integrable (with-n-node node receiver)
+  (receiver (node/k node) (node/v node) (node/l node) (node/r node)))
+
+
+;;;
+;;;  Constructors for building node trees of various complexity
+;;;
+
+(define (n-join k v l r)
+  (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r)))))
+(declare (integrate-operator n-join))
+
+(define (single-l a.k a.v x r)
+  (with-n-node r
+    (lambda (b.k b.v y z) (n-join b.k b.v (n-join a.k a.v x y) z))))
+
+(define (double-l a.k a.v x r)
+  (with-n-node r
+    (lambda (c.k c.v r.l z)
+      (with-n-node r.l
+	(lambda (b.k b.v y1 y2)
+	  (n-join b.k b.v
+		  (n-join a.k a.v x y1)
+		  (n-join c.k c.v y2 z)))))))
+
+(define (single-r b.k b.v l z)
+  (with-n-node l
+    (lambda (a.k a.v x y) (n-join a.k a.v x (n-join b.k b.v y z)))))
+
+(define (double-r c.k c.v l z)
+  (with-n-node l
+    (lambda (a.k a.v x l.r)
+      (with-n-node l.r
+	(lambda (b.k b.v y1 y2)
+	  (n-join b.k b.v
+		  (n-join a.k a.v x y1)
+		  (n-join c.k c.v y2 z)))))))
+
+(define-integrable ratio 5)
+
+(define (t-join k v l r)
+  (define (simple-join) (n-join k v l r))
+  (let ((l.n  (node/size l))
+	(r.n  (node/size r)))
+    (cond ((fix:< (fix:+ l.n r.n) 2)   (simple-join))
+	  ((fix:> r.n (fix:* ratio l.n))
+	   ;; right is too big
+	   (let ((r.l.n  (node/size (node/l r)))
+		 (r.r.n  (node/size (node/r r))))
+	     (if (fix:< r.l.n r.r.n)
+		 (single-l k v l r)
+		 (double-l k v l r))))
+	  ((fix:> l.n (fix:* ratio r.n))
+	   ;; left is too big
+	   (let ((l.l.n  (node/size (node/l l)))
+		 (l.r.n  (node/size (node/r l))))
+	     (if (fix:< l.r.n l.l.n)
+		 (single-r k v l r)
+		 (double-r k v l r))))
+	  (else
+	   (simple-join)))))
+
+;;;
+;;;  Node tree Procedures that are independent of key<?
+;;;
+
+(define (node/min node)
+  (cond  ((empty? node)           (error:empty 'min))
+	 ((empty? (node/l node))  node)
+	 (else                   (node/min (node/l node)))))
+
+(define (node/delmin node)
+  (cond ((empty? node)           (error:empty 'delmin))
+	((empty? (node/l node))  (node/r node))
+	(else   (t-join (node/k node) (node/v node)
+			(node/delmin (node/l node)) (node/r node)))))
+
+(define (node/concat2 node1 node2)
+  (cond ((empty? node1)   node2)
+	((empty? node2)   node1)
+	(else
+	 (let ((min-node (node/min node2)))
+	   (t-join (node/k min-node) (node/v min-node)
+		   node1 (node/delmin node2))))))
+
+(define (node/inorder-fold procedure base node)
+  (define (fold base node)
+    (if (empty? node)
+	base
+	(with-n-node node
+	  (lambda (k v l r)
+	    (fold (procedure k v (fold base r)) l)))))
+  (fold base node))
+
+(define (node/for-each procedure node)
+  (if (not (empty? node))
+      (with-n-node node
+	(lambda (k v l r)
+	  (node/for-each procedure l)
+	  (procedure k v)
+	  (node/for-each procedure r)))))
+
+(define (node/height node)
+  (if (empty? node)
+      0
+      (1+ (max (node/height (node/l node)) (node/height (node/r node))))))
+
+(define (node/index node index)
+  (define (loop node index)
+    (let ((size.l  (node/size (node/l node))))
+      (cond ((fix:< index size.l)  (loop (node/l node) index))
+	    ((fix:> index size.l)  (loop (node/r node)
+					 (fix:- index (fix:+ 1 size.l))))
+	    (else                  node))))
+  (let ((bound  (node/size node)))
+    (if (or (< index 0)
+	    (>= index bound)
+	    (not (fix:fixnum? index)))
+	(error:bad-range-argument index 'node/index)
+	(loop node index))))
+
+(define (error:empty owner)
+  ((access error ()) "Operation requires non-empty tree:" owner))
+
+
+(define (make-wt-tree-type key<?)
+
+  (declare (integrate key<?))
+
+  (define-integrable (key>? x y)  (key<? y x))
+
+  ;  (define (node/find k node)
+  ;    (cond ((empty? node)  node)
+  ;	  ((key<? k (node/k node))   (node/find k (node/l node)))
+  ;	  ((key>? k (node/k node))   (node/find k (node/r node)))
+  ;	  (else   node)))
+
+  (define (node/find k node)
+    ;; returns either the node or #f
+    (define (loop this best)
+      (cond ((empty? this)  best)
+	    ((key<? k (node/k this))   (loop (node/l this) best))
+	    (else (loop (node/r this) this))))
+    (let ((best (loop node #f)))
+      (cond ((null? best)             #f)
+	    ((key<? (node/k best) k)  #f)
+	    (else                     best))))
+
+  (define (node/rank k node rank)
+    (cond ((empty? node)             #f)
+	  ((key<? k (node/k node))  (node/rank k (node/l node) rank))
+	  ((key>? k (node/k node))  
+	   (node/rank k (node/r node)
+		        (fix:+ 1 (fix:+ rank (node/size (node/l node))))))
+	  (else                     (fix:+ rank (node/size (node/l node))))))
+
+  (define (node/add node k v)
+    (if (empty? node)
+	(node/singleton k v)
+	(with-n-node node
+	  (lambda (key val l r)
+	    (cond ((key<? k key)   (t-join key val (node/add l k v) r))
+		  ((key<? key k)   (t-join key val l (node/add r k v)))
+		  (else            (n-join key v   l r)))))))
+
+  (define (node/delete x node)
+    (if (empty? node)
+	empty
+	(with-n-node node
+	  (lambda (key val l r)
+	    (cond ((key<? x key)   (t-join key val (node/delete x l) r))
+		  ((key<? key x)   (t-join key val l (node/delete x r)))
+		  (else            (node/concat2 l r)))))))
+
+  (define (node/concat tree1 tree2)
+    (cond ((empty? tree1)  tree2)
+	  ((empty? tree2)  tree1)
+	  (else
+	   (let ((min-node (node/min tree2)))
+	     (node/concat3 (node/k min-node) (node/v min-node) tree1
+			   (node/delmin tree2))))))
+
+  (define (node/concat3 k v l r)
+    (cond ((empty? l)   (node/add r k v))
+	  ((empty? r)   (node/add l k v))
+	  (else
+	   (let ((n1  (node/size l))
+		 (n2  (node/size r)))
+	     (cond ((fix:< (fix:* ratio n1) n2)
+		    (with-n-node r
+				 (lambda (k2 v2 l2 r2)
+				   (t-join k2 v2 (node/concat3 k v l l2) r2))))
+		   ((fix:< (fix:* ratio n2) n1)
+		    (with-n-node l
+				 (lambda (k1 v1 l1 r1)
+				   (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
+		   (else
+		    (n-join k v l r)))))))
+
+  (define (node/split-lt node x)
+    (cond ((empty? node)  empty)
+	  ((key<? x (node/k node))
+	   (node/split-lt (node/l node) x))
+	  ((key<? (node/k node) x)
+	   (node/concat3 (node/k node) (node/v node) (node/l node)
+			 (node/split-lt (node/r node) x)))
+	  (else (node/l node))))
+
+  (define (node/split-gt node x)
+    (cond ((empty? node)  empty)
+	  ((key<? (node/k node) x)
+	   (node/split-gt (node/r node) x))
+	  ((key<? x (node/k node))
+	   (node/concat3 (node/k node) (node/v node) 
+			 (node/split-gt (node/l node) x) (node/r node)))
+	  (else (node/r node))))
+
+  (define (node/union tree1 tree2)
+    (cond  ((empty? tree1)  tree2)
+	   ((empty? tree2)  tree1)
+	   (else
+	    (with-n-node tree2
+	      (lambda (ak av l r)
+		(let ((l1  (node/split-lt tree1 ak))
+		      (r1  (node/split-gt tree1 ak)))
+		  (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))
+
+  (define (node/difference tree1 tree2)
+    (cond ((empty? tree1)   empty)
+	  ((empty? tree2)   tree1)
+	  (else
+	   (with-n-node tree2
+	     (lambda (ak av l r)
+	       (let ((l1  (node/split-lt tree1 ak))
+		     (r1  (node/split-gt tree1 ak)))
+		 av
+		 (node/concat (node/difference l1 l)
+			      (node/difference r1 r))))))))
+
+  (define (node/intersection tree1 tree2)
+    (cond ((empty? tree1)   empty)
+	  ((empty? tree2)   empty)
+	  (else
+	   (with-n-node tree2
+	     (lambda (ak av l r)
+	       (let ((l1  (node/split-lt tree1 ak))
+		     (r1  (node/split-gt tree1 ak)))
+		 (if (node/find ak tree1)
+		     (node/concat3 ak av (node/intersection l1 l)
+				   (node/intersection r1 r))
+		     (node/concat (node/intersection l1 l)
+				  (node/intersection r1 r)))))))))
+
+  (define (node/subset? tree1 tree2)
+    (or (empty? tree1)
+	(and (fix:<= (node/size tree1) (node/size tree2))
+	     (with-n-node tree1
+               (lambda (k v l r)
+		 v
+		 (cond ((key<? k (node/k tree2))
+			(and (node/subset? l (node/l tree2))
+			     (node/find k tree2)
+			     (node/subset? r tree2)))
+		       ((key>? k (node/k tree2))
+			(and (node/subset? r (node/r tree2))
+			     (node/find k tree2)
+			     (node/subset? l tree2)))
+		       (else
+			(and (node/subset? l (node/l tree2))
+			     (node/subset? r (node/r tree2))))))))))
+
+
+  ;;; Tree interface: stripping of or injecting the tree types
+
+  (define (tree/map-add tree k v)
+    (%make-wt-tree (tree/type tree)
+		   (node/add (tree/root tree) k v)))
+
+  ;(define (tree/set-add tree k)  (tree/map-add tree k #f))
+
+  (define (tree/insert! tree k v)
+    (set-tree/root! tree (node/add (tree/root tree) k v)))
+
+  (define (tree/delete tree k)
+    (%make-wt-tree (tree/type tree)
+		   (node/delete k (tree/root tree))))
+
+  (define (tree/delete! tree k)
+    (set-tree/root! tree (node/delete k (tree/root tree))))
+
+  (define (tree/split-lt tree key)
+    (%make-wt-tree (tree/type tree)
+		   (node/split-lt (tree/root tree) key)))
+
+  (define (tree/split-gt tree key)
+    (%make-wt-tree (tree/type tree)
+		   (node/split-gt (tree/root tree) key)))
+
+  (define (tree/union tree1 tree2)
+    (%make-wt-tree (tree/type tree1)
+		   (node/union (tree/root tree1) (tree/root tree2))))
+
+  (define (tree/intersection tree1 tree2)
+    (%make-wt-tree (tree/type tree1)
+		   (node/intersection (tree/root tree1) (tree/root tree2))))
+
+  (define (tree/difference tree1 tree2)
+    (%make-wt-tree (tree/type tree1)
+		  (node/difference (tree/root tree1) (tree/root tree2))))
+
+  (define (tree/subset? tree1 tree2)
+    (node/subset? (tree/root tree1) (tree/root tree2)))
+
+  (define (alist->tree alist)
+    (define (loop alist node)
+      (cond ((null? alist)  node)
+	    ((pair? alist)  (loop (cdr alist)
+				  (node/add node (caar alist) (cdar alist))))
+	    (else           
+	     (error:wrong-type-argument alist "alist" 'alist->tree))))
+    (%make-wt-tree my-type (loop alist empty)))
+
+  (define (tree/get tree key default)
+    (let ((node  (node/find key (tree/root tree))))
+      (if node
+	  (node/v node)
+	  default)))
+
+  (define (tree/rank tree key)  (node/rank key (tree/root tree) 0))
+
+  (define (tree/member? key tree)
+    (and (node/find key (tree/root tree))
+	 #t))
+
+  (define my-type
+    (%make-tree-type
+     key<?                ;  key<?
+     alist->tree          ;  alist->tree
+     tree/map-add         ;  add
+     tree/insert!         ;  insert!
+     tree/delete          ;  delete
+     tree/delete!         ;  delete!
+     tree/member?         ;  member?
+     tree/get             ;  lookup
+     tree/split-lt        ;  split-lt
+     tree/split-gt        ;  split-gt
+     tree/union           ;  union
+     tree/intersection    ;  intersection
+     tree/difference      ;  difference
+     tree/subset?         ;  subset?
+     tree/rank            ;  rank
+     ))
+
+  my-type)
+	
+
+
+;;;
+;;;
+;;;
+
+(define-integrable (guarantee-tree tree procedure)
+  (if (not (wt-tree? tree))
+      (error:wrong-type-argument tree "weight-balanced tree" procedure)))
+
+(define-integrable (guarantee-tree-type type procedure)
+  (if (not (tree-type? type))
+      (error:wrong-type-argument type "weight-balanced tree type" procedure)))
+
+(define-integrable (guarantee-compatible-trees tree1 tree2 procedure)
+  (guarantee-tree tree1 procedure)
+  (guarantee-tree tree2 procedure)
+  (if (not (eq? (tree/type tree1) (tree/type tree2)))
+      (error "The trees" tree1 'and tree2 'have 'incompatible 'types
+	     (tree/type tree1) 'and (tree/type tree2))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;  Exported interface
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define (make-wt-tree tree-type)
+  (%make-wt-tree tree-type empty))
+
+(define (singleton-wt-tree type key value)
+  (guarantee-tree-type type 'singleton-wt-tree)
+  (%make-wt-tree type (node/singleton key value)))
+
+(define (alist->wt-tree type alist)
+  (guarantee-tree-type type 'alist->wt-tree)
+  ((tree-type/alist->tree type) alist))
+
+(define (wt-tree/empty? tree)
+  (guarantee-tree tree 'wt-tree/empty?)
+  (empty? (tree/root tree)))
+
+(define (wt-tree/size tree)
+  (guarantee-tree tree 'wt-tree/size)
+  (node/size (tree/root tree)))
+
+(define (wt-tree/add tree key datum)
+  (guarantee-tree tree 'wt-tree/add)
+  ((tree-type/add (tree/type tree)) tree key datum))
+
+(define (wt-tree/delete tree key)
+  (guarantee-tree tree 'wt-tree/delete)
+  ((tree-type/delete (tree/type tree)) tree key))
+
+(define (wt-tree/add! tree key datum)
+  (guarantee-tree tree 'wt-tree/add!)
+  ((tree-type/insert! (tree/type tree)) tree key datum))
+
+(define (wt-tree/delete! tree key)
+  (guarantee-tree tree 'wt-tree/delete!)
+  ((tree-type/delete! (tree/type tree)) tree key))
+
+(define (wt-tree/member? key tree)
+  (guarantee-tree tree 'wt-tree/member?)
+  ((tree-type/member? (tree/type tree)) key tree))
+
+(define (wt-tree/lookup tree key default)
+  (guarantee-tree tree 'wt-tree/lookup)
+  ((tree-type/lookup (tree/type tree)) tree key default))
+
+(define (wt-tree/split< tree key)
+  (guarantee-tree tree 'wt-tree/split<)
+  ((tree-type/split-lt (tree/type tree)) tree key))
+
+(define (wt-tree/split> tree key)
+  (guarantee-tree tree 'wt-tree/split>)
+  ((tree-type/split-gt (tree/type tree)) tree key))
+
+(define (wt-tree/union tree1 tree2)
+  (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
+  ((tree-type/union (tree/type tree1)) tree1 tree2))
+
+(define (wt-tree/intersection tree1 tree2)
+  (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
+  ((tree-type/intersection (tree/type tree1)) tree1 tree2))
+
+(define (wt-tree/difference tree1 tree2)
+  (guarantee-compatible-trees tree1 tree2 'wt-tree/difference)
+  ((tree-type/difference (tree/type tree1)) tree1 tree2))
+
+(define (wt-tree/subset? tree1 tree2)
+  (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?)
+  ((tree-type/subset? (tree/type tree1)) tree1 tree2))
+
+(define (wt-tree/set-equal? tree1 tree2)
+  (and (wt-tree/subset? tree1 tree2)
+       (wt-tree/subset? tree2 tree1)))
+
+(define (wt-tree/fold combiner-key-datum-result init tree)
+  (guarantee-tree tree 'wt-tree/fold)
+  (node/inorder-fold combiner-key-datum-result init (tree/root tree)))
+
+(define (wt-tree/for-each action-key-datum tree)
+  (guarantee-tree tree 'wt-tree/for-each)
+  (node/for-each action-key-datum (tree/root tree)))
+
+(define (wt-tree/index tree index)
+  (guarantee-tree tree 'wt-tree/index)
+  (let ((node  (node/index (tree/root tree) index)))
+    (and node (node/k node))))
+
+(define (wt-tree/index-datum tree index)
+  (guarantee-tree tree 'wt-tree/index-datum)
+  (let ((node  (node/index (tree/root tree) index)))
+    (and node (node/v node))))
+
+(define (wt-tree/index-pair tree index)
+  (guarantee-tree tree 'wt-tree/index-pair)
+  (let ((node  (node/index (tree/root tree) index)))
+    (and node (cons (node/k node) (node/v node)))))
+
+(define (wt-tree/rank tree key)
+  (guarantee-tree tree 'wt-tree/rank)
+  ((tree-type/rank (tree/type tree)) tree key))
+
+(define (wt-tree/min tree)
+  (guarantee-tree tree 'wt-tree/min)
+  (node/k (node/min (tree/root tree))))
+
+(define (wt-tree/min-datum tree)
+  (guarantee-tree tree 'wt-tree/min-datum)
+  (node/v (node/min (tree/root tree))))
+
+(define (wt-tree/min-pair tree)
+  (guarantee-tree tree 'wt-tree/min-pair)
+  (let ((node  (node/min (tree/root tree))))
+    (cons (node/k node) (node/v node))))
+
+(define (wt-tree/delete-min tree)
+  (guarantee-tree tree 'wt-tree/delete-min)
+  (%make-wt-tree (tree/type tree) (node/delmin (tree/root tree))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;
+
+(define ttype (make-wt-tree-type <))
+
+(define number-wt-type
+  ((lambda()
+     (declare (integrate-operator make-wt-tree-type))
+     (make-wt-tree-type  <))))
+
+(define string-wt-type
+  ((lambda()
+     (declare (integrate-operator make-wt-tree-type))
+     (make-wt-tree-type  string<?))))
+
+;;;
+;;;
+;;;