path: root/tests/internal.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.
 |----------------------------------------------
 | This test suite would be better if property tests (and by association
 | generators) could take multiple values. As it stands now property
 | test generators cannot be correlated without doing a hack like returning
 | a vector (which the current implementation does).
 |#

;;; ;;;;;;;;;;;;;;;;
;;; Parameters

(define verbose (make-parameter #f))
(define max-vector-length (make-parameter 100))

;;; ;;;;;;;;;;;;;;;;;;;
;;; Random in-order vector generator
;;; ;;;;;;;;;;;;;;;;;;;

(define (vector->node-generator)
  (gmap in-order-vector->node (in-order-vector-generator
                               (max-vector-length))))

(define number-comparator
  (make-comparator
   number?
   =
   <
   (lambda (x) x)))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Test node creation
;;; ;;;;;;;;;;;;;;;;;;;;;;

(test-group "in-order-vector->node and node->in-order-list round-trip"
  (define (vector->node->list? vec)
    (let* ((node (in-order-vector->node vec))
           (lst (node->in-order-list node)))
      (when (verbose)
        (dynamic-property-set! 'vec vec)
        (dynamic-property-set! 'lst lst))
      (equal? (vector->list vec) lst)))
  (test-property vector->node->list?
                 (list (in-order-vector-generator (max-vector-length)))))

(test-group "in-order-vector->node is balanced?"
  (test-assert (balanced? '()))
  (test-property balanced? (list (vector->node-generator))))

;;; ;;;;;;;;;
;;; Make a "split" vector. A "split" vector is two sorted vectors and a 
;;; number, where for all indicies i
;;; 
;;;      v1[i] < number
;;;      number < v2[i]
;;;   
;;; ;;;;;;;;;

(define (split-in-order-vector vec)
  ;; Take an in order vector and split it into two in-order vectors and
  ;; an element in between those two vectors.
  (let* ((len (vector-length vec))
         (pivot ((make-random-integer-generator 0 len))))
    (vector (vector-copy-exclusive vec 0 pivot)
            (vector-ref vec pivot)
            (vector-copy-exclusive vec (+ pivot 1) len))))

(define (split-vector-generator)
  (chain (in-order-vector-generator (max-vector-length))
         (gmap split-in-order-vector _)))

(define (call/split-vecs procedure)
  (lambda (vec)
    (let ((left (vector-ref vec 0))
          (middle (vector-ref vec 1))
          (right (vector-ref vec 2)))
      (procedure left middle right))))

(define (join-vectors left middle right)
  (join middle (in-order-vector->node left) (in-order-vector->node right)))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; join
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define join-preserves-order-of
  (call/split-vecs
   (lambda (left middle right)
     ;; Test if joining two in-order vectors with a node in between will
     ;; preserve order in the tree.
     ;; Log the left, middle, and right vectors.
     (when (verbose)
       (dynamic-property-set! 'right right)
       (dynamic-property-set! 'middle middle)
       (dynamic-property-set! 'left left))
     (let ((ret (node->in-order-list
                 (join-vectors left middle right)))
           (orig (append (vector->list left)
                         (list middle)
                         (vector->list right))))
       (when (verbose)
         (dynamic-property-set! 'ret ret))
       (equal? ret orig)))))

(test-group "join of in-order vectors preserves order"
  (parameterize ((verbose #f))
    (test-property join-preserves-order-of
                   (list (split-vector-generator)))))

(test-group "join of in-order vectors is balanced"
  (define (joined-vector-generator)
    (gmap (call/split-vecs join-vectors)
          (split-vector-generator)))
  (test-property balanced? (list (joined-vector-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; join2
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(define join2-preserves-order-of
  (call/split-vecs
   (lambda (left _ right)
     (let ((ret (node->in-order-list
                 (join2 (in-order-vector->node left)
                        (in-order-vector->node right))))
           (orig (append (vector->list left)
                         (vector->list right))))
       (equal? ret orig)))))

(test-group "join2 of in-order vectors preserves order"
  (test-property join2-preserves-order-of
                 (list (split-vector-generator))))

(test-group "join2 of in-order vectors is balanced"
  (define (join2-split-vector-generator)
    (define (join2-of-split vec)
      (join2 (in-order-vector->node (vector-ref vec 0))
             (in-order-vector->node (vector-ref vec 2))))
    (gmap join2-of-split (split-vector-generator)))
  (test-property balanced?
                 (list (join2-split-vector-generator))))

;;; ;;;;;;
;;; search
;;; ;;;;;;

(define (call/inserted procedure)
  (call/split-vecs
   (lambda (left middle right)
     (let ((node (join-vectors left middle right)))
       (procedure left middle right node)))))

(define (call-w/o-inserted procedure)
  (call/split-vecs
   (lambda (left middle right)
     (let ((node (join2 (in-order-vector->node left)
                        (in-order-vector->node right))))
       (procedure left middle right node)))))

(test-group "search with inserted node"
  (define search-finds
    (call/inserted
     (lambda (left middle right node)
       (when (verbose)
         (dynamic-property-set! 'expected middle)
         (dynamic-property-set! 'right right)
         (dynamic-property-set! 'left left)
         (dynamic-property-set! 'node (node->in-order-list node)))
       (search number-comparator middle node))))
  (parameterize ((verbose #f))
    (test-property search-finds (list (split-vector-generator)))))

(test-group "search without inserted node"
  (define search-does-not-find
    (call-w/o-inserted
     (lambda (left middle right node)
       (not (search number-comparator middle node)))))
  (test-property search-does-not-find (list (split-vector-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; split
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(define (call/split wrapper procedure)
  (wrapper
   (lambda (left middle right node)
     (call-with-values (lambda ()
                         (split number-comparator node middle
                                (lambda () #f)))
       procedure))))

(test-group "split finds"
  (define split-finds
    (call/split
     call/inserted
     (lambda (new-left found? new-right)
       found?)))
  (test-property split-finds (list (split-vector-generator))))

(test-group "left tree from split with found element is balanced"
  (define split-left-balanced
    (call/split
     call/inserted
     (lambda (new-found found? new-right)
       (balanced? new-found))))
  (test-property split-left-balanced (list (split-vector-generator))))

(test-group "right tree from split with found element is balanced"
  (define split-right-balanced
    (call/split
     call/inserted
     (lambda (new-found found? new-right)
       (balanced? new-right))))
  (test-property split-right-balanced (list (split-vector-generator))))

(test-group "split should not find element not in left or right"
  (define split-does-not-find
    (call/split
     call-w/o-inserted
     (lambda (new-left found? new-right)
       (not found?))))
  (test-property split-does-not-find (list (split-vector-generator))))

(test-group "left tree from split without found element is balanced"
  (define split-left-balanced-w/o-inserted
    (call/split
     call-w/o-inserted
     (lambda (new-left found? new-right)
       (balanced? new-left))))
  (test-property split-left-balanced-w/o-inserted (list (split-vector-generator))))

(test-group "right tree from split without found element is balanced"
  (define split-right-balanced-w/o-inserted
    (call/split
     call-w/o-inserted
     (lambda (new-left found? new-right)
       (balanced? new-right))))
  (test-property split-right-balanced-w/o-inserted (list (split-vector-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Union
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(test-group "union is balanced"
  (define (union-balanced node1 node2)
    (balanced? (union number-comparator node1 node2)))
  (test-property union-balanced
                 (list (vector->node-generator)
                       (vector->node-generator))))

(define (union-subset-of-lset node1 node2)
    (let ((node (union number-comparator node1 node2))
          (union (lset-union =
                             (node->in-order-list node1)
                             (node->in-order-list node2))))
      (if (verbose)
          (dynamic-property-set! 'union
                                 (node->in-order-list node)))
      (every (cut search number-comparator <> node) union)))

(test-group "union subset of lset"
  (parameterize ((verbose #t))
    (test-property union-subset-of-lset
                   (list (vector->node-generator)
                         (vector->node-generator)))))

(test-group "union subset of lset, right null"
  (test-property union-subset-of-lset
                 (list (vector->node-generator)
                       (circular-generator '()))))

(test-group "union subset of lset, left null"
  (test-property union-subset-of-lset
                 (list (circular-generator '())
                       (vector->node-generator))))

(define (lset-subset-of-union node1 node2)
  (let ((node (union number-comparator node1 node2))
        (union (lset-union =
                           (node->in-order-list node1)
                           (node->in-order-list node2))))
    (node-every (cut memq <> union) node)))

(test-group "lset subset of union"
  (test-property lset-subset-of-union
                 (list (vector->node-generator)
                       (vector->node-generator))))

(test-group "lset subset of union, right null"
  (test-property lset-subset-of-union
                 (list (vector->node-generator)
                       (circular-generator '()))))

(test-group "lset subset of union, left null"
  (test-property lset-subset-of-union
                 (list (circular-generator '())
                       (vector->node-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Intersection
;;; ;;;;;;;;;;;;;;;;;;;;

(test-group "intersection balanced?"
  (define (intersection-balanced? node1 node2)
    (balanced? (intersection number-comparator node1 node2)))
  (test-property intersection-balanced?
                 (list (vector->node-generator)
                       (vector->node-generator))))

(test-group "intersection of itself"
  (define (intersection-of-itself node1)
    (let ((node (intersection number-comparator node1 node1))
          (lst (node->in-order-list node1)))
      (every (cut search number-comparator <> node) lst)))
  (test-property intersection-of-itself
                 (list (vector->node-generator))))

(test-group "intersection of null, left"
  (define (intersection-of-null-left node1)
    (null? (intersection number-comparator node1 '())))
  (test-property intersection-of-null-left
                 (list (vector->node-generator))))

(test-group "intersection of null, right"
  (define (intersection-of-null-right node1)
    (null? (intersection number-comparator '() node1)))
  (test-property intersection-of-null-right 
                 (list (vector->node-generator))))

(test-group "intersection subset of lset"
  (define (intersection-lset node1 node2)
    (let ((node (intersection number-comparator node1 node2))
          (intersection (lset-intersection =
                                           (node->in-order-list node1)
                                           (node->in-order-list node2))))
      (every (cut search number-comparator <> node) intersection)))
  (test-property intersection-lset
                 (list (vector->node-generator)
                       (vector->node-generator))))

(test-group "lset subset of intersection"
  (define (lset-subset-of-intersection node1 node2)
    (let ((node (intersection number-comparator node1 node2))
          (intersection (lset-intersection =
                                           (node->in-order-list node1)
                                           (node->in-order-list node2))))
      (node-every (cut memv <> intersection) node)))
  (test-property lset-subset-of-intersection
                 (list (vector->node-generator)
                       (vector->node-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Difference
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;

(test-group "difference balanced?"
  (define (difference-balanced? node1 node2)
    (balanced? (difference number-comparator node1 node2)))
  (test-property difference-balanced?
                 (list (vector->node-generator)
                       (vector->node-generator))))

(test-group "difference subset of lset"
  (define (difference-subset-of-lset node1 node2)
    (let ((node (difference number-comparator node1 node2))
          (intersection (lset-difference =
                                         (node->in-order-list node1)
                                         (node->in-order-list node2))))
      (every (cut search number-comparator <> node) intersection)))
  (test-property difference-subset-of-lset
                 (list (vector->node-generator)
                       (vector->node-generator))))

(test-group "lset subset of difference"
  (define (lset-subset-of-difference node1 node2)
    (let ((node (difference number-comparator node1 node2))
          (intersection (lset-difference =
                                         (node->in-order-list node1)
                                         (node->in-order-list node2))))
      (node-every (cut memq <> intersection) node)))
  (test-property lset-subset-of-difference
                 (list (vector->node-generator)
                       (vector->node-generator))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Update
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define %insert insert)
(define (insert elem set)
  (%insert number-comparator
           set
           elem))

(test-group "update of unordered list is balanced"
  (define (insert-unordered lst)
    (let ((set (fold insert '() lst)))
      (balanced? set)))
  (test-property insert-unordered
                 (list (list-generator-of
                        (exact-integer-generator)))))

(test-group "update of unordered list is subset of list"
  (define (subset-of-list lst)
    (let ((set (fold insert '() lst)))
      (when (verbose)
        (dynamic-property-set! 'lst lst)
        (dynamic-property-set! 'set (node->in-order-list set)))
      (every (cut search number-comparator <> set) lst)))
  (parameterize ((verbose #f))
    (test-property subset-of-list
                   (list (list-generator-of
                          (exact-integer-generator))))))

(test-group "list is subset of update of unordered list"
  (define (list-is-subset-of lst)
    (let ((set (fold insert '() lst)))
      (node-every (cut memq <> lst) set)))
  (test-property list-is-subset-of
                 (list (list-generator-of
                        (exact-integer-generator)))))

;;; ;;;;;;;;;;;;;;;;
;;; Delete
;;; ;;;;;;;;;;;;;;;;

(define (call/difference procedure)
  (lambda (lst1 lst2)
    (let* ((set1 (fold insert '() lst1))
           (set2 (fold insert '() lst2))
           (diff (difference number-comparator set1 set2))
           (deleted (fold (lambda (elem set)
                            (when (verbose)
                              (dynamic-property-set! 'elem elem)
                              (dynamic-property-set! 'set set))
                            (delete number-comparator set elem))
                          set1
                          lst2)))
      (procedure lst1 lst2 diff deleted))))

(test-group "delete of elements unordered list is balanced"
  (define (delete-balanced? lst1 lst2)
    (let* ((set (fold insert '() lst1))
           (deleted (fold (lambda (elem set)
                            (delete number-comparator set elem))
                          set
                          lst2)))
      (balanced? deleted)))
  (test-property delete-balanced?
                 (list (list-generator-of (exact-integer-generator))
                       (list-generator-of (exact-integer-generator)))))

(test-group "delete of two sets is subset of difference"
  (define (delete-and-difference lst1 lst2 diff deleted)
    (node-every (cut search number-comparator <> diff) deleted))
  (parameterize ((verbose #f))
    (test-property (call/difference delete-and-difference)
                   (list (list-generator-of (exact-integer-generator))
                         (list-generator-of (exact-integer-generator))))))

(test-group "difference is subset of delete of two sets"
  (define (difference-and-delete lst1 lst2 diff deleted)
    (node-every (cut search number-comparator <> deleted) diff))
  (test-property (call/difference difference-and-delete)
                 (list (list-generator-of (exact-integer-generator))
                       (list-generator-of (exact-integer-generator)))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;; xor
;;; ;;;;;;;;;;;;;;;;;;;;;;;

(test-group "xor balanced?"
  (define (xor-balanced? node1 node2)
    (balanced? (xor number-comparator node1 node2)))
  (test-property xor-balanced?
                 (list (vector->node-generator) (vector->node-generator))))

(test-group "lset subset of xor"
  (define (lset-subset-of-xor lst1 lst2)
    (let* ((node1 (fold insert '() lst1))
           (node2 (fold insert '() lst2))
           (set-xor (xor number-comparator node1 node2))
           (list-xor (lset-xor = lst1 lst2)))
      (every (cut search number-comparator <> set-xor) list-xor)))
  (test-property lset-subset-of-xor
                 (list (list-generator-of (exact-integer-generator))
                       (list-generator-of (exact-integer-generator)))))

(test-group "xor subset of lset"
  (define (xor-subset-of-lset lst1 lst2)
    (let* ((node1 (fold insert '() lst1))
           (node2 (fold insert '() lst2))
           (set-xor (xor number-comparator node1 node2))
           (list-xor (lset-xor = lst1 lst2)))
      (node-every (cut member <> list-xor) set-xor)))
  (test-property xor-subset-of-lset
                 (list (list-generator-of (exact-integer-generator))
                       (list-generator-of (exact-integer-generator)))))

;;; ;;;;;;;;;;
;;; Generators
;;; ;;;;;;;;;;

(test-group "node->generator"
  (define (node->generator-works lst)
    (let* ((node (fold insert '() lst))
           (result-lst
            (generator->list (node->generator node))))
      (lset= = lst result-lst)))
  (test-property node->generator-works
                 (list (list-generator-of (exact-integer-generator)))))

(test-group "generator->node"
  (define (generator->node-works lst)
    (let* ((gen (list->generator lst))
           (node (generator->node number-comparator gen)))
      (and (node-every (cut member <> lst) node)
           (every (cut search number-comparator <> node) lst))))
  (test-property generator->node-works
                 (list (list-generator-of (exact-integer-generator)))))

(test-group "node->in-order-generator"
  (define (node->in-order-generator-works lst)
    (let* ((node (fold insert '() lst))
           (result-lst (generator->list
                        (node->in-order-generator node))))
      (and (lset= = lst result-lst)
           (list-sorted? < result-lst))))
  (test-property node->in-order-generator-works
                 (list (list-generator-of (exact-integer-generator)))))

(test-group "node->reverse-order-generator"
  (define (node->reverse-order-generator-works lst)
    (let* ((node (fold insert '() lst))
           (result-lst (generator->list
                        (node->reverse-order-generator node))))
      (and (lset= = lst result-lst)
           (list-sorted? > result-lst))))
  (test-property node->reverse-order-generator-works
                 (list (list-generator-of (exact-integer-generator)))))