add sets

5 files changed, 436 insertions, 6 deletions

diff --git a/doubly-linked-list.scm b/doubly-linked-list.scm
index fa6bd20..8906f83 100644
--- a/doubly-linked-list.scm
+++ b/doubly-linked-list.scm
@@ -174,7 +174,7 @@
           (dl:set-head! ctr next)
           #f)
       (if was-tail?
-          (dl:set-tail! ctr tail)
+          (dl:set-tail! ctr prev)
           #f))))
 
 ;;; (DL:PUSH-LIST-BACK CTR LST) appends LST to CTR.
diff --git a/miniscm/init.scm b/miniscm/init.scm
index c3f5612..91abe72 100644
--- a/miniscm/init.scm
+++ b/miniscm/init.scm
@@ -114,3 +114,63 @@
                        (if (< (char->integer x) (char->integer y))
                            '<
                            '>))))))
+
+(define max
+  (lambda (curmax . rest)
+    (if (null? rest)
+        curmax
+        (let ((next-num (car rest)))
+          (apply max
+                 (cons (if (> next-num curmax) next-num curmax)
+                       (cdr rest)))))))
+
+(define all
+  (lambda (f l)
+    (cond
+      ((null? l) #t)
+      ((not (f (car l))) (all f (cdr l)))
+      (else #f))))
+
+(define any
+  (lambda (f l)
+    (cond
+      ((null? l) #f)
+      ((f (car l)) #t)
+      (else (any f (cdr l))))))
+
+(macro
+ cond-expand
+ (lambda (body)
+   (letrec
+       ((loop
+         (lambda (body)
+           (if (null? body)
+               #f
+               (let ((elem (car body)))
+                 (cond
+                   ((eqv? (car elem) 'else)
+                    (cons 'begin (cdr elem)))
+                   ((and (pair? elem)
+                         (passes? (car elem)))
+                    (cons 'begin (cdr elem)))
+                   (else (loop (cdr body))))))))
+        (passes?
+         (lambda (boolean-form)
+           (cond
+             ((eqv? boolean-form 'miniscm-unslisp) #t)
+             ((eqv? boolean-form 'r3rs) #t)
+             ((symbol? boolean-form) #f)
+             ((not (pair? boolean-form)) (error "invalid boolean form"))
+             ((eqv? (car boolean-form) 'and)
+              (all passes? (cdr boolean-form)))
+             ((eqv? (car boolean-form) 'or)
+              (any passes? (cdr boolean-form)))
+             ((eqv? (car boolean-form) 'not)
+              (not (passes? (cadr boolean-form))))
+             (else (error "invalid boolean function"))))))
+     (loop (cdr body)))))
+
+(define (abs x)
+  (if (< x 0)
+      (- x)
+      x))
diff --git a/miniscm/miniscm.c b/miniscm/miniscm.c
index e7597c9..6708a1a 100644
--- a/miniscm/miniscm.c
+++ b/miniscm/miniscm.c
@@ -79,7 +79,6 @@
  * Define or undefine following symbols as you need.
  */
 /* #define VERBOSE */	/* define this if you want verbose GC */
-#define VERBOSE
 #define	AVOID_HACK_LOOP	/* define this if your compiler is poor
 			 * enougth to complain "do { } while (0)"
 			 * construction.
@@ -91,6 +90,8 @@
 #define USE_MACRO	/* undef this if you do not need macro */
 #endif
 
+#define USE_MACRO
+
 #ifdef USE_QQUOTE
 /*--
  *  If your machine can't support "forward single quotation character"
diff --git a/set.scm b/set.scm
new file mode 100644
index 0000000..f43a19f
--- /dev/null
+++ b/set.scm
@@ -0,0 +1,357 @@
+;;; Copyright (C) Peter McGoron 2024
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, version 3 of the License.
+;;; 
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Persistent AVL sets and maps using JOIN.
+
+;;; ;;;;;;;;;;;;;;;;
+;;; Nodes, direction
+;;; ;;;;;;;;;;;;;;;;
+
+;;; Returns the slot number for
+;;; =: The node data
+;;; h: the height
+;;; <: the left child
+;;; >: the right child
+(define %set:accessor
+  (lambda (sym)
+    (cond
+      ((eq? sym '=) 0)
+      ((eq? sym 'h) 1)
+      ((eq? sym '<) 2)
+      ((eq? sym '>) 3)
+      (else (error "invalid direction")))))
+
+;;; Gets data from node value given accessor symbol.
+(define %set:get
+  (lambda (t sym)
+    (vector-ref t (%set:accessor sym))))
+
+(define %set->sexpr
+  (lambda (node)
+    (if (null? node)
+        '()
+        (list (list 'data (%set:get node '=))
+              (list '< (%set->sexpr (%set:get node '<)))
+              (list '> (%set->sexpr (%set:get node '>)))))))
+
+;;; Get the height of a node, handling the empty node.
+(define %set:height
+  (lambda (node)
+    (if (null? node)
+        0
+        (%set:get node 'h))))
+
+;;; Get the difference between the heights of two trees.
+(define %set:height-diff
+  (lambda (t1 t2)
+    (- (%set:height t1) (%set:height t2))))
+
+;;; Get the balance factor of a tree.
+(define %set:bal
+  (lambda (t) (%set:height-diff (%set:get t '<)
+                                (%set:get t '>))))
+
+;;; Set data in node given accessor symbol.
+(define %set:set!
+  (lambda (node dir x)
+    (vector-set! node (%set:accessor dir) x)))
+
+;;; Construct a new tree with data VAL.
+(define %set:node
+  (lambda (val dir1 node1 dir2 node2)
+    (let ((node (vector val (+ 1
+                               (max (%set:height node1)
+                                    (%set:height node2)))
+                        '() '())))
+      (%set:set! node dir1 node1)
+      (%set:set! node dir2 node2)
+      node)))
+
+(define %set:invdir
+  (lambda (dir)
+    (cond
+      ((eq? dir '<) '>)
+      ((eq? dir '>) '<)
+      (else (error "invalid direction")))))
+
+;;; ;;;;;;;;;;;;;;
+;;; Tree rotations
+;;; ;;;;;;;;;;;;;;
+
+;;; Rotate NODE to the left (dir = '>) or right (dir = '<).
+(define %set:rotate
+  (lambda (node dir)
+    (if (null? node)
+        #f
+        (let ((invdir (%set:invdir dir)))
+          (let ((child (%set:get node invdir)))
+            (let ((to-swap (%set:get child dir)))
+              (%set:node (%set:get child '=)
+                         dir (%set:node (%set:get node '=)
+                                        dir (%set:get node dir)
+                                        invdir to-swap)
+                         invdir (%set:get child invdir))))))))
+
+;;; ;;;;;;;;;;;;;;;;;;;
+;;; JOIN function for AVL trees.
+;;; ;;;;;;;;;;;;;;;;;;;
+
+;;; Handles rebalancing of the tree.
+(define %set:join
+  (lambda (heavier val lighter heavier-dir)
+    (let ((heavy-val (%set:get heavier '=))
+          (lighter-dir (%set:invdir heavier-dir)))
+      (let ((heavy-heavy (%set:get heavier heavier-dir))
+            (heavy-light (%set:get heavier lighter-dir)))
+        (if (<= (abs (%avl:diff heavy-light lighter) 1))
+            (let ((node (%set:node val
+                                   heavier-dir heavy-light
+                                   lighter-dir lighter)))
+              (if (<= (abs (%set:bal node)) 1)
+                  (%set:node heavy-val
+                             heavier-dir heavy-heavy
+                             lighter-dir node)
+                  (%set:rotate (%set:node heavy-val
+                                          heavier-dir heavy-heavy
+                                          lighter-dir
+                                          (%set:rotate node lighter-dir))
+                               heavier-dir)))
+            (let ((new-light (%set:join heavy-light val lighter heavier-dir)))
+              (let ((node (%set:node heavy-val
+                                     heavier-dir heavy-heavy
+                                     lighter-dir new-light)))
+                (if (<= (abs (%set:bal node)) 1)
+                    node
+                    (%set:rotate node heavier-dir)))))))))
+
+;;; JOIN takes two trees and the data for a node, such that all nodes
+;;; in LEFT are less than or equal to VAL, and all nodes in RIGHT are
+;;; greater than or equal to VAL, and outputs a balanced binary search
+;;; tree.
+(define set:join
+  (lambda (left val right)
+    (let ((diff (%set:diff left right)))
+      (cond
+        ((> diff 1) (%set:join left val right '<))
+        ((< diff -1) (%set:join right val left '>))
+        (else (set:node val '< left '> right))))))
+
+(define set:join2
+  (letrec
+      ((join2
+        (lambda (left right)
+          (if (null? left)
+              right
+              (let ((split-last-tree (split-last left)))
+                (set:join (bst:get split-last-tree '<)
+                          (bst:get split-last-tree '=)
+                          right)))))
+       (split-last
+        (lambda (tree)
+          (let ((right (set:get tree '>)))
+            (if (null? right)
+                tree
+                (let ((last (split-last right)))
+                  (bst:node (set:get last '=)
+                            (join (set:get tree '<)
+                                  (set:get tree '=)
+                                  (set:get last '<))
+                            '())))))))
+    join2))
+
+;;; ;;;;;;;;;;;;;;;;;
+;;; Element functions
+;;; ;;;;;;;;;;;;;;;;;
+
+;;; (SET:IN <=>) generates a search function for comparison function <=>.
+;;; (SEARCH TREE DATA) searches TREE for a node that matches DATA.
+;;; It will return the node that contains the matched DATA, or #F.
+(define set:in
+  (lambda (<=>)
+    (lambda (tree data)
+      (letrec
+          ((loop
+            (lambda (tree)
+              (if (null? tree)
+                  #f
+                  (let ((dir (<=> (%set:get tree '=) data)))
+                    (if (eq? dir '=)
+                        tree
+                        (loop (set:get tree dir))))))))
+        (loop tree)))))
+
+;;; (SET:INSERT <=>) generates an insert function for comparison function
+;;; <=>.
+;;; (INSERT TREE NODE) inserts NODE into TREE. It returns
+;;; (CONS NEWTREE FOUND), where FOUND is the node that was replaced by
+;;; NODE, and #F otherwise, and NEWTREE is the new root of the tree.
+(define set:insert
+  (lambda (<=>)
+    (lambda (tree node)
+      (let ((found #f))
+        (letrec
+            ((loop
+              (lambda (tree)
+                (if (null? tree)
+                    node
+                    (let ((dir (<=> (%set:get tree '=)
+                                    (%set:get node '=)))
+                          (left (%set:get tree '<))
+                          (right (%set:get tree '>)))
+                      (if (eq? dir '=)
+                          (begin
+                            (set! found tree)
+                            (set:node (set:get node '=)
+                                      '< left '> right))
+                          (join (set:node (%set:get tree '=)
+                                          dir (loop left)
+                                          (set:invdir dir) right))))))))
+          (let ((newtree (loop tree)))
+            (cons newtree found)))))))
+
+;;; (SET:DELETE <=>) generates a delete function for comparison function
+;;; <=>.
+;;; (DELETE TREE DATA) deletes a node from TREE that compares equal to
+;;; DATA. The function returns (CONS NEWTREE FOUND), where FOUND is the
+;;; deleted node, or #F if not found, and NEWTREE is the root of the new
+;;; tree.
+(define set:delete
+  (lambda (<=>)
+    (lambda (tree node)
+      (let ((found #f))
+        (letrec
+            ((loop
+              (lambda (tree)
+                (if (null? tree)
+                    node
+                    (let ((dir (<=> (%set:get tree '=)
+                                    (%set:get node '=)))
+                          (left (%set:get tree '<))
+                          (right (%set:get tree '>)))
+                      (if (eq? dir '=)
+                          (begin
+                            (set! found tree)
+                            (set:join2 left right))
+                          (join (set:node (%set:get tree '=)
+                                          dir (loop left)
+                                          (set:invdir dir) right))))))))
+          (let ((newtree (loop tree)))
+            (cons newtree found)))))))
+
+;;; ;;;;;;;;;;;
+;;; For strings
+;;; ;;;;;;;;;;;
+
+(cond-expand
+ ((not miniscm-unslisp)
+  (define (string<=> x y)
+    (cond
+      ((string<? x y) '<)
+      ((string>? x y) '>)
+      (else '=)))))
+
+(define map:string<=>
+  (lambda (x y)
+    (string<=> (car x) (car y))))
+
+(define %smap:insert (set:insert map:string<=>))
+(define smap:insert
+  (lambda (tree key val)
+    (%smap:insert tree (%set:node (cons key val)
+                                  '< '()
+                                  '> '()))))
+
+(define %smap:search (set:in map:string<=>))
+(define smap:search
+  (lambda (tree key)
+    (%smap:search tree (cons key '()))))
+
+(define %smap:delete (set:delete map:string<=>))
+(define smap:delete
+  (lambda (tree key)
+    (%smap:delete tree (%set:node (cons key '())
+                                  '< '() '> '()))))
+
+(define smap:key
+  (lambda (node) (car (%set:get node '=))))
+(define smap:val
+  (lambda (node) (cdr (%set:get node '=))))
+
+(define %set:tests
+  (list
+   (cons "rotate right"
+         (lambda ()
+           (let ((right (%set:rotate (%set:node 1
+                                                '< (%set:node 2
+                                                              '< (%set:node 3
+                                                                            '< '()
+                                                                            '> '())
+                                                              '> (%set:node 4
+                                                                            '< '()
+                                                                            '> '()))
+                                                '> (%set:node 5 '< '() '> '()))
+                                     '>)))
+             (cond
+               ((not (eqv? (%set:get right '=) 2)) "bad parent")
+               ((not (eqv? (%set:get (%set:get right '>) '=) 1)) "bad right child")
+               ((not (eqv? (%set:get (%set:get right '<) '=) 3)) "bad left child")
+               ((not (eqv? (%set:get (%set:get (%set:get right '>) '>) '=) 5))
+                "bad right child of right child")
+               ((not (eqv? (%set:get (%set:get (%set:get right '>) '<) '=) 4))
+                "bad left child of right child")
+               (else #t)))))
+   (cons "rotate left"
+         (lambda ()
+           (let ((right (%set:rotate (%set:node 1
+                                                '> (%set:node 2
+                                                              '< (%set:node 3
+                                                                            '< '()
+                                                                            '> '())
+                                                              '> (%set:node 4
+                                                                            '< '()
+                                                                            '> '()))
+                                                '< (%set:node 5 '< '() '> '()))
+                                     '<)))
+             (cond
+               ((not (eqv? (%set:get right '=) 2)) "bad parent")
+               ((not (eqv? (%set:get (%set:get right '>) '=) 4)) "bad right child")
+               ((not (eqv? (%set:get (%set:get right '<) '=) 1)) "bad left child")
+               ((not (eqv? (%set:get (%set:get (%set:get right '<) '>) '=) 3))
+                "bad right child of left child")
+               ((not (eqv? (%set:get (%set:get (%set:get right '<) '<) '=) 5))
+                "bad left child of left child")
+               (else #t)))))
+   (cons "insert then delete"
+         (lambda ()
+           (let ((insert-return (smap:insert '() (string #\a) 5)))
+             (cond
+               ((not (pair? insert-return)) "invalid insert return")
+               ((cdr insert-return) "string found in empty tree")
+               (else
+                (let ((tree (car insert-return)))
+                  (let ((found (smap:search tree (string #\a))))
+                    (cond
+                      ((not found) "string not in tree")
+                      ((not (equal? (smap:key tree) (string #\a)))
+                       "returned key not equal to a")
+                      ((not (equal? (smap:val tree) 5))
+                       "returned value not equal to 5")
+                      (else
+                       (let ((delete-return (smap:delete tree (string #\a))))
+                         (cond
+                           ((not (pair? delete-return))
+                            "invalid delete return")
+                           ((not (cdr delete-return)) "string not found")
+                           ((not (eqv? (car delete-return) '()))
+                            "returned tree not null")
+                           (else #t))))))))))))))
diff --git a/tests.scm b/tests.scm
index 717a0be..a7b4b67 100644
--- a/tests.scm
+++ b/tests.scm
@@ -48,10 +48,22 @@
                         (loop (cdr rest)))))))))
       (loop tests))))
 
+(define report-tests
+  (lambda (tests)
+    (let ((res (run-tests tests)))
+      (if (eq? res #t)
+          (display "passed")
+          (begin
+            (display "failed: ")
+            (display res))))
+    (newline)))
+
 (load "doubly-linked-list.scm")
-(display "running doubly linked list tests")
+(display "running doubly linked list tests: ")
 (newline)
-(if (run-tests %dl:tests)
-    (display "doubly linked list tests: passed")
-    (display "doubly linked list tests: failed"))
+(report-tests %dl:tests)
+
+(load "set.scm")
+(display "running string BST-AVL tests")
 (newline)
+(report-tests %set:tests)