tests for different constructors

3 files changed, 175 insertions, 66 deletions

diff --git a/doc/mcgoron.weight-balanced-trees.srfi.113.sets.scm b/doc/mcgoron.weight-balanced-trees.srfi.113.sets.scm
new file mode 100644
index 0000000..8152521
--- /dev/null
+++ b/doc/mcgoron.weight-balanced-trees.srfi.113.sets.scm
@@ -0,0 +1,48 @@
+(((name . "set-xor")
+  (signature lambda ((set? set1) (set? set2) ...) set?)
+  (desc "
+A left associative version of `set-xor` from SRFI-113 that takes any number
+of arguments."))
+ ((name . "set->generator")
+  (signature
+   case-lambda
+   (((set? set)) procedure?)
+   (((set? set) *) procedure?))
+  (desc "
+Returns a generator that returns the elements of `set` in arbitrary order.
+
+This generator is always finite."))
+ ((name . "set-adjoin-all")
+  (signature
+   lambda ((set? set) (list? elements)) set?)
+  (desc "
+Equivalent to `(apply set-adjoin set elements)`."))
+ ((name . "set-replace-all")
+  (signature
+   lambda ((set? set) (list? elements)) set?)
+  (desc "
+Equivalent to `(apply set-replace set elements)`."))
+ ((name . "generator->set")
+  (signature lambda ((comparator? comparator) (generator? gen)) set?)
+  (desc "
+* It is an error if `gen` is not finite.
+* It is an error if the elements of `gen` are not comparable by
+  `comparator`.
+
+Returns a set whose elements are the elements of `gen`. If there are
+duplicate elements in `gen`, the latest one will be kept."))
+ ((name . "set->in-order-generator")
+  (signature
+   lambda ((set? set)) generator?)
+  (desc "
+Like `generator->set`, but elements are returned in order."))
+ ((name . "set->reverse-order-generator")
+  (signature
+   lambda ((set? set)) generator?)
+  (desc "
+Like `generator->set`, but elements are returned in reverse order."))
+ ((name . "compatible-sets?")
+  (signature lambda ((set? set1) (set? set2) ...) set?)
+  (desc "
+Returns `#t` if each set has the same comparator, and `#f` otherwise.")))
+
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index d9552db..7c31ece 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -107,24 +107,21 @@
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 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-find
+  (case-lambda
+    ((predicate set default-value)
+     (set-find predicate set default-value (lambda (x) x)))
+    ((predicate set default-value transform)
+     (let loop ((queue (list (get-node set))))
+       (cond
+         ((null? queue) default-value)
+         ((null? (car queue)) (loop (cdr queue)))
+         (else (with-node ((car queue) data ("<" left) (">" right))
+                 (if (predicate data)
+                     (transform data)
+                     (loop (cons* left right (cdr queue)))))))))))
 
 (define (set-count predicate set)
   (define (count node)
@@ -136,33 +133,25 @@
   (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)))))))
+  (set-find predicate set (lambda () #f) (lambda (x) #t)))
 
 (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)))))
+  (set-find (lambda (x) (not (predicate x)))
+            set
+            (lambda () #f)
+            (lambda (x) #t)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 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))))))
+  (let ((cmp (set-element-comparator old-set)))
+    (raw-set cmp
+             (set-fold (lambda (value new-node)
+                         (insert cmp new-node (proc value)))
+                       '()
+                       old-set))))
 
 (define (set-for-each proc set)
   (let loop ((node (get-node set)))
@@ -235,10 +224,14 @@
   #;(raw-set (get-element-comparator set) (node-copy node)))
 
 (define (list->set comparator lst)
-  (set-unfold comparator null? car cdr lst))
+  (let loop ((node '())
+             (lst lst))
+    (if (null? lst)
+        (raw-set comparator node)
+        (loop (insert comparator node (car lst)) (cdr lst)))))
 
 (define (set->list set)
-  (generator->list (set->generator set)))
+  (set-fold cons '() set))
 
 (define (list->set! set elements)
   (set-union set (list->set (set-element-comparator set) elements)))
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index edb6334..a43ca33 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -13,33 +13,17 @@
  | limitations under the License.
  |#
 
-(import (mcgoron weight-balanced-trees srfi 113 sets)
-        (srfi 252)
-        (srfi 64))
-
 (define (orderable-generator)
   ;; Return a value that can be ordered in an obvious way.
-  (gsampling #;(boolean-generator)
+  (gsampling (boolean-generator)
              (real-generator)
-             #;(char-generator)
-             #;(string-generator)
-             #;(bytevector-generator)))
-
-(test-group "multiple element set using `set` procedure"
-  (define (multiple-element-set lst)
-    (let* ((new-set (apply set (make-default-comparator) 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))))
-      ;; The new-set will remove duplicates.
-      (test-assert "length?" (<= (set-size new-set) (length lst)))
-      (test-assert "subset of inserted" (lset<= equal? set-as-list lst))))
-  (test-property multiple-element-set
-                 (list (list-generator-of (orderable-generator)))))
+             (char-generator)
+             (string-generator)
+             (bytevector-generator)))
 
 (define (remove-duplicates generator)
+  ;; Remove duplicates (according to the default comparator) from lists
+  ;; made by `generator`.
   (gmap (lambda (lst)
           (let ((cmp (make-default-comparator)))
             (let loop ((seen '())
@@ -53,19 +37,103 @@
                 (else (loop (cons (car lst) seen) (cdr lst)))))))
         generator))
 
-(test-group "multiple element set using `set` procedure, unique elements"
-  (define (multiple-element-set lst)
-    (let* ((new-set (apply set (make-default-comparator) lst))
+(define (%set . elements)
+  (apply set (make-default-comparator) elements))
+
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Tests
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(test-group "set-empty?"
+  (test-assert "empty" (set-empty? (%set)))
+  (test-assert "not empty 1"
+               (not (set-empty? (%set 0))))
+  (test-assert "not empty 2"
+               (not (set-empty? (%set 0 1))))
+  (test-assert "not empty 3"
+               (not (set-empty? (%set 0 1 2))))
+  (test-assert "not empty 4"
+               (not (set-empty? (%set 0 1 2 3)))))
+
+(test-group "lengths"
+  (test-equal "0" 0 (set-size (%set)))
+  (test-equal "1" 1 (set-size (%set 0)))
+  (test-equal "2" 2 (set-size (%set 0 1)))
+  (test-equal "3" 3 (set-size (%set 0 1 2)))
+  (test-equal "4" 4 (set-size (%set 0 1 2 3))))
+
+(test-group "set->list"
+  (test-equal "empty" '() (set->list (%set)))
+  (test-assert "1" (lset= = '(1) (set->list (%set 1))))
+  (test-assert "2" (lset= = '(1 2) (set->list (%set 1 2))))
+  (test-assert "3" (lset= = '(0 1 2) (set->list (%set 0 1 2))))
+  (test-assert "4" (lset= = '(0 1 2 3) (set->list (%set 0 1 2 3)))))
+
+(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))
+      (test-assert "empty?" (if (null? lst)
+                                (set-empty? new-set)
+                                (not (set-empty? new-set))))
+      ;; The new-set will remove duplicates.
+      (test-assert "length?" (<= (set-size new-set) (length lst)))
+      (test-assert "subset of 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 (make-default-comparator) <>))
+                 (list (list-generator-of (orderable-generator)))))
+
+(test-group "multiple element set using `set` procedure"
+  (test-property (test-create-with-duplicates
+                  (cute apply set (make-default-comparator) <...>))
+                 (list (list-generator-of (orderable-generator)))))
+
+(test-group "multiple element set using `set-unfold` procedure"
+  (test-property (test-create-with-duplicates
+                  (cute set-unfold
+                        (make-default-comparator)
+                        null?
+                        car
+                        cdr
+                        <>))
+                 (list (list-generator-of (orderable-generator)))))
+
+(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))))
-      (dynamic-property-set! 'set set-as-list)
-      (dynamic-property-set! 'list lst)
       (test-equal "length?" (set-size new-set) (length lst))
-      (test-assert "exactly inserted" (lset= equal? set-as-list lst))))
-  (test-property multiple-element-set
+      (test-assert "exactly inserted" (lset= equal? set-as-list lst)))))
+
+(test-group "multiple element set using `list->set` procedure, unique elements"
+  (test-property (test-create-without-duplicates
+                  (cute list->set (make-default-comparator) <>))
+                 (list (remove-duplicates
+                        (list-generator-of
+                         (orderable-generator))))))
+
+(test-group "multiple element set using `set` procedure, unique elements"
+  (test-property (test-create-without-duplicates
+                  (cute apply set (make-default-comparator) <...>))
                  (list (remove-duplicates
                         (list-generator-of
                          (orderable-generator))))))
+
+(test-group "multiple element set using `set-unfold` procedure, unique elements"
+  (test-property (test-create-without-duplicates
+                  (cute set-unfold
+                        (make-default-comparator)
+                        null?
+                        car
+                        cdr
+                        <>))
+                 (list (remove-duplicates
+                        (list-generator-of
+                         (orderable-generator))))))
\ No newline at end of file