change set-disjoint?, test set-intersection

1 files changed, 67 insertions, 21 deletions

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))))))
+