insert and delete

4 files changed, 190 insertions, 20 deletions

diff --git a/doc/mcgoron.weight-balanced-trees.internal.scm b/doc/mcgoron.weight-balanced-trees.internal.scm
index 8baf5e7..231ee7b 100644
--- a/doc/mcgoron.weight-balanced-trees.internal.scm
+++ b/doc/mcgoron.weight-balanced-trees.internal.scm
@@ -1,6 +1,7 @@
 (((name . "wb-tree-node?")
   (signature lambda (x) => boolean?)
-  (desc "Returns true if `x` is a node in a weight-balanced tree."))
+  (desc "Returns true if `x` is a node in a weight-balanced tree.
+This porcedure does not check that the node itself is balanced: see `balanced?`."))
  ((name . "non-null-wb-tree-node?")
   (signature lambda (x) => boolean?)
   (desc "Returns true if `x` is a node with data and children."))
@@ -20,7 +21,7 @@
   (signature lambda ((wb-tree-node? x)) => boolean?)
   (desc "Recursively traverses `x` and checks if it is weight balanced."))
  ((name . "in-order-vector->node")
-  (signature lambda ((vector? x)) => wb-tree-node?)
+  (signature lambda ((vector? x)) => balanced?)
   (desc "
 * It is an error if `x` is not in order.
 
@@ -30,8 +31,7 @@ elements of `x`."))
   (signature lambda ((wb-tree-node? x)) => list?)
   (desc "Returns a list of all elements of `x` in order."))
  ((name . "join")
-  (signature lambda (data (wb-tree-node? left) (wb-tree-node? right))
-             => non-null-wb-tree-node?)
+  (signature lambda (data (balanced? left) (balanced? right)) balanced?)
   (desc "
 * It is an error if `left` or `right` are not balanced.
 * It is an error if any element of `left` is greater than or equal to
@@ -44,21 +44,20 @@ elements of `x`."))
 Returns a balanced tree containing all elements of `left` and `right`
 with `data`."))
  ((name . "join2")
-  (signature lambda ((wb-tree-node? left) (wb-tree-node? right))
-             => wb-tree-node?)
+  (signature lambda ((balanced? left) (balanced? right)) balanced?)
   (desc "
 * It is an error if any element in `left` is greater than or equal to any
   element in `right`.
 
 Returns a new tree with the elements of `left` and `right`."))
  ((name . "split")
-  (signature lambda ((comparator? cmp) (wb-tree-node? tree) key (procedure? default))
-             => (values wb-tree-node? * wb-tree-node?))
+  (signature lambda ((comparator? cmp) (balanced? tree) key (procedure? default))
+             => (values balanced? * balanced?))
+  (subsigs (default lambda (() *)))
   "
 * It is an error if any element of `tree` is not comparable by `cmp`.
 * It is an error if `key` is not comparable by `cmp`.
 * It is an error if `cmp` does not have an order.
-* It is an error if `default` is not a thunk.
 
 Returns two trees, one of all values to the left of `key`, and one with
 all values to the right of `key`.
@@ -66,12 +65,72 @@ all values to the right of `key`.
 If a value that compares equal to `key` is found, that value is returned.
 Otherwise the result of calling `default` with no arguments is returned.")
  ((name . "search")
-  (signature case-lambda ((((wb-tree-node? tree) (comparator? cmp) key) *)
-                          (((wb-tree-node? tree) (comparator? cmp) key (procedure? default)) *)))
+  (signature case-lambda ((((comparator? cmp) (balanced? tree) key) *)
+                          (((comparator? cmp) (balanced? tree) key (procedure? default)) *)))
+  (subsigs (default (lambda () *)))
   (desc "
 * It is an error if `cmp` does not order `key` and all elements in `tree`.
-* It is an error if `default` is not a thunk.
 
 Searches `tree` for `key` using `cmp`. If a node contains data that compares equal
 to `key`, return that data. Otherwise, tail call `default.` If `default` is not
-supplied, the function returns `#f`.")))
\ No newline at end of file
+supplied, the function returns `#f`."))
+ ((name . "union")
+  (signature lambda ((comparator? cmp) (balanced? left) (balanced? right)) balanced?)
+  (desc "
+* It is an error if `cmp` does not order the elements in `left` and `right`.
+
+Return a weight-balanced tree with the elements of `left` and `right`. If
+there is an element in `left` that compares equal to an element in `right`,
+then the element in `left` is kept and the element in `right` is discarded.
+"))
+ ((name . "intersection")
+  (signature lambda ((comparator? cmp) (balanced? left) (balanced? right)) balanced?)
+  (desc "
+* It is an error if `cmp` does not order the elements in `left` and `right`.
+
+Return a weight-balanced tree with only the elements of `left` that compare
+equal to an element of `right`.
+"))
+ ((name . "difference")
+  (signature lambda ((comparator? cmp) (balanced? left) (balanced? right)) balanced?)
+  (desc "
+* It is an error if `cmp` does not order the elements in `left` and `right`.
+
+Return a weight-balanced tree with only the elements of `left` that do not
+compare equal to an element of `right`.
+"))
+ ((name . "update")
+  (signature
+   lambda ((comparator? cmp) (balanced? set) to-search (procedure? on-found) (procedure? on-not-found)) balanced?)
+  (subsigs
+   (on-not-found lambda () balanced?)
+   (on-found lambda (*) *))
+  (desc "
+* It is an error if `cmp` does not order the elements of `set`, the
+  elements of the tree returned from `on-found`, and the element
+  returned from `on-not-found`.
+
+Search `set` for an element that compares equal to `to-search`. If an
+element `E` is found that compares equal to `to-search`, then
+`(on-found E)` is evaluated and the resulting value is placed into the
+tree. If no element is found, then `(on-not-found)` is evaluated and the
+resulting node is inserted into the tree.
+"))
+ ((name . "delete")
+  (signature
+   lambda ((comparator? cmp) element (balanced? set)) balanced?)
+  (desc "
+* It is an error if `cmp` does not order the elements of `set` and the
+  value `element`.
+
+Search `set` for an element `E` that compares equal to `element`. If `E`
+is found, the returned tree does not have `E`. Otherwise the returned
+tree has the same number of elements."))
+ ((name . "every")
+  (signature
+   lambda ((procedure? predicate?) (wb-tree-node? tree)) *)
+  (subsigs
+   (predicate? lambda (*) *))
+  (desc "
+Calls `predicate?` on each element of `tree` in an arbitrary order. If all
+calls return a truthy value, return a truthy value. Otherwise return `#f`.")))
\ No newline at end of file
diff --git a/mcgoron.weight-balanced-trees.internal.scm b/mcgoron.weight-balanced-trees.internal.scm
index b220780..ff8b0aa 100644
--- a/mcgoron.weight-balanced-trees.internal.scm
+++ b/mcgoron.weight-balanced-trees.internal.scm
@@ -253,6 +253,10 @@
             (let-values (((new-left bool new-right) (split right)))
               (values (join data left new-left) bool new-right)))))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Derived tree operations
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define search
   (case-lambda
     ((cmp key tree) (search cmp key tree (lambda () #f)))
@@ -321,6 +325,32 @@
                 (join2 (difference new-left left-of-right)
                        (difference new-right right-of-right))))))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Single value operations
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(: update (* node-type * (-> *) (-> node-type) --> node-type))
+(define (update cmp set to-search on-found on-not-found)
+  (let update ((set set))
+    (if (null? set)
+        (on-not-found)
+        (with-node (set data ("<" left) (">" right))
+          (comparator-if<=> cmp to-search data
+            (join data (update left) right)
+            (wb-tree-node (on-found data) left right)
+            (join data left (update right)))))))
+
+(: delete (* * node-type --> node-type))
+(define (delete cmp to-search set)
+  (let delete ((set set))
+    (if (null? set)
+        '()
+        (with-node (set data ("<" left) (">" right))
+          (comparator-if<=> cmp to-search data
+            (join data (delete left) right)
+            (join2 left right)
+            (join data left (delete right)))))))
+
 ;;; ;;;;;;;;;;;;;;;;;
 ;;; Generic tree functions
 ;;; ;;;;;;;;;;;;;;;;;
diff --git a/mcgoron.weight-balanced-trees.internal.sld b/mcgoron.weight-balanced-trees.internal.sld
index ac85dee..246d2a3 100644
--- a/mcgoron.weight-balanced-trees.internal.sld
+++ b/mcgoron.weight-balanced-trees.internal.sld
@@ -27,6 +27,7 @@
               (syntax-rules ()
                 ((the type expression) expression))))))
   (export wb-tree-node? non-null-wb-tree-node?
+          wb-tree-node
           get-data get-left get-right get-size
           balanced?
           in-order-vector->node
@@ -34,6 +35,7 @@
           join join2 split
           search
           union intersection difference
+          update delete
           every)
   (include "mcgoron.weight-balanced-trees.internal.scm"))
 
diff --git a/tests/run.scm b/tests/run.scm
index f9218bc..365fa29 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -11,6 +11,11 @@
  | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  | See the License for the specific language governing permissions and
  | limitations under the License.
+ |----------------------------------------------
+ | This test suite would be better if property tests (and by association
+ | generators) could take multiple values. As it stands now property
+ | test generators cannot be correlated without doing a hack like returning
+ | a vector (which the current implementation does).
  |#
 
 (import r7rs)
@@ -18,17 +23,17 @@
 (load "random-number-vector.sld")
 (load "util.sld")
 
-(import (except (mcgoron weight-balanced-trees internal)
-                every)
-        (prefix (only (mcgoron weight-balanced-trees internal)
-                      every)
-                node-)
-        (mcgoron weight-balanced-trees test util)
+(import (mcgoron weight-balanced-trees test util)
         (mcgoron weight-balanced-trees test random-number-vector)
         (prefix (only (mcgoron srfi 64) factory) mcgoron-test-)
         (except (mcgoron srfi 64) factory)
         (srfi 1) (srfi 26) (srfi 64) (srfi 128) (srfi 132) (srfi 133)
-        (srfi 158) (srfi 194) (srfi 197) (srfi 252))
+        (srfi 158) (srfi 194) (srfi 197) (srfi 252)
+        (except (mcgoron weight-balanced-trees internal)
+                every)
+        (prefix (only (mcgoron weight-balanced-trees internal)
+                      every)
+                node-))
 
 ;;; ;;;;;;;;;;;;;;;;
 ;;; Parameters
@@ -412,3 +417,77 @@
                  (list (vector->node-generator)
                        (vector->node-generator))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Update
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (insert elem set)
+  (update number-comparator
+          set
+          elem
+          (lambda (value) value)
+          (lambda ()
+            (wb-tree-node elem '() '()))))
+
+(test-group "update of unordered list is balanced"
+  (define (insert-unordered lst)
+    (let ((set (fold insert '() lst)))
+      (balanced? set)))
+
+  (test-property insert-unordered
+                 (list (list-generator-of
+                        (exact-integer-generator)))))
+
+(test-group "update of unordered list is subset of list"
+  (define (subset-of-list lst)
+    (let ((set (fold insert '() lst)))
+      (when (verbose)
+        (dynamic-property-set! 'lst lst)
+        (dynamic-property-set! 'set (node->in-order-list set)))
+      (every (cut search number-comparator <> set) lst)))
+  (parameterize ((verbose #f))
+    (test-property subset-of-list
+                   (list (list-generator-of
+                          (exact-integer-generator))))))
+
+(test-group "list is subset of update of unordered list"
+  (define (list-is-subset-of lst)
+    (let ((set (fold insert '() lst)))
+      (node-every (cut memq <> lst) set)))
+  (test-property list-is-subset-of
+                 (list (list-generator-of
+                        (exact-integer-generator)))))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Delete
+;;; ;;;;;;;;;;;;;;;;
+
+(define (call/difference procedure)
+  (lambda (lst1 lst2)
+    (let* ((set1 (fold insert '() lst1))
+           (set2 (fold insert '() lst2))
+           (diff (difference number-comparator set1 set2))
+           (deleted (fold (lambda (elem set)
+                            (when (verbose)
+                              (dynamic-property-set! 'elem elem)
+                              (dynamic-property-set! 'set set))
+                            (delete number-comparator elem set))
+                          set1
+                          lst2)))
+      (procedure lst1 lst2 diff deleted))))
+
+(test-group "delete of two sets is subset of difference"
+  (define (delete-and-difference lst1 lst2 diff deleted)
+    (node-every (cut search number-comparator <> diff) deleted))
+  (parameterize ((verbose #f))
+    (test-property (call/difference delete-and-difference)
+                   (list (list-generator-of (exact-integer-generator))
+                         (list-generator-of (exact-integer-generator))))))
+
+(test-group "difference is subset of delete of two sets"
+  (define (difference-and-delete lst1 lst2 diff deleted)
+    (node-every (cut search number-comparator <> deleted) diff))
+  (test-property (call/difference difference-and-delete)
+                 (list (list-generator-of (exact-integer-generator))
+                       (list-generator-of (exact-integer-generator)))))
+