diff options
Diffstat (limited to 'wttree.scm')
| -rwxr-xr-x[-rw-r--r--] | wttree.scm | 170 |
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: |