more tests of subset and set equality predicates

1 files changed, 32 insertions, 33 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index ea15436..c9085cf 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -272,52 +272,51 @@
 
 (define (apply-nary-predicate binary)
   (lambda (first . rest)
-    (let ((cmp (set-element-comparator first)))
-      (let loop ((arg1 first)
-                 (arg-rest rest))
-        (if (null? arg-rest)
-            #t
-            (let ((arg2 (car arg-rest)))
-              (check-compatible arg1 arg2)
-              (if (binary cmp arg1 arg2)
-                  (loop arg2 (cdr arg-rest))
-                  #f)))))))
+    (let loop ((arg1 first)
+               (arg-rest rest))
+      (if (null? arg-rest)
+          #t
+          (let ((arg2 (car arg-rest)))
+            (if (binary (check-compatible arg1 arg2) arg1 arg2)
+                (loop arg2 (cdr arg-rest))
+                #f))))))
 (define set=?
   (apply-nary-predicate
    (lambda (cmp set1 set2)
-     (and (= (set-size set1) (set-size set2))
-          (let ((gen1 (set->in-order-generator set1))
-                (gen2 (set->in-order-generator set2)))
-            (let loop ((value1 (gen1))
-                       (value2 (gen2)))
-              (cond
-                ((and (eof-object? value1) (eof-object? value2)) #t)
-                ((=? cmp value1 value2) (loop (gen1) (gen2)))
-                (else #f))))))))
+     (or (eq? set1 set2)
+         (and (= (set-size set1) (set-size set2))
+              (let ((gen1 (set->in-order-generator set1))
+                    (gen2 (set->in-order-generator set2)))
+                (let loop ((value1 (gen1))
+                           (value2 (gen2)))
+                  (cond
+                    ((and (eof-object? value1) (eof-object? value2)) #t)
+                    ((=? cmp value1 value2) (loop (gen1) (gen2)))
+                    (else #f)))))))))
+
+(define (binary-set<=? cmp set1 set2)
+  (or (eq? set1 set2)
+      (and (<= (set-size set1) (set-size set2))
+           (set-every? (cut set-contains? set2 <>) set1))))
 
 (define set<=?
-  (apply-nary-predicate
-   (lambda (cmp set1 set2)
-     (and (<= (set-size set1) (set-size set2))
-          (set-every? (cut set-contains? set2 <>) set1)))))
+  (apply-nary-predicate binary-set<=?))
+
+(define (binary-set<? cmp set1 set2)
+  (and (not (eq? set1 set2))
+       (< (set-size set1) (set-size set2))
+       (set-every? (cut set-contains? set2 <>) set1)))
 
 (define set<?
-  (apply-nary-predicate
-   (lambda (cmp set1 set2)
-     (and (< (set-size set1) (set-size set2))
-          (set-every? (cut set-contains? set2 <>) set1)))))
+  (apply-nary-predicate binary-set<?))
 
 (define set>?
   (apply-nary-predicate
-   (lambda (cmp set1 set2)
-     (and (> (set-size set1) (set-size set2))
-          (set-every? (cut set-contains? set1 <>) set2)))))
+   (lambda (cmp set1 set2) (binary-set<? cmp set2 set1))))
 
 (define set>=?
   (apply-nary-predicate
-   (lambda (cmp set1 set2)
-     (and (>= (set-size set1) (set-size set2))
-          (set-every? (cut set-contains? set1 <>) set2)))))
+   (lambda (cmp set1 set2) (binary-set<=? cmp set2 set1))))
 
 ;;; ;;;;;;;;;;;;;;;;
 ;;; Set theory operations