change set-disjoint?, test set-intersection

1 files changed, 34 insertions, 9 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))))