peter/weight-balanced-trees
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Peter McGoron 2025-02-17 14:59:44 -05:00
parent e1622eadb6
commit 98da920c04
5 changed files with 105 additions and 11 deletions

11
mcgoron/weight-balanced-trees/srfi/113/sets.scm
View file

@ -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

2
mcgoron/weight-balanced-trees/srfi/113/sets.sld
View file

@ -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

3
tests/run.scm
View file

@ -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"))

94
tests/srfi-113-sets.scm
View file

@ -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?)
))

6
weight-balanced-trees.egg
View file

@ -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"))))