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-contains #f)
(define test-set-member #f)
(define test-set-adjoin #f)
(define test-set-find #f)
(define test-set-disjoint #f)
(define test-set-every #f)
(define test-set-delete #f)
(define test-set= #t)
(define test-set-intersection #f)

(define cmp (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))))

(define (remove-duplicates generator)
  ;; Remove duplicates (according to the default comparator) from vectors
  ;; made by `generator`.
  (gmap (lambda (vec)
          (let* ((table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
                 (n 0))
            (vector-for-each
             (lambda (value)
               (when (not (hash-table-ref/default table value #f))
                 (hash-table-set! table value #t)
                 (set! n (+ n 1))))
             vec)
            (let ((new-vec (make-vector n))
                  (n 0))
              (hash-table-walk table
                               (lambda (key _)
                                 (vector-set! new-vec n key)
                                 (set! n (+ n 1))))
              new-vec)))
        generator))

(define (unique-vector)
  ;; Return a vector of unique elements (according to the equality
  ;; predicate of the default comparator).
  (remove-duplicates (vector-generator-of (orderable-generator))))

(define (random-sets)
  ;; Return a set of random elements.
  (gcons* (set cmp)
          (gmap (lambda (vec)
                  (set-unfold cmp
                              (cute = <> (vector-length vec))
                              (cut vector-ref vec <>)
                              (cut + <> 1)
                              0))
                (unique-vector))))

(define (filter-non-empty-sets set-generator)
  (gfilter (lambda (set) (not (set-empty? set)))
           set-generator))

(define (split-vector gen)
  ;; Split vectors in half, return it as a list.
  (gmap (lambda (vec)
          (let* ((len (vector-length vec))
                 (midpoint (floor (/ len 2))))
            (list (vector-copy vec 0 midpoint)
                  (vector-copy vec (+ midpoint 1) len))))
        (gfilter (lambda (vec)
                   (not (zero? (vector-length vec))))
                 gen)))

(define (call/split proc)
  (lambda (vals)
    (let ((v1 (list-ref vals 0))
          (v2 (list-ref vals 1)))
      (proc v1 v2))))

(define (split-unique-vectors)
  ;; Generator of list of two elements, each of which is a vector. The
  ;; vectors are disjoint.
  (split-vector (unique-vector)))

(define (split-unique-sets)
  ;; Generator of a list of two elements, each of which is a set. The
  ;; sets are disjoint.
  (gmap (call/split
         (lambda (v1 v2)
           (list (list->set cmp (vector->list v1))
                 (list->set cmp (vector->list v2)))))
        (split-unique-vectors)))

(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 (split-non-disjoint-sets)
  (gmap (call/split
         (lambda (s1 s2)
           (let* ((from-s1 (find-some-element s1))
                  (s2 (set-adjoin s2 from-s1)))
             (list s1 s2))))
        (split-unique-sets)))

(define
    (%set . elements)
  (apply set cmp elements))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Tests
;;; ;;;;;;;;;;;;;;;;;;;;

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

(define (test-create-with-duplicates creator)
  (lambda (vec)
    (let* ((lst (vector->list vec))
           (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)))))

(when test-constructor
  (test-group "multiple element set using `list->set` procedure"
    (test-property (test-create-with-duplicates
                  (cute list->set cmp <>))
                   (list (unique-vector))))
  (test-group "multiple element set using `set` procedure"
    (test-property (test-create-with-duplicates
                    (cute apply set cmp <...>))
                   (list (unique-vector))))
  (test-group "multiple element set using `set-unfold` procedure"
    (test-property (test-create-with-duplicates
                    (cute set-unfold cmp null? car cdr <>))
                   (list (unique-vector)))))

(define (test-create-without-duplicates creator)
  (lambda (vec)
    (let* ((lst (vector->list vec))
           (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)))))

(when test-constructor
  (test-group "multiple element set using `list->set` procedure, unique elements"
    (test-property (test-create-without-duplicates
                    (cute list->set cmp <>))
                   (list (unique-vector))))
  (test-group "multiple element set using `set` procedure, unique elements"
    (test-property (test-create-without-duplicates
                    (cute apply set cmp <...>))
                   (list (unique-vector))))
  (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-vector)))))

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

(when test-set-contains
  (test-group "set-contains?"
    (define (set-contains-from vec)
      (let ((set (list->set cmp (vector->list vec))))
        (vector-every (cut set-contains? set <>) vec)))
    (test-property set-contains-from (list (unique-vector))))
  (test-group "not set-contains?"
    (define (set-does-not-contain vecs)
      (define (set-does-not-contain? set value)
        (not (set-contains? set value)))
      (let ((set (list->set cmp (vector->list (list-ref vecs 0))))
            (not-in (list-ref vecs 1)))
        (vector-every (cut set-does-not-contain? set <>) not-in)))
    (test-property set-does-not-contain (list (split-unique-vectors)))))

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

(when test-set-member
  (test-group "set-member"
    (define (set-member-from vec)
      (let ((set (list->set cmp (vector->list vec))))
        (vector-every (lambda (value)
                        (eq?
                         value
                         (set-member set value set-member-from)))
                      vec)))
    (test-property set-member-from (list (unique-vector))))
  (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 (random-sets)
                                                   (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 (random-sets)
                                         (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
                                             (random-sets)))))
  (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 (random-sets)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 (random-sets))))
    (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 (random-sets))))
    (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-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-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
                          (random-sets)))))
  (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
                          (random-sets)))))
  (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
                          (random-sets)))))
  (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))
                                  (random-sets))))))

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

(when test-set=
  (test-group "sets are set= to themselves"
    (define (always-set= set)
      (set=? set set))
    (test-property always-set= (list (random-sets))))
  (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
                                    (random-sets)))))
  (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
                                          (random-sets)))))
  (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 (random-sets)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))
    ;; More tests:
    ;; intersection of self is self
    ;; intersection is subset of both sets (test subset beforehand?)
))