member, adjoin and find tests

3 files changed, 89 insertions, 21 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index 768be10..20f01d9 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -64,8 +64,8 @@
 
 (define (set-member set element default)
   (search (set-element-comparator set)
-          (get-node set)
           element
+          (get-node set)
           (lambda () default)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;
@@ -118,7 +118,7 @@
     ((predicate set default-value transform)
      (let loop ((queue (list (get-node set))))
        (cond
-         ((null? queue) default-value)
+         ((null? queue) (default-value))
          ((null? (car queue)) (loop (cdr queue)))
          (else (with-node ((car queue) data ("<" left) (">" right))
                  (if (predicate data)
@@ -330,15 +330,16 @@
 
 (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)))
+    (raw-set
+     cmp
+     (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)))
diff --git a/tests/run.scm b/tests/run.scm
index 9d754a6..d5920d5 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -46,7 +46,7 @@
           (chicken condition)
           (except (mcgoron srfi 64) factory)
           (srfi 1) (srfi 26) (srfi 64) (srfi 69) (srfi 128)
-          (srfi 158) (srfi 194) (srfi 252)
+          (srfi 133) (srfi 158) (srfi 194) (srfi 252)
           (mcgoron weight-balanced-trees srfi 113 sets))
   (include "srfi-113-sets.scm"))
 
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index 8bd6299..5a220c7 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -15,7 +15,10 @@
 
 (define test-constructor #f)
 (define test-set-contains #f)
-(define test-set-disjoint #t)
+(define test-set-member #t)
+(define test-set-find #t)
+(define test-set-adjoin #t)
+(define test-set-disjoint #f)
 
 (define cmp (make-default-comparator))
 
@@ -72,6 +75,10 @@
                   (list->set cmp (vector->list vec)))
                 (unique-vector))))
 
+(define (filter-non-empty-sets set-generator)
+  (gfilter (lambda (set) (not (set-empty? set)))
+           set-generator))
+
 (define (split-vector gen)
   ;; Split vectors in half, return it as a list.
   (gmap (lambda (vec)
@@ -186,22 +193,82 @@
   (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)))
+        (vector-every (cut set-contains? set <>) vec)))
     (test-property set-contains-from (list (unique-vector))))
   (test-group "not set-contains?"
     (define (set-does-not-contain vecs)
       (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-for-each
+            (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-member
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-member
+  (test-group "set-member"
+    (define (set-member-from vec)
+      (let ((set (list->set cmp (vector->list vec))))
+        (vector-every (lambda (value)
+                        (eq?
+                         value
+                         (set-member set value set-member-from)))
+                      vec)))
+    (test-property set-member-from (list (unique-vector))))
+  (test-group "not set-member"
+    (define (set-not-member vecs)
+      (let ((set (list->set cmp (vector->list (list-ref vecs 0))))
+            (not-in (list-ref vecs 1)))
+        (vector-every
          (lambda (value)
-           (test-call "does not contain" (set-does-not-contain? set value)))
+           (eq? (set-member set value set-not-member)
+                set-not-member))
          not-in)))
-    (test-property set-does-not-contain (list (split-unique-vectors)))))
+    (test-property set-not-member (list (split-unique-vectors)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Set-adjoin
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-adjoin
+  (test-group "set contains after adjoin"
+    (define (set-contains-after-adjoin set element)
+      (set-contains? (set-adjoin set element) element))
+    (test-property set-contains-after-adjoin (list (random-sets)
+                                                   (orderable-generator))))
+  (test-group "adjoin returns the old element"
+    (define (set-returns-old set element)
+      (let* ((el1 (cons element element))
+             (el2 (cons element element))
+             (set (set-adjoin set el1))
+             (set (set-adjoin set el2)))
+        (eq? (set-member set el2 (lambda () #f)) el1)))
+    (test-property set-returns-old (list (random-sets)
+                                         (orderable-generator)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Set-find
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-find
+  (test-equal "set-find on empty set always return false"
+              #f
+              (set-find (lambda (x) #t) (set cmp) (lambda () #f)))
+  (test-group "set-find on non-empty set can return something"
+    (define (set-find-something set)
+      (not
+       (eq? (set-find (lambda (x) #t) set (lambda () set-find-something))
+            set-find-something)))
+    (test-property set-find-something (list (filter-non-empty-sets
+                                             (random-sets)))))
+  (test-group "set-find a number"
+    (define (set-find-a-number set)
+      (let ((set (set-adjoin set 0)))
+        (number? (set-find number? set (lambda () set-find-a-number)))))
+    (test-property set-find-a-number (list (random-sets)))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; set-disjoint?