#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

(define test-constructor #f)
(define test-set-generator-of #f)
(define test-intersecting-set-generator-of #f)
(define test-disjoint-set-generator-of #f)
(define test-set-every #t)
(define test-set-contains #t)
(define test-set-member #f)
(define test-set-adjoin #f)
(define test-set-find #f)
(define test-set-disjoint #f)
(define test-set-delete #f)
(define test-set= #f)
(define test-set<= #f)
(define test-set< #f)
(define test-set>= #f)
(define test-set> #f)
(define test-set-intersection #t)

(define cmp
  ;; The global comparator.
  (make-default-comparator))

(define (orderable-generator)
  ;; Return a value that can be ordered in an obvious way.
  ;; 
  ;; NOTE: The default comparator will equate things like `#i0.5` and `1/2`
  ;; or `-0.0` and `0`. This will filter only for exact integers and
  ;; inexact non-integers.
  (gfilter (lambda (x)
             (if (number? x)
                 (cond
                   ((and (inexact? x) (integer? x)) #f)
                   ((nan? x) #f)
                   (else #t))
                 #t))
           (gsampling (boolean-generator)
                      (inexact-real-generator)
                      (exact-integer-generator)
                      (char-generator)
                      (string-generator)
                      (bytevector-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Utility functions
;;; ;;;;;;;;;;;;;;;;;;;;;;

(define (unique-list)
  ;; Return a list of unique elements (according to the equality
  ;; predicate of the global comparator).
  (gmap (lambda (lst)
          (let loop ((list-set '())
                     (lst lst))
            (cond
              ((null? lst) list-set)
              ((member (car lst) list-set (cut =? cmp <> <>))
               (loop list-set (cdr lst)))
              (else (loop (cons (car lst) list-set) (cdr lst))))))
        (list-generator-of (orderable-generator))))

(define (find-some-element s1)
  ;; Get some arbitrary element from the set.
  ;; 
  ;; Note that despite being arbitrary, this procedure is deterministic:
  ;; when applied to the same set it will return the same results.
  (set-find (lambda (x) #t) s1 (lambda () (error "s1 is empty" s1))))

(define (delete-some-element s1)
  ;; Delete an arbitrary element from the set.
  (let ((element (find-some-element s1)))
    (values (set-delete s1 element) element)))

(define (%set . elements)
  ;; Create a set with the `cmp` comparator.
  (apply set cmp elements))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Tests
;;; 
;;; Tests are structured so that tests will depend on functions that
;;; were tested previously.
;;; 
;;; The first part of these tests assume that `lset=` from SRFI-1 works
;;; properly.
;;; ;;;;;;;;;;;;;;;;;;;;

(test-group "set-empty?"
  (test-assert "empty" (set-empty? (%set)))
  (test-assert "not empty 1" (not (set-empty? (%set 0))))
  (test-assert "not empty 2" (not (set-empty? (%set 0 1))))
  (test-assert "not empty 3" (not (set-empty? (%set 0 1 2))))
  (test-assert "not empty 4" (not (set-empty? (%set 0 1 2 3)))))

(test-group "lengths"
  (test-call "0" (= 0 (set-size (%set))))
  (test-call "1" (= 1 (set-size (%set 0))))
  (test-call "2" (= 2 (set-size (%set 0 1))))
  (test-call "3" (= 3 (set-size (%set 0 1 2))))
  (test-call "4" (= 4 (set-size (%set 0 1 2 3)))))

(test-group "set->list"
  (test-call "empty" (eq? '() (set->list (%set))))
  (test-call "1" (lset= = '(1) (set->list (%set 1))))
  (test-call "2" (lset= = '(1 2) (set->list (%set 1 2))))
  (test-call "3" (lset= = '(0 1 2) (set->list (%set 0 1 2))))
  (test-call "4" (lset= = '(0 1 2 3) (set->list (%set 0 1 2 3)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Constructor tests.
;;; 
;;; The constructor tests will test the three set constructors,
;;; `list->set`, `set`, and `set-unfold`. These in the process test
;;; `set->list`.
;;; 
;;; The SRFI does not specify what elements will be preserved in the set
;;; when the constructors run, if they compare equal according to the
;;; comparator.
;;; 
;;; There are two types of tests: tests for creation from unique vectors
;;; and from possibly non-unique vectors.

(when test-constructor
  (test-group "constructors"
    (define (test-create-with-duplicates creator)
      (lambda (lst)
        (let* ((new-set (creator lst))
               (set-as-list (set->list new-set)))
          (test-assert "set?" (set? new-set))
          (if (null? lst)
              (test-assert "empty?" (set-empty? new-set))
              (test-assert "empty?" (not (set-empty? new-set))))
          ;; The new-set will remove duplicates.
          (test-call "length?" (<= (set-size new-set) (length lst)))
          (test-call "subset of inserted" (lset<= equal? set-as-list lst)))))
    (define (test-create-without-duplicates creator)
      (lambda (lst)
        (let* ((new-set (creator lst))
               (set-as-list (set->list new-set)))
          (test-assert "set?" (set? new-set))
          (test-assert "empty?" (if (null? lst)
                                    (set-empty? new-set)
                                    (not (set-empty? new-set))))
          (test-equal "length?" (set-size new-set) (length lst))
          (test-call "exactly inserted" (lset= equal? set-as-list lst)))))
    (test-group "multiple element set using `list->set` procedure"
      (test-property (test-create-with-duplicates
                      (cute list->set cmp <>))
                     (list (unique-list))))
    (test-group "multiple element set using `set` procedure"
      (test-property (test-create-with-duplicates
                      (cute apply set cmp <...>))
                     (list (unique-list))))
    (test-group "multiple element set using `set-unfold` procedure"
      (test-property (test-create-with-duplicates
                      (cute set-unfold cmp null? car cdr <>))
                     (list (unique-list))))
    (test-group "multiple element set using `list->set` procedure, unique elements"
      (test-property (test-create-without-duplicates
                      (cute list->set cmp <>))
                     (list (unique-list))))
    (test-group "multiple element set using `set` procedure, unique elements"
      (test-property (test-create-without-duplicates
                      (cute apply set cmp <...>))
                     (list (unique-list))))
    (test-group "multiple element set using `set-unfold` procedure, unique elements"
      (test-property (test-create-without-duplicates
                      (cute set-unfold cmp null? car cdr <>))
                     (list (unique-list))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set generators
;;; 
;;; These generators are defined in terms of other set operations. Although
;;; it is possible to test operations of the set without these, these make
;;; the tests significantly easier to read.

(when test-set-generator-of
  (test-group "set-generator-of"
    (test-group "generates sets"
      (test-property set? (list (set-generator-of (orderable-generator)))))
    (test-group "generates set with a comparator"
      (test-property (lambda (set)
                       (eq? (set-element-comparator set) cmp))
                     (list (set-generator-of cmp (orderable-generator)))))
    (test-group "generates set of a max size"
      (test-property (lambda (set)
                       (<= (set-size set) 10))
                     (list (set-generator-of cmp
                                             (orderable-generator)
                                             10))))))

(define (set-generator)
  ;; Generate a set with the global comparator.
  (set-generator-of cmp (orderable-generator)))

(define (mutually-non-disjoint sets)
  (every (lambda (set1)
           (every (lambda (set2)
                    (not (set-disjoint? set1 set2)))
                  sets))
         sets))

(define (mutually-disjoint sets)
  (every (lambda (set1)
           (every (lambda (set2)
                    (if (eq? set1 set2)
                        #t
                        (set-disjoint? set1 set2)))
                  sets))
         sets))

(when test-intersecting-set-generator-of
  (test-group "intersecting-set-generator-of-exactly"
    (test-group "generates a list of sets of a certain length"
      (define (test list-of-sets)
        (and (= (length list-of-sets) 2)
             (every set? list-of-sets)))
      (test-property test
                     (list (intersecting-set-generator-of-exactly
                            (set-generator)
                            2))))
    (test-group "generates non-disjoint sets"
      (test-property mutually-non-disjoint
                     (list (intersecting-set-generator-of-exactly
                            (set-generator)
                            2)))))
  (test-group "intersecting-set-generator-of"
    (test-group "generates lists of sets"
      (define (test list-of-sets)
        (and (<= (length list-of-sets) 10)
             (every set? list-of-sets)))
      (test-property test
                     (list (intersecting-set-generator-of
                            (set-generator)
                            10))))
    (test-group "generates non-disjoint sets"
      (test-property mutually-non-disjoint
                     (list (intersecting-set-generator-of
                            (set-generator)
                            10))))))

(when test-disjoint-set-generator-of
  (test-group "disjoint-set-generator-of-exactly"
    (test-group "generates a list of sets of a certain length"
      (define (test list-of-sets)
        (and (= (length list-of-sets) 2)
             (every set? list-of-sets)))
      (test-property test
                     (list (disjoint-set-generator-of-exactly
                            (set-generator)
                            2))))
    (test-group "generates -disjoint sets"
      (test-property mutually-disjoint
                     (list (disjoint-set-generator-of-exactly
                            (set-generator)
                            2)))))
  (test-group "disjoint-set-generator-of generates lists of sets"
    (define (test list-of-sets)
      (and (<= (length list-of-sets) 10)
           (every set? list-of-sets)))
    (test-property test
                   (list (disjoint-set-generator-of
                          (set-generator)
                          10))))
  (test-group "disjoint-set-generator-of generates mutually disjoint sets"
    (test-property mutually-disjoint
                   (list (disjoint-set-generator-of
                          (set-generator)
                          10)))))

;;; ;;;;;;;;;;;;;;;;;;;;;
;;; set-every
;;; ;;;;;;;;;;;;;;;;;;;;;

(define (less-than-10 x) (< x 10))

(when test-set-every
  (test-group "set-every less than 10"
    (test-property (cut set-every? less-than-10 <>)
                   (list
                    (set-generator-of (gfilter
                                       less-than-10
                                       (exact-integer-generator))))))
  (test-group "set-every less than 10, another element added"
    (define (not-less-than-10 set)
      (let ((set (set-adjoin set 100)))
        (not (set-every? less-than-10 set))))
    (test-property not-less-than-10
                   (list
                    (set-generator-of cmp
                                      (gfilter
                                       less-than-10
                                       (exact-integer-generator))
                                      20)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-contains
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-contains
  (test-group "set-contains every element from list->set"
    (define (set-contains-from lst)
      (let ((set (list->set cmp lst)))
        (every (cut set-contains? set <>) lst)))
    (test-property set-contains-from (list (list-generator-of
                                            (orderable-generator)))))
  (test-group "set-contains every element from set-every?"
    (define (set-contains-every set)
      (set-every? (cut set-contains? set <>) set))
    (test-property set-contains-every (list (set-generator))))
  (test-group "set-contains? is false for elements in disjoint set"
    (define (set-does-not-contain sets)
      (define (set-does-not-contain? set value)
        (not (set-contains? set value)))
      (set-every? (cute set-does-not-contain?
                        (list-ref sets 1)
                        <>)
                  (list-ref sets 0)))
    (test-property set-does-not-contain (list (disjoint-set-generator-of-exactly
                                               (set-generator)
                                               2)))))

#|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-member
;;; 
;;; Defined in terms of set-every? and set-contains?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-member
  (test-group "set-member"
    (define (set-member-from set)
      (set-every? (lambda (value)
                    (eq?
                     value
                     (set-member set value set-member-from)))
                  set))
    (test-property set-member-from (list (set-generator))))
  (test-group "not set-member"
    (define (set-not-member vecs)
      (let ((set (list->set cmp (vector->list (list-ref vecs 0))))
            (not-in (list-ref vecs 1)))
        (vector-every
         (lambda (value)
           (eq? (set-member set value set-not-member)
                set-not-member))
         not-in)))
    (test-property set-not-member (list (split-unique-vectors)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-adjoin
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-adjoin
  (test-group "set contains after adjoin"
    (define (set-contains-after-adjoin set element)
      (set-contains? (set-adjoin set element) element))
    (test-property set-contains-after-adjoin (list (set-generator)
                                                   (orderable-generator))))
  (test-group "adjoin returns the old element"
    (define (set-returns-old set element)
      (let* ((el1 (cons element element))
             (el2 (cons element element))
             (set (set-adjoin set el1))
             (set (set-adjoin set el2)))
        (eq? (set-member set el2 (lambda () #f)) el1)))
    (test-property set-returns-old (list (set-generator)
                                         (orderable-generator)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-find
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-find
  (test-equal "set-find on empty set always return false"
              #f
              (set-find (lambda (x) #t) (set cmp) (lambda () #f)))
  (test-group "set-find on non-empty set can return something"
    (define (set-find-something set)
      (not
       (eq? (set-find (lambda (x) #t) set (lambda () set-find-something))
            set-find-something)))
    (test-property set-find-something (list (filter-non-empty-sets
                                             (set-generator)))))
  (test-group "set-find a number"
    (define (set-find-a-number set)
      (let ((set (set-adjoin set 0)))
        (number? (set-find number? set (lambda () set-find-a-number)))))
    (test-property set-find-a-number (list (set-generator)))))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Set-count
;;; ;;;;;;;;;;;;;;;;;;;;

#;(when test-set-count
  (test-group "count traverses the whole set"
    (define (count-identity set)
      (= (set-count exact-integer? set) (set-size set)))
    (test-property count-identity
                   (list (set-generator-of cmp
                                           (exact-integer-generator)))))
  ;; TODO: use sets of different types (like bytevectors and exact
  ;; integers) and check set count after union.
)

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; set-disjoint?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-disjoint
  (let ()
    (define (set-not-disjoint? s1 s2)
      (not (set-disjoint? s1 s2)))
    (test-group "non-empty sets are not disjoint from themselves"
      (define (self-never-disjoint s)
        (if (set-empty? s)
            #t
            (set-not-disjoint? s s)))
      (test-property self-never-disjoint (list (set-generator))))
    (test-group "empty set is disjoint from every set"
      (define (disjoint-to-empty s)
        (and (set-disjoint? s (set cmp))
             (set-disjoint? (set cmp) s)))
      (test-property disjoint-to-empty (list (set-generator))))
    (test-group "sets from unique vectors are disjoint"
      (define (unique-disjoint s1 s2)
        (and (set-disjoint? s1 s2) (set-disjoint? s2 s1)))
      (test-property (call/split unique-disjoint)
                     (list (split-unique-sets))))
    (test-group "including an element from two disjoint sets make them not disjoint"
      (define (include-makes-not-disjoint s1 s2)
        (and (not (set-disjoint? s1 s2))
             (not (set-disjoint? s2 s1))))
      (test-property (call/split
                      include-makes-not-disjoint)
                     (list (split-non-disjoint-sets))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; set-delete
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-delete
  (test-group "delete from empty set is always empty"
    (define (delete-from-empty element)
      (set-empty? (set-delete (set cmp) element)))
    (test-property delete-from-empty (list (orderable-generator))))
  (test-group "delete from singleton set is empty"
    (define (delete-from-singleton element)
      (set-empty? (set-delete (set cmp element) element)))
    (test-property delete-from-singleton (list (orderable-generator))))
  (test-group "delete of element from set keeps the rest"
    (define (delete-some-element set)
      (let* ((some-element (find-some-element set))
             (set* (set-delete set some-element)))
        (and (not (set-contains? set* some-element))
             (set-every? (cut set-contains? set <>) set*))))
    (test-property delete-some-element
                   (list (filter-non-empty-sets
                          (set-generator)))))
  (test-group "separate deletes are idempotent"
    (define (delete-idempotent set)
      (let-values (((new-set el) (delete-some-element set)))
        (set=? (set-delete new-set el) new-set)))
    (test-property delete-idempotent
                   (list (filter-non-empty-sets
                          (set-generator)))))
  (test-group "deletes in the same line are idempotent"
    (define (delete-same-idem set)
      (let ((el (find-some-element set)))
        (set=? (set-delete set el)
               (set-delete set el el el el el el))))
    (test-property delete-same-idem
                   (list (filter-non-empty-sets
                          (set-generator)))))
  (test-group "delete of multiple elements from set"
    (define (delete-multiple set)
      (let*-values (((set1 el1) (delete-some-element set))
                    ((set2 el2) (delete-some-element set1))
                    ((set3 el3) (delete-some-element set2)))
        (set=? set3 (set-delete set el1 el2 el3))))
    (test-property delete-multiple
                   (list (gfilter (lambda (set)
                                    (> (set-size set) 3))
                                  (set-generator))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; set=?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (shuffle-vector! vec)
  (let ((len (vector-length vec)))
    (do ((i 0 (+ i 1)))
        ((= i len) vec)
      (let* ((r (random-integer len))
             (tmp (vector-ref vec r)))
        (vector-set! vec r (vector-ref vec i))
        (vector-set! vec i tmp)))))

(when test-set=
  (test-group "sets are set= to themselves"
    (define (always-set= set)
      (set=? set set))
    (test-property always-set= (list (set-generator))))
  (test-group "sets are set= to shuffled versions of themselves"
    (define (shuffle-set= vec)
      (let* ((set1 (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec))))
        (set=? set1 set2)))
    (test-property shuffle-set= (list (vector-generator-of
                                       (orderable-generator)))))
  (test-group "nary set="
    (define (nary-set= vec)
      ;; NOTE: There is no way, as far as I know, to make sets that have
      ;; the same of elements but are structurally different. This tries
      ;; to do that by shuffling a list of elements.
      (let* ((set1 (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec)))
             (set3 (vector->set (shuffle-vector! vec)))
             (set4 (vector->set (shuffle-vector! vec)))
             (set5 (vector->set (shuffle-vector! vec))))
        (set=? set1 set2 set3 set4 set5)))
    (test-property nary-set= (list (unique-vector))))
  (test-group "set with one element deleted is not set="
    (define (not-set=? set)
      (let ((set* (set-delete set (find-some-element set))))
        (and (not (set=? set set*))
             (not (set=? set* set)))))
    (test-property not-set=? (list (filter-non-empty-sets
                                    (set-generator)))))
  (test-group "two unique sets are not set="
    (define (unique-not-set= set1 set2)
      (if (and (set-empty? set1) (set-empty? set2))
          #t
          (and (not (set=? set1 set2))
               (not (set=? set2 set1)))))
    (test-property (call/split unique-not-set=)
                   (list (split-unique-sets))))
  (test-group "deleting an element from a set makes it not set="
    (define (delete-not-set= set)
      (let ((deleted (set-delete set (find-some-element set))))
        (and (not (set=? set deleted))
             (not (set=? deleted set)))))
    (test-property delete-not-set= (list (filter-non-empty-sets
                                          (set-generator)))))
  (test-group "adding an element to a set makes it not set="
    (define (adjoin-not-set= set)
      (let ((set+ (set-adjoin set (cons #f #f))))
        (and (not (set=? set set+))
             (not (set=? set+ set)))))
    (test-property adjoin-not-set= (list (set-generator)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; set<=?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set<=
  (test-group "all sets are <= to themselves"
    (define (self-set<= set)
      (set<=? set set))
    (test-property self-set<= (list (set-generator))))
  (test-group "all sets are <= to permutations of themselves"
    (define (random-set<= vec)
      (let* ((set (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec))))
        (set<=? set set2))))
  (test-group "deleting an element from a set makes it <="
    (define (delete-set<= set)
      (let ((set- (set-delete set (find-some-element set))))
        (set<=? set- set)))
    (test-property delete-set<= (list (filter-non-empty-sets
                                       (set-generator)))))
  (test-group "adding an element to a set makes it <="
    (define (adjoin-set<= set)
      (let ((set+ (set-adjoin set (cons #f #f))))
        (set<=? set set+)))
    (test-property adjoin-set<= (list (set-generator))))
  (test-group "nary <="
    (define (nary-set<= set)
      (let* ((set- (delete-some-element set))
             (set-- (delete-some-element set-))
             (set--- (delete-some-element set--)))
        (set<=? set--- set-- set- set)))
    (test-property nary-set<= (list
                               (gfilter (lambda (set)
                                          (> (set-size set) 4))
                                        (set-generator))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; set>=?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set>=
  (test-group "all sets are >= to themselves"
    (define (self-set>= set)
      (set>=? set set))
    (test-property self-set>= (list (set-generator))))
  (test-group "all sets are >= to permutations of themselves"
    (define (random-set>= vec)
      (let* ((set (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec))))
        (set>=? set set2))))
  (test-group "deleting an element from a set makes it >="
    (define (delete-set>= set)
      (let ((set- (set-delete set (find-some-element set))))
        (set>=? set set-)))
    (test-property delete-set>= (list (filter-non-empty-sets
                                       (set-generator)))))
  (test-group "adding an element to a set makes it >="
    (define (adjoin-set>= set)
      (let ((set+ (set-adjoin set (cons #f #f))))
        (set>=? set+ set)))
    (test-property adjoin-set>= (list (set-generator))))
  (test-group "nary >="
    (define (nary-set>= set)
      (let* ((set- (delete-some-element set))
             (set-- (delete-some-element set-))
             (set--- (delete-some-element set--)))
        (set>=? set set- set-- set---)))
    (test-property nary-set>= (list
                               (gfilter (lambda (set)
                                          (> (set-size set) 4))
                                        (set-generator))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; set<?
;;; ;;;;;;;;;;;;;;;;;;;;;;

(when test-set<
  (test-group "no set is < to itself"
    (define (not-set< set)
      (not (set<? set set)))
    (test-property not-set< (list (set-generator))))
  (test-group "no set is < to a permutation of itself"
    (define (random-not-set< vec)
      (let* ((set1 (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec))))
        (not (set<? set1 set2)))))
  (test-group "deleting an element from a set makes it <"
    (define (delete-set< set)
      (let ((set- (set-delete set (find-some-element set))))
        (set<? set- set)))
    (test-property delete-set< (list (filter-non-empty-sets
                                      (set-generator)))))
  (test-group "adjoining an element to a set makes it <"
    (define (adjoin-set< set)
      (let ((set+ (set-adjoin set (cons #f #f))))
        (set<? set set+)))
    (test-property adjoin-set< (list (filter-non-empty-sets
                                      (set-generator)))))
  (test-group "nary <"
    (define (nary-set< set)
      (let* ((set- (delete-some-element set))
             (set-- (delete-some-element set-))
             (set--- (delete-some-element set--)))
        (set<? set--- set-- set- set)))
    (test-property nary-set< (list
                              (gfilter (lambda (set)
                                         (> (set-size set) 4))
                                       (set-generator))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;; set>?
;;; ;;;;;;;;;;;;;;;;;;;;;;;

(when test-set>
  (test-group "no set is > to itself"
    (define (not-set> set)
      (not (set>? set set)))
    (test-property not-set> (list (set-generator))))
  (test-group "no set is > to a permutation of itself"
    (define (random-not-set> vec)
      (let* ((set1 (vector->set vec))
             (set2 (vector->set (shuffle-vector! vec))))
        (not (set>? set1 set2)))))
  (test-group "deleting an element from a set makes it >"
    (define (delete-set> set)
      (let ((set- (set-delete set (find-some-element set))))
        (set>? set set-)))
    (test-property delete-set> (list (filter-non-empty-sets
                                      (set-generator)))))
  (test-group "adjoining an element to a set makes it >"
    (define (adjoin-set> set)
      (let ((set+ (set-adjoin set (cons #f #f))))
        (set>? set+ set)))
    (test-property adjoin-set> (list (filter-non-empty-sets
                                      (set-generator)))))
  (test-group "nary >"
    (define (nary-set> set)
      (let* ((set- (delete-some-element set))
             (set-- (delete-some-element set-))
             (set--- (delete-some-element set--)))
        (set>? set set- set-- set---)))
    (test-property nary-set> (list
                              (gfilter (lambda (set)
                                         (> (set-size set) 4))
                                       (set-generator))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-intersection
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-intersection
  (test-group "set-intersection"
    (define (disjoint-implies-empty-intersection set1 set2)
      (let ((i (set-intersection set1 set2)))
        (if (set-disjoint? set1 set2)
            (set-empty? i)
            (not (set-empty? i)))))
    (define (empty-intersection-implies-disjoint set1 set2)
      (let ((i (set-intersection set1 set2)))
        (if (set-empty? i)
            (set-disjoint? set1 set2)
            (not (set-disjoint? set1 set2)))))
    (test-group "disjoint sets have empty intersections"
      (test-property (call/split disjoint-implies-empty-intersection)
                     (list (split-unique-sets))))
    (test-group "non-disjoint sets have non-empty intersections"
      (test-property (call/split disjoint-implies-empty-intersection)
                     (list (split-non-disjoint-sets))))
    (test-group "empty intersections are disjoint"
      (test-property (call/split empty-intersection-implies-disjoint)
                     (list (split-unique-sets))))
    (test-group "non-empty intersections are non-disjoint sets"
      (test-property (call/split empty-intersection-implies-disjoint)
                     (list (split-non-disjoint-sets))))
    (test-group "intersection of self is self"
      (define (intersection-self set)
        (set=? (set-intersection set set) set))
      (test-property intersection-self (list (set-generator))))
    (test-group "intersection is always subset of both sets"
      (define (intersection-subset set1 set2)
        (let ((i (set-intersection set1 set2)))
          (and (set<=? i set1)
               (set<=? i set2))))
      (test-property (call/split intersection-subset)
                     (list (gsampling
                            (split-non-disjoint-sets)
                            (gmap list
                                  (set-generator)
                                  (set-generator))))))))


|#