Major work on, something.

3 files changed, 41 insertions, 7 deletions

diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm
new file mode 100644
index 00000000..74715654
--- /dev/null
+++ b/module/hnh/util/assert.scm
@@ -0,0 +1,9 @@
+(define-module (hnh util assert)
+  :use-module (rnrs base)
+  :export (assert*)
+  )
+
+(define-syntax assert*
+  (syntax-rules ()
+    ((_ assertion)
+     (assert assertion))))
diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm
index 7a8fbd19..26c75be7 100644
--- a/module/hnh/util/lens.scm
+++ b/module/hnh/util/lens.scm
@@ -9,7 +9,9 @@
            compose-lenses
            lens-compose
 
-           ref car* cdr*))
+           ref car* cdr*
+
+           each))
 
 
 (define (modify object lens f . args)
@@ -97,3 +99,7 @@
 
 (define car* (make-lens car (lambda (pair value) (cons value (cdr pair)))))
 (define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value))))
+
+(define (each obj lens proc)
+  (modify obj lens
+          (lambda (lst) (map proc lst))))
diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm
index 5835851b..a57e6591 100644
--- a/module/hnh/util/table.scm
+++ b/module/hnh/util/table.scm
@@ -8,6 +8,8 @@
   :export ((make-tree . table)
            (tree-get . table-get)
            (tree-put . table-put)
+           (tree-remove . table-remove)
+           (tree->list . table->list)
            (tree? . table?)
            (alist->tree . alist->table)))
 
@@ -41,13 +43,30 @@
                  tree-put k v))))
 
 (define (tree-get tree k)
-  (cond ((tree-terminal? tree) (throw 'out-of-range))
+  (cond ((tree-terminal? tree) #f ; (throw 'out-of-range)
+         )
         ((eq? k (key tree)) (value tree))
         ((symbol<? k (key tree))
          (tree-get (left tree) k))
         (else
          (tree-get (right tree) k))))
 
+(define (tree-remove tree k)
+  (cond ((tree-terminal? tree) tree)
+        ((eq? k (key tree))
+         (merge-trees (left tree) (right tree)))
+        ((symbol<? k (key tree))
+         (modify tree left (lambda (t) (tree-remove t k))))
+        (else
+         (modify tree right (lambda (t) (tree-remove t k))))))
+
+(define (merge-trees a b)
+  ;; TODO write a better version of this
+  (fold (lambda (item tree)
+          (apply tree-put tree item))
+        a
+        b))
+
 ;; in-order traversal
 (define (tree->list tree)
   (if (tree-terminal? tree)
@@ -60,10 +79,10 @@
 (define (tree-map f tree)
   (if (tree-terminal? tree)
       '()
-      (tree-node (key tree)
-                 (f (key tree) (value tree))
-                 (tree-map f (left tree))
-                 (tree-map f (right tree)))))
+      (tree-node key:   (key tree)
+                 value: (f (key tree) (value tree))
+                 left:  (tree-map f (left tree))
+                 right: (tree-map f (right tree)))))
 
 ;; pre-order
 (define (tree-fold f init tree)
@@ -74,7 +93,7 @@
           (tree-fold f b (right tree))))))
 
 (define (alist->tree alist)
-  (fold (lambda (kv tree) (apply tree-put tree kv))
+  (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv)))
         (tree-terminal)
         alist))