(module test-bag mzscheme
(require "../private/require.ss")
(require-contracts)
(require-schemeunit)
(require-etc)
(require-lists)
(require (lib "11.ss" "srfi")
"../private/datum.ss"
(prefix bag: "../bag.ss"))
(provide/contract
[test-bag test-suite?]
[test-ordered-bag test-suite?]
[test-hashed-bag test-suite?]
[test-unordered-bag test-suite?])
(define (alist->sexp alist)
(map (lambda (p)
(list (car p) (cdr p)))
alist))
(define (make-bag-test name bag)
(make-test-suite (format "Bag: ~a" name)
(make-test-suite "accessors"
(make-test-suite "elements"
(make-test-case "empty"
(assert datum-list=? (bag:elements (bag)) null))
(make-test-case "1,2,3"
(assert datum-list=? (bag:elements (bag 1 2 3)) (list 1 2 3)))
(make-test-case "1,2,2,3"
(assert datum-list=? (bag:elements (bag 1 2 2 3)) (list 1 2 3))))
(make-test-suite "to-sexp"
(make-test-case "empty"
(assert datum-bindings=?
(bag:to-sexp (bag))
null))
(make-test-case "1,2,3"
(assert datum-bindings=?
(bag:to-sexp (bag 1 2 3))
(list (list 1 1)
(list 2 1)
(list 3 1))))
(make-test-case "1,2,2,3"
(assert datum-bindings=?
(bag:to-sexp (bag 1 2 2 3))
(list (list 1 1)
(list 2 2)
(list 3 1)))))
(make-test-suite "to-alist"
(make-test-case "empty"
(assert datum-bindings=?
(alist->sexp (bag:to-alist (bag)))
null))
(make-test-case "1,2,3"
(assert datum-bindings=?
(alist->sexp (bag:to-alist (bag 1 2 3)))
(list (list 1 1)
(list 2 1)
(list 3 1))))
(make-test-case "1,2,2,3"
(assert datum-bindings=?
(alist->sexp (bag:to-alist (bag 1 2 2 3)))
(list (list 1 1)
(list 2 2)
(list 3 1)))))
(make-test-suite "empty?"
(make-test-case "true"
(assert-true (bag:empty? (bag))))
(make-test-case "false"
(assert-false (bag:empty? (bag 1 2 3)))))
(make-test-suite "size"
(make-test-case "empty"
(assert = (bag:size (bag)) 0))
(make-test-case "1,2,3"
(assert = (bag:size (bag 1 2 3)) 3))
(make-test-case "1,2,2,3"
(assert = (bag:size (bag 1 2 2 3)) 4)))
(make-test-suite "size/unique"
(make-test-case "empty"
(assert = (bag:size/unique (bag)) 0))
(make-test-case "1,2,3"
(assert = (bag:size/unique (bag 1 2 3)) 3))
(make-test-case "1,2,2,3"
(assert = (bag:size/unique (bag 1 2 2 3)) 3)))
(make-test-suite "member?"
(make-test-case "true"
(assert-true (bag:member? 2 (bag 1 2 3))))
(make-test-case "false"
(assert-false (bag:member? 4 (bag 1 2 3)))))
(make-test-suite "count"
(make-test-case "1,2,2,3,4,4,4"
(let ([new-bag (bag 1 2 2 3 4 4 4)])
(assert = (bag:count 1 new-bag) 1)
(assert = (bag:count 2 new-bag) 2)
(assert = (bag:count 3 new-bag) 1)
(assert = (bag:count 4 new-bag) 3))))
(make-test-suite "lookup"
(make-test-case "a in a,b,c"
(assert datum=?
(bag:lookup "a" (bag "a" "b" "c"))
"a"))
(make-test-case "a in b,c"
(assert-false (bag:lookup "a" (bag "b" "c"))))
(make-test-case "success override"
(assert-equal?
(bag:lookup 1 (bag 1 2 3)
(lambda () 'failure)
(lambda (elem) (list 'success elem)))
(list 'success 1)))
(make-test-case "failure override"
(assert-equal?
(bag:lookup 4 (bag 1 2 3)
(lambda () 'failure)
(lambda (elem) (list 'success elem)))
'failure)))
(make-test-suite "lookup/count"
(make-test-case "a in a,b,c"
(assert datum=?
(bag:lookup/count "a" (bag "a" "b" "c"))
"a"))
(make-test-case "a in b,c"
(assert-false (bag:lookup/count "a" (bag "b" "c"))))
(make-test-case "success override"
(assert-equal?
(bag:lookup/count 1 (bag 1 2 3)
(lambda () 'failure)
(lambda (elem count) (list 'success elem count)))
(list 'success 1 1)))
(make-test-case "failure override"
(assert-equal?
(bag:lookup/count 4 (bag 1 2 3)
(lambda () 'failure)
(lambda (elem count) (list 'success elem count)))
'failure)))
(make-test-suite "select"
(make-test-case "select from 1 2 3"
(let ([new-bag (bag 1 2 3)])
(assert-true (bag:member? (bag:select new-bag) new-bag)))))
(make-test-suite "select/count"
(make-test-case "select from 1 2 3"
(let*-values ([(new-bag) (bag 1 2 3)]
[(elem count) (bag:select/count new-bag)])
(assert-true (bag:member? elem new-bag))
(assert-true (= (bag:count elem new-bag) count)))))
)
(make-test-suite "updaters"
(make-test-suite "insert"
(make-test-case "1,3 + 2"
(assert datum-list=?
(bag:elements (bag:insert 2 (bag 1 3)))
(list 1 2 3)))
(make-test-case "1,2,3 + 2"
(let* ([new-bag (bag:insert 2 (bag 1 2 3))]
[elems (bag:elements new-bag)])
(assert datum-list=? elems (list 1 2 3))
(assert = (bag:count 2 new-bag) 2
"Inserting the element did not change the element count.")))
(make-test-case "a + a"
(let* ([a "a"]
[a* (string-copy a)]
[new-bag (bag:insert a* (bag a))]
[elems (bag:elements new-bag)])
(assert = (length elems) 1
"Inserting a duplicate changed set size.")
(assert = (bag:count a* new-bag) 2
"Inserting a duplicate did not change the element count.")
(assert-false
(eq? (first elems) a)
"Inserted duplicate; original value remains.")
(assert-true
(eq? (first elems) a*)
"Inserted duplicate; new value not found."))))
(make-test-suite "insert/count"
(make-test-case "1,3 + 2 * 2"
(assert datum-bindings=?
(bag:to-sexp (bag:insert/count 2 2 (bag 1 3)))
(list (list 1 1)
(list 2 2)
(list 3 1))))
(make-test-case "1,2,3 + 2 * 2"
(let* ([new-bag (bag:insert/count 2 2 (bag 1 2 3))]
[elems (bag:elements new-bag)])
(assert datum-list=? elems (list 1 2 3))
(assert = (bag:count 2 new-bag) 3
"Inserting the element did not change the element count.")))
(make-test-case "a + a * 3"
(let* ([a "a"]
[a* (string-copy a)]
[new-bag (bag:insert/count a* 3 (bag a))]
[elems (bag:elements new-bag)])
(assert = (length elems) 1
"Inserting a duplicate changed set size.")
(assert = (bag:count a* new-bag) 4
"Inserting a duplicate did not change the element count.")
(assert-false
(eq? (first elems) a)
"Inserted duplicate; original value remains.")
(assert-true
(eq? (first elems) a*)
"Inserted duplicate; new value not found."))))
(make-test-suite "remove"
(make-test-case "present"
(assert datum-list=?
(bag:elements (bag:remove 2 (bag 1 2 3)))
(list 1 3))
(let* ([old-bag (bag 1 2 2 3)]
[new-bag (bag:remove 2 old-bag)])
(assert datum-list=?
(bag:elements new-bag)
(list 1 2 3))
(assert = (bag:count 2 old-bag) 2)
(assert = (bag:count 2 new-bag) 1)))
(make-test-case "absent"
(assert datum-list=?
(bag:elements (bag:remove 4 (bag 1 2 3)))
(list 1 2 3))))
(make-test-suite "remove/count"
(make-test-case "present"
(assert datum-list=?
(bag:elements (bag:remove/count 2 4 (bag 1 2 2 2 2 3)))
(list 1 3))
(let* ([old-bag (bag 1 2 2 2 3)]
[new-bag (bag:remove/count 2 2 old-bag)])
(assert datum-list=?
(bag:elements new-bag)
(list 1 2 3))
(assert = (bag:count 2 old-bag) 3)
(assert = (bag:count 2 new-bag) 1)))
(make-test-case "absent"
(assert datum-list=?
(bag:elements (bag:remove/count 4 3 (bag 1 2 3)))
(list 1 2 3))))
(make-test-suite "remove*"
(make-test-case "present"
(assert datum-list=?
(bag:elements (bag:remove* (bag 1 2 3) 2))
(list 1 3))
(let* ([old-bag (bag 1 2 2 3)]
[new-bag (bag:remove* old-bag 1 2)])
(assert datum-list=?
(bag:elements new-bag)
(list 2 3))
(assert = (bag:count 2 old-bag) 2)
(assert = (bag:count 2 new-bag) 1)))
(make-test-case "absent"
(assert datum-list=?
(bag:elements (bag:remove* (bag 1 2 3) 4 5))
(list 1 2 3))))
(make-test-suite "remove/all"
(make-test-case "present"
(assert datum-list=?
(bag:elements (bag:remove/all 2 (bag 1 2 3)))
(list 1 3))
(assert datum-list=?
(bag:elements (bag:remove/all 2 (bag 1 2 2 3)))
(list 1 3)))
(make-test-case "absent"
(assert datum-list=?
(bag:elements (bag:remove/all 4 (bag 1 2 3)))
(list 1 2 3))))
(make-test-suite "clear"
(make-test-case "1,2,3"
(let* ([old-bag (bag 1 2 3)]
[new-bag (bag:clear old-bag)])
(assert-false (bag:empty? old-bag))
(assert-true (bag:empty? new-bag)))))
)
(make-test-suite "traversals"
(make-test-suite "fold"
(make-test-case "1,2,2,3"
(assert datum-list=?
(bag:fold (lambda (e l)
(cons e l))
null
(bag 1 2 2 3))
(list 1 2 3))))
(make-test-suite "fold/count"
(make-test-case "1,2,2,3"
(assert datum-bindings=?
(bag:fold/count (lambda (e c l)
(cons (list e c) l))
null
(bag 1 2 2 3))
(list (list 1 1) (list 2 2) (list 3 1)))))
(make-test-suite "map"
(make-test-case "1,2,2,3"
(assert datum-bindings=?
(bag:to-sexp (bag:map (lambda (e) (+ e 3))
(bag 1 2 2 3)))
(list (list 4 1) (list 5 2) (list 6 1)))))
(make-test-suite "map/count"
(make-test-case "1,2,2,3"
(assert datum-bindings=?
(bag:to-sexp (bag:map/count (lambda (e c) (+ e c))
(bag 1 2 2 3)))
(list (list 2 1) (list 4 3)))))
(make-test-suite "for-each"
(make-test-case "1,2,2,3"
(let* ([elems null])
(bag:for-each (lambda (e)
(set! elems (cons e elems)))
(bag 1 2 2 3))
(assert datum-list=?
elems
(list 1 2 3))))
(make-test-case "non-void"
(bag:for-each (constant #f) (bag 1 2 3))))
(make-test-suite "for-each/count"
(make-test-case "1,2,2,3"
(let* ([elems null])
(bag:for-each/count (lambda (e c)
(set! elems (cons (list e c) elems)))
(bag 1 2 2 3))
(assert datum-bindings=?
elems
(list (list 1 1) (list 2 2) (list 3 1)))))
(make-test-case "non-void"
(bag:for-each (constant #f) (bag 1 2 3))))
(make-test-suite "filter"
(make-test-case "numbers"
(assert datum-list=?
(bag:elements (bag:filter number?
(bag 1 2 3 'a 'b 'c "A" "B" "C")))
(list 1 2 3))))
(make-test-suite "filter/count"
(make-test-case "count > 1"
(assert datum-list=?
(bag:elements (bag:filter/count (lambda (e c) (> c 1))
(bag 1 2 3 'a 'b 'c "A" "B" "C" 1 2 3)))
(list 1 2 3))))
(make-test-suite "all?"
(make-test-case "all"
(assert-true (bag:all? number? (bag 1 2 3 4))))
(make-test-case "some"
(assert-false (bag:all? even? (bag 1 2 3 4))))
(make-test-case "none"
(assert-false (bag:all? negative? (bag 1 2 3 4)))))
(make-test-suite "any?"
(make-test-case "all"
(assert-true (bag:any? number? (bag 1 2 3 4))))
(make-test-case "some"
(assert-true (bag:any? even? (bag 1 2 3 4))))
(make-test-case "none"
(assert-false (bag:any? negative? (bag 1 2 3 4)))))
(make-test-suite "all?/count"
(make-test-case "all"
(assert-true (bag:all?/count (lambda (e c) (> c 1))
(bag 1 1 2 2 2 3 3 4 4 4 4))))
(make-test-case "some"
(assert-false (bag:all?/count (lambda (e c) (> c 2))
(bag 1 1 2 2 2 3 3 4 4 4 4))))
(make-test-case "none"
(assert-false (bag:all?/count (lambda (e c) (> c 4))
(bag 1 1 2 2 2 3 3 4 4 4 4)))))
(make-test-suite "any?/count"
(make-test-case "all"
(assert-true (bag:any?/count (lambda (e c) (> c 1))
(bag 1 1 2 2 2 3 3 4 4 4 4))))
(make-test-case "some"
(assert-true (bag:any?/count (lambda (e c) (> c 2))
(bag 1 1 2 2 2 3 3 4 4 4 4))))
(make-test-case "none"
(assert-false (bag:any?/count (lambda (e c) (> c 4))
(bag 1 1 2 2 2 3 3 4 4 4 4)))))
)
(make-test-suite "combinations"
(make-test-suite "union"
(make-test-suite "idempotent"
(make-test-case "b1 union b1 = b1"
(let ([b1 (bag 1 2 3 2 3 4)])
(assert bag:equal?
(bag:union b1 b1)
b1))))
(make-test-suite "commutative"
(make-test-case "b1 union b2 = b2 union b1"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)])
(assert bag:equal?
(bag:union b1 b2)
(bag:union b2 b1))))
(make-test-case "b1 union b2 = b3"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b3 (bag 1 2 2 3 3 3 4 5)])
(assert bag:equal?
(bag:union b1 b2)
b3))))
(make-test-suite "associative"
(make-test-case "(b1 union b2) union b4 = b1 union (b2 union b4)"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b4 (bag 2 3 4 5 6)])
(assert bag:equal?
(bag:union (bag:union b1 b2) b4)
(bag:union b1 (bag:union b2 b4)))))
(make-test-case "(b1 union b2) union b4 = b5"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b4 (bag 2 3 4 5 6)]
[b5 (bag 1 2 2 3 3 3 4 5 6)])
(assert bag:equal?
(bag:union (bag:union b1 b2) b4)
b5)))))
(make-test-suite "intersection"
(make-test-suite "idempotent"
(make-test-case "b1 union b1 = b1"
(let ([b1 (bag 1 2 3 2 3 4)])
(assert bag:equal?
(bag:intersection b1 b1)
b1))))
(make-test-suite "commutative"
(make-test-case "b1 union b2 = b2 union b1"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)])
(assert bag:equal?
(bag:intersection b1 b2)
(bag:intersection b2 b1))))
(make-test-case "b1 union b2 = b3"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b3 (bag 2 2 3 3)])
(assert bag:equal?
(bag:intersection b1 b2)
b3))))
(make-test-suite "associative"
(make-test-case "(b1 union b2) union b4 = b1 union (b2 union b4)"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b4 (bag 2 3 4 5 6)])
(assert bag:equal?
(bag:intersection (bag:intersection b1 b2) b4)
(bag:intersection b1 (bag:intersection b2 b4)))))
(make-test-case "(b1 union b2) union b4 = b5"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b4 (bag 2 3 4 5 6)]
[b5 (bag 2 3)])
(assert bag:equal?
(bag:intersection (bag:intersection b1 b2) b4)
b5)))))
(make-test-suite "difference"
(make-test-case "b1 difference b1 = (empty)"
(let ([b1 (bag 1 2 3 2 3 4)])
(assert bag:equal?
(bag:difference b1 b1)
(bag:clear b1))))
(make-test-case "b1 difference b2 = b3"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b3 (bag 1 4)])
(assert bag:equal?
(bag:difference b1 b2)
b3)))
(make-test-case "(b1 difference b2) difference b4 = b5"
(let ([b1 (bag 1 2 2 3 3 4)]
[b2 (bag 2 2 3 3 3 5)]
[b4 (bag 2 3 4 5 6)]
[b5 (bag 1)])
(assert bag:equal?
(bag:difference (bag:difference b1 b2) b4)
b5))))
)
(make-test-suite "relations"
(make-test-suite "subbag?"
(make-test-case "true"
(assert-true (bag:subbag? (bag 1 2 3) (bag 1 2 2 3))))
(make-test-case "false"
(assert-false (bag:subbag? (bag 4 4 5 6 6 6) (bag 4 5 6 6)))))
(make-test-suite "equal?"
(make-test-case "true"
(assert-true (bag:equal? (bag 1 2 2 3) (bag 1 2 2 3))))
(make-test-case "false"
(assert-false (bag:equal? (bag 1 2 2 3) (bag 1 2 3)))))
)
))
(define test-ordered-bag
(make-bag-test "Ordered" (curry bag:make-ordered datum-compare)))
(define test-hashed-bag
(make-bag-test "Hashed" (curry bag:make-hashed datum-hash datum=?)))
(define test-unordered-bag
(make-bag-test "Unordered" (curry bag:make-unordered datum=?)))
(define test-bag
(make-test-suite "Bags"
test-ordered-bag
test-hashed-bag
test-unordered-bag))
)![[logo]](/logo.png){kind=logo}