git.iko.soy/elk
on master help sign in
Dict: Implement remove.
9523a81Max New
libraries/Dict.elm+160−105
compare with master
unifiedsplit
@@ -1,4 +1,3 @@
1−
2module Dict (empty,singleton,insert
1module Dict (empty,singleton,insert
3 ,lookup,findWithDefault
2 ,lookup,findWithDefault
4 ,remove,member
3 ,remove,member
@@ -8,6 +7,10 @@ module Dict (empty,singleton,insert
8 ,toList,fromList
7 ,toList,fromList
9 ) where
8 ) where
10
9
10+-- Cleanup: Change RBEmpty to 2 constructors: Leaf and BBLeaf
11+-- Consider making the types safer or moving all the remove methods to
12+-- a let
13+
11{-| A dictionary mapping unique keys to values. The keys can be any comparable
14{-| A dictionary mapping unique keys to values. The keys can be any comparable
12type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or
15type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or
13lists of comparable types.
16lists of comparable types.
@@ -38,13 +41,19 @@ import Native.Error
38import List as List
41import List as List
39import Native.Utils
42import Native.Utils
40
43
44+-- BBlack and NBlack should only be used during the deletion
45+-- algorithm. Any other occurrence is a bug and should fail an assert.
41data NColor = Red | Black
46data NColor = Red | Black
47+ | BBlack | NBlack
42
48
49+data LeafColor = LBlack | LBBlack
50+
43−data Dict k v = RBNode NColor k v (Dict k v) (Dict k v) | RBEmpty
51+data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)
52+ | RBEmpty LeafColor
44
53
45{-| Create an empty dictionary. -}
54{-| Create an empty dictionary. -}
46empty : Dict comparable v
55empty : Dict comparable v
47−empty = RBEmpty
56+empty = RBEmpty LBlack
48
57
49{-- Helpers for checking invariants
58{-- Helpers for checking invariants
50
59
@@ -127,24 +136,22 @@ invariants_hold t =
127min : Dict k v -> (k,v)
136min : Dict k v -> (k,v)
128min t =
137min t =
129 case t of
138 case t of
130− RBNode _ k v RBEmpty _ -> (k,v)
139+ RBNode _ k v (RBEmpty LBlack) _ -> (k,v)
131 RBNode _ _ _ l _ -> min l
140 RBNode _ _ _ l _ -> min l
132− RBEmpty -> Native.Error.raise "(min Empty) is not defined"
141+ RBEmpty LBlack -> Native.Error.raise "(min Empty) is not defined"
133
142
134−{--
143+max : Dict k v -> (k, v)
135max t =
144max t =
136 case t of
145 case t of
137− { RBNode _ k v _ RBEmpty -> (k,v)
146+ RBNode _ k v _ (RBEmpty _) -> (k,v)
138− ; RBNode _ _ _ _ r -> max r
147+ RBNode _ _ _ _ r -> max r
139− ; RBEmpty -> Native.Error.raise "(max Empty) is not defined"
148+ RBEmpty _ -> Native.Error.raise "(max Empty) is not defined"
140− }
141−--}
142
149
143{-| Lookup the value associated with a key. -}
150{-| Lookup the value associated with a key. -}
144lookup : comparable -> Dict comparable v -> Maybe v
151lookup : comparable -> Dict comparable v -> Maybe v
145lookup k t =
152lookup k t =
146 case t of
153 case t of
147− RBEmpty -> Nothing
154+ RBEmpty LBlack -> Nothing
148 RBNode _ k' v l r ->
155 RBNode _ k' v l r ->
149 case Native.Utils.compare k k' of
156 case Native.Utils.compare k k' of
150 LT -> lookup k l
157 LT -> lookup k l
@@ -156,7 +163,7 @@ return the default value. -}
156findWithDefault : v -> comparable -> Dict comparable v -> v
163findWithDefault : v -> comparable -> Dict comparable v -> v
157findWithDefault base k t =
164findWithDefault base k t =
158 case t of
165 case t of
159− RBEmpty -> base
166+ RBEmpty LBlack -> base
160 RBNode _ k' v l r ->
167 RBNode _ k' v l r ->
161 case Native.Utils.compare k k' of
168 case Native.Utils.compare k k' of
162 LT -> findWithDefault base k l
169 LT -> findWithDefault base k l
@@ -230,7 +237,8 @@ ensureBlackRoot : Dict k v -> Dict k v
230ensureBlackRoot t =
237ensureBlackRoot t =
231 case t of
238 case t of
232 RBNode Red k v l r -> RBNode Black k v l r
239 RBNode Red k v l r -> RBNode Black k v l r
233− _ -> t
240+ RBNode Black _ _ _ _ -> t
241+ RBEmpty LBlack -> t
234
242
235{-| Insert a key-value pair into a dictionary. Replaces value when there is
243{-| Insert a key-value pair into a dictionary. Replaces value when there is
236a collision. -}
244a collision. -}
@@ -238,7 +246,7 @@ insert : comparable -> v -> Dict comparable v -> Dict comparable v
238insert k v t = -- Invariant: t is a valid left-leaning rb tree
246insert k v t = -- Invariant: t is a valid left-leaning rb tree
239 let ins t =
247 let ins t =
240 case t of
248 case t of
241− RBEmpty -> RBNode Red k v RBEmpty RBEmpty
249+ RBEmpty LBlack -> RBNode Red k v (RBEmpty LBlack) (RBEmpty LBlack)
242 RBNode c k' v' l r ->
250 RBNode c k' v' l r ->
243 let h = case Native.Utils.compare k k' of
251 let h = case Native.Utils.compare k k' of
244 LT -> RBNode c k' v' (ins l) r
252 LT -> RBNode c k' v' (ins l) r
@@ -257,71 +265,17 @@ insert k v t = -- Invariant: t is a valid left-leaning rb tree
257
265
258{-| Create a dictionary with one key-value pair. -}
266{-| Create a dictionary with one key-value pair. -}
259singleton : comparable -> v -> Dict comparable v
267singleton : comparable -> v -> Dict comparable v
260−singleton k v = insert k v RBEmpty
268+singleton k v = insert k v (RBEmpty LBlack)
261−
262−isRed : Dict k v -> Bool
263−isRed t =
264− case t of
265− RBNode Red _ _ _ _ -> True
266− _ -> False
267−
268−isRedLeft : Dict k v -> Bool
269−isRedLeft t =
270− case t of
271− RBNode _ _ _ (RBNode Red _ _ _ _) _ -> True
272− _ -> False
273−
274−isRedLeftLeft : Dict k v -> Bool
275−isRedLeftLeft t =
276− case t of
277− RBNode _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) _ -> True
278− _ -> False
279−
280−isRedRight : Dict k v -> Bool
281−isRedRight t =
282− case t of
283− RBNode _ _ _ _ (RBNode Red _ _ _ _) -> True
284− _ -> False
285−
286−isRedRightLeft : Dict k v -> Bool
287−isRedRightLeft t =
288− case t of
289− RBNode _ _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) -> True
290− _ -> False
291−
292−moveRedLeft : Dict k v -> Dict k v
293−moveRedLeft t =
294− let t' = color_flip t in
295− case t' of
296− RBNode c k v l r ->
297− case r of
298− RBNode _ _ _ (RBNode Red _ _ _ _) _ ->
299− color_flip (rotateLeft (RBNode c k v l (rotateRight r)))
300− _ -> t'
301− _ -> t'
302−
303−moveRedRight : Dict k v -> Dict k v
304−moveRedRight t =
305− let t' = color_flip t in
306− if isRedLeftLeft t' then color_flip (rotateRight t') else t'
307−
308−moveRedLeftIfNeeded : Dict k v -> Dict k v
309−moveRedLeftIfNeeded t =
310− if isRedLeft t || isRedLeftLeft t then t else moveRedLeft t
311−
312−moveRedRightIfNeeded : Dict k v -> Dict k v
313−moveRedRightIfNeeded t =
314− if isRedRight t || isRedRightLeft t then t else moveRedRight t
315
269
316−deleteMin : Dict k v -> Dict k v
270+-- deleteMin : Dict k v -> Dict k v
317−deleteMin t =
271+-- deleteMin t =
318− let del t =
272+-- let del t =
319− case t of
273+-- case t of
320− RBNode _ _ _ RBEmpty _ -> RBEmpty
274+-- RBNode _ _ _ RBEmpty _ -> RBEmpty
321− _ -> case moveRedLeftIfNeeded t of
275+-- _ -> case moveRedLeftIfNeeded t of
322− RBNode c k v l r -> fixUp (RBNode c k v (del l) r)
276+-- RBNode c k v l r -> fixUp (RBNode c k v (del l) r)
323− RBEmpty -> RBEmpty
277+-- RBEmpty -> RBEmpty
324− in ensureBlackRoot (del t)
278+-- in ensureBlackRoot (del t)
325
279
326{--
280{--
327deleteMax t =
281deleteMax t =
@@ -336,32 +290,133 @@ deleteMax t =
336 in ensureBlackRoot (del t)
290 in ensureBlackRoot (del t)
337--}
291--}
338
292
293+-- Finds and deletes k in t
294+del : comparable -> Dict comparable v -> Dict comparable v
295+del k t = case t of
296+ RBEmpty _ -> t
297+ RBNode c k' v l r -> case Native.Utils.compare k k' of
298+ LT -> bubble c k' v (del k l) r
299+ EQ -> rem t
300+ GT -> bubble c k' v l (del k r)
301+
302+-- Remove the top node from the tree, may leave behind BBlacks
303+rem : Dict k v -> Dict k v
304+rem t = case t of
305+ RBNode c k v (RBEmpty _) (RBEmpty _) -> case c of
306+ Red -> RBEmpty LBlack
307+ Black -> RBEmpty LBBlack
308+ RBNode Black _ _ (RBEmpty _) (RBNode _ k v l r) ->
309+ RBNode Black k v l r
310+ RBNode Black _ _ (RBNode _ k v l r) (RBEmpty _) ->
311+ RBNode Black k v l r
312+ -- l and r are both RBNodes
313+ RBNode c _ _ l r ->
314+ let (k, v) = max l
315+ l' = remove_max l
316+ in bubble c k v l' r
317+
318+isBBlack : Dict k v -> Bool
319+isBBlack t = case t of
320+ RBNode c _ _ _ _ -> case c of
321+ BBlack -> True
322+ _ -> False
323+ RBEmpty LBBlack -> True
324+ _ -> False
325+
326+moreBlack : NColor -> NColor
327+moreBlack c = case c of
328+ BBlack -> BBlack
329+ Black -> BBlack
330+ Red -> Black
331+ NBlack -> Red
332+lessBlack : NColor -> NColor
333+lessBlack c = case c of
334+ BBlack -> Black
335+ Black -> Red
336+ Red -> NBlack
337+ NBlack -> NBlack
338+
339+moreBlackTree : Dict k v -> Dict k v
340+moreBlackTree t = case t of
341+ RBNode c k v l r -> RBNode (moreBlack c) k v l r
342+ RBEmpty _ -> RBEmpty LBBlack
343+
344+lessBlackTree : Dict k v -> Dict k v
345+lessBlackTree t = case t of
346+ RBNode c k v l r -> RBNode (lessBlack c) k v l r
347+ RBEmpty _ -> RBEmpty LBlack
348+
349+-- Kills a BBlack or moves it upward, may leave behind NBlack
350+bubble : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v
351+bubble c k v l r = if isBBlack l || isBBlack r
352+ then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)
353+ else RBNode c k v l r
354+
355+-- Removes rightmost node, may leave root as BBlack
356+remove_max : Dict k v -> Dict k v
357+remove_max t = case t of
358+ RBNode c k v l (RBEmpty _) -> rem t
359+ RBNode c k v l r -> bubble c k v l (remove_max r)
360+
361+-- generalized tree balancing act
362+balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v
363+balance c k v l r = balance_node (RBNode c k v l r)
364+
365+blackish : Dict k v -> Bool
366+blackish (RBNode c _ _ _ _) = c == Black || c == BBlack
367+
368+balance_node : Dict k v -> Dict k v
369+balance_node t =
370+ let assemble col xk xv yk yv zk zv a b c d =
371+ RBNode (lessBlack col) yk yv (RBNode Black xk xv a b) (RBNode Black zk zv c d)
372+ in
373+ if blackish t
374+ then case t of
375+ RBNode col zk zv (RBNode Red yk yv (RBNode Red xk xv a b) c) d ->
376+ assemble col xk xv yk yv zk zv a b c d
377+ RBNode col zk zv (RBNode Red xk xv a (RBNode Red yk yv b c)) d ->
378+ assemble col xk xv yk yv zk zv a b c d
379+ RBNode col xk xv a (RBNode Red zk zv (RBNode Red yk yv b c) d) ->
380+ assemble col xk xv yk yv zk zv a b c d
381+ RBNode col xk xv a (RBNode Red yk yv b (RBNode Red zk zv c d)) ->
382+ assemble col xk xv yk yv zk zv a b c d
383+
384+ RBNode BBlack xk xv a (RBNode NBlack zk zv (RBNode Black yk yv b c) d) ->
385+ case d of
386+ (RBNode Black _ _ _ _) ->
387+ RBNode Black yk yv (RBNode Black xk xv a b) (balance Black zk zv c (redden d))
388+ _ -> t
389+
390+ RBNode BBlack zk zv (RBNode NBlack xk xv a (RBNode Black yk yv b c)) d ->
391+ case a of
392+ (RBNode Black _ _ _ _) ->
393+ RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)
394+ _ -> t
395+
396+ _ -> t
397+
398+ else t
399+
400+
401+
402+
403+-- make the top node black
404+blacken : Dict k v -> Dict k v
405+blacken t = case t of
406+ RBEmpty _ -> RBEmpty LBlack
407+ RBNode _ k v l r -> RBNode Black k v l r
408+
409+-- make the top node red
410+redden : Dict k v -> Dict k v
411+redden t = case t of
412+ RBEmpty _ -> Native.Error.raise "can't make a Leaf red"
413+ RBNode _ k v l r -> RBNode Red k v l r
414+
339{-| Remove a key-value pair from a dictionary. If the key is not found,
415{-| Remove a key-value pair from a dictionary. If the key is not found,
340no changes are made. -}
416no changes are made. -}
341remove : comparable -> Dict comparable v -> Dict comparable v
417remove : comparable -> Dict comparable v -> Dict comparable v
342−remove k t =
418+remove k t = blacken <| del k t
343− let eq_and_noRightNode t =
419+
344− case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }
345− eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }
346− delLT t = case moveRedLeftIfNeeded t of
347− RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)
348− RBEmpty -> Native.Error.raise "delLT on Empty"
349− delEQ t = case t of -- Replace with successor
350− RBNode c _ _ l r -> let (k',v') = min r in
351− fixUp (RBNode c k' v' l (deleteMin r))
352− RBEmpty -> Native.Error.raise "delEQ called on a Empty"
353− delGT t = case t of
354− RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))
355− RBEmpty -> Native.Error.raise "delGT called on a Empty"
356− del t = case t of
357− RBEmpty -> RBEmpty
358− RBNode _ k' _ _ _ ->
359− if k < k' then delLT t else
360− let u = if isRedLeft t then rotateRight t else t in
361− if eq_and_noRightNode u then RBEmpty else
362− let t' = moveRedRightIfNeeded t in
363− if eq t' then delEQ t' else delGT t'
364− in if member k t then ensureBlackRoot (del t) else t
365{--
420{--
366 if not (invariants_hold t) then
421 if not (invariants_hold t) then
367 Native.Error.raise "invariants broken before remove"
422 Native.Error.raise "invariants broken before remove"
@@ -374,7 +429,7 @@ remove k t =
374map : (a -> b) -> Dict comparable a -> Dict comparable b
429map : (a -> b) -> Dict comparable a -> Dict comparable b
375map f t =
430map f t =
376 case t of
431 case t of
377− RBEmpty -> RBEmpty
432+ RBEmpty LBlack -> RBEmpty LBlack
378 RBNode c k v l r -> RBNode c k (f v) (map f l) (map f r)
433 RBNode c k v l r -> RBNode c k (f v) (map f l) (map f r)
379
434
380{-| Fold over the key-value pairs in a dictionary, in order from lowest
435{-| Fold over the key-value pairs in a dictionary, in order from lowest
@@ -382,7 +437,7 @@ key to highest key. -}
382foldl : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b
437foldl : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b
383foldl f acc t =
438foldl f acc t =
384 case t of
439 case t of
385− RBEmpty -> acc
440+ RBEmpty LBlack -> acc
386 RBNode _ k v l r -> foldl f (f k v (foldl f acc l)) r
441 RBNode _ k v l r -> foldl f (f k v (foldl f acc l)) r
387
442
388{-| Fold over the key-value pairs in a dictionary, in order from highest
443{-| Fold over the key-value pairs in a dictionary, in order from highest
@@ -390,7 +445,7 @@ key to lowest key. -}
390foldr : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b
445foldr : (comparable -> v -> b -> b) -> b -> Dict comparable v -> b
391foldr f acc t =
446foldr f acc t =
392 case t of
447 case t of
393− RBEmpty -> acc
448+ RBEmpty LBlack -> acc
394 RBNode _ k v l r -> foldr f (f k v (foldr f acc r)) l
449 RBNode _ k v l r -> foldr f (f k v (foldr f acc r)) l
395
450
396{-| Combine two dictionaries. If there is a collision, preference is given
451{-| Combine two dictionaries. If there is a collision, preference is given