add set-contains? test, remove NaNs because they cannot be used in the default comparator

4 files changed, 67 insertions, 47 deletions

diff --git a/doc/mcgoron.weight-balanced-trees.internal.scm b/doc/mcgoron.weight-balanced-trees.internal.scm
index 07eacc1..13b2925 100644
--- a/doc/mcgoron.weight-balanced-trees.internal.scm
+++ b/doc/mcgoron.weight-balanced-trees.internal.scm
@@ -64,8 +64,8 @@ all values to the right of `key`.
 If a value that compares equal to `key` is found, that value is returned.
 Otherwise the result of calling `default` with no arguments is returned.")
  ((name . "search")
-  (signature case-lambda ((((comparator? cmp) (balanced? tree) key) *)
-                          (((comparator? cmp) (balanced? tree) key (procedure? default)) *)))
+  (signature case-lambda ((((comparator? cmp) key (balanced? tree)) *)
+                          (((comparator? cmp) key (balanced? tree) (procedure? default)) *)))
   (subsigs (default (lambda () *)))
   (desc "
 * It is an error if `cmp` does not order `key` and all elements in `tree`.
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index 5b456b1..bc6c7bd 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -46,6 +46,7 @@
 (define (set-contains? set element)
   (let ((found? #t))
     (search (set-element-comparator set)
+            element
             (get-node set)
             (lambda () (set! found? #f)))
     found?))
diff --git a/tests/run.scm b/tests/run.scm
index a4e504a..9d754a6 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -26,7 +26,7 @@
 (test-runner-current (test-runner-create))
 (set-verbosity! '(fails))
 
-(define-library (mcgoron weight-balanced-trees test internal)
+#;(define-library (mcgoron weight-balanced-trees test internal)
   (import (scheme base)
           (chicken condition)
           (mcgoron weight-balanced-trees test util)
@@ -42,7 +42,7 @@
   (include "internal.scm"))
 
 (define-library (mcgoron weight-balanced-trees test srfi 113 sets)
-  (import (scheme base)
+  (import (scheme base) (scheme write) (scheme inexact)
           (chicken condition)
           (except (mcgoron srfi 64) factory)
           (srfi 1) (srfi 26) (srfi 64) (srfi 69) (srfi 128)
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 6cbb1ae..82da12b 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -13,24 +13,28 @@
  | limitations under the License.
  |#
 
+(define test-expensive #f)
+(define cmp (make-default-comparator))
+
 (define (orderable-generator)
   ;; Return a value that can be ordered in an obvious way.
-  (gsampling (boolean-generator)
-             (real-generator)
-             (char-generator)
-             (string-generator)
-             (bytevector-generator)))
+  (gfilter (lambda (x) (or (not (number? x))
+                           (not (nan? x))))
+           (gsampling (boolean-generator)
+                      (real-generator)
+                      (char-generator)
+                      (string-generator)
+                      (bytevector-generator))))
 
 (define (remove-duplicates generator)
   ;; Remove duplicates (according to the default comparator) from vectors
   ;; made by `generator`.
   (gmap (lambda (vec)
-          (let* ((cmp (make-default-comparator))
-                 (table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
+          (let* ((table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
                  (n 0))
             (vector-for-each
              (lambda (value)
-               (when (hash-table-ref/default table value #f)
+               (when (not (hash-table-ref/default table value #f))
                  (hash-table-set! table value #t)
                  (set! n (+ n 1))))
              vec)
@@ -43,8 +47,19 @@
               new-vec)))
         generator))
 
+(define (split-vector gen)
+  ;; Split vectors in half.
+  (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 (%set . elements)
-  (apply set (make-default-comparator) elements))
+  (apply set cmp elements))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Tests
@@ -84,25 +99,24 @@
       (test-call "length?" (<= (set-size new-set) (length lst)))
       (test-call "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 (vector-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 (vector-generator-of (orderable-generator)))))
-
-(test-group "multiple element set using `set-unfold` procedure"
-  (test-property (test-create-with-duplicates
+(when test-expensive
+  (test-group "multiple element set using `list->set` procedure"
+    (test-property (test-create-with-duplicates
+                  (cute list->set cmp <>))
+                   (list (vector-generator-of (orderable-generator)))))
+  (test-group "multiple element set using `set` procedure"
+    (test-property (test-create-with-duplicates
+                  (cute apply set cmp <...>))
+                   (list (vector-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)
+                        cmp
                         null?
                         car
                         cdr
                         <>))
-                 (list (vector-generator-of (orderable-generator)))))
+                   (list (vector-generator-of (orderable-generator))))))
 
 (define (test-create-without-duplicates creator)
   (lambda (vec)
@@ -116,33 +130,38 @@
       (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, unique elements"
-  (test-property (test-create-without-duplicates
-                  (cute list->set (make-default-comparator) <>))
-                 (list (remove-duplicates
+(when test-expensive
+  (test-group "multiple element set using `list->set` procedure, unique elements"
+    (test-property (test-create-without-duplicates
+                  (cute list->set cmp <>))
+                   (list (remove-duplicates
                         (vector-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
+  (test-group "multiple element set using `set` procedure, unique elements"
+    (test-property (test-create-without-duplicates
+                  (cute apply set cmp <...>))
+                   (list (remove-duplicates
                         (vector-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
+  (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 (remove-duplicates
                         (vector-generator-of
-                         (orderable-generator))))))
+                         (orderable-generator)))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-contains
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(test-group "set-contains?"
+  (define (set-contains-from vec)
+    (let ((set (list->set cmp (vector->list vec))))
+      (vector-for-each
+       (lambda (value)
+         (test-call "contains" (set-contains? set value)))
+       vec)))
+  (test-property set-contains-from
+                 (list (remove-duplicates (vector-generator-of
+                                           (orderable-generator))))))
+