mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
adding srfi 113
This commit is contained in:
Alex Shinn
parent
7cd26b9823
commit
ab88f53e48
5 changed files with 1243 additions and 0 deletions
66
lib/srfi/113.sld
Normal file
66
lib/srfi/113.sld
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
|
||||
(define-library (srfi 113)
|
||||
(import (scheme base) (srfi 1) (srfi 125) (srfi 128))
|
||||
(export
|
||||
;;;;;;;;;;;;;; Sets
|
||||
;; Constructors:
|
||||
set set-contains? set-unfold
|
||||
;; Predicates:
|
||||
set? set-empty? set-disjoint?
|
||||
;; Accessors:
|
||||
set-member set-element-comparator
|
||||
;; Updaters:
|
||||
set-adjoin set-adjoin! set-replace set-replace!
|
||||
set-delete set-delete! set-delete-all set-delete-all!
|
||||
set-search!
|
||||
;; The whole set:
|
||||
set-size set-find set-count set-any? set-every?
|
||||
;; Mapping and folding:
|
||||
set-map set-for-each set-fold set-filter set-filter!
|
||||
set-remove set-remove! set-partition set-partition!
|
||||
;; Copying and conversion:
|
||||
set-copy set->list list->set list->set!
|
||||
;; Subsets:
|
||||
set=? set<? set>? set<=? set>=?
|
||||
;; Set theory operations:
|
||||
set-union set-intersection set-difference set-xor
|
||||
set-union! set-intersection! set-difference! set-xor!
|
||||
;; Comparators:
|
||||
(rename the-set-comparator set-comparator)
|
||||
|
||||
;;;;;;;;;;;;;; Bags
|
||||
;; Constructors:
|
||||
bag bag-contains? bag-unfold
|
||||
;; Predicates:
|
||||
bag? bag-empty? bag-disjoint?
|
||||
;; Accessors:
|
||||
bag-member bag-element-comparator
|
||||
;; Updaters:
|
||||
bag-adjoin bag-adjoin! bag-replace bag-replace!
|
||||
bag-delete bag-delete! bag-delete-all bag-delete-all!
|
||||
bag-search!
|
||||
;; The whole bag:
|
||||
bag-size bag-find bag-count bag-any? bag-every?
|
||||
;; Mapping and folding:
|
||||
bag-map bag-for-each bag-fold bag-filter bag-filter!
|
||||
bag-remove bag-remove! bag-partition bag-partition!
|
||||
;; Copying and conversion:
|
||||
bag-copy bag->list list->bag list->bag!
|
||||
;; Subbags:
|
||||
bag=? bag<? bag>? bag<=? bag>=?
|
||||
;; Bag theory operations:
|
||||
bag-union bag-intersection bag-difference bag-xor
|
||||
bag-union! bag-intersection! bag-difference! bag-xor!
|
||||
;; Comparators:
|
||||
(rename the-bag-comparator bag-comparator)
|
||||
|
||||
;; Additional bag procedures:
|
||||
bag-unique-size
|
||||
bag-sum bag-sum! bag-product bag-product! bag-element-count
|
||||
bag-for-each-unique bag-fold-unique bag-increment! bag-decrement!
|
||||
bag->set set->bag set->bag!
|
||||
bag->alist alist->bag
|
||||
)
|
||||
(include-shared "69/hash")
|
||||
(include "113/sets.scm"
|
||||
"113/bags.scm"))
|
||||
344
lib/srfi/113/bags.scm
Normal file
344
lib/srfi/113/bags.scm
Normal file
|
|
@ -0,0 +1,344 @@
|
|||
|
||||
(define-record-type Bag (make-bag table comparator) bag?
|
||||
(table bag-table)
|
||||
(comparator bag-comparator))
|
||||
|
||||
(define (bag comparator . elts)
|
||||
(let ((res (make-bag (make-hash-table comparator) comparator)))
|
||||
(for-each (lambda (x) (bag-adjoin! res x)) elts)
|
||||
res))
|
||||
|
||||
(define (bag-unfold comparator stop? mapper successor seed)
|
||||
(let ((mapper (lambda (acc) (let ((elt (mapper acc))) (values elt 1)))))
|
||||
(make-bag (hash-table-unfold stop? mapper successor seed comparator)
|
||||
comparator)))
|
||||
|
||||
(define (bag-contains? bag element)
|
||||
(hash-table-contains? (bag-table bag) element))
|
||||
|
||||
(define (bag-empty? bag)
|
||||
(zero? (bag-size bag)))
|
||||
|
||||
(define (bag-disjoint? bag1 bag2)
|
||||
(if (< (hash-table-size (bag-table bag2))
|
||||
(hash-table-size (bag-table bag1)))
|
||||
(bag-disjoint? bag2 bag1)
|
||||
(let ((ht (bag-table bag2)))
|
||||
(not (hash-table-find (lambda (key value) (hash-table-contains? ht key))
|
||||
(bag-table bag1)
|
||||
(lambda () #f))))))
|
||||
|
||||
(define (bag-member bag element default)
|
||||
(let ((cell (hash-table-cell (bag-table bag) element #f)))
|
||||
(if cell (car cell) default)))
|
||||
|
||||
(define (bag-element-comparator bag)
|
||||
(bag-comparator bag))
|
||||
|
||||
(define (bag-adjoin bag . elts)
|
||||
(apply bag-adjoin! (bag-copy bag) elts))
|
||||
|
||||
(define (bag-adjoin! bag . elts)
|
||||
(for-each (lambda (elt)
|
||||
(hash-table-update!/default (bag-table bag)
|
||||
elt
|
||||
(lambda (count) (+ 1 count))
|
||||
0))
|
||||
elts)
|
||||
bag)
|
||||
|
||||
(define (bag-replace bag element)
|
||||
(bag-replace! (bag-copy bag) element))
|
||||
|
||||
(define (bag-replace! bag element)
|
||||
(when (hash-table-contains? (bag-table bag) element)
|
||||
(hash-table-delete! (bag-table bag) element)
|
||||
(hash-table-set! (bag-table bag) element 1))
|
||||
bag)
|
||||
|
||||
(define (bag-delete bag . elts)
|
||||
(bag-delete-all bag elts))
|
||||
|
||||
(define (bag-delete! bag . elts)
|
||||
(bag-delete-all! bag elts))
|
||||
|
||||
(define (bag-delete-all bag element-list)
|
||||
(bag-delete-all! (bag-copy bag) element-list))
|
||||
|
||||
(define (bag-delete-all! bag element-list)
|
||||
(let ((ht (bag-table bag)))
|
||||
(for-each (lambda (elt)
|
||||
(let ((count (- (hash-table-ref/default ht elt 0) 1)))
|
||||
(cond
|
||||
((positive? count) (hash-table-set! ht elt count))
|
||||
((zero? count) (hash-table-delete! ht elt)))))
|
||||
element-list))
|
||||
bag)
|
||||
|
||||
(define bag-search!
|
||||
(let ((not-found (list 'not-found)))
|
||||
(lambda (bag element failure success)
|
||||
(let ((elt (hash-table-ref/default (bag-table bag) element not-found)))
|
||||
(if (eq? elt not-found)
|
||||
(failure (lambda (obj)
|
||||
(hash-table-set! (bag-table bag) element 1)
|
||||
(values bag obj))
|
||||
(lambda (obj)
|
||||
(values bag obj)))
|
||||
(success elt
|
||||
(lambda (new-element obj)
|
||||
(hash-table-delete! (bag-table bag) element)
|
||||
(bag-adjoin! bag new-element)
|
||||
(values bag obj))
|
||||
(lambda (obj)
|
||||
(hash-table-delete! (bag-table bag) element)
|
||||
(values bag obj))))))))
|
||||
|
||||
(define (bag-size bag)
|
||||
(hash-table-fold (bag-table bag) (lambda (elt count acc) (+ count acc)) 0))
|
||||
|
||||
(define (bag-find predicate bag failure)
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(hash-table-for-each
|
||||
(lambda (elt count) (if (predicate elt) (return elt)))
|
||||
(bag-table bag))
|
||||
(failure))))
|
||||
|
||||
(define (bag-count predicate bag)
|
||||
(hash-table-fold (lambda (elt count acc) (+ acc (if (predicate elt) count 0)))
|
||||
0
|
||||
(bag-table bag)))
|
||||
|
||||
(define (bag-any? predicate bag)
|
||||
(and (hash-table-find (lambda (key value) (predicate key))
|
||||
(bag-table bag)
|
||||
(lambda () #f))
|
||||
#t))
|
||||
|
||||
(define (bag-every? predicate bag)
|
||||
(not (bag-any? (lambda (x) (not (predicate x))) bag)))
|
||||
|
||||
(define (bag-map comparator proc s)
|
||||
(bag-fold (lambda (elt res) (bag-adjoin! res (proc elt)))
|
||||
(bag comparator)
|
||||
s))
|
||||
|
||||
(define (bag-for-each proc bag)
|
||||
(hash-table-for-each (lambda (elt count)
|
||||
(let lp ((i count))
|
||||
(when (positive? i)
|
||||
(proc elt)
|
||||
(lp (- i 1)))))
|
||||
(bag-table bag)))
|
||||
|
||||
(define (bag-fold proc nil bag)
|
||||
(hash-table-fold (lambda (elt count acc)
|
||||
(let lp ((i count) (acc acc))
|
||||
(if (zero? i)
|
||||
acc
|
||||
(lp (- i 1) (proc elt acc)))))
|
||||
nil
|
||||
(bag-table bag)))
|
||||
|
||||
(define (bag-filter predicate st)
|
||||
(bag-fold (lambda (elt res)
|
||||
(if (predicate elt) (bag-adjoin! res elt) res))
|
||||
(bag (bag-comparator st))
|
||||
st))
|
||||
|
||||
(define bag-filter! bag-filter)
|
||||
|
||||
(define (bag-remove predicate bag)
|
||||
(bag-filter (lambda (elt) (not (predicate elt))) bag))
|
||||
|
||||
(define bag-remove! bag-remove)
|
||||
|
||||
(define (bag-partition predicate bag)
|
||||
(values (bag-filter predicate bag)
|
||||
(bag-remove predicate bag)))
|
||||
|
||||
(define bag-partition! bag-partition)
|
||||
|
||||
(define (bag-copy bag)
|
||||
(make-bag (hash-table-copy (bag-table bag))
|
||||
(bag-comparator bag)))
|
||||
|
||||
(define (bag->list bag)
|
||||
(hash-table-keys (bag-table bag)))
|
||||
|
||||
(define (list->bag comparator list)
|
||||
(fold (lambda (elt bag) (bag-adjoin! bag elt)) (bag comparator) list))
|
||||
|
||||
(define (list->bag! bag list)
|
||||
(fold (lambda (elt bag) (bag-adjoin! bag elt)) bag list))
|
||||
|
||||
(define (comparable-bags? bag1 bag2)
|
||||
(or (eq? (bag-comparator bag1) (bag-comparator bag2))
|
||||
(error "can't compare bags with different comparators" bag1 bag2)))
|
||||
|
||||
(define (bag=? bag1 . bags)
|
||||
(or (null? bags)
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(= (bag-size bag1) (bag-size (car bags)))
|
||||
(bag-every? (lambda (elt) (bag-contains? bag1 elt)) (car bags))
|
||||
(apply bag=? bags))))
|
||||
|
||||
(define (bag<? bag1 . bags)
|
||||
(or (null? bags)
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(< (bag-size bag1) (bag-size (car bags)))
|
||||
(bag-every? (lambda (elt) (bag-contains? (car bags) elt)) bag1)
|
||||
(apply bag<? bags))))
|
||||
|
||||
(define (bag>? . bags)
|
||||
(apply bag<? (reverse bags)))
|
||||
|
||||
(define (bag<=? bag1 . bags)
|
||||
(or (null? bags)
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(<= (bag-size bag1) (bag-size (car bags)))
|
||||
(bag-every? (lambda (elt) (bag-contains? (car bags) elt)) bag1)
|
||||
(apply bag<=? bags))))
|
||||
|
||||
(define (bag>=? . bags)
|
||||
(apply bag<=? (reverse bags)))
|
||||
|
||||
(define (bag-union bag1 . bags)
|
||||
(apply bag-union! (bag-copy bag1) bags))
|
||||
|
||||
(define (bag-intersection bag1 . bags)
|
||||
(apply bag-intersection! (bag-copy bag1) bags))
|
||||
|
||||
(define (bag-difference bag1 . bags)
|
||||
(apply bag-difference! (bag-copy bag1) bags))
|
||||
|
||||
(define (bag-xor bag1 bag2)
|
||||
(bag-xor! (bag-copy bag1) bag2))
|
||||
|
||||
(define (bag-union! bag1 . bags)
|
||||
(if (null? bags)
|
||||
bag1
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(begin
|
||||
(hash-table-for-each
|
||||
(lambda (elt count)
|
||||
(hash-table-update!/default (bag-table bag1)
|
||||
elt
|
||||
(lambda (c) (max c count))
|
||||
count))
|
||||
(bag-table (car bags)))
|
||||
(apply bag-union! bag1 (cdr bags))))))
|
||||
|
||||
(define (bag-intersection! bag1 . bags)
|
||||
(if (null? bags)
|
||||
bag1
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(let ((ht (bag-table (car bags))))
|
||||
(hash-table-for-each
|
||||
(lambda (elt count)
|
||||
(let ((count2 (min count (hash-table-ref/default ht elt 0))))
|
||||
(if (positive? count2)
|
||||
(hash-table-set! (bag-table bag1) elt count2)
|
||||
(hash-table-delete! (bag-table bag1) elt))))
|
||||
(bag-table bag1))
|
||||
(apply bag-intersection! bag1 (cdr bags))))))
|
||||
|
||||
(define (bag-difference! bag1 . bags)
|
||||
(if (null? bags)
|
||||
bag1
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(let ((ht (bag-table (car bags))))
|
||||
(hash-table-for-each
|
||||
(lambda (elt count)
|
||||
(let ((count2 (- count (hash-table-ref/default ht elt 0))))
|
||||
(if (positive? count2)
|
||||
(hash-table-set! (bag-table bag1) elt count2)
|
||||
(hash-table-delete! (bag-table bag1) elt))))
|
||||
(bag-table bag1))
|
||||
(apply bag-difference! bag1 (cdr bags))))))
|
||||
|
||||
(define (bag-xor! bag1 bag2)
|
||||
(and (comparable-bags? bag1 bag2)
|
||||
(let ((ht1 (bag-table bag1))
|
||||
(ht2 (bag-table bag2)))
|
||||
(hash-table-for-each
|
||||
(lambda (elt count)
|
||||
(let ((count2 (abs (- count (hash-table-ref/default ht1 elt 0)))))
|
||||
(if (positive? count2)
|
||||
(hash-table-set! ht1 elt count2)
|
||||
(hash-table-delete! ht1 elt))))
|
||||
ht2)
|
||||
bag1)))
|
||||
|
||||
(define (bag-sum bag1 . bags)
|
||||
(apply bag-sum! (bag-copy bag1) bags))
|
||||
|
||||
(define (bag-sum! bag1 . bags)
|
||||
(if (null? bags)
|
||||
bag1
|
||||
(and (comparable-bags? bag1 (car bags))
|
||||
(begin
|
||||
(hash-table-for-each
|
||||
(lambda (elt count)
|
||||
(hash-table-update!/default (bag-table bag1)
|
||||
elt
|
||||
(lambda (c) (+ c count))
|
||||
count))
|
||||
(bag-table (car bags)))
|
||||
(apply bag-sum! bag1 (cdr bags))))))
|
||||
|
||||
(define (bag-product n bag)
|
||||
(bag-product! n (bag-copy bag)))
|
||||
|
||||
(define (bag-product! n bag)
|
||||
(for-each
|
||||
(lambda (elt)
|
||||
(hash-table-update! (bag-table bag) elt (lambda (count) (* n count))))
|
||||
(hash-table-keys (bag-table bag)))
|
||||
bag)
|
||||
|
||||
(define (bag-unique-size bag)
|
||||
(hash-table-size (bag-table bag)))
|
||||
|
||||
(define (bag-element-count bag element)
|
||||
(hash-table-ref/default (bag-table bag) element 0))
|
||||
|
||||
(define (bag-for-each-unique proc bag)
|
||||
(hash-table-for-each proc (bag-table bag)))
|
||||
|
||||
(define (bag-fold-unique proc nil bag)
|
||||
(hash-table-fold proc nil (bag-table bag)))
|
||||
|
||||
(define (bag-increment! bag element count)
|
||||
(let* ((ht (bag-table bag))
|
||||
(count2 (+ count (hash-table-ref/default ht element 0))))
|
||||
(if (positive? count2)
|
||||
(hash-table-set! ht element count2)
|
||||
(hash-table-delete! ht element))))
|
||||
|
||||
(define (bag-decrement! bag element count)
|
||||
(bag-increment! bag element (- count)))
|
||||
|
||||
(define (bag->set bag)
|
||||
(let ((ht (hash-table-copy (bag-table bag))))
|
||||
(hash-table-map! (lambda (key count) key) ht)
|
||||
(make-set ht (bag-comparator bag))))
|
||||
|
||||
(define (set->bag set)
|
||||
(set->bag! (bag (set-comparator set)) set))
|
||||
|
||||
(define (set->bag! bag set)
|
||||
(set-for-each (lambda (elt) (bag-adjoin! bag elt)) set)
|
||||
bag)
|
||||
|
||||
(define (bag->alist bag)
|
||||
(hash-table->alist (bag-table bag)))
|
||||
|
||||
(define (alist->bag comparator alist)
|
||||
(let ((res (bag comparator)))
|
||||
(for-each (lambda (x) (bag-increment! res (car x) (cdr x))) alist)
|
||||
res))
|
||||
|
||||
(define the-bag-comparator
|
||||
(make-comparator bag? bag=? bag<? hash))
|
||||
225
lib/srfi/113/sets.scm
Normal file
225
lib/srfi/113/sets.scm
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
|
||||
(define-record-type Set (make-set table comparator) set?
|
||||
(table set-table)
|
||||
(comparator set-comparator))
|
||||
|
||||
(define (set comparator . elts)
|
||||
(let ((res (make-hash-table comparator)))
|
||||
(for-each (lambda (x) (hash-table-set! res x x)) elts)
|
||||
(make-set res comparator)))
|
||||
|
||||
(define (set-unfold comparator stop? mapper successor seed)
|
||||
(let ((mapper (lambda (acc) (let ((elt (mapper acc))) (values elt elt)))))
|
||||
(make-set (hash-table-unfold stop? mapper successor seed comparator)
|
||||
comparator)))
|
||||
|
||||
(define (set-contains? set element)
|
||||
(hash-table-contains? (set-table set) element))
|
||||
|
||||
(define (set-empty? set)
|
||||
(zero? (set-size set)))
|
||||
|
||||
(define (set-disjoint? set1 set2)
|
||||
(if (< (hash-table-size (set-table set2))
|
||||
(hash-table-size (set-table set1)))
|
||||
(set-disjoint? set2 set1)
|
||||
(let ((ht (set-table set2)))
|
||||
(not (hash-table-find (lambda (key value) (hash-table-contains? ht key))
|
||||
(set-table set1)
|
||||
(lambda () #f))))))
|
||||
|
||||
(define (set-member set element default)
|
||||
(hash-table-ref/default (set-table set) element default))
|
||||
|
||||
(define (set-element-comparator set)
|
||||
(set-comparator set))
|
||||
|
||||
(define (set-adjoin set . elts)
|
||||
(apply set-adjoin! (set-copy set) elts))
|
||||
|
||||
(define (set-adjoin! set . elts)
|
||||
(for-each (lambda (elt) (hash-table-set! (set-table set) elt elt)) elts)
|
||||
set)
|
||||
|
||||
(define (set-replace set element)
|
||||
(set-replace! (set-copy set) element))
|
||||
|
||||
(define (set-replace! set element)
|
||||
(when (hash-table-contains? (set-table set) element)
|
||||
(hash-table-delete! (set-table set) element)
|
||||
(hash-table-set! (set-table set) element element))
|
||||
set)
|
||||
|
||||
(define (set-delete set . elts)
|
||||
(set-delete-all set elts))
|
||||
|
||||
(define (set-delete! set . elts)
|
||||
(set-delete-all! set elts))
|
||||
|
||||
(define (set-delete-all set element-list)
|
||||
(set-delete-all! (set-copy set) element-list))
|
||||
|
||||
(define (set-delete-all! set element-list)
|
||||
(for-each (lambda (elt) (hash-table-delete! (set-table set) elt))
|
||||
element-list)
|
||||
set)
|
||||
|
||||
(define set-search!
|
||||
(let ((not-found (list 'not-found)))
|
||||
(lambda (set element failure success)
|
||||
(let ((elt (hash-table-ref/default (set-table set) element not-found)))
|
||||
(if (eq? elt not-found)
|
||||
(failure (lambda (obj)
|
||||
(hash-table-set! (set-table set) element element)
|
||||
(values set obj))
|
||||
(lambda (obj)
|
||||
(values set obj)))
|
||||
(success elt
|
||||
(lambda (new-element obj)
|
||||
(hash-table-delete! (set-table set) elt)
|
||||
(hash-table-set! (set-table set) new-element new-element)
|
||||
(values set obj))
|
||||
(lambda (obj)
|
||||
(hash-table-delete! (set-table set) element)
|
||||
(values set obj))))))))
|
||||
|
||||
(define (set-size set)
|
||||
(hash-table-size (set-table set)))
|
||||
|
||||
(define (set-find predicate set failure)
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(hash-table-for-each
|
||||
(lambda (elt _) (if (predicate elt) (return elt)))
|
||||
(set-table set))
|
||||
(failure))))
|
||||
|
||||
(define (set-count predicate set)
|
||||
(hash-table-count (lambda (key value) (predicate key)) (set-table set)))
|
||||
|
||||
(define (set-any? predicate set)
|
||||
(and (hash-table-find (lambda (key value) (predicate key))
|
||||
(set-table set)
|
||||
(lambda () #f))
|
||||
#t))
|
||||
|
||||
(define (set-every? predicate set)
|
||||
(not (set-any? (lambda (x) (not (predicate x))) set)))
|
||||
|
||||
(define (set-map comparator proc s)
|
||||
(set-fold (lambda (elt res) (set-adjoin! res (proc elt)))
|
||||
(set comparator)
|
||||
s))
|
||||
|
||||
(define (set-for-each proc set)
|
||||
(hash-table-for-each (lambda (elt _) (proc elt)) (set-table set)))
|
||||
|
||||
(define (set-fold proc nil set)
|
||||
(hash-table-fold (lambda (elt _ acc) (proc elt acc)) nil (set-table set)))
|
||||
|
||||
(define (set-filter predicate st)
|
||||
(set-fold (lambda (elt res)
|
||||
(if (predicate elt) (set-adjoin! res elt) res))
|
||||
(set (set-comparator st))
|
||||
st))
|
||||
|
||||
(define set-filter! set-filter)
|
||||
|
||||
(define (set-remove predicate set)
|
||||
(set-filter (lambda (elt) (not (predicate elt))) set))
|
||||
|
||||
(define set-remove! set-remove)
|
||||
|
||||
(define (set-partition predicate set)
|
||||
(values (set-filter predicate set)
|
||||
(set-remove predicate set)))
|
||||
|
||||
(define set-partition! set-partition)
|
||||
|
||||
(define (set-copy set)
|
||||
(make-set (hash-table-copy (set-table set))
|
||||
(set-comparator set)))
|
||||
|
||||
(define (set->list set)
|
||||
(hash-table-keys (set-table set)))
|
||||
|
||||
(define (list->set comparator list)
|
||||
(fold (lambda (elt set) (set-adjoin! set elt)) (set comparator) list))
|
||||
|
||||
(define (list->set! set list)
|
||||
(fold (lambda (elt set) (set-adjoin! set elt)) set list))
|
||||
|
||||
(define (comparable-sets? set1 set2)
|
||||
(or (eq? (set-comparator set1) (set-comparator set2))
|
||||
(error "can't compare sets with different comparators" set1 set2)))
|
||||
|
||||
(define (set=? set1 . sets)
|
||||
(or (null? sets)
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(= (set-size set1) (set-size (car sets)))
|
||||
(set-every? (lambda (elt) (set-contains? set1 elt)) (car sets))
|
||||
(apply set=? sets))))
|
||||
|
||||
(define (set<? set1 . sets)
|
||||
(or (null? sets)
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(< (set-size set1) (set-size (car sets)))
|
||||
(set-every? (lambda (elt) (set-contains? (car sets) elt)) set1)
|
||||
(apply set<? sets))))
|
||||
|
||||
(define (set>? . sets)
|
||||
(apply set<? (reverse sets)))
|
||||
|
||||
(define (set<=? set1 . sets)
|
||||
(or (null? sets)
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(<= (set-size set1) (set-size (car sets)))
|
||||
(set-every? (lambda (elt) (set-contains? (car sets) elt)) set1)
|
||||
(apply set<=? sets))))
|
||||
|
||||
(define (set>=? . sets)
|
||||
(apply set<=? (reverse sets)))
|
||||
|
||||
(define (set-union set1 . sets)
|
||||
(apply set-union! (set-copy set1) sets))
|
||||
|
||||
(define (set-intersection set1 . sets)
|
||||
(apply set-intersection! (set-copy set1) sets))
|
||||
|
||||
(define (set-difference set1 . sets)
|
||||
(apply set-difference! (set-copy set1) sets))
|
||||
|
||||
(define (set-xor set1 set2)
|
||||
(set-xor! (set-copy set1) set2))
|
||||
|
||||
(define (set-union! set1 . sets)
|
||||
(if (null? sets)
|
||||
set1
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(apply set-union!
|
||||
(set-fold (lambda (elt set) (set-adjoin! set elt)) set1 (car sets))
|
||||
(cdr sets)))))
|
||||
|
||||
(define (set-intersection! set1 . sets)
|
||||
(if (null? sets)
|
||||
set1
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(apply set-intersection!
|
||||
(set-filter! (lambda (elt) (set-contains? (car sets) elt)) set1)
|
||||
(cdr sets)))))
|
||||
|
||||
(define (set-difference! set1 . sets)
|
||||
(if (null? sets)
|
||||
set1
|
||||
(and (comparable-sets? set1 (car sets))
|
||||
(apply set-difference!
|
||||
(set-remove! (lambda (elt) (set-contains? (car sets) elt)) set1)
|
||||
(cdr sets)))))
|
||||
|
||||
(define (set-xor! set1 set2)
|
||||
(and (comparable-sets? set1 set2)
|
||||
(set-union (set-remove (lambda (elt) (set-contains? set2 elt)) set1)
|
||||
(set-remove (lambda (elt) (set-contains? set1 elt)) set2))))
|
||||
|
||||
(define the-set-comparator
|
||||
(make-comparator set? set=? set<? hash))
|
||||
606
lib/srfi/113/test.sld
Normal file
606
lib/srfi/113/test.sld
Normal file
|
|
@ -0,0 +1,606 @@
|
|||
;; adapted from the reference implementation
|
||||
|
||||
(define-library (srfi 113 test)
|
||||
(import (scheme base) (scheme char) (srfi 113) (srfi 128) (chibi test))
|
||||
(export run-tests)
|
||||
(begin
|
||||
(define equal-comparator (make-equal-comparator))
|
||||
(define eqv-comparator (make-eqv-comparator))
|
||||
(define eq-comparator (make-eq-comparator))
|
||||
(define number-comparator
|
||||
(make-comparator real? = < (lambda (x . o) (exact (abs (round x))))))
|
||||
(define char-comparator
|
||||
(make-comparator char? char=? char<? char-hash))
|
||||
(define string-ci-comparator
|
||||
(make-comparator string? string-ci=? string-ci<? string-ci-hash))
|
||||
(define (run-tests)
|
||||
(test-group "srfi-113: sets"
|
||||
(define (big x) (> x 5))
|
||||
|
||||
(test-group "sets/simple"
|
||||
(define nums (set number-comparator))
|
||||
;; nums is now {}
|
||||
(define syms (set eq-comparator 'a 'b 'c 'd))
|
||||
;; syms is now {a, b, c, d}
|
||||
(define nums2 (set-copy nums))
|
||||
;; nums2 is now {}
|
||||
(define syms2 (set-copy syms))
|
||||
;; syms2 is now {a, b, c, d}
|
||||
(define esyms (set eq-comparator))
|
||||
;; esyms is now {}
|
||||
(define total 0)
|
||||
(test-assert (set-empty? esyms))
|
||||
(test-assert (set? nums))
|
||||
(test-assert (set? syms))
|
||||
(test-assert (set? nums2))
|
||||
(test-assert (set? syms2))
|
||||
(test-assert (not (set? 'a)))
|
||||
(set! nums (set-adjoin! nums 2))
|
||||
(set! nums (set-adjoin! nums 3))
|
||||
(set! nums (set-adjoin! nums 4))
|
||||
(set! nums (set-adjoin! nums 4))
|
||||
;; nums is now {2, 3, 4}
|
||||
(test 4 (set-size (set-adjoin nums 5)))
|
||||
(test 3 (set-size nums))
|
||||
(test 3 (set-size (set-delete syms 'd)))
|
||||
(test 2 (set-size (set-delete-all syms '(c d))))
|
||||
(test 4 (set-size syms))
|
||||
(set! syms (set-adjoin! syms 'e 'f))
|
||||
;; syms is now {a, b, c, d, e, f}
|
||||
(test 4 (set-size (set-delete-all! syms '(e f))))
|
||||
;; syms is now {a, b, c, d}
|
||||
(test 0 (set-size nums2))
|
||||
(test 4 (set-size syms2))
|
||||
(set! nums (set-delete! nums 2))
|
||||
;; nums is now {3, 4}
|
||||
(test 2 (set-size nums))
|
||||
(set! nums (set-delete! nums 1))
|
||||
(test-assert (set-contains? nums 3))
|
||||
(test 2 (set-size nums))
|
||||
(set! nums2 (set-map number-comparator (lambda (x) (* 10 x)) nums))
|
||||
;; nums2 is now {30, 40}
|
||||
(test-assert (set-contains? nums2 30))
|
||||
(test-assert (not (set-contains? nums2 3)))
|
||||
(set-for-each (lambda (x) (set! total (+ total x))) nums2)
|
||||
(test 70 total)
|
||||
(test 10 (set-fold + 3 nums))
|
||||
(set! nums (set eqv-comparator 10 20 30 40 50))
|
||||
;; nums is now {10, 20, 30, 40, 50}
|
||||
(test-assert
|
||||
(set=? nums (set-unfold
|
||||
eqv-comparator
|
||||
(lambda (i) (= i 0))
|
||||
(lambda (i) (* i 10))
|
||||
(lambda (i) (- i 1))
|
||||
5)))
|
||||
(test '(a) (set->list (set eq-comparator 'a)))
|
||||
(set! syms2 (list->set eq-comparator '(e f)))
|
||||
;; syms2 is now {e, f}
|
||||
(test 2 (set-size syms2))
|
||||
(test-assert (set-contains? syms2 'e))
|
||||
(test-assert (set-contains? syms2 'f))
|
||||
(test 4 (set-size (list->set! syms2 '(a b))))
|
||||
)
|
||||
|
||||
(test-group "sets/search"
|
||||
(define yam (set char-comparator #\y #\a #\m))
|
||||
(define (failure/insert insert ignore)
|
||||
(insert 1))
|
||||
(define (failure/ignore insert ignore)
|
||||
(ignore 2))
|
||||
(define (success/update element update remove)
|
||||
(update #\b 3))
|
||||
(define (success/remove element update remove)
|
||||
(remove 4))
|
||||
(define yam! (set char-comparator #\y #\a #\m #\!))
|
||||
(define bam (set char-comparator #\b #\a #\m))
|
||||
(define ym (set char-comparator #\y #\m))
|
||||
(define-values (set1 obj1)
|
||||
(set-search! (set-copy yam) #\! failure/insert error))
|
||||
(define-values (set2 obj2)
|
||||
(set-search! (set-copy yam) #\! failure/ignore error))
|
||||
(define-values (set3 obj3)
|
||||
(set-search! (set-copy yam) #\y error success/update))
|
||||
(define-values (set4 obj4)
|
||||
(set-search! (set-copy yam) #\a error success/remove))
|
||||
(test-assert (set=? yam! set1))
|
||||
(test 1 obj1)
|
||||
(test-assert (set=? yam set2))
|
||||
(test 2 obj2)
|
||||
(test-assert (set=? bam set3))
|
||||
(test 3 obj3)
|
||||
(test-assert (set=? ym set4))
|
||||
(test 4 obj4)
|
||||
)
|
||||
|
||||
(test-group "sets/subsets"
|
||||
(define set2 (set number-comparator 1 2))
|
||||
(define other-set2 (set number-comparator 1 2))
|
||||
(define set3 (set number-comparator 1 2 3))
|
||||
(define set4 (set number-comparator 1 2 3 4))
|
||||
(define setx (set number-comparator 10 20 30 40))
|
||||
(test-assert (set=? set2 other-set2))
|
||||
(test-assert (not (set=? set2 set3)))
|
||||
(test-assert (not (set=? set2 set3 other-set2)))
|
||||
(test-assert (set<? set2 set3 set4))
|
||||
(test-assert (not (set<? set2 other-set2)))
|
||||
(test-assert (set<=? set2 other-set2 set3))
|
||||
(test-assert (not (set<=? set2 set3 other-set2)))
|
||||
(test-assert (set>? set4 set3 set2))
|
||||
(test-assert (not (set>? set2 other-set2)))
|
||||
(test-assert (set>=? set3 other-set2 set2))
|
||||
(test-assert (not (set>=? other-set2 set3 set2)))
|
||||
)
|
||||
|
||||
(test-group "sets/ops"
|
||||
;; Potentially mutable
|
||||
(define abcd (set eq-comparator 'a 'b 'c 'd))
|
||||
(define efgh (set eq-comparator 'e 'f 'g 'h))
|
||||
(define abgh (set eq-comparator 'a 'b 'g 'h))
|
||||
;; Never get a chance to be mutated
|
||||
(define other-abcd (set eq-comparator 'a 'b 'c 'd))
|
||||
(define other-efgh (set eq-comparator 'e 'f 'g 'h))
|
||||
(define other-abgh (set eq-comparator 'a 'b 'g 'h))
|
||||
(define all (set eq-comparator 'a 'b 'c 'd 'e 'f 'g 'h))
|
||||
(define none (set eq-comparator))
|
||||
(define ab (set eq-comparator 'a 'b))
|
||||
(define cd (set eq-comparator 'c 'd))
|
||||
(define ef (set eq-comparator 'e 'f))
|
||||
(define gh (set eq-comparator 'g 'h))
|
||||
(define cdgh (set eq-comparator 'c 'd 'g 'h))
|
||||
(define abcdgh (set eq-comparator 'a 'b 'c 'd 'g 'h))
|
||||
(define abefgh (set eq-comparator 'a 'b 'e 'f 'g 'h))
|
||||
(test-assert (set-disjoint? abcd efgh))
|
||||
(test-assert (not (set-disjoint? abcd ab)))
|
||||
(parameterize ((current-test-comparator set=?))
|
||||
(test abcd (set-union abcd))
|
||||
(test all (set-union abcd efgh))
|
||||
(test abcdgh (set-union abcd abgh))
|
||||
(test abefgh (set-union efgh abgh))
|
||||
(let ((efgh2 (set-copy efgh)))
|
||||
(set-union! efgh2)
|
||||
(test efgh efgh2)
|
||||
(set-union! efgh2 abgh)
|
||||
(test abefgh efgh2))
|
||||
(test abcd (set-intersection abcd))
|
||||
(test none (set-intersection abcd efgh))
|
||||
;; (let ((abcd2 (set-copy abcd)))
|
||||
;; (set-intersection! abcd2)
|
||||
;; (test abcd abcd2)
|
||||
;; (set-intersection! abcd2 efgh)
|
||||
;; (test none abcd2))
|
||||
(test ab (set-intersection abcd abgh))
|
||||
(test ab (set-intersection abgh abcd))
|
||||
(test abcd (set-difference abcd))
|
||||
(test cd (set-difference abcd ab))
|
||||
(test abcd (set-difference abcd gh))
|
||||
(test none (set-difference abcd abcd))
|
||||
;; (let ((abcd3 (set-copy abcd)))
|
||||
;; (set-difference! abcd3)
|
||||
;; (test abcd abcd3)
|
||||
;; (set-difference! abcd3 abcd)
|
||||
;; (test none abcd3))
|
||||
(test cdgh (set-xor abcd abgh))
|
||||
(test all (set-xor abcd efgh))
|
||||
(test none (set-xor abcd other-abcd))
|
||||
;; don't test xor! effect
|
||||
(test none (set-xor! (set-copy abcd) other-abcd))
|
||||
(test "abcd smashed?" other-abcd abcd)
|
||||
(test "efgh smashed?" other-efgh efgh)
|
||||
(test "abgh smashed?" other-abgh abgh))
|
||||
)
|
||||
|
||||
(test-group "sets/mismatch"
|
||||
(define nums (set number-comparator 1 2 3))
|
||||
(define syms (set eq-comparator 'a 'b 'c))
|
||||
(test-error (set=? nums syms))
|
||||
(test-error (set<? nums syms))
|
||||
(test-error (set<=? nums syms))
|
||||
(test-error (set>? nums syms))
|
||||
(test-error (set>=? nums syms))
|
||||
(test-error (set-union nums syms))
|
||||
(test-error (set-intersection nums syms))
|
||||
(test-error (set-difference nums syms))
|
||||
(test-error (set-xor nums syms))
|
||||
(test-error (set-union! nums syms))
|
||||
(test-error (set-intersection! nums syms))
|
||||
(test-error (set-difference! nums syms))
|
||||
(test-error (set-xor! nums syms))
|
||||
)
|
||||
|
||||
(test-group "sets/whole"
|
||||
(define whole (set eqv-comparator 1 2 3 4 5 6 7 8 9 10))
|
||||
(define whole2 (set-copy whole))
|
||||
(define whole3 (set-copy whole))
|
||||
(define whole4 (set-copy whole))
|
||||
(define bottom (set eqv-comparator 1 2 3 4 5))
|
||||
(define top (set eqv-comparator 6 7 8 9 10))
|
||||
(define-values (topx bottomx)
|
||||
(set-partition big whole))
|
||||
;; (set-partition! big whole4)
|
||||
(parameterize ((current-test-comparator set=?))
|
||||
(test top (set-filter big whole))
|
||||
(test bottom (set-remove big whole))
|
||||
;; (set-filter! big whole2)
|
||||
;; (test-assert (not (set-contains? whole2 1)))
|
||||
;; (set-remove! big whole3)
|
||||
;; (test-assert (not (set-contains? whole3 10)))
|
||||
;; (test top topx)
|
||||
;; (test bottom bottomx)
|
||||
;; (test top whole4)
|
||||
)
|
||||
(test 5 (set-count big whole))
|
||||
(let ((hetero (set eqv-comparator 1 2 'a 3 4))
|
||||
(homo (set eqv-comparator 1 2 3 4 5)))
|
||||
(test 'a (set-find symbol? hetero (lambda () (error "wrong"))))
|
||||
(test-error (set-find symbol? homo (lambda () (error "wrong"))))
|
||||
(test-assert (set-any? symbol? hetero))
|
||||
(test-assert (set-any? number? hetero))
|
||||
(test-assert (not (set-every? symbol? hetero)))
|
||||
(test-assert (not (set-every? number? hetero)))
|
||||
(test-assert (not (set-any? symbol? homo)))
|
||||
(test-assert (set-every? number? homo)))
|
||||
)
|
||||
|
||||
(test-group "sets/lowlevel"
|
||||
(define bucket (set string-ci-comparator "abc" "def"))
|
||||
(define nums (set number-comparator 1 2 3))
|
||||
;; nums is now {1, 2, 3}
|
||||
(define nums2 (set-replace nums 2.0))
|
||||
;; nums2 is now {1, 2.0, 3}
|
||||
(test string-ci-comparator (set-element-comparator bucket))
|
||||
(test-assert (set-contains? bucket "abc"))
|
||||
(test-assert (set-contains? bucket "ABC"))
|
||||
(test "def" (set-member bucket "DEF" "fqz"))
|
||||
(test "fqz" (set-member bucket "lmn" "fqz"))
|
||||
(test-assert (set-any? inexact? nums2))
|
||||
(set! nums (set-replace! nums 2.0))
|
||||
;; nums is now {1, 2.0, 3}
|
||||
(test-assert (set-any? inexact? nums))
|
||||
(let ((sos
|
||||
(set set-comparator
|
||||
(set equal-comparator '(2 . 1) '(1 . 1) '(0 . 2) '(0 . 0))
|
||||
(set equal-comparator '(2 . 1) '(1 . 1) '(0 . 0) '(0 . 2)))))
|
||||
(test 1 (set-size sos)))
|
||||
)
|
||||
|
||||
(test-group "bags/simple"
|
||||
(define nums (bag number-comparator))
|
||||
;; nums is now {}
|
||||
(define syms (bag eq-comparator 'a 'b 'c 'd))
|
||||
;; syms is now {a, b, c, d}
|
||||
(define nums2 (bag-copy nums))
|
||||
;; nums2 is now {}
|
||||
(define syms2 (bag-copy syms))
|
||||
;; syms2 is now {a, b, c, d}
|
||||
(define esyms (bag eq-comparator))
|
||||
;; esyms is now {}
|
||||
(test-assert (bag-empty? esyms))
|
||||
(test-assert (bag? nums))
|
||||
(test-assert (bag? syms))
|
||||
(test-assert (bag? nums2))
|
||||
(test-assert (bag? syms2))
|
||||
(test-assert (not (bag? 'a)))
|
||||
(bag-adjoin! nums 2)
|
||||
(bag-adjoin! nums 3)
|
||||
(bag-adjoin! nums 4)
|
||||
;; nums is now {2, 3, 4}
|
||||
(test 4 (bag-size (bag-adjoin nums 5)))
|
||||
(test 3 (bag-size nums))
|
||||
(test 3 (bag-size (bag-delete syms 'd)))
|
||||
(test 2 (bag-size (bag-delete-all syms '(c d))))
|
||||
(test 4 (bag-size syms))
|
||||
(bag-adjoin! syms 'e 'f)
|
||||
;; syms is now {a, b, c, d, e, f}
|
||||
(test 4 (bag-size (bag-delete-all! syms '(e f))))
|
||||
;; syms is now {a, b, c, d}
|
||||
(test 3 (bag-size nums))
|
||||
(bag-delete! nums 1)
|
||||
(test 3 (bag-size nums))
|
||||
(set! nums2 (bag-map number-comparator (lambda (x) (* 10 x)) nums))
|
||||
;; nums2 is now {20, 30, 40}
|
||||
(test-assert (bag-contains? nums2 30))
|
||||
(test-assert (not (bag-contains? nums2 3)))
|
||||
(let ((total 0))
|
||||
(bag-for-each (lambda (x) (set! total (+ total x))) nums2)
|
||||
(test 90 total))
|
||||
(test 12 (bag-fold + 3 nums))
|
||||
(set! nums (bag eqv-comparator 10 20 30 40 50))
|
||||
;; nums is now {10, 20, 30, 40, 50}
|
||||
(test-assert
|
||||
(bag=? nums (bag-unfold
|
||||
eqv-comparator
|
||||
(lambda (i) (= i 0))
|
||||
(lambda (i) (* i 10))
|
||||
(lambda (i) (- i 1))
|
||||
5)))
|
||||
(test '(a) (bag->list (bag eq-comparator 'a)))
|
||||
(set! syms2 (list->bag eq-comparator '(e f)))
|
||||
;; syms2 is now {e, f}
|
||||
(test 2 (bag-size syms2))
|
||||
(test-assert (bag-contains? syms2 'e))
|
||||
(test-assert (bag-contains? syms2 'f))
|
||||
(list->bag! syms2 '(e f))
|
||||
;; syms2 is now {e, e, f, f}
|
||||
(test 4 (bag-size syms2))
|
||||
)
|
||||
|
||||
(test-group "bags/search"
|
||||
(define yam (bag char-comparator #\y #\a #\m))
|
||||
(define (failure/insert insert ignore)
|
||||
(insert 1))
|
||||
(define (failure/ignore insert ignore)
|
||||
(ignore 2))
|
||||
(define (success/update element update remove)
|
||||
(update #\b 3))
|
||||
(define (success/remove element update remove)
|
||||
(remove 4))
|
||||
(define yam! (bag char-comparator #\y #\a #\m #\!))
|
||||
(define bam (bag char-comparator #\b #\a #\m))
|
||||
(define ym (bag char-comparator #\y #\m))
|
||||
(define-values (bag1 obj1)
|
||||
(bag-search! (bag-copy yam) #\! failure/insert error))
|
||||
(define-values (bag2 obj2)
|
||||
(bag-search! (bag-copy yam) #\! failure/ignore error))
|
||||
(define-values (bag3 obj3)
|
||||
(bag-search! (bag-copy yam) #\y error success/update))
|
||||
(define-values (bag4 obj4)
|
||||
(bag-search! (bag-copy yam) #\a error success/remove))
|
||||
(test-assert (bag=? yam! bag1))
|
||||
(test 1 obj1)
|
||||
(test-assert (bag=? yam bag2))
|
||||
(test 2 obj2)
|
||||
(test-assert (bag=? bam bag3))
|
||||
(test 3 obj3)
|
||||
(test-assert (bag=? ym bag4))
|
||||
(test 4 obj4)
|
||||
)
|
||||
|
||||
(test-group "bags/elemcount"
|
||||
(define mybag (bag eqv-comparator 1 1 1 1 1 2 2))
|
||||
(test 5 (bag-element-count mybag 1))
|
||||
(test 0 (bag-element-count mybag 3)))
|
||||
|
||||
(test-group "bags/subbags"
|
||||
(define bag2 (bag number-comparator 1 2))
|
||||
(define other-bag2 (bag number-comparator 1 2))
|
||||
(define bag3 (bag number-comparator 1 2 3))
|
||||
(define bag4 (bag number-comparator 1 2 3 4))
|
||||
(define bagx (bag number-comparator 10 20 30 40))
|
||||
(test-assert (bag=? bag2 other-bag2))
|
||||
(test-assert (not (bag=? bag2 bag3)))
|
||||
(test-assert (not (bag=? bag2 bag3 other-bag2)))
|
||||
(test-assert (bag<? bag2 bag3 bag4))
|
||||
(test-assert (not (bag<? bag2 other-bag2)))
|
||||
(test-assert (bag<=? bag2 other-bag2 bag3))
|
||||
(test-assert (not (bag<=? bag2 bag3 other-bag2)))
|
||||
(test-assert (bag>? bag4 bag3 bag2))
|
||||
(test-assert (not (bag>? bag2 other-bag2)))
|
||||
(test-assert (bag>=? bag3 other-bag2 bag2))
|
||||
(test-assert (not (bag>=? other-bag2 bag3 bag2))))
|
||||
|
||||
(test-group "bags/multi"
|
||||
(define one (bag eqv-comparator 10))
|
||||
(define two (bag eqv-comparator 10 10))
|
||||
(test-assert (not (bag=? one two)))
|
||||
(test-assert (bag<? one two))
|
||||
(test-assert (not (bag>? one two)))
|
||||
(test-assert (bag<=? one two))
|
||||
(test-assert (not (bag>? one two)))
|
||||
(test-assert (bag=? two two))
|
||||
(test-assert (not (bag<? two two)))
|
||||
(test-assert (not (bag>? two two)))
|
||||
(test-assert (bag<=? two two))
|
||||
(test-assert (bag>=? two two))
|
||||
(test '((10 . 2))
|
||||
(let ((result '()))
|
||||
(bag-for-each-unique
|
||||
(lambda (x y) (set! result (cons (cons x y) result)))
|
||||
two)
|
||||
result))
|
||||
(test 25 (bag-fold + 5 two))
|
||||
(test 12 (bag-fold-unique (lambda (k n r) (+ k n r)) 0 two)))
|
||||
|
||||
(test-group "bags/ops"
|
||||
;; Potentially mutable
|
||||
(define abcd (bag eq-comparator 'a 'b 'c 'd))
|
||||
(define efgh (bag eq-comparator 'e 'f 'g 'h))
|
||||
(define abgh (bag eq-comparator 'a 'b 'g 'h))
|
||||
;; Never get a chance to be mutated
|
||||
(define other-abcd (bag eq-comparator 'a 'b 'c 'd))
|
||||
(define other-efgh (bag eq-comparator 'e 'f 'g 'h))
|
||||
(define other-abgh (bag eq-comparator 'a 'b 'g 'h))
|
||||
(define all (bag eq-comparator 'a 'b 'c 'd 'e 'f 'g 'h))
|
||||
(define none (bag eq-comparator))
|
||||
(define ab (bag eq-comparator 'a 'b))
|
||||
(define cd (bag eq-comparator 'c 'd))
|
||||
(define ef (bag eq-comparator 'e 'f))
|
||||
(define gh (bag eq-comparator 'g 'h))
|
||||
(define cdgh (bag eq-comparator 'c 'd 'g 'h))
|
||||
(define abcdgh (bag eq-comparator 'a 'b 'c 'd 'g 'h))
|
||||
(define abefgh (bag eq-comparator 'a 'b 'e 'f 'g 'h))
|
||||
(test-assert (bag-disjoint? abcd efgh))
|
||||
(test-assert (not (bag-disjoint? abcd ab)))
|
||||
(parameterize ((current-test-comparator bag=?))
|
||||
(test abcd (bag-union abcd))
|
||||
(test all (bag-union abcd efgh))
|
||||
(test abcdgh (bag-union abcd abgh))
|
||||
(test abefgh (bag-union efgh abgh))
|
||||
(let ((efgh2 (bag-copy efgh)))
|
||||
(bag-union! efgh2)
|
||||
(test efgh efgh2)
|
||||
(bag-union! efgh2 abgh)
|
||||
(test abefgh efgh2))
|
||||
(test abcd (bag-intersection abcd))
|
||||
(test none (bag-intersection abcd efgh))
|
||||
(let ((abcd2 (bag-copy abcd)))
|
||||
(bag-intersection! abcd2)
|
||||
(test abcd abcd2)
|
||||
(bag-intersection! abcd2 efgh)
|
||||
(test none abcd2))
|
||||
(test ab (bag-intersection abcd abgh))
|
||||
(test ab (bag-intersection abgh abcd))
|
||||
(test abcd (bag-difference abcd))
|
||||
(test cd (bag-difference abcd ab))
|
||||
(test abcd (bag-difference abcd gh))
|
||||
(test none (bag-difference abcd abcd))
|
||||
(let ((abcd3 (bag-copy abcd)))
|
||||
(bag-difference! abcd3)
|
||||
(test abcd abcd3)
|
||||
(bag-difference! abcd3 abcd)
|
||||
(test none abcd3))
|
||||
(test cdgh (bag-xor abcd abgh))
|
||||
(test all (bag-xor abcd efgh))
|
||||
(test none (bag-xor abcd other-abcd))
|
||||
(test none (bag-xor! (bag-copy abcd) other-abcd))
|
||||
(let ((abab (bag eq-comparator 'a 'b 'a 'b))
|
||||
(ab2 (bag-copy ab)))
|
||||
(test ab (bag-sum ab))
|
||||
(test ab (bag-sum! ab2))
|
||||
(test abab (bag-sum! ab2 ab))
|
||||
(test abab ab2)
|
||||
(test abab (bag-product 2 ab))
|
||||
(let ((ab3 (bag-copy ab)))
|
||||
(bag-product! 2 ab3)
|
||||
(test abab ab3)))
|
||||
(test "abcd smashed?" other-abcd abcd)
|
||||
(test "abcd smashed?" other-abcd abcd)
|
||||
(test "efgh smashed?" other-efgh efgh)
|
||||
(test "abgh smashed?" other-abgh abgh)))
|
||||
|
||||
(test-group "bags/mismatch"
|
||||
(define nums (bag number-comparator 1 2 3))
|
||||
(define syms (bag eq-comparator 'a 'b 'c))
|
||||
(test-error (bag=? nums syms))
|
||||
(test-error (bag<? nums syms))
|
||||
(test-error (bag<=? nums syms))
|
||||
(test-error (bag>? nums syms))
|
||||
(test-error (bag>=? nums syms))
|
||||
(test-error (bag-union nums syms))
|
||||
(test-error (bag-intersection nums syms))
|
||||
(test-error (bag-difference nums syms))
|
||||
(test-error (bag-xor nums syms))
|
||||
(test-error (bag-union! nums syms))
|
||||
(test-error (bag-intersection! nums syms))
|
||||
(test-error (bag-difference! nums syms)))
|
||||
|
||||
(test-group "bags/whole"
|
||||
(define whole (bag eqv-comparator 1 2 3 4 5 6 7 8 9 10))
|
||||
(define whole2 (bag-copy whole))
|
||||
(define whole3 (bag-copy whole))
|
||||
(define whole4 (bag-copy whole))
|
||||
(define bottom (bag eqv-comparator 1 2 3 4 5))
|
||||
(define top (bag eqv-comparator 6 7 8 9 10))
|
||||
(define-values (topx bottomx)
|
||||
(bag-partition big whole))
|
||||
(call-with-values (lambda () (bag-partition! big whole4))
|
||||
(lambda (pass fail) (set! whole4 pass)))
|
||||
(parameterize ((current-test-comparator bag=?))
|
||||
(test top (bag-filter big whole))
|
||||
(test bottom (bag-remove big whole))
|
||||
(set! whole2 (bag-filter! big whole2))
|
||||
(test-assert (not (bag-contains? whole2 1)))
|
||||
(set! whole3 (bag-remove! big whole3))
|
||||
(test-assert (not (bag-contains? whole3 10)))
|
||||
(test top topx)
|
||||
(test bottom bottomx)
|
||||
(test top whole4))
|
||||
(test 5 (bag-count big whole))
|
||||
(let ((hetero (bag eqv-comparator 1 2 'a 3 4))
|
||||
(homo (bag eqv-comparator 1 2 3 4 5)))
|
||||
(test 'a (bag-find symbol? hetero (lambda () (error "wrong"))))
|
||||
(test-error (bag-find symbol? homo (lambda () (error "wrong"))))
|
||||
(test-assert (bag-any? symbol? hetero))
|
||||
(test-assert (bag-any? number? hetero))
|
||||
(test-assert (not (bag-every? symbol? hetero)))
|
||||
(test-assert (not (bag-every? number? hetero)))
|
||||
(test-assert (not (bag-any? symbol? homo)))
|
||||
(test-assert (bag-every? number? homo))))
|
||||
|
||||
(test-group "bags/lowlevel"
|
||||
(define bucket (bag string-ci-comparator "abc" "def"))
|
||||
(define nums (bag number-comparator 1 2 3))
|
||||
;; nums is now {1, 2, 3}
|
||||
(define nums2 (bag-replace nums 2.0))
|
||||
;; nums2 is now {1, 2.0, 3}
|
||||
(test string-ci-comparator (bag-element-comparator bucket))
|
||||
(test-assert (bag-contains? bucket "abc"))
|
||||
(test-assert (bag-contains? bucket "ABC"))
|
||||
(test "def" (bag-member bucket "DEF" "fqz"))
|
||||
(test "fqz" (bag-member bucket "lmn" "fqz"))
|
||||
(test-assert (bag-any? inexact? nums2))
|
||||
(bag-replace! nums 2.0)
|
||||
;; nums is now {1, 2.0, 3}
|
||||
(test-assert (bag-any? inexact? nums))
|
||||
(let ((bob
|
||||
(bag bag-comparator
|
||||
(bag eqv-comparator 1 2)
|
||||
(bag eqv-comparator 1 2))))
|
||||
(test 2 (bag-size bob))))
|
||||
|
||||
(test-group "bags/semantics"
|
||||
(define mybag (bag number-comparator 1 2))
|
||||
;; mybag is {1, 2}
|
||||
(test 2 (bag-size mybag))
|
||||
(bag-adjoin! mybag 1)
|
||||
;; mybag is {1, 1, 2}
|
||||
(test 3 (bag-size mybag))
|
||||
(test 2 (bag-unique-size mybag))
|
||||
(bag-delete! mybag 2)
|
||||
;; mybag is {1, 1}
|
||||
(bag-delete! mybag 2)
|
||||
(test 2 (bag-size mybag))
|
||||
(bag-increment! mybag 1 3)
|
||||
;; mybag is {1, 1, 1, 1, 1}
|
||||
(test 5 (bag-size mybag))
|
||||
(test-assert (bag-decrement! mybag 1 2))
|
||||
;; mybag is {1, 1, 1}
|
||||
(test 3 (bag-size mybag))
|
||||
(bag-decrement! mybag 1 5)
|
||||
;; mybag is {}
|
||||
(test 0 (bag-size mybag)))
|
||||
|
||||
(test-group "bags/convert"
|
||||
(define multi (bag eqv-comparator 1 2 2 3 3 3))
|
||||
(define single (bag eqv-comparator 1 2 3))
|
||||
(define singleset (set eqv-comparator 1 2 3))
|
||||
(define minibag (bag eqv-comparator 'a 'a))
|
||||
(define alist '((a . 2)))
|
||||
(test alist (bag->alist minibag))
|
||||
(test-assert (bag=? minibag (alist->bag eqv-comparator alist)))
|
||||
(test-assert (set=? singleset (bag->set single)))
|
||||
(test-assert (set=? singleset (bag->set multi)))
|
||||
(test-assert (bag=? single (set->bag singleset)))
|
||||
(test-assert (not (bag=? multi (set->bag singleset))))
|
||||
(set->bag! minibag singleset)
|
||||
;; minibag is now {a, a, a, a, 1, 2, 3}
|
||||
(test-assert (bag-contains? minibag 1)))
|
||||
|
||||
(test-group "bags/sumprod"
|
||||
(define abb (bag eq-comparator 'a 'b 'b))
|
||||
(define aab (bag eq-comparator 'a 'a 'b))
|
||||
(define total (bag-sum abb aab))
|
||||
(test 3 (bag-count (lambda (x) (eqv? x 'a)) total))
|
||||
(test 3 (bag-count (lambda (x) (eqv? x 'b)) total))
|
||||
(test 12 (bag-size (bag-product 2 total)))
|
||||
(let ((bag1 (bag eqv-comparator 1)))
|
||||
(bag-sum! bag1 bag1)
|
||||
(test 2 (bag-size bag1))
|
||||
(bag-product! 2 bag1)
|
||||
(test 4 (bag-size bag1)))
|
||||
)
|
||||
|
||||
(test-group "comparators"
|
||||
(define a (set number-comparator 1 2 3))
|
||||
(define b (set number-comparator 1 2 4))
|
||||
(define aa (bag number-comparator 1 2 3))
|
||||
(define bb (bag number-comparator 1 2 4))
|
||||
(test-assert (not (=? set-comparator a b)))
|
||||
(test-assert (=? set-comparator a (set-copy a)))
|
||||
;;(test-error (<? set-comparator a b))
|
||||
(test-assert (not (=? bag-comparator aa bb)))
|
||||
(test-assert (=? bag-comparator aa (bag-copy aa)))
|
||||
;;(test-error (<? bag-comparator aa bb))
|
||||
(test-assert (not (=? (make-default-comparator) a aa)))
|
||||
))
|
||||
)))
|
||||
|
|
@ -14,6 +14,7 @@
|
|||
(rename (srfi 95 test) (run-tests run-srfi-95-tests))
|
||||
(rename (srfi 99 test) (run-tests run-srfi-99-tests))
|
||||
(rename (srfi 101 test) (run-tests run-srfi-101-tests))
|
||||
(rename (srfi 113 test) (run-tests run-srfi-113-tests))
|
||||
(rename (srfi 116 test) (run-tests run-srfi-116-tests))
|
||||
(rename (srfi 117 test) (run-tests run-srfi-117-tests))
|
||||
(rename (srfi 121 test) (run-tests run-srfi-121-tests))
|
||||
|
|
@ -73,6 +74,7 @@
|
|||
(run-srfi-95-tests)
|
||||
(run-srfi-99-tests)
|
||||
(run-srfi-101-tests)
|
||||
(run-srfi-113-tests)
|
||||
(run-srfi-116-tests)
|
||||
(run-srfi-117-tests)
|
||||
(run-srfi-121-tests)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue