succesfully test join

1 files changed, 166 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..b7d78d3
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,166 @@
+#| 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.
+ |#
+
+(import (mcgoron weight-balanced-trees)
+        (prefix (only (mcgoron srfi 64) factory) mcgoron-test-)
+        (except (mcgoron srfi 64) factory)
+        (srfi 1) (srfi 26) (srfi 64) (srfi 128) (srfi 132) (srfi 133)
+        (srfi 158) (srfi 194) (srfi 197) (srfi 252))
+
+(define verbose
+  (make-parameter #f))
+
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Setup my test runner
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(test-runner-factory mcgoron-test-factory)
+(test-runner-current (test-runner-create))
+
+;;; ;;;;;;;;;;;
+;;; Utils
+;;; ;;;;;;;;;;;
+
+(define (vector-copy-exclusive vec start end)
+  ;; Copy `[start,end)` from `vec`.
+  (if (= start end)
+      #()
+      (vector-copy vec start (- end 1))))
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Random in-order vector generator
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define (random-number-vector of)
+  ;; Generate a random vector of exact integers with at most `of` number
+  ;; of elements.
+  (vector-generator-of (exact-integer-generator) of))
+
+(define (filter-non-empty-vectors gen)
+  ;; Filter out the empty vector.
+  (gremove (lambda (vec) (zero? (vector-length vec))) gen))
+
+(define (remove-duplicates gen)
+  ;; Filter out vectors with duplicate entries.
+  (define (filter vec)
+    (call/cc
+     (lambda (return)
+       (vector-fold (lambda (prev elem)
+                      (cond
+                        ((null? prev) elem)
+                        ((= elem prev) (return #f))
+                        (else elem)))
+                    '()
+                    vec)
+       #t)))
+  (gfilter filter gen))
+
+(define (make-in-order gen)
+  ;; Sort all vectors to be in-order.
+  (gmap (cut vector-sort < <>) gen))
+
+(define (in-order-vector-generator of)
+  (chain (random-number-vector of)
+         (filter-non-empty-vectors _)
+         (make-in-order _)
+         (remove-duplicates _)))
+
+(define (vector->node-generator of)
+  (chain (in-order-vector-generator of)
+         (gmap in-order-vector->node _)))
+
+(define number-comparator
+  (make-comparator
+   number?
+   =
+   <
+   (lambda (x) x)))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Test node creation
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+
+(test-group "vector->node is correct"
+  (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 50))))
+
+(test-group "vector->node balanced?"
+  (test-assert (balanced? '()))
+  (test-property balanced? (list (vector->node-generator 50))))
+
+;;; ;;;;;;;;;
+;;; Test that join preserves the order of nodes
+;;; ;;;;;;;;;
+
+(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 of)
+  (chain (random-number-vector of)
+         (filter-non-empty-vectors _)
+         (remove-duplicates _)
+         (make-in-order _)
+         (gmap split-in-order-vector _)))
+
+(define (join-preserves-order-of vec)
+  ;; Test if joining two in-order vectors with a node in between will
+  ;; preserve order in the tree.
+  (let ((left (vector-ref vec 0))
+        (middle (vector-ref vec 1))
+        (right (vector-ref vec 2)))
+    ;; 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 middle
+                      (in-order-vector->node left)
+                      (in-order-vector->node right))))
+          (orig (append (vector->list left)
+                        (list middle)
+                        (vector->list right))))
+      (when (verbose)
+        (dynamic-property-set! 'ret ret))
+      (equal? ret orig))))
+
+(test-group "join-preserves-order-of"
+  (parameterize ((verbose #f))
+    (test-property join-preserves-order-of (list (split-vector-generator 50)))))
+
+(test-group "join balanced?"
+  (define (join-split-vectors vec)
+    (let ((left (vector-ref vec 0))
+          (middle (vector-ref vec 1))
+          (right (vector-ref vec 2)))
+      (join middle
+            (in-order-vector->node left)
+            (in-order-vector->node right))))
+  (define (joined-vector-generator of)
+    (gmap join-split-vectors (split-vector-generator of)))
+  (test-property balanced? (list (joined-vector-generator 50))))