add bulk list operations for set-set operatoins

5 files changed, 141 insertions, 21 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/252.scm b/mcgoron/weight-balanced-trees/srfi/113/252.scm
new file mode 100644
index 0000000..2a9eeab
--- /dev/null
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.scm
@@ -0,0 +1,68 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define default-max-set-size
+  (make-parameter 100))
+
+(define set-generator-of
+  (case-lambda
+    ((element-generator)
+     (set-generator-of (make-default-comparator)
+                       element-generator))
+    ((comparator element-generator)
+     (set-generator-of comparator
+                       element-generator
+                       (default-max-set-size)))
+    ((comparator element-generator max-set-size)
+     (gmap (cut list->set comparator <>)
+           (list-generator-of element-generator max-set-size)))))
+
+(define default-max-number-of-sets
+  (make-parameter 100))
+
+(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 set-generator
+                                       max-num-of-sets))))))
+
+(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)
+             (let ((i (apply set-intersection sets)))
+               (map (cut set-difference <> i) 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
new file mode 100644
index 0000000..07a60f0
--- /dev/null
+++ b/mcgoron/weight-balanced-trees/srfi/113/252.sld
@@ -0,0 +1,24 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(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))
+  (export default-max-set-size set-generator-of
+          default-max-number-of-sets
+          intersecting-set-generator-of
+          disjoint-set-generator-of)
+  (include "252.scm"))
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index b65b56e..ba55520 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -323,36 +323,62 @@
 ;;; ;;;;;;;;;;;;;;;;
 
 (define (apply-nary-procedure binary)
-  (lambda (first . rest)
-    (let ((cmp (set-element-comparator first)))
-      (let loop ((arg1 first)
-                 (arg-rest rest))
-        (if (null? arg-rest)
-            arg1
-            (let ((arg2 (car arg-rest)))
-              (check-compatible arg1 arg2)
-              (loop (binary cmp arg1 arg2)
-                    (cdr arg-rest))))))))
+  (lambda (lst)
+    (let loop ((arg1 (car lst))
+               (arg-rest (cdr lst)))
+      (if (null? arg-rest)
+          arg1
+          (let ((arg2 (car arg-rest)))
+            (loop (binary (check-compatible arg1 arg2) arg1 arg2)
+                  (cdr arg-rest)))))))
 
 (define (convert-binary-procedure proc)
   (apply-nary-procedure
    (lambda (cmp arg1 arg2)
      (raw-set cmp (proc cmp (get-node arg1) (get-node arg2))))))
 
-(define set-union (convert-binary-procedure union))
+(define set-union-all
+  (convert-binary-procedure
+   (lambda (cmp node1 node2)
+     (if (eq? node1 node2)
+         node1
+         (union cmp node1 node2)))))
+
+(define (set-union first . rest)
+  (set-union-all (cons first rest)))
 (define set-union! set-union)
 
-(define set-intersection (convert-binary-procedure
-                          (lambda (cmp node1 node2)
-                            (if (eq? node1 node2)
-                                node1
-                                (intersection cmp node1 node2)))))
+(define set-intersection-all
+  (convert-binary-procedure
+   (lambda (cmp node1 node2)
+     (if (eq? node1 node2)
+         node1
+         (intersection cmp node1 node2)))))
+
+(define (set-intersection first . rest)
+  (set-intersection-all (cons first rest)))
 (define set-intersection! set-intersection)
 
-(define set-difference (convert-binary-procedure difference))
+(define set-difference-all
+  (convert-binary-procedure
+   (lambda (cmp node1 node2)
+     (if (eq? node1 node2)
+         '()
+         (difference cmp node1 node2)))))
+
+(define (set-difference first . rest)
+  (set-difference-all (cons first rest)))
 (define set-difference! set-difference)
 
-(define set-xor (apply-nary-procedure xor))
+(define set-xor-all
+  (convert-binary-procedure
+   (lambda (cmp node1 node2)
+     (if (eq? node1 node2)
+         '()
+         (xor cmp node1 node2)))))
+
+(define (set-xor first . rest)
+  (set-xor (cons first rest)))
 (define set-xor! set-xor)
 
 ;;; ;;;;;;;;;;;;
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.sld b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
index fffb7fa..4b8c358 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.sld
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
@@ -30,6 +30,8 @@
           set-union set-intersection set-difference set-xor
           set-union! set-intersection! set-difference! set-xor!
           ;;  Extra procedures
+          set-union-all set-intersection-all set-difference-all set-xor-all
+          set-adjoin-all set-replace-all
           compatible-sets? generator->set set->generator)
   (include "sets.scm"))
 
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 344f3bd..68395e5 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -295,7 +295,7 @@
         (vector-every (cut set-contains? set <>) vec)))
     (test-property set-contains-from (list (unique-vector))))
   (test-group "set-contains every element from set-every?"
-    (define (set-contains-every ste)
+    (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"
@@ -661,13 +661,13 @@
   (test-group "deleting an element from a set makes it >"
     (define (delete-set> set)
       (let ((set- (set-delete set (find-some-element set))))
-        (set>? set- set)))
+        (set>? set set-)))
     (test-property delete-set> (list (filter-non-empty-sets
                                       (set-generator)))))
   (test-group "adjoining an element to a set makes it >"
     (define (adjoin-set> set)
       (let ((set+ (set-adjoin set (cons #f #f))))
-        (set>? set set+)))
+        (set>? set+ set)))
     (test-property adjoin-set> (list (filter-non-empty-sets
                                       (set-generator)))))
   (test-group "nary >"