test set-every, set-delete, and set=?

5 files changed, 105 insertions, 11 deletions

diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.scm b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
index 2fdf0ed..03f5045 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.scm
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.scm
@@ -105,7 +105,12 @@
 
 (define (set-delete-all set elements)
   (let ((cmp (set-element-comparator set)))
-    (fold (cut delete cmp <> <>) set elements)))
+    (raw-set
+     cmp
+     (fold (lambda (element node)
+             (delete cmp node element))
+           (get-node set)
+           elements))))
 (define set-delete-all! set-delete-all)
 
 (define (set-delete set . elements)
@@ -163,8 +168,8 @@
 (define (set-every? predicate set)
   (set-find (lambda (x) (not (predicate x)))
             set
-            (lambda () #f)
-            (lambda (x) #t)))
+            (lambda () #t)
+            (lambda (x) #f)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Mapping and folding
diff --git a/mcgoron/weight-balanced-trees/srfi/113/sets.sld b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
index ccc578d..fffb7fa 100644
--- a/mcgoron/weight-balanced-trees/srfi/113/sets.sld
+++ b/mcgoron/weight-balanced-trees/srfi/113/sets.sld
@@ -17,7 +17,7 @@
   (import (scheme base)
           (scheme case-lambda)
           (mcgoron weight-balanced-trees internal)
-          (srfi 1) (srfi 26) (srfi 128) (srfi 158))
+          (except (srfi-1) delete) (srfi 26) (srfi 128) (srfi 158))
   (export set set-unfold
           set? set-contains? set-empty? set-disjoint?
           set-member set-element-comparator
diff --git a/tests/run.scm b/tests/run.scm
index d5920d5..0d5f561 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -47,6 +47,7 @@
           (except (mcgoron srfi 64) factory)
           (srfi 1) (srfi 26) (srfi 64) (srfi 69) (srfi 128)
           (srfi 133) (srfi 158) (srfi 194) (srfi 252)
-          (mcgoron weight-balanced-trees srfi 113 sets))
+          (mcgoron weight-balanced-trees srfi 113 sets)
+          (mcgoron weight-balanced-trees srfi 113 252))
   (include "srfi-113-sets.scm"))
 
diff --git a/tests/srfi-113-sets.scm b/tests/srfi-113-sets.scm
index adcb091..6db4b24 100644
--- a/tests/srfi-113-sets.scm
+++ b/tests/srfi-113-sets.scm
@@ -19,6 +19,9 @@
 (define test-set-adjoin #f)
 (define test-set-find #f)
 (define test-set-disjoint #f)
+(define test-set-every #t)
+(define test-set-delete #t)
+(define test-set= #t)
 (define test-set-intersection #t)
 
 (define cmp (make-default-comparator))
@@ -73,7 +76,11 @@
   ;; Return a set of random elements.
   (gcons* (set cmp)
           (gmap (lambda (vec)
-                  (list->set cmp (vector->list vec)))
+                  (set-unfold cmp
+                              (cute = <> (vector-length vec))
+                              (cut vector-ref vec <>)
+                              (cut + <> 1)
+                              0))
                 (unique-vector))))
 
 (define (filter-non-empty-sets set-generator)
@@ -111,13 +118,13 @@
                  (list->set cmp (vector->list v2)))))
         (split-unique-vectors)))
 
+(define (find-some-element s1)
+  (set-find (lambda (x) #t) s1 (lambda () (error "s1 is empty" s1))))
+
 (define (split-non-disjoint-sets)
   (gmap (call/split
          (lambda (s1 s2)
-           (let* ((from-s1 (set-find (lambda (x) #t)
-                                     s1
-                                     (lambda ()
-                                       (error "s1 is empty" s1))))
+           (let* ((from-s1 (find-some-element s1))
                   (s2 (set-adjoin s2 from-s1)))
              (list s1 s2))))
         (split-unique-sets)))
@@ -321,6 +328,77 @@
                       include-makes-not-disjoint)
                      (list (split-non-disjoint-sets))))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;
+;;; set-every
+;;; ;;;;;;;;;;;;;;;;;;;;;
+
+(define (less-than-10 x) (< x 10))
+
+(when test-set-every
+  (test-group "set-every less than 10"
+    (test-property (cut set-every? less-than-10 <>)
+                   (list
+                    (set-generator-of (gfilter
+                                       less-than-10
+                                       (exact-integer-generator))))))
+  (test-group "set-every less than 10, another element added"
+    (define (not-less-than-10 set)
+      (let ((set (set-adjoin set 100)))
+        (not (set-every? less-than-10 set))))
+    (test-property not-less-than-10
+                   (list
+                    (set-generator-of cmp
+                                      (gfilter
+                                       less-than-10
+                                       (exact-integer-generator))
+                                      20)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; set-delete
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set-delete
+  (test-group "delete from empty set is always empty"
+    (define (delete-from-empty element)
+      (set-empty? (set-delete (set cmp) element)))
+    (test-property delete-from-empty (list (orderable-generator))))
+  (test-group "delete from singleton set is empty"
+    (define (delete-from-singleton element)
+      (set-empty? (set-delete (set cmp element) element)))
+    (test-property delete-from-singleton (list (orderable-generator))))
+  (test-group "delete of element from set keeps the rest"
+    (define (delete-some-element set)
+      (let* ((some-element (find-some-element set))
+             (set* (set-delete set some-element)))
+        (and (not (set-contains? set* some-element))
+             (set-every? (cut set-contains? set <>) set*))))
+    (test-property delete-some-element
+                   (list (filter-non-empty-sets
+                          (random-sets))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; set=?
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when test-set=
+  (test-group "sets are set= to themselves"
+    (define (always-set= set)
+      (set=? set set))
+    (test-property always-set= (list (random-sets))))
+  (test-group "set with one element deleted is not set="
+    (define (not-set=? set)
+      (let ((set* (set-delete set (find-some-element set))))
+        (not (set=? set set*))))
+    (test-property not-set=? (list (filter-non-empty-sets
+                                    (random-sets)))))
+  (test-group "two unique sets are not set="
+    (define (unique-not-set= set1 set2)
+      (if (and (set-empty? set1) (set-empty? set2))
+          #t
+          (not (set=? set1 set2))))
+    (test-property (call/split unique-not-set=)
+                   (list (split-unique-sets)))))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Set-intersection
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
@@ -348,5 +426,9 @@
                      (list (split-unique-sets))))
     (test-group "non-empty intersections are non-disjoint sets"
       (test-property (call/split empty-intersection-implies-disjoint)
-                     (list (split-non-disjoint-sets))))))
+                     (list (split-non-disjoint-sets))))
+    ;; More tests:
+    ;; intersection of self is self
+    ;; intersection is subset of both sets (test subset beforehand?)
+))
 
diff --git a/weight-balanced-trees.egg b/weight-balanced-trees.egg
index 3243bc1..b6c5d82 100644
--- a/weight-balanced-trees.egg
+++ b/weight-balanced-trees.egg
@@ -15,4 +15,10 @@
                (types-file)
                (source-dependencies "mcgoron/weight-balanced-trees/srfi/113/sets.scm")
                (component-dependencies mcgoron.weight-balanced-trees.internal)
+               (csc-options "-O3" "-R" "r7rs" "-X" "r7rs")))
+ (components (extension mcgoron.weight-balanced-trees.srfi.113.252
+               (source "mcgoron/weight-balanced-trees/srfi/113/252.sld")
+               (types-file)
+               (source-dependencies "mcgoron/weight-balanced-trees/srfi/113/252.scm")
+               (component-dependencies mcgoron.weight-balanced-trees.srfi.113.sets)
                (csc-options "-O3" "-R" "r7rs" "-X" "r7rs"))))