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

1 files changed, 152 insertions, 17 deletions

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)))))))))
+