test bulk set generators

4 files changed, 173 insertions, 167 deletions

diff --git a/README.md b/README.md
index bb77bc7..2bbf78a 100644
--- a/README.md
+++ b/README.md
@@ -22,8 +22,9 @@ Benefits of using this library:
 
 * `(mcgoron weight-balanced-trees internal)`: low-level operations on tree
   nodes. Includes `join`, `split`, and binary set operations.
-* `(mcgoron weight-balanced-trees srfi 113 set)`: The set operations from
-  [SRFI-113][5], with extra procedures.
+* `(mcgoron weight-balanced-trees srfi 113 set)`: Exposes an interface like
+  [SRFI-113][5], but with extra procedures. This can be used to implement the
+  other SRFIs using disjoint container types.
 
 [5]: https://srfi.schemers.org/srfi-113/srfi-113.html
 
@@ -32,21 +33,6 @@ Benefits of using this library:
 Tests of set operations are implemented in terms of the SRFI-1 list-set
 operations.
 
-The implementation of the SRFI interfaces uses [generators][3] for
-iteration whenever a function can terminate in the middle of a set (like
-`set-every?`). Generators are usually lightweight, but are intrinsically
-mutating.  Some Scheme implementations, like CHICKEN, implement
-write-barriers in their garbage collectors, which make mutation slower
-(See ["Mutations"][4]).
-
-Alternative implementation strategies include:
-
-* escape continuations (`call/cc` might be slow, `call/ec` is not
-  standard, `guard` could be used to emulate escape continuations)
-* direct recursion (would have to traverse the whole set before
-  terminating)
-* sentinel-value return (uglier)
-
 The linear update procedures are the same as the functional procedures.
 
 [3]: https://srfi.schemers.org/srfi-158/srfi-158.html
diff --git a/mcgoron/weight-balanced-trees/srfi/113/252.scm b/mcgoron/weight-balanced-trees/srfi/113/252.scm
index 2a9eeab..db8f267 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/252.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.scm
@@ -13,6 +13,18 @@
  | limitations under the License.
  |#
 
+(define (unique-vector-of cmp element-generator max-vector-length)
+  (define vector-length-generator
+    (make-random-integer-generator 0 max-vector-length))
+  (lambda ()
+    (generator->vector
+     (gstate-filter (lambda (element set)
+                      (if (set-contains? set element)
+                          (values #f set)
+                          (values #t (set-adjoin set element))))
+                    element-generator)
+     (vector-length-generator))))
+
 (define default-max-set-size
   (make-parameter 100))
 
@@ -26,6 +38,9 @@
                        element-generator
                        (default-max-set-size)))
     ((comparator element-generator max-set-size)
+     (define set-size-generator
+       (make-random-integer-generator 0 max-set-size))
+     (define the-set (set comparator))
      (gmap (cut list->set comparator <>)
            (list-generator-of element-generator max-set-size)))))
 
@@ -50,9 +65,19 @@
          (map (cut set-union i-set <>) sets)))
      (gmap do-intersection
            (gremove null?
-                    (list-generator-of set-generator
+                    (list-generator-of (gremove set-empty? set-generator)
                                        max-num-of-sets))))))
 
+(define (make-set-disjoint-from-all set other-sets)
+  ;; Make `set` disjoint from all sets in `other-sets`, except for a set
+  ;; that is exactly itself (i.e. `eq?`).
+  (fold (lambda (other-set set)
+          (if (eq? other-set set)
+              set
+              (set-difference set other-set)))
+        set
+        other-sets))
+
 (define disjoint-set-generator-of
   (case-lambda
     ((set-generator)
@@ -60,8 +85,7 @@
                                 (default-max-number-of-sets)))
     ((set-generator max-num-of-sets)
      (gmap (lambda (sets)
-             (let ((i (apply set-intersection sets)))
-               (map (cut set-difference <> i) sets)))
+             (map (cut make-set-disjoint-from-all <> sets) sets))
            (gremove null?
                     (list-generator-of set-generator
                                        max-num-of-sets))))))
diff --git a/mcgoron/weight-balanced-trees/srfi/113/252.sld b/mcgoron/weight-balanced-trees/srfi/113/252.sld
index 07a60f0..7e34a84 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/252.sld
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.sld
@@ -16,7 +16,7 @@
 (define-library (mcgoron weight-balanced-trees srfi 113 252)
   (import (scheme base) (scheme case-lambda)
           (mcgoron weight-balanced-trees srfi 113 sets)
-          (srfi 26) (srfi 128) (srfi 158) (srfi 252))
+          (srfi 1) (srfi 26) (srfi 128) (srfi 158) (srfi 194) (srfi 252))
   (export default-max-set-size set-generator-of
           default-max-number-of-sets
           intersecting-set-generator-of
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