History

Initial structure

TT types and values, some text manipulation, basics of Core

Edwin Brady committed 7 years ago

Commit 082bc5cNo parent (first commit)18 files · +3139 −0Browse files

Showing the changes to src/Data/StringMap.idr (1 of 18 files). Show all

Unified · Split

src/Data/StringMap.idr+303−0
@@ -0,0 +1,303 @@
1+module Data.StringMap
2+
3+-- Hand specialised map, for efficiency...
4+
5+%default covering
6+
7+Key : Type
8+Key = String
9+
10+-- TODO: write split
11+
12+private
13+data Tree : Nat -> Type -> Type where
14+ Leaf : Key -> v -> Tree Z v
15+ Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v
16+ Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v
17+
18+branch4 :
19+ Tree n v -> Key ->
20+ Tree n v -> Key ->
21+ Tree n v -> Key ->
22+ Tree n v ->
23+ Tree (S (S n)) v
24+branch4 a b c d e f g =
25+ Branch2 (Branch2 a b c) d (Branch2 e f g)
26+
27+branch5 :
28+ Tree n v -> Key ->
29+ Tree n v -> Key ->
30+ Tree n v -> Key ->
31+ Tree n v -> Key ->
32+ Tree n v ->
33+ Tree (S (S n)) v
34+branch5 a b c d e f g h i =
35+ Branch2 (Branch2 a b c) d (Branch3 e f g h i)
36+
37+branch6 :
38+ Tree n v -> Key ->
39+ Tree n v -> Key ->
40+ Tree n v -> Key ->
41+ Tree n v -> Key ->
42+ Tree n v -> Key ->
43+ Tree n v ->
44+ Tree (S (S n)) v
45+branch6 a b c d e f g h i j k =
46+ Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)
47+
48+branch7 :
49+ Tree n v -> Key ->
50+ Tree n v -> Key ->
51+ Tree n v -> Key ->
52+ Tree n v -> Key ->
53+ Tree n v -> Key ->
54+ Tree n v -> Key ->
55+ Tree n v ->
56+ Tree (S (S n)) v
57+branch7 a b c d e f g h i j k l m =
58+ Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)
59+
60+merge1 : Tree n v -> Key -> Tree (S n) v -> Key -> Tree (S n) v -> Tree (S (S n)) v
61+merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
62+merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
63+merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
64+merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m
65+
66+merge2 : Tree (S n) v -> Key -> Tree n v -> Key -> Tree (S n) v -> Tree (S (S n)) v
67+merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
68+merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
69+merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
70+merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m
71+
72+merge3 : Tree (S n) v -> Key -> Tree (S n) v -> Key -> Tree n v -> Tree (S (S n)) v
73+merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
74+merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
75+merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
76+merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m
77+
78+treeLookup : Key -> Tree n v -> Maybe v
79+treeLookup k (Leaf k' v) =
80+ if k == k' then
81+ Just v
82+ else
83+ Nothing
84+treeLookup k (Branch2 t1 k' t2) =
85+ if k <= k' then
86+ treeLookup k t1
87+ else
88+ treeLookup k t2
89+treeLookup k (Branch3 t1 k1 t2 k2 t3) =
90+ if k <= k1 then
91+ treeLookup k t1
92+ else if k <= k2 then
93+ treeLookup k t2
94+ else
95+ treeLookup k t3
96+
97+treeInsert' : Key -> v -> Tree n v -> Either (Tree n v) (Tree n v, Key, Tree n v)
98+treeInsert' k v (Leaf k' v') =
99+ case compare k k' of
100+ LT => Right (Leaf k v, k, Leaf k' v')
101+ EQ => Left (Leaf k v)
102+ GT => Right (Leaf k' v', k', Leaf k v)
103+treeInsert' k v (Branch2 t1 k' t2) =
104+ if k <= k' then
105+ case treeInsert' k v t1 of
106+ Left t1' => Left (Branch2 t1' k' t2)
107+ Right (a, b, c) => Left (Branch3 a b c k' t2)
108+ else
109+ case treeInsert' k v t2 of
110+ Left t2' => Left (Branch2 t1 k' t2')
111+ Right (a, b, c) => Left (Branch3 t1 k' a b c)
112+treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
113+ if k <= k1 then
114+ case treeInsert' k v t1 of
115+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
116+ Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
117+ else
118+ if k <= k2 then
119+ case treeInsert' k v t2 of
120+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
121+ Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
122+ else
123+ case treeInsert' k v t3 of
124+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
125+ Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)
126+
127+treeInsert : Key -> v -> Tree n v -> Either (Tree n v) (Tree (S n) v)
128+treeInsert k v t =
129+ case treeInsert' k v t of
130+ Left t' => Left t'
131+ Right (a, b, c) => Right (Branch2 a b c)
132+
133+delType : Nat -> Type -> Type
134+delType Z v = ()
135+delType (S n) v = Tree n v
136+
137+treeDelete : Key -> Tree n v -> Either (Tree n v) (delType n v)
138+treeDelete k (Leaf k' v) =
139+ if k == k' then
140+ Right ()
141+ else
142+ Left (Leaf k' v)
143+treeDelete {n=S Z} k (Branch2 t1 k' t2) =
144+ if k <= k' then
145+ case treeDelete k t1 of
146+ Left t1' => Left (Branch2 t1' k' t2)
147+ Right () => Right t2
148+ else
149+ case treeDelete k t2 of
150+ Left t2' => Left (Branch2 t1 k' t2')
151+ Right () => Right t1
152+treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) =
153+ if k <= k1 then
154+ case treeDelete k t1 of
155+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
156+ Right () => Left (Branch2 t2 k2 t3)
157+ else if k <= k2 then
158+ case treeDelete k t2 of
159+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
160+ Right () => Left (Branch2 t1 k1 t3)
161+ else
162+ case treeDelete k t3 of
163+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
164+ Right () => Left (Branch2 t1 k1 t2)
165+treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =
166+ if k <= k' then
167+ case treeDelete k t1 of
168+ Left t1' => Left (Branch2 t1' k' t2)
169+ Right t1' =>
170+ case t2 of
171+ Branch2 a b c => Right (Branch3 t1' k' a b c)
172+ Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
173+ else
174+ case treeDelete k t2 of
175+ Left t2' => Left (Branch2 t1 k' t2')
176+ Right t2' =>
177+ case t1 of
178+ Branch2 a b c => Right (Branch3 a b c k' t2')
179+ Branch3 a b c d e => Left (branch4 a b c d e k' t2')
180+treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =
181+ if k <= k1 then
182+ case treeDelete k t1 of
183+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
184+ Right t1' => Left (merge1 t1' k1 t2 k2 t3)
185+ else if k <= k2 then
186+ case treeDelete k t2 of
187+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
188+ Right t2' => Left (merge2 t1 k1 t2' k2 t3)
189+ else
190+ case treeDelete k t3 of
191+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
192+ Right t3' => Left (merge3 t1 k1 t2 k2 t3')
193+
194+treeToList : Tree n v -> List (Key, v)
195+treeToList = treeToList' (:: [])
196+ where
197+ treeToList' : ((Key, v) -> List (Key, v)) -> Tree n v -> List (Key, v)
198+ treeToList' cont (Leaf k v) = cont (k, v)
199+ treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1
200+ treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1
201+
202+export
203+data StringMap : Type -> Type where
204+ Empty : StringMap v
205+ M : (n : Nat) -> Tree n v -> StringMap v
206+
207+export
208+empty : StringMap v
209+empty = Empty
210+
211+export
212+lookup : String -> StringMap v -> Maybe v
213+lookup _ Empty = Nothing
214+lookup k (M _ t) = treeLookup k t
215+
216+export
217+insert : String -> v -> StringMap v -> StringMap v
218+insert k v Empty = M Z (Leaf k v)
219+insert k v (M _ t) =
220+ case treeInsert k v t of
221+ Left t' => (M _ t')
222+ Right t' => (M _ t')
223+
224+export
225+insertFrom : Foldable f => f (String, v) -> StringMap v -> StringMap v
226+insertFrom = flip $ foldl $ flip $ uncurry insert
227+
228+export
229+delete : String -> StringMap v -> StringMap v
230+delete _ Empty = Empty
231+delete k (M Z t) =
232+ case treeDelete k t of
233+ Left t' => (M _ t')
234+ Right () => Empty
235+delete k (M (S _) t) =
236+ case treeDelete k t of
237+ Left t' => (M _ t')
238+ Right t' => (M _ t')
239+
240+export
241+fromList : List (String, v) -> StringMap v
242+fromList l = foldl (flip (uncurry insert)) empty l
243+
244+export
245+toList : StringMap v -> List (String, v)
246+toList Empty = []
247+toList (M _ t) = treeToList t
248+
249+||| Gets the Keyeys of the map.
250+export
251+keys : StringMap v -> List String
252+keys = map fst . toList
253+
254+||| Gets the values of the map. Could contain duplicates.
255+export
256+values : StringMap v -> List v
257+values = map snd . toList
258+
259+treeMap : (a -> b) -> Tree n a -> Tree n b
260+treeMap f (Leaf k v) = Leaf k (f v)
261+treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
262+treeMap f (Branch3 t1 k1 t2 k2 t3)
263+ = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)
264+
265+export
266+implementation Functor (StringMap) where
267+ map _ Empty = Empty
268+ map f (M n t) = M _ (treeMap f t)
269+
270+||| Merge two maps. When encountering duplicate keys, using a function to combine the values.
271+||| Uses the ordering of the first map given.
272+export
273+mergeWith : (v -> v -> v) -> StringMap v -> StringMap v -> StringMap v
274+mergeWith f x y = insertFrom inserted x where
275+ inserted : List (Key, v)
276+ inserted = do
277+ (k, v) <- toList y
278+ let v' = (maybe id f $ lookup k x) v
279+ pure (k, v')
280+
281+||| Merge two maps using the Semigroup (and by extension, Monoid) operation.
282+||| Uses mergeWith internally, so the ordering of the left map is kept.
283+export
284+merge : Semigroup v => StringMap v -> StringMap v -> StringMap v
285+merge = mergeWith (<+>)
286+
287+||| Left-biased merge, also keeps the ordering specified by the left map.
288+export
289+mergeLeft : StringMap v -> StringMap v -> StringMap v
290+mergeLeft = mergeWith const
291+
292+-- TODO: is this the right variant of merge to use for this? I think it is, but
293+-- I could also see the advantages of using `mergeLeft`. The current approach is
294+-- strictly more powerful I believe, because `mergeLeft` can be emulated with
295+-- the `First` monoid. However, this does require more code to do the same
296+-- thing.
297+export
298+Semigroup v => Semigroup (StringMap v) where
299+ (<+>) = merge
300+
301+export
302+(Semigroup v) => Monoid (StringMap v) where
303+ neutral = empty

Keyboard shortcuts

General

Show keyboard shortcuts
?
Focus the current search
/

Issues and pull requests

Open filters
f

Issues, pull requests and Inbox

Select next item
j↓
Select previous item
k↑
Open selected item
Enter
Dismiss filters or clear selection
Esc

Repository code

Go to file
t