more tests of subset and set equality predicates

3 files changed, 103 insertions, 44 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
diff --git a/tests/run.scm b/tests/run.scm
index 0d5f561..1175791 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -45,7 +45,7 @@
   (import (scheme base) (scheme write) (scheme inexact)
           (chicken condition)
           (except (mcgoron srfi 64) factory)
-          (srfi 1) (srfi 26) (srfi 64) (srfi 69) (srfi 128)
+          (srfi 1) (srfi 26) (srfi 27) (srfi 64) (srfi 69) (srfi 128)
           (srfi 133) (srfi 158) (srfi 194) (srfi 252)
           (mcgoron weight-balanced-trees srfi 113 sets)
           (mcgoron weight-balanced-trees srfi 113 252))
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index ba1d96a..61dcc82 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -21,8 +21,8 @@
 (define test-set-disjoint #f)
 (define test-set-every #f)
 (define test-set-delete #f)
-(define test-set= #f)
-(define test-set<= #f)
+(define test-set= #t)
+(define test-set<= #t)
 (define test-set< #t)
 (define test-set-intersection #f)
 
@@ -74,15 +74,17 @@
   ;; predicate of the default comparator).
   (remove-duplicates (vector-generator-of (orderable-generator))))
 
+(define (vector->set vec)
+  (set-unfold cmp
+              (cute = <> (vector-length vec))
+              (cut vector-ref vec <>)
+              (cut + <> 1)
+              0))
+
 (define (random-sets)
   ;; Return a set of random elements.
   (gcons* (set cmp)
-          (gmap (lambda (vec)
-                  (set-unfold cmp
-                              (cute = <> (vector-length vec))
-                              (cut vector-ref vec <>)
-                              (cut + <> 1)
-                              0))
+          (gmap vector->set
                 (unique-vector))))
 
 (define (filter-non-empty-sets set-generator)
@@ -416,11 +418,39 @@
 ;;; set=?
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define (shuffle-vector! vec)
+  (let ((len (vector-length vec)))
+    (do ((i 0 (+ i 1)))
+        ((= i len) vec)
+      (let* ((r (random-integer len))
+             (tmp (vector-ref vec r)))
+        (vector-set! vec r (vector-ref vec i))
+        (vector-set! vec i tmp)))))
+
 (when test-set=
   (test-group "sets are set= to themselves"
     (define (always-set= set)
       (set=? set set))
     (test-property always-set= (list (random-sets))))
+  (test-group "sets are set= to shuffled versions of themselves"
+    (define (shuffle-set= vec)
+      (let* ((set1 (vector->set vec))
+             (set2 (vector->set (shuffle-vector! vec))))
+        (set=? set1 set2)))
+    (test-property shuffle-set= (list (vector-generator-of
+                                       (orderable-generator)))))
+  (test-group "nary set="
+    (define (nary-set= vec)
+      ;; NOTE: There is no way, as far as I know, to make sets that have
+      ;; the same of elements but are structurally different. This tries
+      ;; to do that by shuffling a list of elements.
+      (let* ((set1 (vector->set vec))
+             (set2 (vector->set (shuffle-vector! vec)))
+             (set3 (vector->set (shuffle-vector! vec)))
+             (set4 (vector->set (shuffle-vector! vec)))
+             (set5 (vector->set (shuffle-vector! vec))))
+        (set=? set1 set2 set3 set4 set5)))
+    (test-property nary-set= (list (unique-vector))))
   (test-group "set with one element deleted is not set="
     (define (not-set=? set)
       (let ((set* (set-delete set (find-some-element set))))
@@ -459,6 +489,11 @@
     (define (self-set<= set)
       (set<=? set set))
     (test-property self-set<= (list (random-sets))))
+  (test-group "all sets are <= to permutations of themselves"
+    (define (random-set<= vec)
+      (let* ((set (vector->set vec))
+             (set2 (vector->set (shuffle-vector! vec))))
+        (set<=? set set2))))
   (test-group "deleting an element from a set makes it <="
     (define (delete-set<= set)
       (let ((set- (set-delete set (find-some-element set))))
@@ -469,7 +504,17 @@
     (define (adjoin-set<= set)
       (let ((set+ (set-adjoin set (cons #f #f))))
         (set<=? set set+)))
-    (test-property adjoin-set<= (list (random-sets)))))
+    (test-property adjoin-set<= (list (random-sets))))
+  (test-group "nary <="
+    (define (nary-set<= set)
+      (let* ((set- (delete-some-element set))
+             (set-- (delete-some-element set-))
+             (set--- (delete-some-element set--)))
+        (set<=? set--- set-- set- set)))
+    (test-property nary-set<= (list
+                               (gfilter (lambda (set)
+                                          (> (set-size set) 4))
+                                        (random-sets))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;
 ;;; set<?
@@ -480,6 +525,11 @@
     (define (not-set< set)
       (not (set<? set set)))
     (test-property not-set< (list (random-sets))))
+  (test-group "no set is < to a permutation of itself"
+    (define (random-not-set< vec)
+      (let* ((set1 (vector->set vec))
+             (set2 (vector->set (shuffle-vector! vec))))
+        (not (set<? set1 set2)))))
   (test-group "deleting an element from a set makes it <"
     (define (delete-set< set)
       (let ((set- (set-delete set (find-some-element set))))
@@ -491,7 +541,17 @@
       (let ((set+ (set-adjoin set (cons #f #f))))
         (set<? set set+)))
     (test-property adjoin-set< (list (filter-non-empty-sets
-                                      (random-sets))))))
+                                      (random-sets)))))
+  (test-group "nary <"
+    (define (nary-set< set)
+      (let* ((set- (delete-some-element set))
+             (set-- (delete-some-element set-))
+             (set--- (delete-some-element set--)))
+        (set<? set--- set-- set- set)))
+    (test-property nary-set< (list
+                              (gfilter (lambda (set)
+                                         (> (set-size set) 4))
+                                       (random-sets))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-intersection