blob: ebd5c8f76bdf778812991c944eff07d08c8be410 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
;;; Commentary:
;;; An immutable key-value table.
;;;
;;; Currently implemented as a simple binary search tree,
;;; this may however change at any time.
;;; Code:
(define-module (hnh util table)
:use-module (srfi srfi-1)
:use-module (srfi srfi-88)
:use-module (hnh util lens)
:use-module (hnh util object)
: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)))
(define (symbol<? . args)
(apply string<? (map symbol->string args)))
(define-syntax-rule (symbol< args ...)
(string< (symbol->string args) ...))
(define-type (tree-node)
(key type: symbol?)
value
(left type: tree? default: (tree-terminal))
(right type: tree? default: (tree-terminal)))
;; Type tagged null
(define-type (tree-terminal))
;; Wrapped for better error messages
(define (make-tree) (tree-terminal))
(define (tree? x)
(or (tree-node? x)
(tree-terminal? x)))
(define (tree-put tree k v)
(cond ((tree-terminal? tree) (tree-node key: k value: v))
((eq? k (key tree)) (value tree v))
(else
(modify tree (if (symbol<? k (key tree)) left right)
tree-put k v))))
(define* (tree-get tree k optional: default)
(cond ((tree-terminal? tree) default)
((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)
'()
(append (tree->list (left tree))
(list (cons (key tree) (value tree)))
(tree->list (right tree)))))
;; undefined order, probably pre-order
(define (tree-map f tree)
(if (tree-terminal? 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)
(if (tree-terminal? tree)
init
(let ((a (f (key tree) (value tree) init)))
(let ((b (tree-fold f a (left tree))))
(tree-fold f b (right tree))))))
(define (alist->tree alist)
(fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv)))
(tree-terminal)
alist))
(define (make-indent depth) (make-string (* 2 depth) #\space))
(define* (print-tree tree optional: (depth 0))
(unless (tree-terminal? tree)
(format #t "~a- ~s: ~s~%" (make-indent depth) (key tree) (value tree))
(print-tree (left tree) (1+ depth))
(print-tree (right tree) (1+ depth))))
|
