From: Taylor R Campbell Date: Mon, 24 Jan 2011 14:26:36 +0000 (+0000) Subject: Fix wt-tree balancing. Add some trivial tests. X-Git-Tag: 20110426-Gtk~2^2~41 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fa7ec497241664b891e2b57c8330b47e6c8ede11;p=mit-scheme.git Fix wt-tree balancing. Add some trivial tests. Thanks to Yoichi Hirai and Kazuhiko Yamamoto for analyzing the nature of the bug and finding a good fix. The trivial tests are enough to catch trivial errors, and one manifestation of the balancing bug, but they should be replaced by a more comprehensive test suite later. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e142f2dd7..008a5b9ba 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5008,6 +5008,7 @@ USA. wt-tree/subset? wt-tree/union wt-tree/union-merge + wt-tree/valid? ; Debugging utility only. wt-tree?)) (define-package (runtime apropos) diff --git a/src/runtime/wttree.scm b/src/runtime/wttree.scm index 4a5618f30..07dbec885 100644 --- a/src/runtime/wttree.scm +++ b/src/runtime/wttree.scm @@ -29,7 +29,28 @@ reference: Stephen Adams, Implemeting Sets Efficiently in a Functional Language, CSTR 92-10, Department of Electronics and Computer - Science, University of Southampton, 1992 + Science, University of Southampton, 1992. + +The data structure was originally introduced in + + J. Nievergelt and E.M. Reingold, `Binary search trees of bounded + balance', Proceedings of the fourth ACM Symposium on Theory of + Computing, pp. 137--142, 1972. + +The balance parameters, Delta and Gamma, proposed by Nievergelt and +Reingold were irrational, making the balance condition complicated to +express exactly. In his paper, Adams used a different definition of a +node's weight, which introduced more complicated edge cases, and used +Delta = 4 and Gamma = 1, which do not preserve balance for deletion. +This implementation formerly used Delta = 5 and Gamma = 1, which was +also buggy. + +Yoichi Hirai and Kazuhiko Yamamoto proposed, in `Balance Conditions on +Weight-Balanced Trees' (to appear in the Journal of Functional +Programming), Nievergelt and Reingold's definition of a node's weight, +with Delta = 3 and Gamma = 2, based on analysis of the algorithms and +parameters assisted by Coq. This is what we use here now. + |# ;;;; Weight-balanced tree (wt-tree) Operations @@ -38,7 +59,7 @@ reference: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare (usual-integrations)) - + ;;; A tree type is a collection of those procedures that depend on the ordering ;;; relation. @@ -92,6 +113,9 @@ reference: (define-integrable (node/size node) (if (empty? node) 0 (node/w node))) +(define-integrable (node/weight node) + (+ 1 (node/size node))) + (define-integrable (node/singleton k v) (make-node k v empty empty 1)) (define-integrable (with-n-node node receiver) @@ -103,7 +127,7 @@ reference: ;;; (define (n-join k v l r) - (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r))))) + (make-node k v l r (+ 1 (+ (node/size l) (node/size r))))) (declare (integrate-operator n-join)) (define (single-l a.k a.v x r) @@ -132,29 +156,27 @@ reference: (n-join a.k a.v x y1) (n-join c.k c.v y2 z))))))) -(define-integrable wt-tree-ratio 5) +(define-integrable wt-tree-delta 3) +(define-integrable 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.w (node/weight l)) + (r.w (node/weight r))) + (cond ((> r.w (* wt-tree-delta l.w)) ;; 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.w (node/weight (node/l r))) + (r.r.w (node/weight (node/r r)))) + (if (< r.l.w (* wt-tree-gamma r.r.w)) (single-l k v l r) (double-l k v l r)))) - ((fix:> l.n (fix:* wt-tree-ratio r.n)) + ((> l.w (* wt-tree-delta r.w)) ;; 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.w (node/weight (node/l l))) + (l.r.w (node/weight (node/r l)))) + (if (< l.r.w (* wt-tree-gamma l.l.w)) (single-r k v l r) (double-r k v l r)))) - (else - (simple-join))))) + (else (n-join k v l r))))) ;;; ;;; Node tree Procedures that are independent of key index size.l) (loop (node/r node) - (fix:- index (fix:+ 1 size.l)))) - (else node)))) + (cond ((< index size.l) (loop (node/l node) index)) + ((> index size.l) (loop (node/r node) (- index (+ 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)))) + (if (not (and (<= 0 index) (< index bound))) + (error:bad-range-argument index caller)) + (loop node index))) (define (error:empty owner) ((access error system-global-environment) @@ -244,9 +263,8 @@ reference: (cond ((empty? node) #f) ((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)))))) + (node/rank k (node/r node) (+ 1 rank (node/size (node/l node))))) + (else (+ rank (node/size (node/l node)))))) (define (node/add node k v) (if (empty? node) @@ -278,13 +296,13 @@ reference: (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 ((w1 (node/weight l)) + (w2 (node/weight r))) + (cond ((< (* wt-tree-delta w1) w2) (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) + ((< (* wt-tree-delta w2) w1) (with-n-node l (lambda (k1 v1 l1 r1) (t-join k1 v1 l1 (node/concat3 k v r1 r))))) @@ -363,9 +381,9 @@ reference: (define (node/subset? tree1 tree2) (or (empty? tree1) - (and (fix:<= (node/size tree1) (node/size tree2)) + (and (<= (node/size tree1) (node/size tree2)) (with-n-node tree1 - (lambda (k v l r) + (lambda (k v l r) v (cond ((key i hi) - map - (loop (+ i step) (wt-tree/add map (number->string i) i))))) - -(define t1 (make-map 0 99 2)) ; 0,2,4,...,98 -(define t2 (make-map 1 100 2)) ; 1,3,5,...,99 -(define t3 (make-map 0 100 3)) ; 0,3,6,...,99 - -(define (wt-tree->alist t) - (wt-tree/fold (lambda (k d r) (cons (cons k d) r)) '() t)) - -(wt-tree->alist t3); - => (("0" . 0) ("12" . 12) ("15" . 15) ("18" . 18) ("21" . 21) ("24" . 24) ("27" . 27) ("3" . 3) ("30" . 30) ("33" . 33) ("36" . 36) ("39" . 39) ("42" . 42) ("45" . 45) ("48" . 48) ("51" . 51) ("54" . 54) ("57" . 57) ("6" . 6) ("60" . 60) ("63" . 63) ("66" . 66) ("69" . 69) ("72" . 72) ("75" . 75) ("78" . 78) ("81" . 81) ("84" . 84) ("87" . 87) ("9" . 9) ("90" . 90) ("93" . 93) ("96" . 96) ("99" . 99)) - -(define (try-all operation trees) - (map (lambda (t1) - (map (lambda (t2) - (operation t1 t2)) - trees)) - trees)) - -(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/union t1 t2))) - (list t1 t2 t3)) - => ((50 100 67) (100 50 67) (67 67 34)) - -(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/difference t1 t2))) - (list t1 t2 t3)) - => ((0 50 33) (50 0 33) (17 17 0)) - -(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/intersection t1 t2))) - (list t1 t2 t3)) - => ((50 0 17) (0 50 17) (17 17 34)) - -(try-all (lambda (t1 t2) (wt-tree/set-equal? (wt-tree/difference t1 t2) - (wt-tree/difference t2 t1))) - (list t1 t2 t3)) - => ((#t #f #f) (#f #t #f) (#f #f #t)) - -|# \ No newline at end of file diff --git a/tests/runtime/test-wttree.scm b/tests/runtime/test-wttree.scm new file mode 100644 index 000000000..05332d524 --- /dev/null +++ b/tests/runtime/test-wttree.scm @@ -0,0 +1,138 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of weight-balanced trees + +(declare (usual-integrations)) + +(load-option 'WT-TREE) + +(define (make-map low high step) + (let loop ((i low) (map (make-wt-tree string-wt-type))) + (if (<= i high) + (loop (+ i step) (wt-tree/add map (number->string i) i)) + map))) + +(define (wt-tree->alist t) + (wt-tree/fold (lambda (k d r) (cons (cons k d) r)) '() t)) + +(define (try-all operation trees) + (map (lambda (t1) + (map (lambda (t2) + (operation t1 t2)) + trees)) + trees)) + +(define (t1) (make-map 0 99 2)) +(define (t2) (make-map 1 100 2)) +(define (t3) (make-map 0 100 3)) + +(define-test 'T3-ALIST + (lambda () + ((lambda (alist) (assert-equal alist (wt-tree->alist (t3)))) + '(("0" . 0) ("12" . 12) ("15" . 15) ("18" . 18) ("21" . 21) ("24" . 24) + ("27" . 27) ("3" . 3) ("30" . 30) ("33" . 33) ("36" . 36) ("39" . 39) + ("42" . 42) ("45" . 45) ("48" . 48) ("51" . 51) ("54" . 54) ("57" . 57) + ("6" . 6) ("60" . 60) ("63" . 63) ("66" . 66) ("69" . 69) ("72" . 72) + ("75" . 75) ("78" . 78) ("81" . 81) ("84" . 84) ("87" . 87) ("9" . 9) + ("90" . 90) ("93" . 93) ("96" . 96) ("99" . 99))))) + +(define (test-union expected t1 t2) + (assert-eqv expected (wt-tree/size (wt-tree/union (t1) (t2))))) + +(define-test 'T1-UNION-T1 (lambda () (test-union 50 t1 t1))) +(define-test 'T1-UNION-T2 (lambda () (test-union 100 t1 t2))) +(define-test 'T1-UNION-T3 (lambda () (test-union 67 t1 t3))) +(define-test 'T2-UNION-T1 (lambda () (test-union 100 t2 t1))) +(define-test 'T2-UNION-T2 (lambda () (test-union 50 t2 t2))) +(define-test 'T2-UNION-T3 (lambda () (test-union 67 t2 t3))) +(define-test 'T3-UNION-T1 (lambda () (test-union 67 t3 t1))) +(define-test 'T3-UNION-T2 (lambda () (test-union 67 t3 t2))) +(define-test 'T3-UNION-T3 (lambda () (test-union 34 t3 t3))) + +(define (test-difference expected t1 t2) + (assert-eqv expected (wt-tree/size (wt-tree/difference (t1) (t2))))) + +(define-test 'T1-MINUS-T1 (lambda () (test-difference 0 t1 t1))) +(define-test 'T1-MINUS-T2 (lambda () (test-difference 50 t1 t2))) +(define-test 'T1-MINUS-T3 (lambda () (test-difference 33 t1 t3))) +(define-test 'T2-MINUS-T1 (lambda () (test-difference 50 t2 t1))) +(define-test 'T2-MINUS-T2 (lambda () (test-difference 0 t2 t2))) +(define-test 'T2-MINUS-T3 (lambda () (test-difference 33 t2 t3))) +(define-test 'T3-MINUS-T1 (lambda () (test-difference 17 t3 t1))) +(define-test 'T3-MINUS-T2 (lambda () (test-difference 17 t3 t2))) +(define-test 'T3-MINUS-T3 (lambda () (test-difference 0 t3 t3))) + +(define (test-intersection expected t1 t2) + (assert-eqv expected (wt-tree/size (wt-tree/intersection (t1) (t2))))) + +(define-test 'T1-INTERSECT-T1 (lambda () (test-intersection 50 t1 t1))) +(define-test 'T1-INTERSECT-T2 (lambda () (test-intersection 0 t1 t2))) +(define-test 'T1-INTERSECT-T3 (lambda () (test-intersection 17 t1 t3))) +(define-test 'T2-INTERSECT-T1 (lambda () (test-intersection 0 t2 t1))) +(define-test 'T2-INTERSECT-T2 (lambda () (test-intersection 50 t2 t2))) +(define-test 'T2-INTERSECT-T3 (lambda () (test-intersection 17 t2 t3))) +(define-test 'T3-INTERSECT-T1 (lambda () (test-intersection 17 t3 t1))) +(define-test 'T3-INTERSECT-T2 (lambda () (test-intersection 17 t3 t2))) +(define-test 'T3-INTERSECT-T3 (lambda () (test-intersection 34 t3 t3))) + +(define (test-eqdiff expected t1 t2) + (assert-eqv expected + (let ((t1 (t1)) (t2 (t2))) + (wt-tree/set-equal? (wt-tree/difference t1 t2) + (wt-tree/difference t2 t1))))) + +(define-test 'T1-EQDIFF-T1 (lambda () (test-eqdiff #t t1 t1))) +(define-test 'T1-EQDIFF-T2 (lambda () (test-eqdiff #f t1 t2))) +(define-test 'T1-EQDIFF-T3 (lambda () (test-eqdiff #f t1 t3))) +(define-test 'T2-EQDIFF-T1 (lambda () (test-eqdiff #f t2 t1))) +(define-test 'T2-EQDIFF-T2 (lambda () (test-eqdiff #t t2 t2))) +(define-test 'T2-EQDIFF-T3 (lambda () (test-eqdiff #f t2 t3))) +(define-test 'T3-EQDIFF-T1 (lambda () (test-eqdiff #f t3 t1))) +(define-test 'T3-EQDIFF-T2 (lambda () (test-eqdiff #f t3 t2))) +(define-test 'T3-EQDIFF-T3 (lambda () (test-eqdiff #t t3 t3))) + +(define assert-wt-valid + (predicate-assertion wt-tree/valid? "valid wt-tree")) + +(define (random-wt-tree size) + (let ((bound (square size))) + (let loop ((i 0) (tree (make-wt-tree number-wt-type))) + (if (< i size) + (loop (+ i 1) + (let ((n (random-integer bound))) + (wt-tree/add tree n n))) + tree)))) + +(define-test 'DELETE-MIN-PRESERVES-BALANCE + (lambda () + ;; Eight tries seems good enough to catch the problem reliably. + ;; This should also test some particular trees, not just randomly + ;; generated ones. + (do ((i 0 (+ i 1))) ((>= i 8)) + (do ((i 0 (+ i 1)) + (tree (random-wt-tree #x100) (wt-tree/delete-min tree))) + ((wt-tree/empty? tree)) + (assert-wt-valid tree)))))