aatree and linked-listHEADmaster

1 files changed, 188 insertions, 0 deletions

diff --git a/examples/test-aatree.scm b/examples/test-aatree.scm
new file mode 100644
index 0000000..903534b
--- /dev/null
+++ b/examples/test-aatree.scm
@@ -0,0 +1,188 @@
+;;;; Copyright (c) 2024, Peter McGoron
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1) Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2) Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer
+;;;;    in the documentation and/or other materials provided with the
+;;;;    distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;;;; POSSIBILITY OF SUCH DAMAGE.
+
+(load "../srfi/srfi-64.scm")
+(load "../define-namespace-5.scm")
+(load "aatree.scm")
+
+(define (string<=> x y)
+  (if (string<? x y)
+      '<
+      (if (string=? x y)
+          '=
+          '>)))
+
+(import-from-namespace
+ (only aatree aatree? aatree->alist)
+ (rename aatree
+         (new aatree/new)
+         (search aatree/search)
+         (insert aatree/insert)
+         (delete aatree/delete)))
+
+(test-begin "AATree")
+
+(test-begin "insert one")
+(define tree (aatree/new string<=>))
+(let-values (((status key value)
+              (aatree/insert tree "a" 1)))
+  (test-equal "insert status" 'not-found status)
+  (let-values (((status key value)
+                (aatree/search tree "a")))
+    (test-equal "search status" 'found status)
+    (test-equal "search key" "a" key)
+    (test-equal "search value" 1 value)))
+(test-end "insert one")
+
+
+(test-begin "insert many in order")
+(define inspairs
+  '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4) ("e" . 5) ("f" . 6)
+            ("g" . 7) ("h" . 8) ("i" . 9) ("j" . 10) ("k" . 11) ("l" . 12)
+            ("m" . 13) ("n" . 14) ("o" . 15) ("p" . 16) ("q" . 17) ("r" . 18)
+            ("s" . 19) ("t" . 20) ("u" . 21) ("v" . 22) ("w" . 23) ("x" . 24)
+            ("y" . 25) ("z" . 26)))
+
+(define (fold-collect f start processed to-process)
+  (if (null? to-process)
+      start
+      (let ((new-elem (car to-process)))
+        (fold-collect f (f start new-elem processed)
+                      (cons new-elem processed)
+                      (cdr to-process)))))
+
+(define (iter f l)
+  (if (pair? l)
+      (begin
+        (f (car l))
+        (iter f (cdr l)))))
+
+(define (test-insert node pair searchlist)
+  (let-values (((status key value)
+                (aatree/insert node (car pair) (cdr pair))))
+    (test-equal "insert" 'not-found status)
+    (iter (lambda (pair)
+            (let ((key (car pair))
+                  (val (cdr pair)))
+              (let-values (((status retkey retval)
+                            (aatree/search node key)))
+                (test-equal "search status" 'found status)
+                (test-equal "search key" key retkey)
+                (test-equal "search value" val retval))))
+          searchlist)
+    node))
+
+
+(define inserted-in-order
+  (fold-collect test-insert (aatree/new string<=>) '() inspairs))
+(test-end "insert many in order")
+
+(display "a\n")
+;; Not possible to implement good randomin strictly portable R5RS scheme,
+;; Shuffled using "shuf"
+
+(test-begin "insert shuffled")
+(define shuffled-list
+  '(("k" . 11)
+    ("p" . 16)
+    ("r" . 18)
+    ("w" . 23)
+    ("x" . 24)
+    ("t" . 20)
+    ("f" . 6)
+    ("z" . 26)
+    ("h" . 8)
+    ("a" . 1)
+    ("s" . 19)
+    ("e" . 5)
+    ("d" . 4)
+    ("y" . 25)
+    ("c" . 3)
+    ("j" . 10)
+    ("v" . 22)
+    ("g" . 7)
+    ("o" . 15)
+    ("q" . 17)
+    ("m" . 13)
+    ("u" . 21)
+    ("l" . 12)
+    ("b" . 2)
+    ("n" . 14)
+    ("i" . 9)))
+(fold-collect test-insert (aatree/new string<=>) '() shuffled-list)
+(test-end "insert shuffled")
+
+(test-begin "delete one")
+
+(define tree (aatree/new string<=>))
+(let-values (((status key value)
+              (aatree/insert tree "a" 1)))
+  (test-equal "insert status" 'not-found status)
+  (let-values (((status retkey retval)
+                (aatree/search tree "a")))
+    (test-equal "search 1 status" 'found status)
+    (test-equal "search 1 key" "a" retkey)
+    (test-equal "search 1 value" 1 retval)
+    (let-values (((status retkey retval)
+                  (aatree/delete tree "a")))
+      (test-equal "delete status" 'found status)
+      (test-equal "delete key" "a" retkey)
+      (test-equal "delete value" 1 retval)
+      (let-values (((status . _)
+                    (aatree/search tree "a")))
+        (test-equal "search 2 status" status 'not-found)))))
+(test-end "delete one")
+
+(define (test-delete tree deleted to-delete)
+  (if (pair? to-delete)
+      (let ((pair (car to-delete)))
+        (let-values (((status retkey retval)
+                      (aatree/delete tree (car pair))))
+          (test-equal "delete status" 'found status)
+          (test-equal "delete key" (car pair) retkey)
+          (test-equal "delete value" (cdr pair) retval)
+          (iter (lambda (pair)
+                  (let ((key (car pair)))
+                    (let-values (((status . _)
+                                  (aatree/search tree key)))
+                      (test-equal "deleted search" 'not-found status))))
+                (cons pair deleted))
+          (iter (lambda (pair)
+                  (let ((key (car pair))
+                        (val (cdr pair)))
+                    (let-values (((status retkey retval)
+                                  (aatree/search tree key)))
+                      (test-equal "to-delete search" 'found status)
+                      (test-equal "to-delete search value" val retval)
+                      (test-equal "to-delete search key" key retkey))))
+                (cdr to-delete))
+          (test-delete tree (cons pair deleted) (cdr to-delete))))))
+
+(test-begin "insert and shuffled delete")
+(test-delete inserted-in-order '() shuffled-list)
+(test-end "insert and shuffled delete")
+
+(test-end "AATree")