start testing SRFI 113 tests

4 files changed, 411 insertions, 1 deletions

diff --git a/mcgoron/weight-balanced-trees/internal.scm b/mcgoron/weight-balanced-trees/internal.scm
index 35a25bb..73bc00c 100644
--- a/mcgoron/weight-balanced-trees/internal.scm
+++ b/mcgoron/weight-balanced-trees/internal.scm
@@ -12,6 +12,7 @@
  | See the License for the specific language governing permissions and
  | limitations under the License.
  |#
+
 ;;; ;;;;;;;;;;;;;;;;;;;
 ;;; Definition of nodes and functions to calculate values for nodes.
 ;;; ;;;;;;;;;;;;;;;;;;;
@@ -61,6 +62,8 @@
 (define (wb-tree-node data left right)
   ;; Construct a node with `data`, `left`, and `right`, with the correct
   ;; weight.
+  (when (eof-object? data)
+    (error "eof object cannot be added to set" data))
   (%wb-tree-node data (calculate-weight left right) left right))
 
 (: balanced-as-child? (fixnum fixnum --> boolean))
@@ -363,7 +366,7 @@
 ;;; Single value operations
 ;;; ;;;;;;;;;;;;;;;;;;;;
 
-(: update (* node-type * (-> *) (-> node-type) -> node-type))
+(: update (* node-type * (* -> *) (-> node-type) -> node-type))
 (define (update cmp set to-search on-found on-not-found)
   (let update ((set set))
     (if (null? set)
diff --git a/mcgoron/weight-balanced-trees/internal.sld b/mcgoron/weight-balanced-trees/internal.sld
index 5d99d0c..f9bf4ac 100644
--- a/mcgoron/weight-balanced-trees/internal.sld
+++ b/mcgoron/weight-balanced-trees/internal.sld
@@ -28,6 +28,7 @@
                 ((the type expression) expression))))))
   (export wb-tree-node? non-null-wb-tree-node?
           wb-tree-node
+          with-node
           get-data get-left get-right get-size
           balanced?
           in-order-vector->node
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
new file mode 100644
index 0000000..d9552db
--- /dev/null
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -0,0 +1,371 @@
+#| 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-record-type <set>
+  (raw-set comparator node)
+  set?
+  (comparator set-element-comparator)
+  (node get-node))
+
+(define (check-compatible! set1 set2)
+  (when (not (compatible-sets? set1 set2))
+    (error "sets have different comparators" set1 set2)))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Constructors
+;;; ;;;;;;;;;;;;;;;;
+
+(define (set-unfold comparator stop? mapper successor seed)
+  (let loop ((set '())
+             (seed seed))
+    (if (stop? seed)
+        (raw-set comparator set)
+        (let ((new-value (mapper seed)))
+          (loop (insert comparator set new-value)
+                (successor seed))))))
+
+(define (set comparator . elements)
+  (list->set comparator elements))
+
+;;; ;;;;;;;;;;;;;;;;;
+;;; Predicates (besides set?)
+;;; ;;;;;;;;;;;;;;;;;
+
+(define (set-contains? set element)
+  (let ((found? #t))
+    (search (set-element-comparator set)
+            (get-node set)
+            (lambda () (set! found? #f)))
+    found?))
+
+(define (set-empty? set)
+  (null? (get-node set)))
+
+(define (set-disjoint? set1 set2)
+  (set-empty? (set-intersection set1 set2)))
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Accessors
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define (set-member set element default)
+  (search (set-element-comparator set)
+          (get-node set)
+          element
+          (lambda () default)))
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Updaters
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define (set-adjoin set . elements)
+  (set-adjoin-all set elements))
+(define set-adjoin! set-adjoin)
+
+(define (set-replace set . elements)
+  (set-replace-all elements))
+(define set-replace! set-replace)
+
+(define (set-delete-all set elements)
+  (let ((cmp (set-element-comparator set)))
+    (fold (cut delete cmp <> <>) set elements)))
+(define set-delete-all! set-delete-all)
+
+(define (set-delete set . elements)
+  (set-delete-all set elements))
+(define set-delete! set-delete)
+
+(define (set-search! set element failure success)
+  ;; The SRFI mandates that `failure` and `success` are tail-called.
+  (define (%insert obj)
+    (values (set-adjoin set element) obj))
+  (define (%ignore obj)
+    (values set obj))
+  (define (%remove obj)
+    (values (set-remove set element) obj))
+  (define (%update new-element obj)
+    (values (set-replace (set-remove set element) new-element)
+            obj))
+  (let ((value (set-member set element (eof-object))))
+    (if (eof-object? value)
+        (failure %insert %ignore)
+        (success value %update %remove))))
+
+(define (set-size set) (get-size (get-node set)))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The whole set
+;;; 
+;;; Although these functions use generators, they cannot use the
+;;; generator SRFIs, because they might include the false value.
+;;; (this is an example of `false` acting like a null value, except
+;;; in the case of generators, there is no clever getting around it
+;;; like `assoc` or `member`).
+;;; 
+;;; Performance note: generators mutate values and hence might not work
+;;; well with write-barrier based systems like Chicken.
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (set-find predicate? set failure)
+  (let ((gen (set->generator set)))
+    (let loop ((value (gen)))
+      (cond
+        ((eof-object? value) (failure))
+        ((predicate? value) value)
+        (else (loop (gen)))))))
+
+(define (set-count predicate set)
+  (define (count node)
+    (if (null? node)
+        0
+        (+ (if (predicate (get-data node)) 1 0)
+           (count (get-left node))
+           (count (get-right node)))))
+  (count (get-node set)))
+
+(define (set-any? predicate set)
+  (let ((gen (set->generator set)))
+    (let loop ((value (gen)))
+      (cond
+        ((eof-object? value) #f)
+        ((predicate value) #t)
+        (else (loop (gen)))))))
+
+(define (set-every? predicate set)
+  (let ((gen (set->generator set)))
+    (let loop ((value (gen)))
+      (cond
+        ((eof-object? value) #t)
+        ((predicate value) (loop (gen)))
+        (else #f)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Mapping and folding
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (set-map comparator proc old-set)
+  (let ((gen (set->generator old-set)))
+    (let set-map ((new-node '())
+                  (value (gen)))
+      (if (eof-object? value)
+          (raw-set comparator new-node)
+          (set-map (insert comparator new-node (proc value))
+                   (gen))))))
+
+(define (set-for-each proc set)
+  (let loop ((node (get-node set)))
+    (when (not (null? node))
+      (proc (get-data node))
+      (loop (get-left node))
+      (loop (get-right node)))))
+
+(define (set-fold proc nil set)
+  (define (node-fold nil node)
+    (if (null? node)
+        nil
+        (with-node (node data ("<" left) (">" right))
+          (let ((nil (proc data nil)))
+            (node-fold (node-fold nil left) right)))))
+  (node-fold nil (get-node set)))
+
+(define (set-filter predicate? set)
+  (define (loop node)
+    (if (null? node)
+        '()
+        (with-node (node data ("<" left) (">" right))
+          (if (predicate? data)
+              (join data (loop left) (loop right))
+              (join2 (loop left) (loop right))))))
+  (raw-set (set-element-comparator set)
+           (loop (get-node set))))
+(define set-filter! set-filter)
+
+(define (set-remove predicate? set)
+  (set-filter (lambda (x)
+                (not (predicate? x)))
+              set))
+(define set-remove! set-remove)
+
+(define (set-partition predicate? set)
+  (define (loop node)
+    (if (null? node)
+        (values '() '())
+        (with-node (node data ("<" left) (">" right))
+          (let-values (((yes-left no-left)
+                        (loop left))
+                       ((yes-right no-right)
+                        (loop right)))
+            (if (predicate? data)
+                (values (join data yes-left yes-right)
+                        (join2 no-left no-right))
+                (values (join2 yes-left yes-right)
+                        (join data no-left no-right)))))))
+  (let-values (((yes no) (loop (get-node set)))
+               ((cmp) (set-element-comparator set)))
+    (values (raw-set cmp yes)
+            (raw-set cmp no))))
+
+(define set-partition! set-partition)
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Copying and conversion
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+
+(define (set-copy set)
+  ;; NOTE: This function is useless for this implementation because nodes
+  ;; can never be modified.
+  set
+  #;(define (node-copy node)
+      (if (null? node)
+          '()
+          (with-node (node data ("<" left) (">" right))
+            (wb-tree-node data (node-copy left) (node-copy right)))))
+  #;(raw-set (get-element-comparator set) (node-copy node)))
+
+(define (list->set comparator lst)
+  (set-unfold comparator null? car cdr lst))
+
+(define (set->list set)
+  (generator->list (set->generator set)))
+
+(define (list->set! set elements)
+  (set-union set (list->set (set-element-comparator set) elements)))
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Subsets
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(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)))))))
+(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))))))))
+
+(define set<=?
+  (apply-nary-predicate
+   (lambda (cmp 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)))))
+
+(define set>?
+  (apply-nary-predicate
+   (lambda (cmp set1 set2)
+     (and (> (set-size set1) (set-size set2))
+          (set-every? (cut set-contains? set1 <>) set2)))))
+
+(define set>=?
+  (apply-nary-predicate
+   (lambda (cmp set1 set2)
+     (and (>= (set-size set1) (set-size set2))
+          (set-every? (cut set-contains? set1 <>) set2)))))
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Set theory operations
+;;; ;;;;;;;;;;;;;;;;
+
+(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
+            (begin
+              (check-compatible! arg1 (car arg-rest))
+              (loop (binary cmp arg1 (car arg-rest)) (cdr arg-rest))))))))
+
+(define set-union (apply-nary-procedure union))
+(define set-union! set-union)
+
+(define set-intersection (apply-nary-procedure intersection))
+(define set-intersection! set-intersection)
+
+(define set-difference (apply-nary-procedure difference))
+(define set-difference! set-difference)
+
+(define set-xor (apply-nary-procedure xor))
+(define set-xor! set-xor)
+
+;;; ;;;;;;;;;;;;
+;;; exported extensions
+;;; ;;;;;;;;;;;;
+
+(define (set-adjoin-all set elements)
+  (let ((cmp (set-element-comparator set)))
+    (fold (lambda (new set)
+            (update cmp
+                    set
+                    new
+                    (lambda (old) old)
+                    (lambda ()
+                      (wb-tree-node new '() '()))))
+          (get-node set)
+          elements)))
+
+(define (set-replace-all set elements)
+  (let ((cmp (set-element-comparator set)))
+    (fold (lambda (new set)
+            (update cmp
+                    set
+                    new
+                    (lambda (old) new)
+                    (lambda ()
+                      (wb-tree-node new '() '()))))
+          (get-node set)
+          elements)))
+
+(define (generator->set comparator gen)
+  (raw-set comparator (generator->node comparator gen)))
+
+(define (set->generator set)
+  (node->generator (get-node set)))
+
+(define (set->in-order-generator set)
+  (node->in-order-generator (get-node set)))
+
+(define (set->reverse-order-generator set)
+  (node->reverse-order-generator (get-node set)))
+
+(define compatible-sets?
+  (apply-nary-predicate
+   (lambda (cmp s1 s2)
+     (and (eq? cmp (set-element-comparator s1))
+          (eq? cmp (set-element-comparator s2))))))
+
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.sld b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
new file mode 100644
index 0000000..ccc578d
--- /dev/null
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
@@ -0,0 +1,35 @@
+#| 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 sets)
+  (import (scheme base)
+          (scheme case-lambda)
+          (mcgoron weight-balanced-trees internal)
+          (srfi 1) (srfi 26) (srfi 128) (srfi 158))
+  (export set set-unfold
+          set? set-contains? set-empty? set-disjoint?
+          set-member set-element-comparator
+          set-adjoin set-adjoin! set-replace set-replace!
+          set-delete set-delete! set-delete-all set-delete-all! set-search!
+          set-size set-find set-count set-any? set-every?
+          set-map set-for-each set-fold set-filter set-filter! set-remove set-remove! set-partition set-partition!
+          set-copy set->list list->set list->set!
+          set=? set<? set>? set<=? set>=?
+          set-union set-intersection set-difference set-xor
+          set-union! set-intersection! set-difference! set-xor!
+          ;;  Extra procedures
+          compatible-sets? generator->set set->generator)
+  (include "sets.scm"))
+