set-disjoint tests

2 files changed, 78 insertions, 15 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index aa6ff47..768be10 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -20,7 +20,7 @@
   (node get-node))
 
 (define (check-compatible! set1 set2)
-  (when (not (compatible-sets? set1 set2))
+  (when (not (binary-compatible? set1 set2))
     (error "sets have different comparators" set1 set2)))
 
 ;;; ;;;;;;;;;;;;;;;;
@@ -302,17 +302,23 @@
                  (arg-rest rest))
         (if (null? arg-rest)
             arg1
-            (begin
-              (check-compatible! arg1 (car arg-rest))
-              (loop (binary cmp arg1 (car arg-rest)) (cdr arg-rest))))))))
+            (let ((arg2 (car arg-rest)))
+              (check-compatible! arg1 arg2)
+              (loop (binary cmp arg1 arg2)
+                    (cdr arg-rest))))))))
+
+(define (convert-binary-procedure proc)
+  (apply-nary-procedure
+   (lambda (cmp arg1 arg2)
+     (raw-set cmp (proc cmp (get-node arg1) (get-node arg2))))))
 
-(define set-union (apply-nary-procedure union))
+(define set-union (convert-binary-procedure union))
 (define set-union! set-union)
 
-(define set-intersection (apply-nary-procedure intersection))
+(define set-intersection (convert-binary-procedure intersection))
 (define set-intersection! set-intersection)
 
-(define set-difference (apply-nary-procedure difference))
+(define set-difference (convert-binary-procedure difference))
 (define set-difference! set-difference)
 
 (define set-xor (apply-nary-procedure xor))
@@ -362,9 +368,10 @@
   (raw-set comparator
            (in-order-container->node container ref length)))
 
+(define (binary-compatible? s1 s2)
+  (eq? (set-element-comparator s1) (set-element-comparator s2)))
+
 (define compatible-sets?
-  (apply-nary-predicate
-   (lambda (cmp s1 s2)
-     (and (eq? cmp (set-element-comparator s1))
-          (eq? cmp (set-element-comparator s2))))))
+  (apply-nary-predicate (lambda (cut set1 set2)
+                          (binary-compatible? set1 set2))))
 
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 0ba8f41..8bd6299 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -13,8 +13,9 @@
  | limitations under the License.
  |#
 
-(define test-constructor #t)
-(define test-set-contains #t)
+(define test-constructor #f)
+(define test-set-contains #f)
+(define test-set-disjoint #t)
 
 (define cmp (make-default-comparator))
 
@@ -60,10 +61,19 @@
         generator))
 
 (define (unique-vector)
+  ;; Return a vector of unique elements (according to the equality
+  ;; predicate of the default comparator).
   (remove-duplicates (vector-generator-of (orderable-generator))))
 
+(define (random-sets)
+  ;; Return a set of random elements.
+  (gcons* (set cmp)
+          (gmap (lambda (vec)
+                  (list->set cmp (vector->list vec)))
+                (unique-vector))))
+
 (define (split-vector gen)
-  ;; Split vectors in half.
+  ;; Split vectors in half, return it as a list.
   (gmap (lambda (vec)
           (let* ((len (vector-length vec))
                  (midpoint (floor (/ len 2))))
@@ -74,9 +84,20 @@
                  gen)))
 
 (define (split-unique-vectors)
+  ;; Generator of list of two elements, each of which is a vector. The
+  ;; vectors are disjoint.
   (split-vector (unique-vector)))
 
-(define (%set . elements)
+(define (split-unique-sets)
+  ;; Generator of a list of two elements, each of which is a set. The
+  ;; sets are disjoint.
+  (gmap (lambda (vecs)
+          (list (list->set cmp (vector->list (list-ref vecs 0)))
+                (list->set cmp (vector->list (list-ref vecs 1)))))
+        (split-unique-vectors)))
+
+(define
+    (%set . elements)
   (apply set cmp elements))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
@@ -181,3 +202,38 @@
            (test-call "does not contain" (set-does-not-contain? set value)))
          not-in)))
     (test-property set-does-not-contain (list (split-unique-vectors)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; set-disjoint?
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-disjoint
+  (let ()
+    (define (set-not-disjoint? s1 s2)
+      (not (set-disjoint? s1 s2)))
+    (test-group "non-empty sets are not disjoint from themselves"
+      (define (self-never-disjoint s)
+        (if (set-empty? s)
+            #t
+            (set-not-disjoint? s s)))
+      (test-property self-never-disjoint (list (random-sets))))
+    (test-group "empty set is disjoint for every set"
+      (define (disjoint-to-empty s)
+        (and (set-disjoint? s (set cmp))
+             (set-disjoint? (set cmp) s)))
+      (test-property disjoint-to-empty (list (random-sets))))
+    (test-group "sets from unique vectors are disjoint"
+      (define (unique-disjoint sets)
+        (let ((s1 (list-ref sets 0))
+              (s2 (list-ref sets 1)))
+          (and (set-disjoint? s1 s2) (set-disjoint? s2 s1))))
+      (test-property unique-disjoint (list (split-unique-sets))))
+    #;(test-group "including an element from two disjoint sets make them not disjoint"
+        (define (include-makes-not-disjoint sets)
+          (let* ((s1 (list-ref sets 0))
+               (s2 (list-ref sets 1))
+               (some-element-from-s1 (set-find (lambda (x) #t)
+                                               s1
+                                               (lambda ()
+                                                 (error "s1 is empty" s1))))
+               (s2 (set-adjoin s2 some-element-from-s1))))))))