@@ -99,10 +99,9 @@ invariants_hold t =
9999
100100min t =
101101 case t of
102− { RBNode _ k v RBEmpty _ -> (k,v)
103− ; RBNode _ _ _ l _ -> min l
104− ; RBEmpty -> raise "(min RBEmpty) is not defined"
105− }
102+ RBNode _ k v RBEmpty _ -> (k,v)
103+ RBNode _ _ _ l _ -> min l
104+ RBEmpty -> raise "(min RBEmpty) is not defined"
106105
107106{--
108107max t =
@@ -115,23 +114,21 @@ max t =
115114
116115lookup k t =
117116 case t of
118− { RBEmpty -> Nothing
119− ; RBNode _ k' v l r ->
117+ RBEmpty -> Nothing
118+ RBNode _ k' v l r ->
120119 case compare k k' of
121− { LT -> lookup k l
122− ; EQ -> Just v
123− ; GT -> lookup k r }
124− }
120+ LT -> lookup k l
121+ EQ -> Just v
122+ GT -> lookup k r
125123
126124findWithDefault base k t =
127125 case t of
128− { RBEmpty -> base
129− ; RBNode _ k' v l r ->
126+ RBEmpty -> base
127+ RBNode _ k' v l r ->
130128 case compare k k' of
131− { LT -> findWithDefault base k l
132− ; EQ -> v
133− ; GT -> findWithDefault base k r }
134− }
129+ LT -> findWithDefault base k l
130+ EQ -> v
131+ GT -> findWithDefault base k r
135132
136133{--
137134find k t =
@@ -150,60 +147,60 @@ member k t = isJust $ lookup k t
150147
151148rotateLeft t =
152149 case t of
153− { RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c
154− ; _ -> raise "rotateLeft of a node without enough children" }
150+ RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c
151+ _ -> raise "rotateLeft of a node without enough children"
155152
156153-- rotateRight -- the reverse, and
157154-- makes Y have Z's color, and makes Z Red.
158155rotateRight t =
159156 case t of
160− { RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)
161− ; _ -> raise "rotateRight of a node without enough children" }
157+ RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)
158+ _ -> raise "rotateRight of a node without enough children"
162159
163160rotateLeftIfNeeded t =
164161 case t of
165− { RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t
166− ; _ -> t }
162+ RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t
163+ _ -> t
167164
168165rotateRightIfNeeded t =
169166 case t of
170− { RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t
171− ; _ -> t }
167+ RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t
168+ _ -> t
172169
173170otherColor c = case c of { Red -> Black ; Black -> Red }
174171
175172color_flip t =
176173 case t of
177− { RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->
178− RBNode (otherColor c1) bk bv
179− (RBNode (otherColor c2) ak av la ra)
180− (RBNode (otherColor c3) ck cv lc rc)
181− ; _ -> raise "color_flip called on a RBEmpty or RBNode with a RBEmpty child" }
174+ RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->
175+ RBNode (otherColor c1) bk bv
176+ (RBNode (otherColor c2) ak av la ra)
177+ (RBNode (otherColor c3) ck cv lc rc)
178+ _ -> raise "color_flip called on a RBEmpty or RBNode with a RBEmpty child"
182179
183180color_flipIfNeeded t =
184181 case t of
185− { RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t
186− ; _ -> t }
182+ RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t
183+ _ -> t
187184
188185fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))
189186
190187
191188ensureBlackRoot t =
192189 case t of
193− { RBNode Red k v l r -> RBNode Black k v l r
194− ; _ -> t }
190+ RBNode Red k v l r -> RBNode Black k v l r
191+ _ -> t
195192
196193-- Invariant: t is a valid left-leaning rb tree *)
197194insert k v t =
198195 let ins t =
199196 case t of
200− { RBEmpty -> RBNode Red k v RBEmpty RBEmpty
201− ; RBNode c k' v' l r ->
197+ RBEmpty -> RBNode Red k v RBEmpty RBEmpty
198+ RBNode c k' v' l r ->
202199 let h = case compare k k' of
203− { LT -> RBNode c k' v' (ins l) r
204− ; EQ -> RBNode c k' v l r -- replace
205− ; GT -> RBNode c k' v' l (ins r) }
206− in fixUp h }
200+ LT -> RBNode c k' v' (ins l) r
201+ EQ -> RBNode c k' v l r -- replace
202+ GT -> RBNode c k' v' l (ins r)
203+ in fixUp h
207204 in ensureBlackRoot (ins t)
208205{--
209206 if not (invariants_hold t) then
@@ -219,63 +216,59 @@ singleton k v = insert k v RBEmpty
219216
220217isRed t =
221218 case t of
222− { RBNode Red _ _ _ _ -> True
223− ; _ -> False }
219+ RBNode Red _ _ _ _ -> True
220+ _ -> False
224221
225222isRedLeft t =
226223 case t of
227− { RBNode _ _ _ (RBNode Red _ _ _ _) _ -> True
228− ; _ -> False }
224+ RBNode _ _ _ (RBNode Red _ _ _ _) _ -> True
225+ _ -> False
229226
230227isRedLeftLeft t =
231228 case t of
232− { RBNode _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) _ -> True
233− ; _ -> False }
229+ RBNode _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) _ -> True
230+ _ -> False
234231
235232isRedRight t =
236233 case t of
237− { RBNode _ _ _ _ (RBNode Red _ _ _ _) -> True
238− ; _ -> False }
234+ RBNode _ _ _ _ (RBNode Red _ _ _ _) -> True
235+ _ -> False
239236
240237isRedRightLeft t =
241238 case t of
242− { RBNode _ _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) -> True
243− ; _ -> False }
239+ RBNode _ _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) -> True
240+ _ -> False
244241
245242
246243moveRedLeft t =
247244 let t' = color_flip t in
248245 case t' of
249− { RBNode c k v l r ->
246+ RBNode c k v l r ->
250247 case r of
251− { RBNode _ _ _ (RBNode Red _ _ _ _) _ ->
248+ RBNode _ _ _ (RBNode Red _ _ _ _) _ ->
252249 color_flip (rotateLeft (RBNode c k v l (rotateRight r)))
253− ; _ -> t' }
254− ; _ -> t' }
250+ _ -> t'
251+ _ -> t'
255252
256253moveRedRight t =
257254 let t' = color_flip t in
258255 if isRedLeftLeft t' then color_flip (rotateRight t') else t'
259256
260−moveRedLeftIfNeeded t =
261− if not (isRedLeft t) && not (isRedLeftLeft t)
262− then moveRedLeft t
263− else t
257+moveRedLeftIfNeeded t
258+ | not (isRedLeft t) && not (isRedLeftLeft t) = moveRedLeft t
259+ | otherwise = t
264260
265−moveRedRightIfNeeded t =
266− if not (isRedRight t) && not (isRedRightLeft t)
267− then moveRedRight t
268− else t
261+moveRedRightIfNeeded t
262+ | not (isRedRight t) && not (isRedRightLeft t) = moveRedRight t
263+ | otherwise = t
269264
270265deleteMin t =
271266 let del t =
272267 case t of
273− { RBNode _ _ _ RBEmpty _ -> RBEmpty
274− ; _ -> let t' = moveRedLeftIfNeeded t in
275− case t' of
276− { RBNode c k v l r -> fixUp (RBNode c k v (del l) r)
277− ; RBEmpty -> RBEmpty }
278− }
268+ RBNode _ _ _ RBEmpty _ -> RBEmpty
269+ _ -> case moveRedLeftIfNeeded t of
270+ RBNode c k v l r -> fixUp (RBNode c k v (del l) r)
271+ RBEmpty -> RBEmpty
279272 in ensureBlackRoot (del t)
280273
281274{--
@@ -292,31 +285,26 @@ deleteMax t =
292285--}
293286
294287remove k t =
295− let eq_and_noRightNode t = case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False } in
296− let eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False } in
297− let delLT t = let t' = moveRedLeftIfNeeded t in
298− case t' of
299− { RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)
300− ; RBEmpty -> raise "delLT on RBEmpty" }
301− in
302− let delEQ t = case t of -- Replace with successor
303− { RBNode c _ _ l r ->
304− let (k',v') = min r in
305− fixUp (RBNode c k' v' l (deleteMin r))
306− ; RBEmpty -> raise "delEQ called on a RBEmpty" }
307− in
308− let delGT t = case t of
309− { RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))
310− ; RBEmpty -> raise "delGT called on a RBEmpty" }
311− in
312− let del t = case t of
313− { RBEmpty -> RBEmpty
314− ; RBNode _ k' _ _ _ ->
315− if k < k' then delLT t
316− else (let t' = if isRedLeft t then rotateRight t else t in
317− if eq_and_noRightNode t' then RBEmpty
318− else (let t = moveRedRightIfNeeded t in
319− if eq t then delEQ t else delGT t)) }
288+ let eq_and_noRightNode t = case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }
289+ eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }
290+ delLT t = case moveRedLeftIfNeeded t of
291+ RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)
292+ RBEmpty -> raise "delLT on RBEmpty"
293+ delEQ t = case t of -- Replace with successor
294+ RBNode c _ _ l r -> let (k',v') = min r in
295+ fixUp (RBNode c k' v' l (deleteMin r))
296+ RBEmpty -> raise "delEQ called on a RBEmpty"
297+ delGT t = case t of
298+ RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))
299+ RBEmpty -> raise "delGT called on a RBEmpty"
300+ del t = case t of
301+ RBEmpty -> RBEmpty
302+ RBNode _ k' _ _ _ ->
303+ let v | k < k' = delLT t
304+ | eq_and_noRightNode (if isRedLeft t then rotateRight t else t) = RBEmpty
305+ | otherwise = let t' = moveRedRightIfNeeded t in
306+ if eq t' then delEQ t' else delGT t'
307+ in v
320308 in ensureBlackRoot (del t)
321309{--
322310 if not (invariants_hold t) then
@@ -328,28 +316,25 @@ remove k t =
328316
329317map f t =
330318 case t of
331− { RBEmpty -> RBEmpty
332− ; RBNode c k v l r -> RBNode c k (f v) (map f l) (map f r)
333− }
319+ RBEmpty -> RBEmpty
320+ RBNode c k v l r -> RBNode c k (f v) (map f l) (map f r)
334321
335322foldl f acc t =
336323 case t of
337− { RBEmpty -> acc
338− ; RBNode _ k v l r -> foldl f (f k v (foldl f acc l)) r
339− }
324+ RBEmpty -> acc
325+ RBNode _ k v l r -> foldl f (f k v (foldl f acc l)) r
340326
341327foldr f acc t =
342328 case t of
343− { RBEmpty -> acc
344− ; RBNode _ k v l r -> foldr f (f k v (foldr f acc r)) l
345− }
329+ RBEmpty -> acc
330+ RBNode _ k v l r -> foldr f (f k v (foldr f acc r)) l
346331
347−union t1 t2 = foldl insert t2 t1
348−intersect t1 t2 = foldl (\k v t -> if k `member` t2 then insert k v t else t) empty t1
349−diff t1 t2 = foldl (\k _ t -> remove k t) t1 t2
332+union t1 t2 = Dict.foldl insert t2 t1
333+intersect t1 t2 = Dict.foldl (\k v t -> if k `member` t2 then insert k v t else t) empty t1
334+diff t1 t2 = Dict.foldl (\k v t -> remove k t) t1 t2
350335
351−keys t = foldl (\k _ acc -> k : acc) [] t
352−values t = foldl (\_ -> (:)) [] t
336+keys t = Dict.foldl (\k v acc -> k : acc) [] t
337+values t = Dict.foldl (\k v acc -> v : acc) [] t
353338
354−toList t = foldl (\k v acc -> (k,v) : acc) [] t
339+toList t = Dict.foldl (\k v acc -> (k,v) : acc) [] t
355340fromList assocs = List.foldl (uncurry insert) empty assocs