succesfully test join

7 files changed, 478 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0880f22
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+*.build.sh
+*.install.sh
+*.import.scm
+*.so
+*.link
+*.o
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..2cca231
--- /dev/null
+++ b/README.md
@@ -0,0 +1,8 @@
+# Weight Balanced Trees
+
+[Weight Balanced Trees][1] with an SRFI interface. Implementation based on
+["Balancing Weight Balanced Trees"][2] by Yoichi Hirai and Kazuhiko
+Yamamoto.
+
+[1]: https://en.wikipedia.org/wiki/Weight-balanced_tree
+[2]: https://yoichihirai.com/bst.pdf
diff --git a/doc/mcgoron.weight-balanced-trees.scm b/doc/mcgoron.weight-balanced-trees.scm
new file mode 100644
index 0000000..0bebb3d
--- /dev/null
+++ b/doc/mcgoron.weight-balanced-trees.scm
@@ -0,0 +1,34 @@
+(((name . "wb-tree-node?")
+  (signature lambda (x) => boolean?)
+  (desc "Returns true if `x` is a node in a weight-balanced tree."))
+ ((name . "non-null-wb-tree-node?")
+  (signature lambda (x) => boolean?)
+  (desc "Returns true if `x` is a node with data and children."))
+ ((name . "get-data")
+  (signature lambda ((non-null-wb-tree-node? x)) => *)
+  (desc "Returns the data in the tree node."))
+ ((name . "get-left")
+  (signature lambda ((non-null-wb-tree-node? x)) => wb-tree-node?)
+  (desc "Returns the left child in the node."))
+ ((name . "get-right")
+  (signature lambda ((non-null-wb-tree-node? x)) => wb-tree-node?)
+  (desc "Returns the right child in the node."))
+ ((name . "get-size")
+  (signature lambda ((wb-tree-node? x)) => integer?)
+  (desc "Returns the number of elements in this tree."))
+ ((name . "balanced?")
+  (signature lambda ((wb-tree-node? x)) => boolean?)
+  (tags internal)
+  (desc "Recursively traverses `x` and checks if it is weight balanced.
+This function is not called in normal code, but can be useful for
+debugging."))
+ ((name . "in-order-vector->node")
+  (signature lambda ((vector? x)) => wb-tree-node?)
+  (desc "
+* It is an error if `x` is not in order.
+
+Returns a weight-balanced tree where the elements of the tree are the
+elements of `x`."))
+ ((name . "node->in-order-list")
+  (signature lambda ((wb-tree-node? x)) => list?)
+  (desc "Returns a list of all elements of `x` in order.")))
\ No newline at end of file
diff --git a/mcgoron.weight-balanced-trees.scm b/mcgoron.weight-balanced-trees.scm
new file mode 100644
index 0000000..a3c9059
--- /dev/null
+++ b/mcgoron.weight-balanced-trees.scm
@@ -0,0 +1,221 @@
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; Definition of nodes and functions to calculate values for nodes.
+;;; ;;;;;;;;;;;;;;;;;;;
+
+(define-type node-type (or (struct <wb-tree>) null))
+
+(: %wb-tree-node (* fixnum node-type node-type --> (struct <wb-tree>)))
+(: get-data ((struct <wb-tree>) --> *))
+(: %get-weight ((struct <wb-tree>) --> fixnum))
+(: get-left ((struct <wb-tree>) --> node-type))
+(: get-right ((struct <wb-tree>) --> node-type))
+
+(define-record-type <wb-tree>
+  (%wb-tree-node data weight left right)
+  non-null-wb-tree-node?
+  (data get-data)
+  (weight %get-weight)
+  (left get-left)
+  (right get-right))
+
+(define (wb-tree-node? x)
+  (or (null? x) (non-null-wb-tree-node? x)))
+
+(: get-weight (node-type --> fixnum))
+(define (get-weight node)
+  ;; Get the stored size of a node.
+  (cond
+    ((null? node) 1)
+    (else (%get-weight node))))
+
+(: get-size (node-type --> fixnum))
+(define (get-size node)
+  (- (get-weight node) 1))
+
+(: fixnum-calculate-weight (fixnum fixnum --> fixnum))
+(define (fixnum-calculate-weight left-weight right-weight)
+  ;; Calculate the weight of a node given the weight of its children.
+  (+ left-weight right-weight))
+
+(: calculate-weight (node-type node-type --> fixnum))
+(define (calculate-weight left right)
+  ;; Calculate the weight of a node that has children `left` and `right`.
+  (fixnum-calculate-weight (get-weight left) (get-weight right)))
+
+(: wb-tree-node (* node-type node-type --> (struct <wb-tree>)))
+(define (wb-tree-node data left right)
+  ;; Construct a node with `data`, `left`, and `right`, with the correct
+  ;; weight.
+  (%wb-tree-node data (calculate-weight left right) left right))
+
+(: balanced-as-child? (fixnum fixnum --> boolean))
+(define (balanced-as-child? child-weight node-weight)
+  ;; Determine if child would be weight-balanced if its parent was a node
+  ;; with weight `node-weight`.
+  (let ((alpha #e0.29))
+    (>= child-weight (* alpha node-weight))))
+
+(: fixnum-would-be-balanced? (fixnum fixnum --> boolean))
+(define (fixnum-would-be-balanced? left-weight right-weight)
+  ;; Determine if the two weights would be balanced if placed into a node.
+  (let ((size (+ left-weight right-weight)))
+    (and (balanced-as-child? left-weight size)
+         (balanced-as-child? right-weight size))))
+
+(: would-be-balanced? (node-type node-type --> boolean))
+(define (would-be-balanced? left right)
+  ;; Determine if the two nodes would be balanced if placed into a node.
+  (fixnum-would-be-balanced? (get-weight left) (get-weight right))) 
+
+(: heavy<=> (node-type node-type --> fixnum))
+(define (heavy<=> left right)
+  ;; Return 1 if right > left, -1 if left < right, and 0 if left = right
+  ;; weightwise.
+  (let ((left (get-weight left))
+        (right (get-weight right)))
+    (cond
+      ((< left right) -1)
+      ((> left right) 1)
+      (else 0))))
+
+(: balanced? (node-type --> boolean))
+(define (balanced? node)
+  ;; Recursively check if node is weight balanced.
+  (cond
+    ((null? node) #t)
+    (else (let ((left (get-left node))
+                (right (get-right node))
+                (weight (get-weight node)))
+            (and (balanced? left) (balanced? right)
+                 (balanced-as-child? (get-weight left) weight)
+                 (balanced-as-child? (get-weight right) weight))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Convert in-order vectors to ordered trees.
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(: in-order-vector->node (vector --> node-type))
+(define (in-order-vector->node vec)
+  (define (divide left right)
+    (if (< right left)
+        '()
+        (let ((midpoint (floor (/ (+ left right) 2))))
+          (wb-tree-node (vector-ref vec midpoint)
+                        (divide left (- midpoint 1))
+                        (divide (+ midpoint 1) right)))))
+  (divide 0 (- (vector-length vec) 1)))
+
+(: node->in-order-list (node-type --> list))
+(define (node->in-order-list node)
+  (if (null? node)
+      '()
+      (append (node->in-order-list (get-left node))
+              (list (get-data node))
+              (node->in-order-list (get-right node)))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Fundamental tree operations
+;;; 
+;;; These macros are used to automatically generate symmetric cases for
+;;; tree operations. They work with a trick with the syntax-rules
+;;; matcher where it will match literal strings.
+;;; 
+;;; Since syntax-rules is not eager it cannot calculate the inverse
+;;; direction, so both must be supplied. This is fine for most cases,
+;;; and helps make the algorithm more explicit.
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax s-make-node
+  ;; Create a node with these directions.
+  (syntax-rules ()
+    ((_ data ("<" left) (">" right))
+     (wb-tree-node data left right))
+    ((_ data (">" right) ("<" left))
+     (s-make-node data ("<" left) (">" right)))))
+
+(define-syntax with-node
+  (syntax-rules ()
+    ((with-node (%node data ("<" left) (">" right)) body ...)
+     (let* ((node %node)
+            (left (get-left node))
+            (right (get-right node))
+            (data (get-data node)))
+       body ...))
+    ((with-node (%node data (">" right) ("<" left)) body ...)
+     (with-node (%node data ("<" left) (">" right)) body ...))))
+
+(define-syntax s-get
+  (syntax-rules ()
+    ((s-get "<" node) (get-left node))
+    ((s-get ">" node) (get-right node))))
+
+(define-syntax s-rotate
+  ;; Generate rotation based on direction. Rotations are:
+  ;; 
+  ;;     A                  C
+  ;;    / \                / \
+  ;;   B   C      ->      A   E
+  ;;      / \            / \
+  ;;     D   E          B   D
+  ;; 
+  ;;     A                  C
+  ;;    / \                / \
+  ;;   C   B      ->      E   A
+  ;;  / \                    / \
+  ;; E   D                  D   B
+  (syntax-rules ()
+    ((_ dir invdir A)
+     (with-node (A A-data (dir B) (invdir C))
+       (with-node (C C-data (dir D) (invdir E))
+         (s-make-node C-data
+                      (dir (s-make-node A-data (dir B) (invdir D)))
+                      (invdir E)))))))
+
+(define-syntax s-join
+  ;; Generate a macro that traverses `invdir` to make a balanced tree with
+  ;; `dir` in it and `data` in the middle.
+  (syntax-rules ()
+    ((s-join %data (dir init-in-dir) (invdir init-in-invdir))
+     (let ((in-dir init-in-dir)
+           (%data data))
+       (let join ((in-invdir init-in-invdir))
+         (if (would-be-balanced? in-invdir in-dir)
+             (s-make-node data
+                          (invdir in-invdir)
+                          (dir in-dir))
+             (with-node (in-invdir invdir-data
+                                   (dir dir-in-invdir)
+                                   (invdir invdir-in-invdir))
+               (let ((new-dir (join dir-in-invdir)))
+                 (if (would-be-balanced? invdir-in-invdir new-dir)
+                     (s-make-node invdir-data
+                                  (invdir invdir-in-invdir)
+                                  (dir new-dir))
+                     (with-node (new-dir _
+                                         (dir dir-in-new-dir)
+                                         (invdir invdir-in-new-dir))
+                       (if (and (would-be-balanced? invdir-in-invdir
+                                                    invdir-in-new-dir)
+                                (fixnum-would-be-balanced?
+                                 (+ (get-weight invdir-in-invdir)
+                                    (get-weight invdir-in-new-dir))
+                                 (get-weight dir-in-new-dir)))
+                           (s-rotate invdir
+                                     dir
+                                     (s-make-node invdir-data
+                                                  (invdir invdir-in-invdir)
+                                                  (dir new-dir)))
+                           (s-rotate invdir
+                                     dir
+                                     (s-make-node invdir-data
+                                                  (invdir invdir-in-invdir)
+                                                  (dir (s-rotate dir invdir new-dir)))))))))))))))
+
+(: join (* node-type node-type --> (struct <wb-tree>)))
+(define (join data left right)
+  (let ((dir (heavy<=> left right)))
+    (cond
+      ((positive? dir) (s-join data (">" right) ("<" left)))
+      ((negative? dir) (s-join data ("<" left) (">" right)))
+      (else (wb-tree-node data left right)))))
+
diff --git a/mcgoron.weight-balanced-trees.sld b/mcgoron.weight-balanced-trees.sld
new file mode 100644
index 0000000..2cdee36
--- /dev/null
+++ b/mcgoron.weight-balanced-trees.sld
@@ -0,0 +1,32 @@
+#| 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-library (mcgoron weight-balanced-trees)
+  (import (scheme base))
+  (cond-expand
+    ;; Handle type declarations
+    (chicken (import (chicken type)))
+    (else (begin
+            (define-syntax :
+              (syntax-rules ()
+                ((: dummy ...) (begin)))))))
+  (export wb-tree-node? non-null-wb-tree-node?
+          get-data get-left get-right get-size
+          balanced?
+          in-order-vector->node
+          node->in-order-list
+          join)
+  (include "mcgoron.weight-balanced-trees.scm"))
+
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))))
diff --git a/weight-balanced-trees.egg b/weight-balanced-trees.egg
new file mode 100644
index 0000000..b5cc6e2
--- /dev/null
+++ b/weight-balanced-trees.egg
@@ -0,0 +1,11 @@
+((author "Peter McGoron")
+ (version "0.1.0")
+ (synopsis "Persistent weight balanced trees")
+ (category "data")
+ (license "Apache-2.0")
+ (dependencies "r7rs" "srfi-128")
+ (test-dependencies "srfi-133" "srfi-132" "srfi-194" "srfi-132" "srfi-128" "srfi-1" "srfi-64" "srfi-252" "srfi-158" "sexpr-srfi-64-runner" "srfi-197")
+ (components (extension mcgoron.weight-balanced-trees
+               (source "mcgoron.weight-balanced-trees.sld")
+               (source-dependencies "mcgoron.weight-balanced-trees.scm")
+               (csc-options "-R" "r7rs" "-X" "r7rs"))))