start testing SRFI 113 tests

1 files changed, 552 insertions, 0 deletions

diff --git a/tests/internal.scm b/tests/internal.scm
new file mode 100644
index 0000000..fc61f6e
--- /dev/null
+++ b/tests/internal.scm
@@ -0,0 +1,552 @@
+#| 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)))))
+