From ab88f53e48e18032c48d42c156717966db1b7f8e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Jan 2018 23:47:28 +0900 Subject: [PATCH] adding srfi 113 --- lib/srfi/113.sld | 66 +++++ lib/srfi/113/bags.scm | 344 ++++++++++++++++++++++++ lib/srfi/113/sets.scm | 225 ++++++++++++++++ lib/srfi/113/test.sld | 606 ++++++++++++++++++++++++++++++++++++++++++ tests/lib-tests.scm | 2 + 5 files changed, 1243 insertions(+) create mode 100644 lib/srfi/113.sld create mode 100644 lib/srfi/113/bags.scm create mode 100644 lib/srfi/113/sets.scm create mode 100644 lib/srfi/113/test.sld diff --git a/lib/srfi/113.sld b/lib/srfi/113.sld new file mode 100644 index 00000000..72a9e67f --- /dev/null +++ b/lib/srfi/113.sld @@ -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 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 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")) diff --git a/lib/srfi/113/bags.scm b/lib/srfi/113/bags.scm new file mode 100644 index 00000000..2545e497 --- /dev/null +++ b/lib/srfi/113/bags.scm @@ -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? . bags) + (apply 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=? baglist 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? . sets) + (apply 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 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? 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-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? 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 (bag<=? one two)) + (test-assert (not (bag>? one two))) + (test-assert (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-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 (