aatree and linked-listHEADmaster

3 files changed, 447 insertions, 0 deletions

diff --git a/examples/aatree.scm b/examples/aatree.scm
new file mode 100644
index 0000000..918782c
--- /dev/null
+++ b/examples/aatree.scm
@@ -0,0 +1,232 @@
+;;;; 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.
+;;;; 
+;;;; This implements functional balanced binary search trees (AA Trees).
+;;;; 
+;;;; (NEW <=>) makes a new AA Tree root. 
+;;;; (<=> KEY1 KEY2) must return one of the symbols in '(< = >), which
+;;;; denote that KEY1 is less than, equivalent to, or greater than KEY2.
+;;;; 
+;;;; (SEARCH TREE KEY) searches the tree for the first node equivalent
+;;;; to KEY. If successful, it returns (VALUES 'FOUND KEY VAL). Otherwise
+;;;; it returns (VALUES 'NOT-FOUND '() '()).
+;;;; 
+;;;; (INSERT TREE KEY VAL) inserts KEY into TREE with value VAL. If
+;;;; a key equivalent to KEY is already in TREE, the old key is replaced with
+;;;; KEY and the old value is replaced with VAL, and the function returns
+;;;; (VALUES 'FOUND OLDKEY OLDVAL). If the value is not found, then
+;;;; the function returns (VALUES 'NOT-FOUND OLDKEY OLDVAL).
+;;;; 
+;;;; (DELETE TREE KEY) deletes the node equivalent to KEY, if it exists.
+;;;; It returns 
+
+(define-namespace aatree
+  (begin
+    (define-record-type :aatree-node
+      (new-node key value left right level)
+      node?
+      (key get-key key-set!)
+      (value get-value value-set!)
+      (left get-left left-set!)
+      (right get-right right-set!)
+      (level get-level-raw level-set!))
+    (define-record-type :aatree
+      (%aatree <=> root)
+      aatree?
+      (<=> get-<=>)
+      (root get-root set-root!))
+    (define leaf '())
+    (define (new <=>) (%aatree <=> leaf))
+    (define leaf? null?)
+    (define (get-level r)
+      (if (leaf? r)
+          0
+          (get-level-raw r)))
+    ; Option-like accessors
+    (define (maybe-right t)
+      (if (null? t)
+          leaf
+          (get-right t)))
+    (define (maybe-left t)
+      (if (null? t)
+          leaf
+          (get-left t)))
+    ; right rotation
+    ;        a        b
+    ;       / \      / \
+    ;      b   c -> d   a
+    ;     / \          / \
+    ;    d   e        e   c
+    (define (skew A)
+      (let* ((B (maybe-left A))
+             (E (maybe-right B)))
+        (if (and (not (leaf? A))
+                 (eq? (get-level B)
+                      (get-level A)))
+            (begin
+              (right-set! B A)
+              (left-set! A E)
+              B)
+            A)))
+    ; left rotation
+    ;     a            c
+    ;    / \          / \
+    ;   b   c   ->   a   e
+    ;      / \      / \
+    ;     d   e    b   d
+    ;   
+    (define (split A)
+      (let* ((C (maybe-right A))
+             (E (maybe-right C))
+             (D (maybe-left C)))
+        (if (and (not (leaf? A))
+                 (not (leaf? C))
+                 (eq? (get-level E)
+                      (get-level A)))
+            (begin
+              (left-set! C A)
+              (right-set! A D)
+              (level-set! C (+ (get-level C) 1))
+              C)
+            A)))
+    (define (search* <=> tree key)
+      (if (leaf? tree)
+          (values 'not-found '() '())
+          (let ((nodekey (get-key tree)))
+            (case (<=> key nodekey)
+              ((<) (search* <=> (get-left tree) key))
+              ((>) (search* <=> (get-right tree) key))
+              ((=) (values 'found nodekey (get-value tree)))))))
+    (define (search tree key) (search* (get-<=> tree) (get-root tree) key))
+    (define (insert* <=> node key val)
+      (if (leaf? node)
+          (values (new-node key val '() '() 1) 'not-found '() '())
+          (case (<=> key (get-key node))
+            ((=) (let ((oldval (get-value node)))
+                   (value-set! node val)
+                   (values node 'found (get-key node) oldval)))
+            ((<) (let-values (((newnode . rest)
+                               (insert* <=> (get-left node) key val)))
+                   (left-set! node newnode)
+                   (apply values (cons (split (skew node)) rest))))
+            ((>) (let-values (((newnode . rest)
+                               (insert* <=> (get-right node) key val)))
+                   (right-set! node newnode)
+                   (apply values (cons (split (skew node)) rest))))
+            (else (error "comparision must return <, =, or >")))))
+    (define (insert tree key val)
+      (let-values (((new-root . rest) (insert* (get-<=> tree) (get-root tree) key val)))
+        (set-root! tree new-root)
+        (apply values rest)))
+    (define (delete* <=> tree key)
+      (if (leaf? tree)
+          (values tree 'not-found '() '())
+          (let ((process (lambda (t)
+                           (if (leaf? t)
+                               t
+                               (let* ((level (get-level t))
+                                      (level-l (get-level (get-left t)))
+                                      (level-r (get-level (get-right t)))
+                                      (new-level (- level 1)))
+                                 (if (or (< level-l new-level)
+                                         (< level-r new-level))
+                                     (begin
+                                       (if (> level-r new-level)
+                                           (level-set! (get-right t)
+                                                       (min level-r new-level)))
+                                       (level-set! t new-level)
+                                       (set! t (skew t))
+                                       (right-set! t (skew (get-right t)))
+                                       (right-set! (get-right t)
+                                                   (skew (get-right (get-right t))))
+                                       (set! t (split t))
+                                       (right-set! t (split (get-right t)))))
+                                 t)))))
+            (case (<=> key (get-key tree))
+              ((<) (let-values (((newnode . rest)
+                                 (delete* <=> (get-left tree) key)))
+                     (left-set! tree newnode)
+                     (apply values (cons (process tree) rest))))
+              ((>) (let-values (((newnode . rest)
+                                 (delete* <=> (get-right tree) key)))
+                     (right-set! tree newnode)
+                     (apply values (cons (process tree) rest))))
+              ((=) (letrec
+                       ((del-min (lambda (t)
+                                   (if (leaf? (get-left t))
+                                       (values (get-right t) 'found (get-key t)
+                                               (get-value t))
+                                       (let-values (((newnode . rest)
+                                                     (del-min (get-left t))))
+                                         (if (leaf? (get-right t))
+                                             (error "imbalanced tree"))
+                                         (left-set! t newnode)
+                                         (apply values
+                                                (cons (process t) rest)))))))
+                     (if (leaf? (get-right tree))
+                         (if (not (leaf? (get-left tree)))
+                             (error "imbalanced tree")
+                             (values '() 'found (get-key tree) (get-value tree)))
+                         (let-values (((newnode status key value)
+                                       (del-min (get-right tree)))
+                                      ((oldvalue) (get-value tree))
+                                      ((oldkey) (get-key tree)))
+                           (key-set! tree key)
+                           (value-set! tree value)
+                           (right-set! tree newnode)
+                           (values (process tree) status oldkey oldvalue)))))))))
+    (define (delete tree key)
+      (let-values (((new-root . rest) (delete* (get-<=> tree)
+                                               (get-root tree)
+                                               key)))
+        (set-root! tree new-root)
+        (apply values rest)))
+    (define (aatree->alist* node alist)
+      (if (leaf? node)
+          alist
+          (let ((alist-right (aatree->alist* (get-right node) alist)))
+            (aatree->alist* (get-left node)
+                            (cons (cons (get-key node)
+                                        (get-value node))
+                                  alist-right)))))
+    (define (aatree->alist tree) (aatree->alist* (get-root tree) '()))
+    (define (alist->aatree* node <=> alist)
+      (if (null? alist)
+          node
+          (let ((pair (car alist)))
+            (let-values (((node . _)
+                          (insert node <=>
+                                  (car pair)
+                                  (cdr pair))))
+              (alist->aatree* node (cdr alist) <=>)))))
+    (define (alist->aatree tree)
+      (alist->aatree* (get-root tree) (get-<=> tree) '())))
+  (export
+   aatree?
+   new
+   aatree->alist alist->aatree
+   search insert delete))
+
diff --git a/examples/linked-list.scm b/examples/linked-list.scm
new file mode 100644
index 0000000..821d0b6
--- /dev/null
+++ b/examples/linked-list.scm
@@ -0,0 +1,27 @@
+(define-namespace linked-list
+  (define-record-type linked-list
+    (linked-list head tail)
+    linked-list?
+    (head get-head set-head!)
+    (tail get-tail set-tail!))
+  (define (new) (linked-list '() '()))
+  (define (empty? lst) (null? (get-head lst)))
+  (define (linked-list->list lst) (get-head lst))
+  (define (push-first lst val)
+    (let ((container (list val)))
+      (set-head! lst container)
+      (set-tail! list container)))
+  (define (push-head lst val)
+    (if (empty? lst)
+        (push-first lst val)
+        (set-head! lst (cons val (get-head lst)))))
+  (define (push-tail lst val)
+    (if (empty? lst)
+        (push-first lst val)
+        (let ((container (list val)))
+          (set-cdr! (get-tail lst) container)
+          (set-tail! lst container))))
+  (export new empty?
+          push-head push-tail
+          linked-list->list))
+
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")