aboutsummaryrefslogtreecommitdiffstats
path: root/wttree.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:06:40 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:06:40 -0800
commita69c9fb665459e2bfdbda1bf80741a0af31a7faf (patch)
treef0bc974f8805049e6b9a4e6864886298fbaa05a4 /wttree.scm
parent4684239efa63dc1b2c1cbe37ef7d3062029f5532 (diff)
downloadslib-a69c9fb665459e2bfdbda1bf80741a0af31a7faf.tar.gz
slib-a69c9fb665459e2bfdbda1bf80741a0af31a7faf.zip
New upstream version 3b5upstream/3b5upstream
Diffstat (limited to 'wttree.scm')
-rwxr-xr-x[-rw-r--r--]wttree.scm170
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: