fix set and trie, add compat COND-EXPAND for chez

3 files changed, 223 insertions, 26 deletions

diff --git a/chez-compat.scm b/chez-compat.scm
new file mode 100644
index 0000000..39cb31a
--- /dev/null
+++ b/chez-compat.scm
@@ -0,0 +1,49 @@
+;;; 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/>.
+;;; 
+;;; Simple COND-EXPAND using SYNTAX-RULES. Designed for chez.
+
+(define-syntax cond-expand-conditional
+  (syntax-rules (and or not chez r6rs)
+    ;; Defined keywords
+    ((cond-expand-conditional chez execute alt) execute)
+    ((cond-expand-conditional r6rs execute alt) execute)
+    ;; Conditional statements: AND
+    ((cond-expand-conditional (and e1 e2 ...) execute alt)
+     (cond-expand-conditional e1
+                              (cond-expand-conditional
+                               (and e2 ...)
+                               execute
+                               alt)
+                              alt))
+    ((cond-expand-conditional (and) execute alt) execute)
+    ;; OR
+    ((cond-expand-conditional (or e1 e2 ...) execute alt)
+     (cond-expand-conditional e1 execute
+                              (cond-expand-conditional
+                               (or e2 ...) execute alt)))
+    ((cond-expand-conditional (or) execute alt) alt)
+    ;; NOT
+    ((cond-expand-conditional (not e) execute alt)
+     (cond-expand-conditional e alt execute))
+    ;; All other conditions
+    ((cond-expand-conditional unknown execute alt) alt)))
+
+(define-syntax cond-expand
+  (syntax-rules (else)
+    ((cond-expand (else evaluated ...)) (begin evaluated ...))
+    ((cond-expand (conditional evaluated ...) rest ...)
+     (cond-expand-conditional conditional
+                              (begin evaluated ...)
+                              (cond-expand rest ...)))))
+
diff --git a/set.scm b/set.scm
index c5f4e90..d00d96f 100644
--- a/set.scm
+++ b/set.scm
@@ -34,7 +34,12 @@
 ;;; Gets data from node value given accessor symbol.
 (define set:get
   (lambda (t sym)
-    (vector-ref t (%set:accessor sym))))
+    (let ((acc (%set:accessor sym)))
+      (if (null? t)
+          (cond
+            ((eq? sym 'h) 0)
+            (else '()))
+          (vector-ref t (%set:accessor sym))))))
 
 (define %set->sexpr
   (lambda (node)
@@ -44,6 +49,50 @@
               (list '< (%set->sexpr (set:get node '<)))
               (list '> (%set->sexpr (set:get node '>)))))))
 
+(cond-expand
+ (chicken
+  (import (chicken process))
+  (define (set:display set)
+    (call-with-output-pipe
+        "dot -T png > /tmp/dot.png"
+      (lambda (out)
+        (letrec
+            ((D
+              (lambda (o)
+                (display o out)
+                (display o)))
+             (dump-data
+              (lambda (tree)
+                (D "\"")
+                (D (set:get tree '=))
+                (D "\"")))
+             (connect
+              (lambda (parent child)
+                (if (null? child)
+                    '()
+                    (begin
+                      (dump-data parent)
+                      (D " -> ")
+                      (dump-data child)
+                      (D " ;\n")
+                      (loop child)))))
+             (loop
+              (lambda (parent)
+                (if (null? parent)
+                    '()
+                    (begin
+                      (connect parent (set:get parent '<))
+                      (connect parent (set:get parent '>)))))))
+          (D "digraph t {\n")
+          (loop set)
+          (D "}\n"))))
+    (system "imv-wayland /tmp/dot.png")))
+ (else
+  (define set:display
+    (lambda (set)
+      (display (%set->sexpr set))
+      (newline)))))
+
 ;;; Get the height of a node, handling the empty node.
 (define %set:height
   (lambda (node)
@@ -123,7 +172,7 @@
             (let ((node (%set:node val
                                    heavier-dir heavy-light
                                    lighter-dir lighter)))
-              (if (<= (abs (%set:bal node)) 1)
+              (if (<= (%set:height-diff node heavy-heavy) 1)
                   (%set:node heavy-val
                              heavier-dir heavy-heavy
                              lighter-dir node)
@@ -165,11 +214,56 @@
                 tree
                 (let ((last (split-last right)))
                   (%set:node (set:get last '=)
-                             (set:join (set:get tree '=)
-                                       '< (set:get tree '<)
-                                       '> (set:get last '>)))))))))
+                             '< (set:join (set:get tree '=)
+                                          '< (set:get tree '<)
+                                          '> (set:get last '>))
+                             '> '())))))))
     join2))
 
+(define set:split
+  (lambda (<=>)
+    (letrec
+        ((split
+          (lambda (set data)
+            (if (null? set)
+                (%set:node #f '< '() '> '())
+                (let ((set-data (set:get set '=)))
+                  (let ((dir (<=> data set-data)))
+                    (if (eq? dir '=)
+                        (set:node-new-val set #t)
+                        (let ((new-tree (split (set:get set dir) data))
+                              (invdir (%set:invdir dir)))
+                          (%set:node (set:get new-tree '=)
+                                     dir (set:get new-tree dir)
+                                     invdir (set:join set-data
+                                                      dir (set:get new-tree invdir)
+                                                      invdir (set:get set invdir)))))))))))
+      split)))
+
+;;; ;;;;;;;;;;;;;
+;;; Set functions
+;;; ;;;;;;;;;;;;;
+
+;;; Generate union operation from split operation.
+;;; Union prioritizes data in PRIORITY over keys in SECONDARY.
+(define set:union
+  (lambda (split)
+    (letrec
+        ((union
+          (lambda (priority secondary)
+            (cond
+              ((null? priority) secondary)
+              ((null? secondary) priority)
+              (else
+               (let ((key (set:get priority '=)))
+                 (let ((split-tree (split secondary key)))
+                   (set:join key
+                             '< (union (set:get priority '<)
+                                       (set:get split-tree '<))
+                             '> (union (set:get priority '>)
+                                       (set:get split-tree '>))))))))))
+      union)))
+
 ;;; ;;;;;;;;;;;;;;;;;
 ;;; Element functions
 ;;; ;;;;;;;;;;;;;;;;;
@@ -185,7 +279,7 @@
             (lambda (tree)
               (if (null? tree)
                   '()
-                  (let ((dir (<=> (set:get tree '=) data)))
+                  (let ((dir (<=> data (set:get tree '=))))
                     (if (eq? dir '=)
                         tree
                         (loop (set:get tree dir))))))))
@@ -203,8 +297,8 @@
             (lambda (tree)
               (if (null? tree)
                   (update node #f)
-                  (let ((dir (<=> (set:get tree '=)
-                                  (set:get node '=))))
+                  (let ((dir (<=> (set:get node '=)
+                                  (set:get tree '=))))
                     (if (eq? dir '=)
                         (update node tree)
                         (let ((invdir (%set:invdir dir)))
@@ -236,19 +330,19 @@
 ;;; <=>.
 ;;; (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
+;;; deleted node, or NULL if not found, and NEWTREE is the root of the new
 ;;; tree.
 (define set:delete
   (lambda (<=>)
     (lambda (tree node)
-      (let ((found #f))
+      (let ((found '()))
         (letrec
             ((loop
               (lambda (tree)
                 (if (null? tree)
                     node
-                    (let ((dir (<=> (set:get tree '=)
-                                    (set:get node '=))))
+                    (let ((dir (<=> (set:get node '=)
+                                    (set:get tree '=))))
                       (if (eq? dir '=)
                           (begin
                             (set! found tree)
@@ -313,6 +407,12 @@
       (lambda (tree key)
         (delete tree (map:empty-node key '()))))))
 
+(define map:split
+  (lambda (<=>) (set:split <=>)))
+
+(define map:union
+  (lambda (split) (set:union split)))
+
 ;;; ;;;;;;;;;;;
 ;;; For strings
 ;;; ;;;;;;;;;;;
@@ -323,14 +423,16 @@
     (cond
       ((string<? x y) '<)
       ((string>? x y) '>)
-      (else '=)))))
+      (else '=))))
+ (else #f))
 
 (cond-expand
  ((and (not miniscm-unslisp) (not r7rs))
   (define (list-set! lst n val)
     (if (= n 0)
         (set-car! lst val)
-        (list-set! (cdr lst) (- n 1) val)))))
+        (list-set! (cdr lst) (- n 1) val))))
+ (else #f))
 
 (define map:string<=> (set:<=>-to-map string<=>))
 (define %smap:update (set:update map:string<=>))
@@ -340,6 +442,9 @@
 (define smap:search (map:search  map:string<=>))
 (define smap:delete (map:delete map:string<=>))
 
+(define %smap:split (map:split map:string<=>))
+(define smap:union (map:union %smap:split))
+
 ;;; ;;;;;
 ;;; Tests
 ;;; ;;;;;
@@ -358,7 +463,7 @@
               (already-in (list-ref (car lst) 2)))
           (let ((insert-return (f tree key val)))
             (cond
-              ((and already-in (not (cdr insert-return)))
+              ((and already-in (null? (cdr insert-return)))
                "should have been found")
               ((and already-in (not (equal? already-in
                                             (map:val (cdr insert-return)))))
@@ -454,7 +559,16 @@
                              (list (string #\a #\b #\c) 1 #f)
                              (list (string #\a #\b #\d) 2 #f)
                              (list (string #\d #\e #\f) 3 #f)
-                             (list (string #\1 #\2 #\3 #\a #\C) 4 #f))))
+                             (list (string #\1 #\2 #\3 #\a #\C) 4 #f)
+                             (list (string #\q #\w #\e) 5 #f)
+                             (list (string #\1 #\2 #\3) 5 #f)
+                             (list (string #\l #\i #\s #\p) 6 #f)
+                             (list (string #\c) 7 #f)
+                             (list (string #\s #\c #\m) 8 #f)
+                             (list (string #\a #\l #\g #\o #\l) 9 #f)
+                             (list (string #\a #\s #\m) 10 #f)
+                             (list (string #\4) 11 #f)
+                             (list (string #\a #\s #\m #\e) 12 #f))))
              (display "insert all") (newline)
              (let ((tree (%set:insert-all '() to-insert)))
                (if (string? tree)
@@ -498,4 +612,25 @@
                                                 (list (string #\a #\b #\c #\d #\e) 10 10)))))
                      (if (string? res)
                          res
-                         #t)))))))))
+                         #t)))))))
+   (cons "union a few"
+         (lambda ()
+           (let ((tree1 (%set:insert-all '()
+                                         (list
+                                          (list (string #\a) 1 #f)
+                                          (list (string #\b) 2 #f)
+                                          (list (string #\c) 3 #f))))
+                 (tree2 (%set:insert-all '()
+                                         (list
+                                          (list (string #\c) 4 #f)
+                                          (list (string #\d) 5 #f)
+                                          (list (string #\e) 6 #f)))))
+             (let ((tree (smap:union tree1 tree2))
+                   (to-search (list
+                               (list (string #\a) 1 1)
+                               (list (string #\b) 2 2)
+                               (list (string #\c) 3 3)
+                               (list (string #\d) 5 5)
+                               (list (string #\e) 6 6))))
+               (not (string? (%set:search-all tree to-search)))))))))
+
diff --git a/trie.scm b/trie.scm
index 1e70e37..c384e12 100644
--- a/trie.scm
+++ b/trie.scm
@@ -34,29 +34,37 @@
 
 ;;; ;;;;;;;;;;
 ;;; Char tries
+;;; 
+;;; Tries are pairs, CAR = backing map from chars to trie nodes, and
+;;; CDR = function tied to this part of the trie.
 ;;; ;;;;;;;;;;
 
+;;; (TRIE:NEW TABLE FUNCTION)
 (define trie:new cons)
-(define trie:empty (trie:new #f '()))
+(define trie:empty (trie:new '() #f))
+
+;;; Get the function inside of trie NODE.
 (define trie:function
   (lambda (node)
     (if (null? node)
         #f
-        (car node))))
-(define %trie:set
+        (cdr node))))
+
+;;; Get the backing set inside of trie NODE.
+(define trie:backing
   (lambda (node)
     (if (null? node)
         '()
-        (cdr node))))
+        (car node))))
 
 ;;; Insert STRING-AS-LIST into NODE with value FUNCTION.
 (define trie:insert
   (lambda (node string-as-list function)
     (if (null? string-as-list)
-        (trie:new function (%trie:set node))
+        (trie:new (trie:backing node) function)
         (let ((ch (car string-as-list))
               (string-as-list (cdr string-as-list)))
-          (let ((newtree (charmap:update (%trie:set node) ch
+          (let ((newtree (charmap:update (trie:backing node) ch
                                          (lambda (node oldnode)
                                            (if oldnode
                                                (map:node-new-val
@@ -70,12 +78,17 @@
                                                                 trie:empty
                                                                 string-as-list
                                                                 function)))))))
-            (trie:new (trie:function node) newtree))))))
+            (trie:new newtree (trie:function node)))))))
 
 (define trie:insert-many
   (lambda (node lst)
     (fold (lambda (pair node)
-            (trie:insert node (string->list (car pair)) (cdr pair)))
+            (let ((key (car pair)))
+              (let ((key (cond
+                           ((list? key) key)
+                           ((string? key) (string->list key))
+                           ((char? key) (list key)))))
+                (trie:insert node key (cdr pair)))))
           node lst)))
 
 ;;; Search for CH in NODE.
@@ -83,7 +96,7 @@
   (lambda (ch node)
     (if (null? node)
         '()
-        (let ((node (charmap:search (%trie:set node) ch)))
+        (let ((node (charmap:search (trie:backing node) ch)))
           (if (null? node)
               '()
               (map:val node))))))