New upstream version 3b5upstream/3b5upstream

1 files changed, 110 insertions, 60 deletions

diff --git a/wttree.scm b/wttree.scm
index 43620d6..60f25c3 100644..100755
--- a/wttree.scm
+++ b/wttree.scm
@@ -1,45 +1,32 @@
 ;;; "wttree.scm" Weight balanced trees			-*-Scheme-*-
-;;; Copyright (c) 1993-1994 Stephen Adams
 ;;;
-;;; References:
+;;; $ I d : wttree.scm,v 1.10 1999/01/02 06:19:10 cph Exp $
 ;;;
-;;;   Stephen Adams, Implemeting Sets Efficiently in a Functional
-;;;      Language, CSTR 92-10, Department of Electronics and Computer
-;;;      Science, University of Southampton, 1992
+;;; Copyright (c) 1993-1999 Massachusetts Institute of Technology
 ;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or (at
+;;; your option) any later version.
 ;;;
-;;; Copyright (c) 1993-94 Massachusetts Institute of Technology
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
 ;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of Electrical
-;;; Engineering and Computer Science.  Permission to copy and modify
-;;; this software, to redistribute either the original software or a
-;;; modified version, and to use this software for any purpose is
-;;; granted, subject to the following restrictions and understandings.
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
+;;; Copyright (c) 1993-1994 Stephen Adams
 ;;;
-;;; 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.
+;;; References:
 ;;;
-;;; 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.
+;;;   Stephen Adams, Implemeting Sets Efficiently in a Functional
+;;;      Language, CSTR 92-10, Department of Electronics and Computer
+;;;      Science, University of Southampton, 1992
 ;;;
-;;; 4. MIT has made no warranty 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 Binary Trees
@@ -88,6 +75,7 @@
 (define wt-tree/split< #f)
 (define wt-tree/split> #f)
 (define wt-tree/union #f)
+(define wt-tree/union-merge #f)
 (define wt-tree/intersection #f)
 (define wt-tree/difference #f)
 (define wt-tree/subset? #f)
@@ -103,7 +91,7 @@
 (define wt-tree/min-pair #f)
 (define wt-tree/delete-min #f)
 (define wt-tree/delete-min! #f)
-
+(define wt-tree/valid? #f)
 
 ;; This LET sets all of the above variables.
 
@@ -141,6 +129,7 @@
   ;;  (split-lt    #F read-only true)
   ;;  (split-gt    #F read-only true)
   ;;  (union       #F read-only true)
+  ;;  (union-merge #F read-only true)
   ;;  (intersection #F read-only true)
   ;;  (difference  #F read-only true)
   ;;  (subset?     #F read-only true)
@@ -159,14 +148,14 @@
                            delete      delete!
                            member?     lookup
                            split-lt    split-gt
-                           union       intersection
-                           difference  subset?
-                           rank        )
+                           union       union-merge
+                           intersection difference
+                           subset?     rank        )
     (vector tag:tree-type
             key<?       alist->tree   add         insert!
             delete      delete!       member?     lookup
-            split-lt    split-gt      union       intersection
-            difference  subset?       rank        ))
+            split-lt    split-gt      union       union-merge
+            intersection difference   subset?     rank        ))
 
   (define (tree-type? tt)
     (and (vector? tt)
@@ -183,10 +172,11 @@
   (define (tree-type/split-lt     tt) (vector-ref tt 9))
   (define (tree-type/split-gt     tt) (vector-ref tt 10))
   (define (tree-type/union        tt) (vector-ref tt 11))
-  (define (tree-type/intersection tt) (vector-ref tt 12))
-  (define (tree-type/difference   tt) (vector-ref tt 13))
-  (define (tree-type/subset?      tt) (vector-ref tt 14))
-  (define (tree-type/rank         tt) (vector-ref tt 15))
+  (define (tree-type/union-merge  tt) (vector-ref tt 12))
+  (define (tree-type/intersection tt) (vector-ref tt 13))
+  (define (tree-type/difference   tt) (vector-ref tt 14))
+  (define (tree-type/subset?      tt) (vector-ref tt 15))
+  (define (tree-type/rank         tt) (vector-ref tt 16))
 
   ;;  User level tree representation.
   ;;
@@ -273,30 +263,31 @@
                     (n-join a_k a_v x y1)
                     (n-join c_k c_v y2 z)))))))
 
-  ;; (define-integrable wt-tree-ratio 5)
-  (define wt-tree-ratio 5)
+  ;; (define-integrable wt-tree-delta 3)
+  (define wt-tree-delta 3)
+  (define wt-tree-gamma 2)
 
   (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:* wt-tree-ratio l_n))
+    (let ((l_n (fix:+ (node/size l) 1))
+          (r_n (fix:+ (node/size r) 1)))
+      (cond ((fix:> r_n (fix:* wt-tree-delta 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)
+             (let ((r_l_n (fix:+ (node/size (node/l r)) 1))
+                   (r_r_n (fix:+ (node/size (node/r r)) 1)))
+               (if (fix:< r_l_n (fix:* wt-tree-gamma r_r_n))
                    (single-l k v l r)
                    (double-l k v l r))))
-            ((fix:> l_n (fix:* wt-tree-ratio r_n))
+            ((fix:> l_n (fix:* wt-tree-delta 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)
+             (let ((l_l_n (fix:+ (node/size (node/l l)) 1))
+                   (l_r_n (fix:+ (node/size (node/r l)) 1)))
+               (if (fix:< l_r_n (fix:* wt-tree-gamma 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<?
   ;;
@@ -418,16 +409,16 @@
                              (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))
+      (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:* wt-tree-ratio n1) n2)
+             (let ((n1 (fix:+ (node/size l) 1))
+                   (n2 (fix:+ (node/size r) 1)))
+               (cond ((fix:< (fix:* wt-tree-delta n1) n2)
                       (with-n-node r
                         (lambda (k2 v2 l2 r2)
                           (t-join k2 v2 (node/concat3 k v l l2) r2))))
-                     ((fix:< (fix:* wt-tree-ratio n2) n1)
+                     ((fix:< (fix:* wt-tree-delta n2) n1)
                       (with-n-node l
                         (lambda (k1 v1 l1 r1)
                           (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
@@ -462,6 +453,22 @@
                        (r1  (node/split-gt tree1 ak)))
                    (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))
 
+    (define (node/union-merge tree1 tree2 merge)
+      (cond ((empty? tree1)  tree2)
+            ((empty? tree2)  tree1)
+            (else
+             (with-n-node tree2
+               (lambda (ak av l r)
+                 (let* ((node1  (node/find ak tree1))
+                        (l1     (node/split-lt tree1 ak))
+                        (r1     (node/split-gt tree1 ak))
+                        (value  (if node1
+				  (merge ak av (node/v node1))
+				  av)))
+                   (node/concat3 ak value
+                                 (node/union-merge l1 l merge)
+                                 (node/union-merge r1 r merge))))))))
+
     (define (node/difference tree1 tree2)
       (cond ((empty? tree1)   empty)
             ((empty? tree2)   tree1)
@@ -535,6 +542,11 @@
       (%make-wt-tree (tree/type tree1)
                      (node/union (tree/root tree1) (tree/root tree2))))
 
+    (define (tree/union-merge tree1 tree2 merge)
+      (%make-wt-tree (tree/type tree1)
+                     (node/union-merge (tree/root tree1) (tree/root tree2)
+                                       merge)))
+
     (define (tree/intersection tree1 tree2)
       (%make-wt-tree (tree/type tree1)
                      (node/intersection (tree/root tree1) (tree/root tree2))))
@@ -582,6 +594,7 @@
            tree/split-lt                ;  split-lt
            tree/split-gt                ;  split-gt
            tree/union                   ;  union
+           tree/union-merge             ;  union-merge
            tree/intersection            ;  intersection
            tree/difference              ;  difference
            tree/subset?                 ;  subset?
@@ -607,6 +620,33 @@
         (slib:error "The trees" tree1 'and tree2 'have 'incompatible 'types
 		    (tree/type tree1) 'and (tree/type tree2))))
 
+  (define (valid? tree)
+    (let ((root (tree/root tree)))
+      (and (balanced? root)
+	   (ordered? root))))
+
+  (define (balanced? n)
+    (define (isBalanced a b)
+      (let ((x (fix:+ (node/size a) 1))
+	    (y (fix:+ (node/size b) 1)))
+	(fix:<= y (fix:* wt-tree-delta x))))
+    (or (empty? n)
+	(let ((l (node/l n))
+	      (r (node/r n)))
+	  (and (isBalanced l r) (isBalanced r l)
+	       (balanced? l) (balanced? r)))))
+
+  (define (ordered? n)
+    (define (isOrdered lo hi m)
+      (or (empty? m)
+	  (let ((k (node/k m))
+		(l (node/l m))
+		(r (node/r m)))
+	    (and (lo k) (hi k)
+		 (isOrdered lo (lambda (x) (< x k)) l)
+		 (isOrdered (lambda (x) (< k x)) hi r)))))
+    (isOrdered (lambda (x) #t) (lambda (x) #t) n))
+
 ;;;______________________________________________________________________
 ;;;
 ;;;  Export interface
@@ -682,6 +722,11 @@
           (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
           ((tree-type/union (tree/type tree1)) tree1 tree2)))
 
+  (set! wt-tree/union-merge
+        (lambda (tree1 tree2 merge)
+          (guarantee-compatible-trees tree1 tree2 'wt-tree/union-merge)
+          ((tree-type/union-merge (tree/type tree1)) tree1 tree2 merge)))
+
   (set! wt-tree/intersection
         (lambda (tree1 tree2)
           (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
@@ -769,6 +814,11 @@
   (set! number-wt-type (local:make-wt-tree-type  (lambda (u v) (< u v))))
   (set! string-wt-type (local:make-wt-tree-type  string<?))
 
+  (set! wt-tree/valid?
+        (lambda (tree)
+          (guarantee-tree tree 'wt-tree/valid?)
+          (valid? tree)))
+
   'done)
 
 ;;; Local Variables: