;; ----------------------------------------------------------------------
;;  SRFI 113 ...
;; ----------------------------------------------------------------------
;;; Below are some default comparators provided by SRFI-114,
;;; but not SRFI-128, which this SRFI has transitioned to
;;; depend on. See the rationale for SRFI-128 as to why it is
;;; preferred in usage compared to SRFI-114.

;; Most if not all of this code is taken from SRFI-114

(import (srfi 128))

(define exact inexact->exact)

(define string-foldcase string-downcase)

(define (make-comparison=/< = <)
  (lambda (a b)
    (cond
      ((= a b) 0)
      ((< a b) -1)
      (else 1))))

;; Comparison procedure for real numbers only
(define (real-comparison a b)
  (cond
    ((< a b) -1)
    ((> a b) 1)
    (else 0)))

;; Comparison procedure for non-real numbers.
(define (complex-comparison a b)
  (let ((real-result (real-comparison (real-part a) (real-part b))))
    (if (= real-result 0)
      (real-comparison (imag-part a) (imag-part b))
      real-result)))

(define (number-hash obj) (exact (abs obj)))

(define number-comparator
  (make-comparator number? = complex-comparison number-hash))

(define char-comparison (make-comparison=/< char=? char<?))

;; not necesary, and interferes with SRFI-128:
;; (define (char-hash obj) (abs (char->integer obj)))

(define char-comparator
  (make-comparator char? char=? char-comparison char-hash))

;; Makes a hash function that works vectorwise
(define limit (expt 2 20))

(define (make-vectorwise-hash hash length ref)
  (lambda (obj)
    (let loop ((index (- (length obj) 1)) (result 5381))
      (if (= index 0)
        result
        (let* ((prod (modulo (* result 33) limit))
               (sum (modulo (+ prod (hash (ref obj index))) limit)))
          (loop (- index 1) sum))))))

;; not necesary, and interferes with SRFI-128:
;; (define string-hash
;;   (make-vectorwise-hash char-hash string-length string-ref))

(define string-comparison (make-comparison=/< string=? string<?))

(define string-ci-comparison (make-comparison=/< string-ci=? string-ci<?))

(define string-comparator
  (make-comparator string? string=? string-comparison string-hash))

(define (string-ci-hash obj) (string-hash (string-foldcase obj)))

(define string-ci-comparator
  (make-comparator string? string-ci=? string-ci-comparison string-ci-hash))

(define eq-comparator
  (make-comparator
    #t
    eq?
    #f
    default-hash))

(define eqv-comparator
  (make-comparator
    #t
    eqv?
    #f
    default-hash))

(define equal-comparator
  (make-comparator
    #t
    equal?
    #f
    default-hash))

;;;
;;; END of srfi-114 piece
;;;


;;; sets/simple

(define (big x) (> x 5))

(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 {}
(test "test/simple 1" #t (set-empty? esyms))
(define total 0)
(test "test/simple 2" #t (set? nums))
(test "test/simple 3" #t (set? syms))
(test "test/simple 4" #t (set? nums2))
(test "test/simple 5" #t (set? syms2))
(test "test/simple 6" #t (not (set? 'a)))
(set-adjoin! nums 2)
(set-adjoin! nums 3)
(set-adjoin! nums 4)
(set-adjoin! nums 4)
;; nums is now {2, 3, 4}
(test "test/simple 7" 4 (set-size (set-adjoin nums 5)))
(test "test/simple 8" 3 (set-size nums))
(test "test/simple 9" 3 (set-size (set-delete syms 'd)))
(test "test/simple 10" 2 (set-size (set-delete-all syms '(c d))))
(test "test/simple 11" 4 (set-size syms))
(set-adjoin! syms 'e 'f)
;; syms is now {a, b, c, d, e, f}
(test "test/simple 12" 4 (set-size (set-delete-all! syms '(e f))))
;; syms is now {a, b, c, d}
(test "test/simple 13" 0 (set-size nums2))
(test "test/simple 14" 4 (set-size syms2))
(set-delete! nums 2)
;; nums is now {3, 4}
(test "test/simple 15" 2 (set-size nums))
(set-delete! nums 1)
(test "test/simple 16" 2 (set-size nums))
(set! nums2 (set-map number-comparator (lambda (x) (* 10 x)) nums))
;; nums2 is now {30, 40}
(test "test/simple 17" #t (set-contains? nums2 30))
(test "test/simple 18" #t (not (set-contains? nums2 3)))
(set-for-each (lambda (x) (set! total (+ total x))) nums2)
(test "test/simple 19" 70 total)
(test "test/simple 20" 10 (set-fold + 3 nums))
(set! nums (set eqv-comparator 10 20 30 40 50))
;; nums is now {10, 20, 30, 40, 50}
(test "test/simple 21" #t
    (set=? nums (set-unfold
                 (lambda (i) (= i 0))
                 (lambda (i) (* i 10))
                 (lambda (i) (- i 1))
                 5
                 eqv-comparator)))
(test "test/simple 22" '(a) (set->list (set eq-comparator 'a)))
(set! syms2 (list->set eq-comparator '(e f)))
;; syms2 is now {e, f}
(test "test/simple 23" 2  (set-size syms2))
(test "test/simple 24" #t (set-contains? syms2 'e))
(test "test/simple 25" #t (set-contains? syms2 'f))
(list->set! syms2 '(a b))
(test "test/simple 26" 4 (set-size syms2))



;;; 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 set1 #f)
(define obj1 #f)
(define-values (set1 obj1)
  (set-search! (set-copy yam) #\! failure/insert error))
(test "sets/search 1" #t (set=? yam! set1))
(test "sets/search 2" 1 obj1)
(define-values (set2 obj2)
  (set-search! (set-copy yam) #\! failure/ignore error))
(test "sets/search 3" #t (set=? yam set2))
(test "sets/search 4" 2 obj2)
(define-values (set3 obj3)
  (set-search! (set-copy yam) #\y error success/update))
(test "sets/search 5" #t (set=? bam set3))
(test "sets/search 6" 3 obj3)
(define-values (set4 obj4)
  (set-search! (set-copy yam) #\a error success/remove))
(test "sets/search 7" #t (set=? ym set4))
(test "sets/search 8" 4 obj4)


;;; 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 sety (set number-comparator 1 2 4 5))
  (define setx (set number-comparator 10 20 30 40))
  (test "sets/subsets 1" #t (set=? set2 other-set2))
  (test "sets/subsets 2" #t (not (set=? set2 set3)))
  (test "sets/subsets 3" #t (not (set=? set2 set3 other-set2)))
  (test "sets/subsets 4" #t (set<? set2 set3 set4))
  (test "sets/subsets 5" #t (not (set<? set2 other-set2)))
  (test "sets/subsets 6" #t (set<=? set2 other-set2 set3))
  (test "sets/subsets 7" #t (not (set<=? set2 set3 other-set2)))
  (test "sets/subsets 8" #t (set>? set4 set3 set2))
  (test "sets/subsets 9" #t (not (set>? set2 other-set2)))
  (test "sets/subsets 10" #t (set>=? set3 other-set2 set2))
  (test "sets/subsets 11" #t (not (set>=? other-set2 set3 set2)))
  (test "sets/subsets 12" #t (not (set<? set2 other-set2)))
  (test "sets/subsets 13" #t (not (set<? set2 setx)))
  (test "sets/subsets 14" #t (not (set<=? set2 setx)))
  (test "sets/subsets 15" #t (not (set>? set2 setx)))
  (test "sets/subsets 16" #t (not (set>=? set2 setx)))
  (test "sets/subsets 17" #t (not (set<?  set3 sety)))
  (test "sets/subsets 18" #t (not (set<=? set3 sety)))
  (test "sets/subsets 19" #t (not (set>?  set3 sety)))
  (test "sets/subsets 20" #t (not (set>=? set3 sety)))

;;; "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 "sets/ops 1" #t (set-disjoint? abcd efgh))
  (test "sets/ops 2" #t (not (set-disjoint? abcd ab)))

(define efgh2 #f)
(define abcd2 #f)
(define abcd3 #f)
(define abcd4 #f)

;; ;(parameterize ((current-test-comparator set=?))

(test "sets/ops 3" #t (set=? abcd (set-union abcd)))
(test "sets/ops 4" #t (set=? all (set-union abcd efgh)))
(test "sets/ops 5" #t (set=? abcdgh (set-union abcd abgh)))
(test "sets/ops 6" #t (set=? abefgh (set-union efgh abgh)))
(set! efgh2 (set-copy efgh))
(set-union! efgh2)
(test "sets/ops 7" #t (set=? efgh efgh2))
(set-union! efgh2 abgh)
(test "sets/ops 8" #t (set=? abefgh efgh2))
(test "sets/ops 9" #t (set=? abcd (set-intersection abcd)))
(test "sets/ops 10" #t (set=? none (set-intersection abcd efgh)))
(set! abcd2 (set-copy abcd))
(set-intersection! abcd2)
(test "sets/ops 11" #t (set=? abcd abcd2))
(set-intersection! abcd2 efgh)
(test "sets/ops 12" #t (set=? none abcd2))
(test "sets/ops 13" #t (set=? ab (set-intersection abcd abgh)))
(test "sets/ops 14" #t (set=? ab (set-intersection abgh abcd)))
(test "sets/ops 15" #t (set=? abcd (set-difference abcd)))
(test "sets/ops 16" #t (set=? cd (set-difference abcd ab)))
(test "sets/ops 17" #t (set=? abcd (set-difference abcd gh)))
(test "sets/ops 18" #t (set=? none (set-difference abcd abcd)))
(set! abcd3 (set-copy abcd))
(set-difference! abcd3)
(test "sets/ops 19" #t (set=? abcd abcd3))
(set-difference! abcd3 abcd)
(test "sets/ops 20" #t (set=? none abcd3))
(test "sets/ops 21" #t (set=? cdgh (set-xor abcd abgh)))
(test "sets/ops 22" #t (set=? all (set-xor abcd efgh)))
(test "sets/ops 23" #t (set=? none (set-xor abcd other-abcd)))
(set! abcd4 (set-copy abcd))
;; don't test xor! effect
(test "sets/ops 24" #t (set=? none (set-xor! abcd4 other-abcd)))
(test "sets/ops 25" #t (set=? other-abcd abcd)) ; "abcd smashed?"
(test "sets/ops 26" #t (set=? other-efgh efgh)) ; "efgh smashed?"
(test "sets/ops 27" #t (set=? other-abgh abgh)) ; "abgh smashed?"

;;; STklos test system won't catch syntax error; skip these
;; ;;; "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))


;; ;;; "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 "sets/whole 1" #t (set=? top (set-filter big whole)))
    (test "sets/whole 2" #t (set=? bottom (set-remove big whole)))
    (set-filter! big whole2)
    (test "sets/whole 3" #t (not (set-contains? whole2 1)))
    (set-remove! big whole3)
    (test "sets/whole 4" #t (not (set-contains? whole3 10)))
    (test "sets/whole 5" #t (set=? top topx))
    (test "sets/whole 6" #t (set=? bottom bottomx))
    (test "sets/whole 7" #t (set=? top whole4))
  (test "sets/whole 8" 5 (set-count big whole))
  (define hetero (set eqv-comparator 1 2 'a 3 4))
  (define homo (set eqv-comparator 1 2 3 4 5))
  (test "sets/whole 8" 'a (set-find symbol? hetero (lambda () (error "wrong"))))
  (test/error  "sets/whole 9" (set-find symbol? homo (lambda () (error "wrong"))))
  (test "sets/whole 10" #t (set-any? symbol? hetero))
  (test "sets/whole 11" #t (set-any? number? hetero))
  (test "sets/whole 12" #t (not (set-every? symbol? hetero)))
  (test "sets/whole 13" #t (not (set-every? number? hetero)))
  (test "sets/whole 14" #t (not (set-any? symbol? homo)))
  (test "sets/whole 15" #t (set-every? number? homo))


;;; "sets/lowlevel"
  (define bucket (set string-ci-comparator "abc" "def"))
  (test "sets/lowlevel 1" string-ci-comparator (set-element-comparator bucket))
  (test "sets/lowlevel 2" #t (set-contains? bucket "abc"))
  (test "sets/lowlevel 3" #t (set-contains? bucket "ABC"))
  (test "sets/lowlevel 4" "def" (set-member bucket "DEF" "fqz"))
  (test "sets/lowlevel 5" "fqz" (set-member bucket "lmn" "fqz"))
  (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 "sets/lowlevel 6" #t (set-any? inexact? nums2))
  (set-replace! nums 2.0)
  ;; nums is now {1, 2.0, 3}
  (test "sets/lowlevel 6" #t (set-any? inexact? nums))
  (define 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 "sets/lowlevel 5" 1 (set-size sos))


;;; "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 "bags/simple 1" #t (bag-empty? esyms))
  (define total 0)
  (test "bags/simple 2" #t (bag? nums))
  (test "bags/simple 3" #t (bag? syms))
  (test "bags/simple 4" #t (bag? nums2))
  (test "bags/simple 5" #t (bag? syms2))
  (test "bags/simple 6" #t (not (bag? 'a)))
  (bag-adjoin! nums 2)
  (bag-adjoin! nums 3)
  (bag-adjoin! nums 4)
  ;; nums is now {2, 3, 4}
  (test "bags/simple 7" 4 (bag-size (bag-adjoin nums 5)))
  (test "bags/simple 8" 3 (bag-size nums))
  (test "bags/simple 9" 3 (bag-size (bag-delete syms 'd)))
  (test "bags/simple 10" 2 (bag-size (bag-delete-all syms '(c d))))
  (test "bags/simple 11" 4 (bag-size syms))
  (bag-adjoin! syms 'e 'f)
  ;; syms is now {a, b, c, d, e, f}
  (test "bags/simple 12" 4 (bag-size (bag-delete-all! syms '(e f))))
  ;; syms is now {a, b, c, d}
  (test "bags/simple 13" 3 (bag-size nums))
  (bag-delete! nums 1)
  (test "bags/simple 14" 3 (bag-size nums))
  (set! nums2 (bag-map number-comparator (lambda (x) (* 10 x)) nums))
  ;; nums2 is now {20, 30, 40}
  (test "bags/simple 15" #t (bag-contains? nums2 30))
  (test "bags/simple 16" #t (not (bag-contains? nums2 3)))
  (bag-for-each (lambda (x) (set! total (+ total x))) nums2)
  (test "bags/simple 17" 90 total)
  (test "bags/simple 18" 12 (bag-fold + 3 nums))
  (set! nums (bag eqv-comparator 10 20 30 40 50))
  ;; nums is now {10, 20, 30, 40, 50}
  (test "bags/simple 19" #t
    (bag=? nums (bag-unfold
       (lambda (i) (= i 0))
       (lambda (i) (* i 10))
       (lambda (i) (- i 1))
       5
       eqv-comparator)))
  (test "bags/simple 20" '(a) (bag->list (bag eq-comparator 'a)))
  (set! syms2 (list->bag eq-comparator '(e f)))
  ;; syms2 is now {e, f}
  (test "bags/simple 21" 2 (bag-size syms2))
  (test "bags/simple 22" #t (bag-contains? syms2 'e))
  (test "bags/simple 23" #t (bag-contains? syms2 'f))
  (list->bag! syms2 '(e f))
  ;; syms2 is now {e, e, f, f}
  (test "bags/simple 24" 4 (bag-size syms2))


;;; "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))
  (test "bags/search 1" #t (bag=? yam! bag1))
  (test "bags/search 2" 1 obj1)
  (define-values (bag2 obj2)
    (bag-search! (bag-copy yam) #\! failure/ignore error))
  (test "bags/search 3" #t (bag=? yam bag2))
  (test "bags/search 4" 2 obj2)
  (define-values (bag3 obj3)
    (bag-search! (bag-copy yam) #\y error success/update))
  (test "bags/search 5" #t (bag=? bam bag3))
  (test "bags/search 6" 3 obj3)
  (define-values (bag4 obj4)
    (bag-search! (bag-copy yam) #\a error success/remove))
  (test "bags/search 7" #t (bag=? ym bag4))
  (test "bags/search 8" 4 obj4)


;;; "bags/elemcount"
  (define mybag (bag eqv-comparator 1 1 1 1 1 2 2))
  (test "bags/elemcount 1" 5 (bag-element-count mybag 1))
  (test "bags/elemcount 2" 0 (bag-element-count mybag 3))


;;; "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))
  (define bagy (bag number-comparator 10 20 20 30 40))
  (test "bags/subbags 1" #t (bag=? bag2 other-bag2))
  (test "bags/subbags 2" #t (not (bag=? bag2 bag3)))
  (test "bags/subbags 3" #t (not (bag=? bag2 bag3 other-bag2)))
  (test "bags/subbags 4" #t (bag<? bag2 bag3 bag4))
  (test "bags/subbags 5" #t (not (bag<? bag2 other-bag2)))
  (test "bags/subbags 6" #t (bag<=? bag2 other-bag2 bag3))
  (test "bags/subbags 7" #t (not (bag<=? bag2 bag3 other-bag2)))
  (test "bags/subbags 8" #t (bag>? bag4 bag3 bag2))
  (test "bags/subbags 9" #t (not (bag>? bag2 other-bag2)))
  (test "bags/subbags 10" #t (bag>=? bag3 other-bag2 bag2))
  (test "bags/subbags 11" #t (not (bag>=? other-bag2 bag3 bag2)))
  (test "bags/subbags 12" #t (not (bag<? bag2 other-bag2)))
  (test "bags/subbags 13" #t (bag<=? bagx bagy))
  (test "bags/subbags 14" #t (not (bag<=? bagy bagx)))
  (test "bags/subbags 15" #t (bag<? bagx bagy))
  (test "bags/subbags 16" #t (not (bag<? bagy bagx)))
  (test "bags/subbags 17" #t (bag>=? bagy bagx))
  (test "bags/subbags 18" #t (not (bag>=? bagx bagy)))
  (test "bags/subbags 19" #t (bag>? bagy bagx))
  (test "bags/subbags 20" #t (not (bag>? bagx bagy)))


;;; "bags/multi"
  (define one (bag eqv-comparator 10))
  (define two (bag eqv-comparator 10 10))
  (test "bags/multi 1" #t (not (bag=? one two)))
  (test "bags/multi 2" #t (bag<? one two))
  (test "bags/multi 3" #t (not (bag>? one two)))
  (test "bags/multi 4" #t (bag<=? one two))
  (test "bags/multi 5" #t (not (bag>? one two)))
  (test "bags/multi 6" #t (bag=? two two))
  (test "bags/multi 7" #t (not (bag<? two two)))
  (test "bags/multi 8" #t (not (bag>? two two)))
  (test "bags/multi 9"  #t (bag<=? two two))
  (test "bags/multi 10" #t (bag>=? two two))
  (test "bags/multi 11"
        '((10 . 2))
        (let ((result '()))
          (bag-for-each-unique
           (lambda (x y) (set! result (cons (cons x y) result)))
           two)
          result))
  (test "bags/multi 12" 25 (bag-fold + 5 two))
  (test "bags/multi 13" 12 (bag-fold-unique (lambda (k n r) (+ k n r)) 0 two))


;;; "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 "bags/ops 1" #t (bag-disjoint? abcd efgh))
  (test "bags/ops 2" #t (not (bag-disjoint? abcd ab)))
;(parameterize ((current-test-comparator bag=?))
    (test "bags/ops " #t (bag=? abcd (bag-union abcd)))
    (test "bags/ops " #t (bag=? all (bag-union abcd efgh)))
    (test "bags/ops " #t (bag=? abcdgh (bag-union abcd abgh)))
    (test "bags/ops " #t (bag=? abefgh (bag-union efgh abgh)))
    (define efgh2 (bag-copy efgh))
    (bag-union! efgh2)
    (test "bags/ops " #t (bag=? efgh efgh2))
    (bag-union! efgh2 abgh)
    (test "bags/ops " #t (bag=? abefgh efgh2))
    (test "bags/ops " #t (bag=? abcd (bag-intersection abcd)))
    (test "bags/ops " #t (bag=? none (bag-intersection abcd efgh)))
    (define abcd2 (bag-copy abcd))
    (bag-intersection! abcd2)
    (test "bags/ops " #t (bag=? abcd abcd2))
    (bag-intersection! abcd2 efgh)
    (test "bags/ops " #t (bag=? none abcd2))
    (test "bags/ops " #t (bag=? ab (bag-intersection abcd abgh)))
    (test "bags/ops " #t (bag=? ab (bag-intersection abgh abcd)))
    (test "bags/ops " #t (bag=? abcd (bag-difference abcd)))
    (test "bags/ops " #t (bag=? cd (bag-difference abcd ab)))
    (test "bags/ops " #t (bag=? abcd (bag-difference abcd gh)))
    (test "bags/ops " #t (bag=? none (bag-difference abcd abcd)))
    (define abcd3 (bag-copy abcd))
    (bag-difference! abcd3)
    (test "bags/ops " #t (bag=? abcd abcd3))
    (bag-difference! abcd3 abcd)
    (test "bags/ops " #t (bag=? none abcd3))
    (test "bags/ops " #t (bag=? cdgh (bag-xor abcd abgh)))
    (test "bags/ops " #t (bag=? all (bag-xor abcd efgh)))
    (test "bags/ops " #t (bag=? none (bag-xor abcd other-abcd)))
    (define abcd4 (bag-copy abcd))
    (test "bags/ops " #t (bag=? none (bag-xor! abcd4 other-abcd)))
    (define abab (bag eq-comparator 'a 'b 'a 'b))
    (test "bags/ops " #t (bag=? ab (bag-sum ab)))
    (define ab2 (bag-copy ab))
    (test "bags/ops " #t (bag=? ab (bag-sum! ab2)))
    (test "bags/ops " #t (bag=? abab (bag-sum! ab2 ab)))
    (test "bags/ops " #t (bag=? abab ab2))
    (test "bags/ops " #t (bag=? abab (bag-product 2 ab)))
    (define ab3 (bag-copy ab))
    (bag-product! 2 ab3)
    (test "bags/ops " #t (bag=? abab ab3))
    (test "bags/ops " #t (bag=?  other-abcd abcd)) ; "abcd smashed?"
    (test "bags/ops " #t (bag=?  other-abcd abcd)) ; "abcd smashed?"
    (test "bags/ops " #t (bag=?  other-efgh efgh)) ; "efgh smashed?"
    (test "bags/ops " #t (bag=?  other-abgh abgh)) ; "abgh smashed?"

;;; STklos test system won't catch syntax error; skip these
;; (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))
;; ) ; end bags/mismatch

;;; "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))
  (bag-partition! big whole4)
;  (parameterize ((current-test-comparator bag=?))
    (test "bags/whole 1" #t (bag=? top (bag-filter big whole)))
    (test "bags/whole 2" #t (bag=? bottom (bag-remove big whole)))
    (bag-filter! big whole2)
    (test "bags/whole 3" #t (not (bag-contains? whole2 1)))
    (bag-remove! big whole3)
    (test "bags/whole 4" #t (not (bag-contains? whole3 10)))
    (test "bags/whole 5" #t (bag=? top topx))
    (test "bags/whole 6" #t (bag=? bottom bottomx))
    (test "bags/whole 7" #t (bag=? top whole4))
  (test "bags/whole 8" 5 (bag-count big whole))
  (define hetero (bag eqv-comparator 1 2 'a 3 4))
  (define homo (bag eqv-comparator 1 2 3 4 5))
  (test "bags/simple 9" 'a (bag-find symbol? hetero (lambda () (error "wrong"))))
  (test/error  "bags/simple 10" (bag-find symbol? homo (lambda () (error "wrong"))))
  (test "bags/simple 11" #t (bag-any? symbol? hetero))
  (test "bags/simple 12" #t (bag-any? number? hetero))
  (test "bags/simple 13" #t (not (bag-every? symbol? hetero)))
  (test "bags/simple 14" #t (not (bag-every? number? hetero)))
  (test "bags/simple 15" #t (not (bag-any? symbol? homo)))
  (test "bags/simple 16" #t (bag-every? number? homo))


;;; "bags/lowlevel"
  (define bucket (bag string-ci-comparator "abc" "def"))
  (test "bags/lowlevel 0"  string-ci-comparator (bag-element-comparator bucket))
  (test "bags/lowlevel 1" #t (bag-contains? bucket "abc"))
  (test "bags/lowlevel 2" #t (bag-contains? bucket "ABC"))
  (test "bags/lowlevel 3" "def" (bag-member bucket "DEF" "fqz"))
  (test "bags/lowlevel 4" "fqz" (bag-member bucket "lmn" "fqz"))
  (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 "bags/lowlevel 5" #t (bag-any? inexact? nums2))
  (bag-replace! nums 2.0)
  ;; nums is now {1, 2.0, 3}
  (test "bags/lowlevel 6" #t (bag-any? inexact? nums))
  (define bob
    (bag bag-comparator
      (bag eqv-comparator 1 2)
      (bag eqv-comparator 1 2)))
  (test "bags/lowlevel 7" 2 (bag-size bob))



;;; "bags/semantics"
  (define mybag (bag number-comparator 1 2))
  ;; mybag is {1, 2}
  (test "bags/semantics 1" 2 (bag-size mybag))
  (bag-adjoin! mybag 1)
  ;; mybag is {1, 1, 2}
  (test "bags/semantics 2" 3 (bag-size mybag))
  (test "bags/semantics 3" 2 (bag-unique-size mybag))
  (bag-delete! mybag 2)
  ;; mybag is {1, 1}
  (bag-delete! mybag 2)
  (test "bags/semantics 4" 2 (bag-size mybag))
  (bag-increment! mybag 1 3)
  ;; mybag is {1, 1, 1, 1, 1}
  (test "bags/semantics 5" 5 (bag-size mybag))
  (test "bags/semantics 6" #t (not (not (bag-decrement! mybag 1 2))))
  ;; mybag is {1, 1, 1}
  (test "bags/semantics 7" 3 (bag-size mybag))
  (bag-decrement! mybag 1 5)
  ;; mybag is {}
  (test "bags/semantics 8" 0 (bag-size mybag))


;;; "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 "bags/convert 1" alist (bag->alist minibag))
  (test "bags/convert 2" #t (bag=? minibag (alist->bag eqv-comparator alist)))
  (test "bags/convert 3" #t (set=? singleset (bag->set single)))
  (test "bags/convert 4" #t (set=? singleset (bag->set multi)))
  (test "bags/convert 5" #t (bag=? single (set->bag singleset)))
  (test "bags/convert 6" #t (not (bag=? multi (set->bag singleset))))
  (set->bag! minibag singleset)
  ;; minibag is now {a, a, a, a, 1, 2, 3}
  (test "bags/convert 7" #t (bag-contains? minibag 1))


;;; "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 "bags/sumprod 1" 3 (bag-count (lambda (x) (eqv? x 'a)) total))
  (test "bags/sumprod 2" 3 (bag-count (lambda (x) (eqv? x 'b)) total))
  (test "bags/sumprod 3" 12 (bag-size (bag-product 2 total)))
  (define bag1 (bag eqv-comparator 1))
  (bag-sum! bag1 bag1)
  (test "bags/sumprod 4" 2 (bag-size bag1))
  (bag-product! 2 bag1)
  (test "bags/sumprod 5" 4 (bag-size bag1))


;;; "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 "bags/comparators 1" #t (not (=? set-comparator a b)))
  (test "bags/comparators 2" #t (=? set-comparator a (set-copy a)))
;;  (test/error (<? set-comparator a b))
  (test "bags/comparators 3" #t (not (=? bag-comparator aa bb)))
  (test "bags/comparators 4" #t (=? bag-comparator aa (bag-copy aa)))
;;  (test/error (<? bag-comparator aa bb))
  (test "bags/comparators 5" #t (not (=? (make-default-comparator) a aa)))
