blob: d28e69a3c028ee2dadca2e204a1cac5e16c45f8f (
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
|
(.module:
[lux #*
[abstract
[predicate (#+ Predicate)]
["." monoid (#+ Monoid)]]
[data
[collection
["." list ("#\." monoid)]]]
[type
[abstract (#+ abstract: :abstraction :representation)]]])
(abstract: #export (Tree @ t v)
{#monoid (Monoid t)
#tag t
#root (| v
[(Tree @ t v) (Tree @ t v)])}
(interface: #export (Builder @ t)
(: (All [v]
(-> t v (Tree @ t v)))
leaf)
(: (All [v]
(-> (Tree @ t v)
(Tree @ t v)
(Tree @ t v)))
branch))
(template [<name> <tag> <output>]
[(def: #export <name>
(All [@ t v] (-> (Tree @ t v) <output>))
(|>> :representation (get@ <tag>)))]
[tag #tag t]
[root #root (Either v [(Tree @ t v) (Tree @ t v)])]
)
(implementation: #export (builder monoid)
(All [t] (Ex [@] (-> (Monoid t) (Builder @ t))))
(def: (leaf tag value)
(:abstraction
{#monoid monoid
#tag tag
#root (0 #0 value)}))
(def: (branch left right)
(:abstraction
{#monoid monoid
#tag (\ monoid compose (..tag left) (..tag right))
#root (0 #1 [left right])})))
(def: #export (value tree)
(All [@ t v] (-> (Tree @ t v) v))
(case (get@ #root (:representation tree))
(0 #0 value)
value
(0 #1 [left right])
(value left)))
(def: #export (tags tree)
(All [@ t v] (-> (Tree @ t v) (List t)))
(case (get@ #root (:representation tree))
(0 #0 value)
(list (get@ #tag (:representation tree)))
(0 #1 [left right])
(list\compose (tags left)
(tags right))))
(def: #export (values tree)
(All [@ t v] (-> (Tree @ t v) (List v)))
(case (get@ #root (:representation tree))
(0 #0 value)
(list value)
(0 #1 [left right])
(list\compose (values left)
(values right))))
(def: #export (search predicate tree)
(All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v)))
(let [[monoid tag root] (:representation tree)]
(if (predicate tag)
(let [(^open "tag//.") monoid]
(loop [_tag tag//identity
_node root]
(case _node
(0 #0 value)
(#.Some value)
(0 #1 [left right])
(let [shifted_tag (tag//compose _tag (..tag left))]
(if (predicate shifted_tag)
(recur _tag (get@ #root (:representation left)))
(recur shifted_tag (get@ #root (:representation right))))))))
#.None)))
)
(def: #export (found? predicate tree)
(All [@ t v] (-> (Predicate t) (Tree @ t v) Bit))
(case (..search predicate tree)
(#.Some _)
true
#.None
false))
|
