set-disjoint tests

1 files changed, 18 insertions, 11 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))))