test bulk set generators

1 files changed, 142 insertions, 146 deletions

diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 68395e5..251107f 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -14,6 +14,9 @@
  |#
 
 (define test-constructor #f)
+(define test-set-generator-of #f)
+(define test-intersecting-set-generator-of #t)
+(define test-disjoint-set-generator-of #t)
 (define test-set-contains #f)
 (define test-set-member #f)
 (define test-set-adjoin #f)
@@ -28,7 +31,9 @@
 (define test-set> #f)
 (define test-set-intersection #t)
 
-(define cmp (make-default-comparator))
+(define cmp
+  ;; The global comparator.
+  (make-default-comparator))
 
 (define (orderable-generator)
   ;; Return a value that can be ordered in an obvious way.
@@ -54,78 +59,18 @@
 ;;; Utility functions
 ;;; ;;;;;;;;;;;;;;;;;;;;;;
 
-(define (remove-duplicates generator)
-  ;; Remove duplicates (according to the default comparator) from vectors
-  ;; made by `generator`.
-  ;; 
-  ;; TODO: This relies on SRFI-69. Just make it depend on SRFI-1 list
-  ;; procedures later, since this will only be used for testing constructors.
-  (gmap (lambda (vec)
-          (let* ((table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
-                 (n 0))
-            (vector-for-each
-             (lambda (value)
-               (when (not (hash-table-ref/default table value #f))
-                 (hash-table-set! table value #t)
-                 (set! n (+ n 1))))
-             vec)
-            (let ((new-vec (make-vector n))
-                  (n 0))
-              (hash-table-walk table
-                               (lambda (key _)
-                                 (vector-set! new-vec n key)
-                                 (set! n (+ n 1))))
-              new-vec)))
-        generator))
-
-(define (unique-vector)
-  ;; Return a vector of unique elements (according to the equality
-  ;; predicate of the default comparator).
-  (remove-duplicates (vector-generator-of (orderable-generator))))
-
-(define (vector->set vec)
-  ;; Convert a vector into a set.
-  (set-unfold cmp
-              (cute = <> (vector-length vec))
-              (cut vector-ref vec <>)
-              (cut + <> 1)
-              0))
-
-(define (filter-non-empty-sets set-generator)
-  ;; Filter a generator of sets for non-empty sets.
-  (gfilter (lambda (set) (not (set-empty? set)))
-           set-generator))
-
-(define (split-vector gen)
-  ;; Split vectors in half, return it as a list.
-  (gmap (lambda (vec)
-          (let* ((len (vector-length vec))
-                 (midpoint (floor (/ len 2))))
-            (list (vector-copy vec 0 midpoint)
-                  (vector-copy vec (+ midpoint 1) len))))
-        (gfilter (lambda (vec)
-                   (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.
-  (split-vector (unique-vector)))
-
-(define (split-unique-sets)
-  ;; Generator of a list of two elements, each of which is a set. The
-  ;; sets are disjoint.
-  (gmap (call/split
-         (lambda (v1 v2)
-           (list (list->set cmp (vector->list v1))
-                 (list->set cmp (vector->list v2)))))
-        (split-unique-vectors)))
+(define (unique-list)
+  ;; Return a list of unique elements (according to the equality
+  ;; predicate of the global comparator).
+  (gmap (lambda (lst)
+          (let loop ((list-set '())
+                     (lst lst))
+            (cond
+              ((null? lst) list-set)
+              ((member (car lst) list-set (cut =? cmp <> <>))
+               (loop list-set (cdr lst)))
+              (else (loop (cons (car lst) list-set) (cdr lst))))))
+        (list-generator-of (orderable-generator))))
 
 (define (find-some-element s1)
   ;; Get some arbitrary element from the set.
@@ -139,27 +84,16 @@
   (let ((element (find-some-element s1)))
     (values (set-delete s1 element) element)))
 
-(define (split-non-disjoint-sets)
-  ;; Create a generator which generates list of two elements. The two
-  ;; elements are list whose sets are not disjoint: they have exactly
-  ;; one element in common.
-  (gmap (call/split
-         (lambda (s1 s2)
-           (let* ((from-s1 (find-some-element s1))
-                  (s2 (set-adjoin s2 from-s1)))
-             (list s1 s2))))
-        (gfilter (call/split
-                  (lambda (s1 s2)
-                    (and (not (set-empty? s1)) (not (set-empty? s2)))))
-                 (split-unique-sets))))
-
-(define
-    (%set . elements)
+(define (%set . elements)
+  ;; Create a set with the `cmp` comparator.
   (apply set cmp elements))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Tests
 ;;; 
+;;; Tests are structured so that tests will depend on functions that
+;;; were tested previously.
+;;; 
 ;;; The first part of these tests assume that `lset=` from SRFI-1 works
 ;;; properly.
 ;;; ;;;;;;;;;;;;;;;;;;;;
@@ -199,65 +133,127 @@
 ;;; There are two types of tests: tests for creation from unique vectors
 ;;; and from possibly non-unique vectors.
 
-(define (test-create-with-duplicates creator)
-  (lambda (vec)
-    (let* ((lst (vector->list vec))
-           (new-set (creator lst))
-           (set-as-list (set->list new-set)))
-      (test-assert "set?" (set? new-set))
-      (if (null? lst)
-          (test-assert "empty?" (set-empty? new-set))
-          (test-assert "empty?" (not (set-empty? new-set))))
-      ;; The new-set will remove duplicates.
-      (test-call "length?" (<= (set-size new-set) (length lst)))
-      (test-call "subset of inserted" (lset<= equal? set-as-list lst)))))
-
 (when test-constructor
-  (test-group "multiple element set using `list->set` procedure"
-    (test-property (test-create-with-duplicates
-                  (cute list->set cmp <>))
-                   (list (unique-vector))))
-  (test-group "multiple element set using `set` procedure"
-    (test-property (test-create-with-duplicates
-                    (cute apply set cmp <...>))
-                   (list (unique-vector))))
-  (test-group "multiple element set using `set-unfold` procedure"
-    (test-property (test-create-with-duplicates
-                    (cute set-unfold cmp null? car cdr <>))
-                   (list (unique-vector)))))
-
-(define (test-create-without-duplicates creator)
-  (lambda (vec)
-    (let* ((lst (vector->list vec))
-           (new-set (creator lst))
-           (set-as-list (set->list new-set)))
-      (test-assert "set?" (set? new-set))
-      (test-assert "empty?" (if (null? lst)
-                                (set-empty? new-set)
-                                (not (set-empty? new-set))))
-      (test-equal "length?" (set-size new-set) (length lst))
-      (test-call "exactly inserted" (lset= equal? set-as-list lst)))))
+  (test-group "constructors"
+    (define (test-create-with-duplicates creator)
+      (lambda (lst)
+        (let* ((new-set (creator lst))
+               (set-as-list (set->list new-set)))
+          (test-assert "set?" (set? new-set))
+          (if (null? lst)
+              (test-assert "empty?" (set-empty? new-set))
+              (test-assert "empty?" (not (set-empty? new-set))))
+          ;; The new-set will remove duplicates.
+          (test-call "length?" (<= (set-size new-set) (length lst)))
+          (test-call "subset of inserted" (lset<= equal? set-as-list lst)))))
+    (define (test-create-without-duplicates creator)
+      (lambda (lst)
+        (let* ((new-set (creator lst))
+               (set-as-list (set->list new-set)))
+          (test-assert "set?" (set? new-set))
+          (test-assert "empty?" (if (null? lst)
+                                    (set-empty? new-set)
+                                    (not (set-empty? new-set))))
+          (test-equal "length?" (set-size new-set) (length lst))
+          (test-call "exactly inserted" (lset= equal? set-as-list lst)))))
+    (test-group "multiple element set using `list->set` procedure"
+      (test-property (test-create-with-duplicates
+                      (cute list->set cmp <>))
+                     (list (unique-list))))
+    (test-group "multiple element set using `set` procedure"
+      (test-property (test-create-with-duplicates
+                      (cute apply set cmp <...>))
+                     (list (unique-list))))
+    (test-group "multiple element set using `set-unfold` procedure"
+      (test-property (test-create-with-duplicates
+                      (cute set-unfold cmp null? car cdr <>))
+                     (list (unique-list))))
+    (test-group "multiple element set using `list->set` procedure, unique elements"
+      (test-property (test-create-without-duplicates
+                      (cute list->set cmp <>))
+                     (list (unique-list))))
+    (test-group "multiple element set using `set` procedure, unique elements"
+      (test-property (test-create-without-duplicates
+                      (cute apply set cmp <...>))
+                     (list (unique-list))))
+    (test-group "multiple element set using `set-unfold` procedure, unique elements"
+      (test-property (test-create-without-duplicates
+                      (cute set-unfold cmp null? car cdr <>))
+                     (list (unique-list))))))
 
-(when test-constructor
-  (test-group "multiple element set using `list->set` procedure, unique elements"
-    (test-property (test-create-without-duplicates
-                    (cute list->set cmp <>))
-                   (list (unique-vector))))
-  (test-group "multiple element set using `set` procedure, unique elements"
-    (test-property (test-create-without-duplicates
-                    (cute apply set cmp <...>))
-                   (list (unique-vector))))
-  (test-group "multiple element set using `set-unfold` procedure, unique elements"
-    (test-property (test-create-without-duplicates
-                    (cute set-unfold cmp null? car cdr <>))
-                   (list (unique-vector)))))
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Set generators
+;;; 
+;;; These generators are defined in terms of other set operations. Although
+;;; it is possible to test operations of the set without these, these make
+;;; the tests significantly easier to read.
+
+(when test-set-generator-of
+  (test-group "set-generator-of"
+    (test-group "generates sets"
+      (test-property set? (list (set-generator-of (orderable-generator)))))
+    (test-group "generates set with a comparator"
+      (test-property (lambda (set)
+                       (eq? (set-element-comparator set) cmp))
+                     (list (set-generator-of cmp (orderable-generator)))))
+    (test-group "generates set of a max size"
+      (test-property (lambda (set)
+                       (<= (set-size set) 10))
+                     (list (set-generator-of cmp
+                                             (orderable-generator)
+                                             10))))))
+
+(when test-intersecting-set-generator-of
+  (test-group "intersecting-set-generator-of"
+    (test-group "generates lists of sets"
+      (define (test list-of-sets)
+        (and (<= (length list-of-sets) 10)
+             (every set? list-of-sets)))
+      (test-property test
+                     (list (intersecting-set-generator-of
+                            (set-generator-of (orderable-generator))
+                            10))))
+    (test-group "generates non-disjoint sets"
+      (define (mutually-non-disjoint sets)
+        (every (lambda (set1)
+                 (every (lambda (set2)
+                          (not (set-disjoint? set1 set2)))
+                        sets))
+               sets))
+      (test-property mutually-non-disjoint
+                     (list (intersecting-set-generator-of
+                            (set-generator-of (orderable-generator))
+                            10))))))
+
+(when test-disjoint-set-generator-of
+  (test-group "disjoint-set-generator-of generates lists of sets"
+    (define (test list-of-sets)
+      (and (<= (length list-of-sets) 10)
+           (every set? list-of-sets)))
+    (test-property test
+                   (list (disjoint-set-generator-of
+                          (set-generator-of (orderable-generator))
+                          10))))
+  (test-group "disjoint-set-generator-of generates mutually disjoint sets"
+    (define (mutually-disjoint sets)
+      (every (lambda (set1)
+               (every (lambda (set2)
+                        (if (eq? set1 set2)
+                            #t
+                            (set-disjoint? set1 set2)))
+                      sets))
+             sets))
+    (test-property mutually-disjoint
+                   (list (disjoint-set-generator-of
+                          (set-generator-of (orderable-generator))
+                          10)))))
+
+(define (set-generator)
+  ;; Generate a set with the global comparator.
+  (set-generator-of cmp (orderable-generator)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;
 ;;; set-every
-;;; 
-;;; After testing constructors, `set-generator-of` should work. It's
-;;; tricky to test itself, since sets combine comparator-equal elements.
-;;; The rest of the test assumes that it works.
 ;;; ;;;;;;;;;;;;;;;;;;;;;
 
 (define (less-than-10 x) (< x 10))
@@ -281,13 +277,11 @@
                                        (exact-integer-generator))
                                       20)))))
 
+#|
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-contains
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (set-generator)
-  (set-generator-of cmp (orderable-generator)))
-
 (when test-set-contains
   (test-group "set-contains every element from list->set"
     (define (set-contains-from vec)
@@ -725,3 +719,5 @@
                                   (set-generator)
                                   (set-generator))))))))
 
+
+|#
\ No newline at end of file