create disjoint set generator of exact number of sets

3 files changed, 104 insertions, 67 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/252.scm b/mcgoron/weight-balanced-trees/srfi/113/252.scm
index db8f267..d1d0a2b 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/252.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.scm
@@ -13,18 +13,6 @@
  | 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))
 
@@ -47,26 +35,31 @@
 (define default-max-number-of-sets
   (make-parameter 100))
 
+(define (intersecting-sets-of-exactly set-generator num)
+  (define (find-arbitrary-element set)
+    (set-find (lambda (x) #t)
+              set
+              (lambda ()
+                (error "empty set passed" set))))
+  (let* ((sets (generator->list
+                (gtake (gremove set-empty? set-generator) num)))
+         (i-set (list->set (set-element-comparator (car sets))
+                           (map find-arbitrary-element sets))))
+    (map (cut set-union i-set <>) sets)))
+
+(define (intersecting-set-generator-of-exactly set-generator num)
+  (cut intersecting-sets-of-exactly set-generator num))
+
 (define intersecting-set-generator-of
   (case-lambda
     ((set-generator)
      (intersecting-set-generator-of set-generator
                                     (default-max-number-of-sets)))
     ((set-generator max-num-of-sets)
-     (define (find-arbitrary-element set)
-       (set-find (lambda (x) #t)
-                 set
-                 (lambda ()
-                   (error "empty set passed" set))))
-     (define (do-intersection sets)
-       (let ((i-set (list->set (set-element-comparator
-                                (car sets))
-                               (map find-arbitrary-element sets))))
-         (map (cut set-union i-set <>) sets)))
-     (gmap do-intersection
-           (gremove null?
-                    (list-generator-of (gremove set-empty? set-generator)
-                                       max-num-of-sets))))))
+     (let ((list-size-generator (make-random-integer-generator 1 max-num-of-sets)))
+       (lambda ()
+         (intersecting-sets-of-exactly set-generator
+                                      (list-size-generator)))))))
 
 (define (make-set-disjoint-from-all set other-sets)
   ;; Make `set` disjoint from all sets in `other-sets`, except for a set
@@ -78,15 +71,23 @@
         set
         other-sets))
 
+(define (disjoint-sets-of-exactly set-generator num)
+  (let ((sets (generator->list
+               (gtake set-generator num))))
+    (map (cut make-set-disjoint-from-all <> sets) sets)))
+
+(define (disjoint-set-generator-of-exactly set-generator num)
+  (cut disjoint-sets-of-exactly set-generator num))
+
 (define disjoint-set-generator-of
   (case-lambda
     ((set-generator)
      (disjoint-set-generator-of set-generator
                                 (default-max-number-of-sets)))
     ((set-generator max-num-of-sets)
-     (gmap (lambda (sets)
-             (map (cut make-set-disjoint-from-all <> sets) sets))
-           (gremove null?
-                    (list-generator-of set-generator
-                                       max-num-of-sets))))))
+     (let ((list-size-generator
+            (make-random-integer-generator 1 max-num-of-sets)))
+       (lambda ()
+         (disjoint-sets-of-exactly set-generator
+                                  (list-size-generator)))))))
 
diff --git a/mcgoron/weight-balanced-trees/srfi/113/252.sld b/mcgoron/weight-balanced-trees/srfi/113/252.sld
index 7e34a84..94f5376 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/252.sld
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.sld
@@ -19,6 +19,8 @@
           (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-exactly
           intersecting-set-generator-of
+          disjoint-set-generator-of-exactly
           disjoint-set-generator-of)
   (include "252.scm"))
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 251107f..5a9da18 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -15,14 +15,14 @@
 
 (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-intersecting-set-generator-of #f)
+(define test-disjoint-set-generator-of #f)
+(define test-set-every #t)
+(define test-set-contains #t)
 (define test-set-member #f)
 (define test-set-adjoin #f)
 (define test-set-find #f)
 (define test-set-disjoint #f)
-(define test-set-every #f)
 (define test-set-delete #f)
 (define test-set= #f)
 (define test-set<= #f)
@@ -203,7 +203,41 @@
                                              (orderable-generator)
                                              10))))))
 
+(define (set-generator)
+  ;; Generate a set with the global comparator.
+  (set-generator-of cmp (orderable-generator)))
+
+(define (mutually-non-disjoint sets)
+  (every (lambda (set1)
+           (every (lambda (set2)
+                    (not (set-disjoint? set1 set2)))
+                  sets))
+         sets))
+
+(define (mutually-disjoint sets)
+  (every (lambda (set1)
+           (every (lambda (set2)
+                    (if (eq? set1 set2)
+                        #t
+                        (set-disjoint? set1 set2)))
+                  sets))
+         sets))
+
 (when test-intersecting-set-generator-of
+  (test-group "intersecting-set-generator-of-exactly"
+    (test-group "generates a list of sets of a certain length"
+      (define (test list-of-sets)
+        (and (= (length list-of-sets) 2)
+             (every set? list-of-sets)))
+      (test-property test
+                     (list (intersecting-set-generator-of-exactly
+                            (set-generator)
+                            2))))
+    (test-group "generates non-disjoint sets"
+      (test-property mutually-non-disjoint
+                     (list (intersecting-set-generator-of-exactly
+                            (set-generator)
+                            2)))))
   (test-group "intersecting-set-generator-of"
     (test-group "generates lists of sets"
       (define (test list-of-sets)
@@ -211,47 +245,43 @@
              (every set? list-of-sets)))
       (test-property test
                      (list (intersecting-set-generator-of
-                            (set-generator-of (orderable-generator))
+                            (set-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))
+                            (set-generator)
                             10))))))
 
 (when test-disjoint-set-generator-of
+  (test-group "disjoint-set-generator-of-exactly"
+    (test-group "generates a list of sets of a certain length"
+      (define (test list-of-sets)
+        (and (= (length list-of-sets) 2)
+             (every set? list-of-sets)))
+      (test-property test
+                     (list (disjoint-set-generator-of-exactly
+                            (set-generator)
+                            2))))
+    (test-group "generates -disjoint sets"
+      (test-property mutually-disjoint
+                     (list (disjoint-set-generator-of-exactly
+                            (set-generator)
+                            2)))))
   (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))
+                          (set-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))
+                          (set-generator)
                           10)))))
 
-(define (set-generator)
-  ;; Generate a set with the global comparator.
-  (set-generator-of cmp (orderable-generator)))
-
 ;;; ;;;;;;;;;;;;;;;;;;;;;
 ;;; set-every
 ;;; ;;;;;;;;;;;;;;;;;;;;;
@@ -277,30 +307,34 @@
                                        (exact-integer-generator))
                                       20)))))
 
-#|
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-contains
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (when test-set-contains
   (test-group "set-contains every element from list->set"
-    (define (set-contains-from vec)
-      (let ((set (vector->set vec)))
-        (vector-every (cut set-contains? set <>) vec)))
-    (test-property set-contains-from (list (unique-vector))))
+    (define (set-contains-from lst)
+      (let ((set (list->set cmp lst)))
+        (every (cut set-contains? set <>) lst)))
+    (test-property set-contains-from (list (list-generator-of
+                                            (orderable-generator)))))
   (test-group "set-contains every element from set-every?"
     (define (set-contains-every set)
       (set-every? (cut set-contains? set <>) set))
     (test-property set-contains-every (list (set-generator))))
   (test-group "set-contains? is false for elements in disjoint set"
-    (define (set-does-not-contain vecs)
+    (define (set-does-not-contain sets)
       (define (set-does-not-contain? set value)
         (not (set-contains? set value)))
-      (let ((set (list->set cmp (vector->list (list-ref vecs 0))))
-            (not-in (list-ref vecs 1)))
-        (vector-every (cut set-does-not-contain? set <>) not-in)))
-    (test-property set-does-not-contain (list (split-unique-vectors)))))
+      (set-every? (cute set-does-not-contain?
+                        (list-ref sets 1)
+                        <>)
+                  (list-ref sets 0)))
+    (test-property set-does-not-contain (list (disjoint-set-generator-of-exactly
+                                               (set-generator)
+                                               2)))))
 
+#|
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-member
 ;;;