path: root/tests/srfi-113-sets.scm

#| 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-contains #f)
(define test-set-disjoint #f)
(define test-set-member #f)
(define test-set-adjoin #f)
(define test-set-replace #f)
(define test-set-delete #t)
(define test-set-delete-all #t)

(define test-set-find #t)
(define test-set-union #t)
(define test-set-difference #t)
(define test-set-every #f)
(define test-set= #f)
(define test-set<= #f)
(define test-set< #f)
(define test-set>= #f)
(define test-set> #f)

(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
  (case-lambda
    (() (unique-list 100))
    ((num)
     ;; 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) num)))))

(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
;;; 
;;; 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-assert "0" (= 0 (set-size (%set))))
  (test-assert "1" (= 1 (set-size (%set 0))))
  (test-assert "2" (= 2 (set-size (%set 0 1))))
  (test-assert "3" (= 3 (set-size (%set 0 1 2))))
  (test-assert "4" (= 4 (set-size (%set 0 1 2 3)))))

(test-group "set->list"
  (test-assert "empty" (eq? '() (set->list (%set))))
  (test-assert "1" (lset= = '(1) (set->list (%set 1))))
  (test-assert "2" (lset= = '(1 2) (set->list (%set 1 2))))
  (test-assert "3" (lset= = '(0 1 2) (set->list (%set 0 1 2))))
  (test-assert "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.
;;; 
;;; `set-generator-of` only depends on `list->set`.

(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 (null? (lset-intersection
                                 (cut =? cmp <...>)
                                 (set->list set1)
                                 (set->list set2)))))
                  sets))
         sets))

;;; ;;;;;;;;;;;;;;;;;;;;;
;;; Advanced set generators
;;; 
;;; Although these generators are implemented in terms of other set
;;; procedures, the tests here are not.
;;; ;;;;;;;;;;;;;;;;;;;;;;

(define (mutually-disjoint sets)
  (every (lambda (set1)
           (every (lambda (set2)
                    (if (eq? set1 set2)
                        #t
                        (null? (lset-intersection
                                (cut =? cmp <...>)
                                (set->list set1)
                                (set->list 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-contains
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-contains
  (test-group "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-disjoint?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-disjoint
  (test-group "set-disjoint?"
    (define (set-not-disjoint? s1 s2)
      (not (set-disjoint? s1 s2)))
    (test-group "sets from parts of unique list are disjoint"
      (define (sets-from-unique-list lst)
        (let-values (((l1 l2) (split-at! lst (floor (/ (length lst) 2)))))
          (let ((set1 (list->set cmp l1))
                (set2 (list->set cmp l2)))
            (set-disjoint? set1 set2))))
      (test-property sets-from-unique-list (list (gremove null? (unique-list)))))
    (test-group "sets from parts of unique list with shared elements are not disjoint"
      (define (sets-from-unique-list lst)
        (let*-values (((el) (car lst))
                      ((lst) (cdr lst))
                      ((l1 l2) (split-at! lst (floor (/ (length lst) 2))))
                      ((set1) (list->set cmp (cons el l1)))
                      ((set2) (list->set cmp (cons el l2))))
          (not (set-disjoint? set1 set2))))
      (test-property sets-from-unique-list (list (gremove null? (unique-list)))))
    (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 "disjoint sets from disjoint-set-generator-of"
      (define (set-disjoint-all lst)
        (every (lambda (set1)
                 (every (lambda (set2)
                          (or (eq? set1 set2)
                              (set-disjoint? set1 set2)))
                        lst))
               lst))
      (test-property set-disjoint-all
                     (list (disjoint-set-generator-of
                            (set-generator)
                            10))))
    (test-group "non disjoint sets from intersecting-set-generator-of"
      (define (not-set-disjoint-all lst)
        (every (lambda (set1)
                 (every (lambda (set2)
                          (or (eq? set1 set2)
                              (not (set-disjoint? set1 set2))))
                        lst))
               lst))
      (test-property not-set-disjoint-all
                     (list (intersecting-set-generator-of
                            (set-generator)
                            10))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-member
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (set-member->boolean set el)
  (let ((res (set-member set el set-member->boolean)))
    (not (eq? res set-member->boolean))))

(when test-set-member
  (test-group "set-member"
    (test-group "no element is set-member of empty set"
      (define (not-member-of-empty el)
        (not (set-member->boolean (%set) el)))
      (test-property not-member-of-empty
                     (list (orderable-generator))))
    (test-group "list->set set-member"
      (define (list-set-member lst)
        (let ((set (list->set cmp lst)))
          (every (cut set-member->boolean set <>) lst)))
      (test-property list-set-member
                     (list (list-generator-of (orderable-generator)))))
    (test-group "elements from set->list are set-member"
      (define (list-set-member set)
        (let ((lst (set->list set)))
          (every (lambda (el) (set-member->boolean set el))
                 lst)))
      (test-property list-set-member
                     (list (set-generator))))
    (test-group "elements that are set-contains? are set-member"
      ;; It's likely that the orderable generator generates things like
      ;; booleans (which are likely to be in a set) and also inexact
      ;; reals (which are highly unlikely to be in the set).
      (define (set-contains-member set el)
        (if (set-contains? set el)
            (set-member->boolean set el)
            (not (set-member->boolean set el))))
      (test-property set-contains-member
                     (list (set-generator) (orderable-generator))))
    (test-group "elements from disjoint set are not set-member"
      (define (list-set-member sets)
        (let ((traversed-set (list-ref sets 0))
              (set (list-ref sets 1)))
          (set-every? (lambda (el-from-traversed)
                        (not (set-member->boolean set el-from-traversed)))
                      traversed-set)))
      (test-property list-set-member
                     (list (disjoint-set-generator-of-exactly
                            (set-generator)
                            2))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-adjoin
;;; 
;;; All procedures with linear-update variants use parameterized tests, i.e.
;;; the same test body runs `set-adjoin` and `set-adjoin!`.
;;; 
;;; This means that all test bodys must copy sets that are modified.
;;; 
;;; Note: my implementation is purely function so `set-copy` is the identity.
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(define (set-adjoin-test set-adjoin)
  (test-group "set contains after"
    (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 of each element from list->set does not change the set"
    (define (set-adjoin-list lst)
      (let* ((set (list->set cmp lst))
             (copy (set-copy set)))
        (every (lambda (el)
                 (set! set (set-adjoin set el))
                 (set=? set copy))
               lst)))
    (test-property set-adjoin-list (list (unique-list 10))))
  (test-group "adjoin of element not in list changes set"
    (define (set-adjoin-list lst)
      (let-values (((l1 l2) (split-at! lst (floor (/ (length lst) 2)))))
        (let* ((set (list->set cmp l1))
               (copy (set-copy set)))
          (every (lambda (el)
                   (let ((old-size (set-size set)))
                     (set! set (set-adjoin set el))
                     (and (set<? copy set)
                          (set-contains? set el)
                          (= (set-size set) (+ old-size 1)))))
                 l2))))
    (test-property set-adjoin-list (list (gremove null? (unique-list)))))
  (test-group "adjoin of new element increases size by exactly 1"
    (define (set-adjoin-increases set element)
      (let ((old-size (set-size set))
            (new-set (set-adjoin set (cons element element))))
        (= (set-size new-set) (+ old-size 1))))
    (test-property set-adjoin-increases (list (set-generator)
                                              (orderable-generator))))
  (test-group "adjoin of new element is idempotent"
    (define (set-adjoin-increases set element)
      (let* ((old-size (set-size set))
             (element (cons element element))
             (new-set (set-adjoin set element element element element)))
        (= (set-size new-set) (+ old-size 1))))
    (test-property set-adjoin-increases (list (set-generator)
                                              (orderable-generator))))
  (test-group "adjoin of arbitrary element increases size by at most one"
    (define (set-adjoin-increases set element)
      (let* ((old-size (set-size set))
             (new-set (set-adjoin set element element element element element)))
        (and (not (negative? (- (set-size new-set) old-size)))
             (<= (- (set-size new-set) old-size) 1))))
    (test-property set-adjoin-increases (list (set-generator)
                                              (orderable-generator))))
  (test-group "adjoin returns the old element"
    (define (set-returns-old set element)
      ;; Cons cells are not a part of `orderable-generator`.
      (let* ((el1 (cons element element))
             (el2 (cons element element))
             (set (set-adjoin set el1))
             (set (set-adjoin set el2)))
        (and (eq? (set-member set el2 (lambda () set)) el1)
             (eq? (set-member set el1 (lambda () set)) el1))))
    (test-property set-returns-old (list (set-generator)
                                         (orderable-generator)))))

(when test-set-adjoin
  (test-group "set-adjoin"
    (set-adjoin-test set-adjoin))
  (test-group "set-adjoin!"
    (set-adjoin-test set-adjoin!)))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-replace
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(define (set-replace-test set-replace)
  ;; TODO: test with lists?
  (test-group "never changes the size of a set"
    (define (set-replace-size set el)
      (let ((old-size (set-size set)))
        (= (set-size set) (set-size (set-replace set el)))))
    (test-property set-replace-size (list (set-generator)
                                          (orderable-generator))))
  (test-group "does not affect a set that does not have the element"
    (define (set-replace-does-not-affect set el)
      ;; Be careful here to copy the set, because this parameterized test
      ;; also tests `set-replace!`.
      (let* ((copy (set-copy set))
             (new-set (set-replace set (cons el el))))
        (set=? copy new-set)))
    (test-property set-replace-does-not-affect (list (set-generator)
                                                     (orderable-generator))))
  (test-group "returns the new element"
    (define (set-returns-new set element)
      ;; Cons cells are not a part of `orderable-generator`.
      (let* ((el1 (cons element element))
             (el2 (cons element element))
             (set (set-adjoin set el1))
             (set (set-replace set el2)))
        (and (eq? (set-member set el1 set) el2)
             (eq? (set-member set el2 set) el2))))
    (test-property set-returns-new (list (set-generator)
                                         (orderable-generator)))))

(when test-set-replace
  (test-group "set-replace"
    (set-replace-test set-replace))
  (test-group "set-replace!"
    (set-replace-test set-replace!)))

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

(define (set-delete-test set-delete)
  (test-group "from empty set is always empty"
    (define (delete-from-empty element)
      (set-empty? (set-delete (%set) element)))
    (test-property delete-from-empty (list (orderable-generator))))
  (test-group "from singleton set is empty"
    (define (delete-from-singleton element)
      (set-empty? (set-delete (%set element) element)))
    (test-property delete-from-singleton (list (orderable-generator))))
  (test-group "delete of elements in list"
    (define (delete-from-elements lst)
      (let* ((set (list->set cmp lst))
             (copy (set-copy set)))
        (let loop ((lst lst)
                   (set set))
          (if (null? lst)
              #t
              (let ((set (set-delete set (car lst))))
                (and (every (cut set-contains? set <>) (cdr lst))
                     (set<? set copy)
                     (loop (cdr lst) set)))))))
    (test-property delete-from-elements (list (unique-list))))
  (test-group "of element not in set does not change the set"
    (define (delete-not-in set element)
      (let ((copy (set-copy set))
            (new-set (set-delete set (cons element element))))
        (set=? new-set copy)))
    (test-property delete-not-in (list (set-generator)
                                       (orderable-generator))))
  (test-group "of element from set keeps the rest"
    (define (delete-element-from-set set)
      (let*-values (((copy) (set-copy set))
                    ((set- some-element) (delete-some-element set)))
        (and (not (set-contains? set- some-element))
             (set<? set- copy)
             (= (set-size set-) (- (set-size copy) 1)))))
    (test-property delete-element-from-set
                   (list (gremove set-empty? (set-generator)))))
  (test-group "separate deletes are idempotent"
    (define (delete-idempotent set)
      (let*-values (((set- el) (delete-some-element set))
                    ((set-*) (set-delete set- el)))
        (set=? set-* set-)))
    (test-property delete-idempotent
                   (list (gremove set-empty? (set-generator)))))
  (test-group "deletes in the same line are idempotent"
    (define (delete-same-idem set)
      (let*-values (((set- el) (delete-some-element set))
                    ((set-*) (set-delete set el el el el el)))
        (set=? set- set-*)))
    (test-property delete-same-idem
                   (list (gremove set-empty? (set-generator)))))
  (test-group "delete of multiple elements from set"
    (define (delete-multiple set)
      (let*-values (((copy) (set-copy set))
                    ((set1 el1) (delete-some-element set))
                    ((set2 el2) (delete-some-element set1))
                    ((set3 el3) (delete-some-element set2)))
        (set=? set3 (set-delete copy el1 el2 el3))))
    (test-property delete-multiple
                   (list (gfilter (lambda (set)
                                    (> (set-size set) 3))
                                  (set-generator))))))

(when test-set-delete
  (test-group "set-delete"
    (set-delete-test set-delete))
  (test-group "set-delete!"
    (set-delete-test set-delete!)))

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

(define (set-delete-all-test set-delete-all)
  (test-group "delete-all equivalent to delete"
    (define (equivalent set elements)
      ;; This is the regular persistent `set-delete`.
      (let* ((delete (apply set-delete set elements)))
        (set=? (set-delete-all set elements) delete)))
    (test-property equivalent (list (set-generator)
                                    (list-generator-of
                                     (orderable-generator)
                                     64)))))

(when test-set-delete-all
  (test-group "set-delete-all"
    (set-delete-all-test set-delete-all))
  (test-group "set-delete-all!"
    (set-delete-all-test set-delete-all!)))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-find
;;; 
;;; Lots of tests use `set-find` to grab an arbitrary element from the
;;; set, so if a lot of tests are failing and you don't know why, it might
;;; be because your implementation of `set-find` is buggy.
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(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 (gremove set-empty?
                                                     (set-generator)))))
  (test-group "set-find finds an element from list->set"
    (define (set-find-something set)
      (member (find-some-element set) (set->list set) (cut =? cmp <...>)))
    (test-property set-find-something
                   (list (gremove set-empty? (set-generator)))))
  (test-group "set-find returns an element that is set-contains?"
    (define (set-contains-something set)
      (set-contains? set (find-some-element set)))
    (test-property set-contains-something
                   (list (gremove set-empty? (set-generator)))))
  (test-group "set-find returns an element that is set-member"
    (define (set-member-something set)
      (let ((el (find-some-element set)))
        (not (eq? (set-member set el (lambda () find-some-element))
                  find-some-element)))
      (test-property set-member-something
                     (list (gremove set-empty? (set-generator)))))))


;;; ;;;;;;;;;;;;;;;;;;;;;
;;; 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=?
;;; ;;;;;;;;;

(define (shuffle-list lst)
  (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)))))
  (vector->list (shuffle-vector! (list->vector lst))))

(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= lst)
      (let* ((set1 (list->set lst))
             (set2 (list->set (shuffle-vector! lst))))
        (set=? set1 set2)))
    (test-property shuffle-set= (list (unique-list))))
  (test-group "nary set="
    (define (nary-set= lst)
      ;; 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 lst))
             (set2 (vector->set (shuffle-list lst)))
             (set3 (vector->set (shuffle-list lst)))
             (set4 (vector->set (shuffle-list lst)))
             (set5 (vector->set (shuffle-list lst))))
        (set=? set1 set2 set3 set4 set5)))
    (test-property nary-set= (list (unique-list))))
  (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 (gremove set-empty? (set-generator)))))
  (test-group "two unique sets are not set="
    (define (unique-not-set= lst)
      (let-values (((s1 s2)
                    (make-sets-with-shared-and-disjoint lst '())))
        (if (and (set-empty? s1) (set-empty? s2))
            #t
            (and (not (set=? set1 set2))
                 (not (set=? set2 set1))))))
    (test-property (call/split unique-not-set=)
                   (list (unique-vector))))
  (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-union
;;; ;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-union
  (test-assert "union of two empty sets is empty"
               (set-empty? (set-union (%set) (%set))))
  (test-group "union of set with empty set is the same set"
    (test-property (lambda (set) (set=? set (set-union (%set) set)))
                   (list (set-generator))))
  (test-group "union is idempotent"
    (test-property (lambda (set) (set=? set (set-union set set)))
                   (list (set-generator))))
  (test-group "union of two sets contains elements of both"
    (test-property (lambda (s1 s2)
                     (let ((combined (set-union s1 s2)))
                       (and (set<=? s1 combined)
                            (set<=? s2 combined))))
                   (list (set-generator) (set-generator)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; set-difference
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(when test-set-difference
  (test-group "difference of set from empty is the same set"
    (define (test set)
      (set=? set (set-difference set (%set))))
    (test-property test (list (set-generator))))
  (test-group "difference of empty from set is empty"
    (define (test set)
      (set-empty? (set-difference (%set) set)))
    (test-property test (list (set-generator))))
  (test-group "difference of set from disjoint set is the same set"
    (define (test lst)
      (let-values (((s1 s2)
                    (make-sets-with-shared-and-disjoint lst '())))
        (and (set=? s1 (set-difference s1 s2))
             (set=? s2 (set-difference s2 s1))))))
  (test-group "difference of set from set with shared elements"
    (define (test lst)
      (let-values (((disjoint1 disjoint2)
              (make-sets-with-shared-and-disjoint (cdr lst) '()))
             ((shared1 shared2)
              (make-sets-with-shared-and-disjoint (cdr lst) (list (car lst)))))
        (and (set=? disjoint1 (set-difference shared1 shared2))
             (set=? disjoint2 (set-difference shared2 shared1)))))
    (test-property test (list (gremove null? (unique-list))))))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; 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=?
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;





;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))))))


|#