diff options
Diffstat (limited to '')
-rw-r--r-- | module/hnh/util/assert.scm | 9 | ||||
-rw-r--r-- | module/hnh/util/lens.scm | 8 | ||||
-rw-r--r-- | module/hnh/util/table.scm | 31 |
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)) |