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-disjoint #t)

(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)
                  (list->set cmp (vector->list vec)))
                (unique-vector))))

(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 (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 (lambda (vecs)
          (list (list->set cmp (vector->list (list-ref vecs 0)))
                (list->set cmp (vector->list (list-ref vecs 1)))))
        (split-unique-vectors)))

(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-for-each
         (lambda (value)
           (test-call "contains" (set-contains? set value)))
         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-for-each
         (lambda (value)
           (test-call "does not contain" (set-does-not-contain? set value)))
         not-in)))
    (test-property set-does-not-contain (list (split-unique-vectors)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 for 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 sets)
        (let ((s1 (list-ref sets 0))
              (s2 (list-ref sets 1)))
          (and (set-disjoint? s1 s2) (set-disjoint? s2 s1))))
      (test-property unique-disjoint (list (split-unique-sets))))
    #;(test-group "including an element from two disjoint sets make them not disjoint"
        (define (include-makes-not-disjoint sets)
          (let* ((s1 (list-ref sets 0))
               (s2 (list-ref sets 1))
               (some-element-from-s1 (set-find (lambda (x) #t)
                                               s1
                                               (lambda ()
                                                 (error "s1 is empty" s1))))
               (s2 (set-adjoin s2 some-element-from-s1))))))))