change set-disjoint?, test set-intersection

2 files changed, 101 insertions, 30 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index 20f01d9..2fdf0ed 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -19,9 +19,11 @@
   (comparator set-element-comparator)
   (node get-node))
 
-(define (check-compatible! set1 set2)
-  (when (not (binary-compatible? set1 set2))
-    (error "sets have different comparators" set1 set2)))
+(define (check-compatible set1 set2)
+  (let ((val (binary-compatible set1 set2)))
+    (if (not val)
+        (error "sets have different comparators" set1 set2)
+        val)))
 
 ;;; ;;;;;;;;;;;;;;;;
 ;;; Constructors
@@ -56,7 +58,28 @@
   (null? (get-node set)))
 
 (define (set-disjoint? set1 set2)
-  (set-empty? (set-intersection set1 set2)))
+  #;(set-empty? (set-intersection set1 set2))
+  ;; More optimized version.
+  ;; 
+  ;; List the values of the sets in order. If any set is exhausted, then
+  ;; the sets are disjoint. If any element is equal, then the sets are
+  ;; not disjoint.
+  ;; 
+  ;; If the element from set 1 is less than the element from set 2, then
+  ;; get the next element from set 1 (if any) and repeat. Since the
+  ;; elements are obtained in order, any elements after the current
+  ;; element of set 2 must be greater than the seen elements from set 1.
+  (let ((gen1 (set->in-order-generator set1))
+        (gen2 (set->in-order-generator set2))
+        (cmp (check-compatible set1 set2)))
+    (let loop ((value1 (gen1))
+               (value2 (gen2)))
+      (if (or (eof-object? value1) (eof-object? value2))
+          #t
+          (comparator-if<=> cmp value1 value2
+            (loop (gen1) value2)
+            #f
+            (loop value1 (gen2)))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;
 ;;; Accessors
@@ -250,7 +273,7 @@
         (if (null? arg-rest)
             #t
             (let ((arg2 (car arg-rest)))
-              (check-compatible! arg1 arg2)
+              (check-compatible arg1 arg2)
               (if (binary cmp arg1 arg2)
                   (loop arg2 (cdr arg-rest))
                   #f)))))))
@@ -303,7 +326,7 @@
         (if (null? arg-rest)
             arg1
             (let ((arg2 (car arg-rest)))
-              (check-compatible! arg1 arg2)
+              (check-compatible arg1 arg2)
               (loop (binary cmp arg1 arg2)
                     (cdr arg-rest))))))))
 
@@ -369,10 +392,12 @@
   (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 (binary-compatible s1 s2)
+  (let ((cmp (set-element-comparator s1)))
+    (and (eq? cmp (set-element-comparator s2))
+         cmp)))
 
 (define compatible-sets?
   (apply-nary-predicate (lambda (cut set1 set2)
-                          (binary-compatible? set1 set2))))
+                          (binary-compatible set1 set2))))
 
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 5a220c7..adcb091 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -15,10 +15,11 @@
 
 (define test-constructor #f)
 (define test-set-contains #f)
-(define test-set-member #t)
-(define test-set-find #t)
-(define test-set-adjoin #t)
+(define test-set-member #f)
+(define test-set-adjoin #f)
+(define test-set-find #f)
 (define test-set-disjoint #f)
+(define test-set-intersection #t)
 
 (define cmp (make-default-comparator))
 
@@ -90,6 +91,12 @@
                    (not (zero? (vector-length vec))))
                  gen)))
 
+(define (call/split proc)
+  (lambda (vals)
+    (let ((v1 (list-ref vals 0))
+          (v2 (list-ref vals 1)))
+      (proc v1 v2))))
+
 (define (split-unique-vectors)
   ;; Generator of list of two elements, each of which is a vector. The
   ;; vectors are disjoint.
@@ -98,11 +105,23 @@
 (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)))))
+  (gmap (call/split
+         (lambda (v1 v2)
+           (list (list->set cmp (vector->list v1))
+                 (list->set cmp (vector->list v2)))))
         (split-unique-vectors)))
 
+(define (split-non-disjoint-sets)
+  (gmap (call/split
+         (lambda (s1 s2)
+           (let* ((from-s1 (set-find (lambda (x) #t)
+                                     s1
+                                     (lambda ()
+                                       (error "s1 is empty" s1))))
+                  (s2 (set-adjoin s2 from-s1)))
+             (list s1 s2))))
+        (split-unique-sets)))
+
 (define
     (%set . elements)
   (apply set cmp elements))
@@ -284,23 +303,50 @@
             #t
             (set-not-disjoint? s s)))
       (test-property self-never-disjoint (list (random-sets))))
-    (test-group "empty set is disjoint for every set"
+    (test-group "empty set is disjoint from 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))))))))
+      (define (unique-disjoint s1 s2)
+        (and (set-disjoint? s1 s2) (set-disjoint? s2 s1)))
+      (test-property (call/split unique-disjoint)
+                     (list (split-unique-sets))))
+    (test-group "including an element from two disjoint sets make them not disjoint"
+      (define (include-makes-not-disjoint s1 s2)
+        (and (not (set-disjoint? s1 s2))
+             (not (set-disjoint? s2 s1))))
+      (test-property (call/split
+                      include-makes-not-disjoint)
+                     (list (split-non-disjoint-sets))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Set-intersection
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-intersection
+  (test-group "set-intersection"
+    (define (disjoint-implies-empty-intersection set1 set2)
+      (let ((i (set-intersection set1 set2)))
+        (if (set-disjoint? set1 set2)
+            (set-empty? i)
+            (not (set-empty? i)))))
+    (define (empty-intersection-implies-disjoint set1 set2)
+      (let ((i (set-intersection set1 set2)))
+        (if (set-empty? i)
+            (set-disjoint? set1 set2)
+            (not (set-disjoint? set1 set2)))))
+    (test-group "disjoint sets have empty intersections"
+      (test-property (call/split disjoint-implies-empty-intersection)
+                     (list (split-unique-sets))))
+    (test-group "non-disjoint sets have non-empty intersections"
+      (test-property (call/split disjoint-implies-empty-intersection)
+                     (list (split-non-disjoint-sets))))
+    (test-group "empty intersections are disjoint"
+      (test-property (call/split empty-intersection-implies-disjoint)
+                     (list (split-unique-sets))))
+    (test-group "non-empty intersections are non-disjoint sets"
+      (test-property (call/split empty-intersection-implies-disjoint)
+                     (list (split-non-disjoint-sets))))))
+