xor

5 files changed, 177 insertions, 47 deletions

diff --git a/README.md b/README.md
index 416199b..4ebc63d 100644
--- a/README.md
+++ b/README.md
@@ -4,3 +4,48 @@
 [Parallel Ordered Sets Using Join][1].
 
 [1]: https://arxiv.org/abs/1602.02120
+
+Benefits of using this library:
+
+* Written in modern Scheme (R7RS).
+* Low level access to implementation using
+  `(mcgoron weight-balanced-trees internal)` library.
+* Implements interface for mapping and set SRFIs.
+* Interfaces with other SRFIs, like generators and streams.
+* Order can be defined on finite sets of ordered elements.
+* Extensively tested using [property testing][2] (like QuickCheck).
+* Permissive license (Apache 2.0)
+
+[2]: https://srfi.schemers.org/srfi-252/srfi-252.html
+
+## Included Libraries
+
+* `(mcgoron weight-balanced-trees internal)`: low-level operations on tree
+  nodes. Includes `join`, `split`, and binary set operations.
+* `(mcgoron weight-balanced-trees srfi 113 set)`: The set operations from
+  [SRFI-113][5], with extra procedures.
+
+[5]: https://srfi.schemers.org/srfi-113/srfi-113.html
+
+## Implementation Notes
+
+Tests of set operations are implemented in terms of the SRFI-1 list-set
+operations.
+
+The implementation of the SRFI interfaces uses [generators][3] for
+iteration whenever a function can terminate in the middle of a set (like
+`set-every?`). Generators are usually lightweight, but are intrinsically
+mutating.  Some Scheme implementations, like CHICKEN, implement
+write-barriers in their garbage collectors, which make mutation slower
+(See ["Mutations"][4]).
+
+Alternative implementation strategies include:
+
+* escape continuations (`call/cc` might be slow, `call/ec` is not
+  standard, `guard` could be used to emulate escape continuations)
+* direct recursion (would have to traverse the whole set before
+  terminating)
+* sentinel-value return (uglier)
+
+[3]: https://srfi.schemers.org/srfi-158/srfi-158.html
+[4]: https://www.more-magic.net/posts/internals-gc.html
diff --git a/doc/mcgoron.weight-balanced-trees.internal.scm b/doc/mcgoron.weight-balanced-trees.internal.scm
index 231ee7b..a48cb23 100644
--- a/doc/mcgoron.weight-balanced-trees.internal.scm
+++ b/doc/mcgoron.weight-balanced-trees.internal.scm
@@ -33,7 +33,6 @@ elements of `x`."))
  ((name . "join")
   (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
   any element in `right`.
 * It is an error if `data` is less than or equal to any element in
@@ -99,6 +98,15 @@ equal to an element of `right`.
 Return a weight-balanced tree with only the elements of `left` that do not
 compare equal to an element of `right`.
 "))
+ ((name . "xor")
+  (signature
+   lambda ((comparator? cmp) (balanced? left) (balanced? right) balanced?))
+  (desc "
+* It is an error if `cmp` does not order the elements of `left` and `right`.
+
+Return a weight-balanced tree with the exclusive or of the elements of `left`
+with the elements of `right`: that is, all elements of `left` and `right` that
+are not both elements of `left` and `right`."))
  ((name . "update")
   (signature
    lambda ((comparator? cmp) (balanced? set) to-search (procedure? on-found) (procedure? on-not-found)) balanced?)
diff --git a/mcgoron.weight-balanced-trees.internal.scm b/mcgoron.weight-balanced-trees.internal.scm
index ff8b0aa..f0dc7c5 100644
--- a/mcgoron.weight-balanced-trees.internal.scm
+++ b/mcgoron.weight-balanced-trees.internal.scm
@@ -1,3 +1,17 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | 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.
+ |#
 ;;; ;;;;;;;;;;;;;;;;;;;
 ;;; Definition of nodes and functions to calculate values for nodes.
 ;;; ;;;;;;;;;;;;;;;;;;;
@@ -325,6 +339,26 @@
                 (join2 (difference new-left left-of-right)
                        (difference new-right right-of-right))))))))
 
+(: xor (* node-type node-type --> node-type))
+(define (xor cmp left right)
+  (let xor ((left left)
+            (right right))
+    (cond
+      ((null? left) right)
+      ((null? right) left)
+      (else (with-node (right right-data
+                              ("<" left-of-right)
+                              (">" right-of-right))
+              (let-values (((new-left new-key new-right)
+                            (split cmp left right-data return-sentinel)))
+                (let ((final-left (xor new-left left-of-right))
+                      (final-right (xor new-right right-of-right)))
+                  ;; If new-key is a sentinel value, that means new-key was
+                  ;; not in the left tree, meaning it should be in the xor.
+                  (if (sentinel? new-key)
+                      (join right-data final-left final-right)
+                      (join2 final-left final-right)))))))))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Single value operations
 ;;; ;;;;;;;;;;;;;;;;;;;;
diff --git a/mcgoron.weight-balanced-trees.internal.sld b/mcgoron.weight-balanced-trees.internal.sld
index 246d2a3..5927d0d 100644
--- a/mcgoron.weight-balanced-trees.internal.sld
+++ b/mcgoron.weight-balanced-trees.internal.sld
@@ -34,7 +34,7 @@
           node->in-order-list
           join join2 split
           search
-          union intersection difference
+          union intersection difference xor
           update delete
           every)
   (include "mcgoron.weight-balanced-trees.internal.scm"))
diff --git a/tests/run.scm b/tests/run.scm
index 365fa29..03248f5 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -68,7 +68,7 @@
 ;;; Test node creation
 ;;; ;;;;;;;;;;;;;;;;;;;;;;
 
-(test-group "vector->node is correct"
+(test-group "in-order-vector->node and node->in-order-list round-trip"
   (define (vector->node->list? vec)
     (let* ((node (in-order-vector->node vec))
            (lst (node->in-order-list node)))
@@ -79,7 +79,7 @@
   (test-property vector->node->list?
                  (list (in-order-vector-generator (max-vector-length)))))
 
-(test-group "vector->node balanced?"
+(test-group "in-order-vector->node is balanced?"
   (test-assert (balanced? '()))
   (test-property balanced? (list (vector->node-generator))))
 
@@ -225,65 +225,59 @@
                                 (lambda () #f)))
        procedure))))
 
-(define split-finds
-  (call/split
-   call/inserted
-   (lambda (new-left found? new-right)
-     found?)))
-
 (test-group "split finds"
+  (define split-finds
+    (call/split
+     call/inserted
+     (lambda (new-left found? new-right)
+       found?)))
   (test-property split-finds (list (split-vector-generator))))
 
-(define split-left-balanced
-  (call/split
-   call/inserted
-   (lambda (new-found found? new-right)
-     (balanced? new-found))))
-
-(test-group "split left balanced"
+(test-group "left tree from split with found element is balanced"
+  (define split-left-balanced
+    (call/split
+     call/inserted
+     (lambda (new-found found? new-right)
+       (balanced? new-found))))
   (test-property split-left-balanced (list (split-vector-generator))))
 
-(define split-right-balanced
-  (call/split
-   call/inserted
-   (lambda (new-found found? new-right)
-     (balanced? new-right))))
-
-(test-group "split right balanced"
+(test-group "right tree from split with found element is balanced"
+  (define split-right-balanced
+    (call/split
+     call/inserted
+     (lambda (new-found found? new-right)
+       (balanced? new-right))))
   (test-property split-right-balanced (list (split-vector-generator))))
 
-(define split-does-not-find
-  (call/split
-   call-w/o-inserted
-   (lambda (new-left found? new-right)
-     (not found?))))
-
-(test-group "split does not find"
+(test-group "split should not find element not in left or right"
+  (define split-does-not-find
+    (call/split
+     call-w/o-inserted
+     (lambda (new-left found? new-right)
+       (not found?))))
   (test-property split-does-not-find (list (split-vector-generator))))
 
-(define split-left-balanced-w/o-inserted
-  (call/split
-   call-w/o-inserted
-   (lambda (new-left found? new-right)
-     (balanced? new-left))))
-
-(test-group "split left balanced without insertion"
+(test-group "left tree from split without found element is balanced"
+  (define split-left-balanced-w/o-inserted
+    (call/split
+     call-w/o-inserted
+     (lambda (new-left found? new-right)
+       (balanced? new-left))))
   (test-property split-left-balanced-w/o-inserted (list (split-vector-generator))))
 
-(define split-right-balanced-w/o-inserted
-  (call/split
-   call-w/o-inserted
-   (lambda (new-left found? new-right)
-     (balanced? new-right))))
-
-(test-group "split right balanced without insertion"
+(test-group "right tree from split without found element is balanced"
+  (define split-right-balanced-w/o-inserted
+    (call/split
+     call-w/o-inserted
+     (lambda (new-left found? new-right)
+       (balanced? new-right))))
   (test-property split-right-balanced-w/o-inserted (list (split-vector-generator))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Union
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(test-group "union balanced"
+(test-group "union is balanced"
   (define (union-balanced node1 node2)
     (balanced? (union number-comparator node1 node2)))
   (test-property union-balanced
@@ -395,6 +389,13 @@
 ;;; Difference
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(test-group "difference balanced?"
+  (define (difference-balanced? node1 node2)
+    (balanced? (difference number-comparator node1 node2)))
+  (test-property difference-balanced?
+                 (list (vector->node-generator)
+                       (vector->node-generator))))
+
 (test-group "difference subset of lset"
   (define (difference-subset-of-lset node1 node2)
     (let ((node (difference number-comparator node1 node2))
@@ -433,7 +434,6 @@
   (define (insert-unordered lst)
     (let ((set (fold insert '() lst)))
       (balanced? set)))
-
   (test-property insert-unordered
                  (list (list-generator-of
                         (exact-integer-generator)))))
@@ -476,6 +476,18 @@
                           lst2)))
       (procedure lst1 lst2 diff deleted))))
 
+(test-group "delete of elements unordered list is balanced"
+  (define (delete-balanced? lst1 lst2)
+    (let* ((set (fold insert '() lst1))
+           (deleted (fold (lambda (elem set)
+                            (delete number-comparator elem set))
+                          set
+                          lst2)))
+      (balanced? deleted)))
+  (test-property delete-balanced?
+                 (list (list-generator-of (exact-integer-generator))
+                       (list-generator-of (exact-integer-generator)))))
+
 (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))
@@ -491,3 +503,34 @@
                  (list (list-generator-of (exact-integer-generator))
                        (list-generator-of (exact-integer-generator)))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;;
+;;; xor
+;;; ;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-group "xor balanced?"
+  (define (xor-balanced? node1 node2)
+    (balanced? (xor number-comparator node1 node2)))
+  (test-property xor-balanced?
+                 (list (vector->node-generator) (vector->node-generator))))
+
+(test-group "lset subset of xor"
+  (define (lset-subset-of-xor lst1 lst2)
+    (let* ((node1 (fold insert '() lst1))
+           (node2 (fold insert '() lst2))
+           (set-xor (xor number-comparator node1 node2))
+           (list-xor (lset-xor = lst1 lst2)))
+      (every (cut search number-comparator <> set-xor) list-xor)))
+  (test-property lset-subset-of-xor
+                 (list (list-generator-of (exact-integer-generator))
+                       (list-generator-of (exact-integer-generator)))))
+
+(test-group "xor subset of lset"
+  (define (xor-subset-of-lset lst1 lst2)
+    (let* ((node1 (fold insert '() lst1))
+           (node2 (fold insert '() lst2))
+           (set-xor (xor number-comparator node1 node2))
+           (list-xor (lset-xor = lst1 lst2)))
+      (node-every (cut member <> list-xor) set-xor)))
+  (test-property xor-subset-of-lset
+                 (list (list-generator-of (exact-integer-generator))
+                       (list-generator-of (exact-integer-generator)))))