implementation module Data.Map from StdBool import &&, || from StdFunc import id, flip, o, const from StdTuple import snd from StdMisc import abort, undef from GenEq import generic gEq import qualified StdList as SL import Data.Maybe, Text.JSON from Data.Set import :: Set import qualified Data.Set as DS import Data.Monoid, Data.Functor, Control.Applicative import Data.List, Data.Either from Data.Foldable import class Foldable from Data.Traversable import class Traversable import qualified Data.Foldable as DF import qualified Data.Traversable as DT import Control.Monad // Ported from Haskell`s Data.Map by Jurriën Stutterheim, 10-09-2014 //////////////////////////////////////////////////////////////////// // Size balanced trees. //////////////////////////////////////////////////////////////////// // | A Map from keys @k@ to values @a@. :: Map k a = Bin !Size !k !a !(Map k a) !(Map k a) | Tip :: Size :== Int // TODO instance Semigroup (Map k v) | < k where mappend x y = union x y instance Monoid (Map k v) | < k where mempty = newMap ////////////////////////////////////////////////////////////////////// // Query ////////////////////////////////////////////////////////////////////// // | /O(1)/. Is the map newMap? // // > Data.Map.null (newMap) == True // > Data.Map.null (singleton 1 'a`) == False //null :: !(Map k a) -> Bool //null Tip = True //null _ = False // | /O(1)/. The number of elements in the map. // // > mapSize newMap == 0 // > mapSize (singleton 1 'a`) == 1 // > mapSize (fromList([(1,'a`), (2,'c'), (3,'b`)])) == 3 //mapSize :: !(Map k a) -> Int //mapSize Tip = 0 //mapSize (Bin sz _ _ _ _) = sz :: LexOrd = LT | GT | EQ //lexOrd :: !a !a -> LexOrd | < a lexOrd x y :== if (x < y) LT (if (x > y) GT EQ) // | /O(log n)/. Lookup the value at a key in the map. // // The function will return the corresponding value as @('Just` value)@, // or 'Nothing' if the key isn't in the map. // // An example of using @get@: // // > import Prelude hiding (get) // > import Data.Map // > // > employeeDept = fromList([("John","Sales"), ("Bob","IT")]) // > deptCountry = fromList([("IT","USA"), ("Sales","France")]) // > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")]) // > // > employeeCurrency :: String -> Maybe String // > employeeCurrency name = do // > dept <- get name employeeDept // > country <- get dept deptCountry // > get country countryCurrency // > // > main = do // > putStrLn $ "John's currency: " ++ (toString (employeeCurrency "John")) // > putStrLn $ "Pete's currency: " ++ (toString (employeeCurrency "Pete")) // // The output of this program: // // > John's currency: Just "Euro" // > Pete's currency: Nothing get :: !k !(Map k a) -> Maybe a | < k get _ Tip = Nothing get k (Bin _ kx x l r) = if (k < kx) (get k l) (if (k > kx) (get k r) (Just x)) // | /O(log n)/. Is the key a member of the map? See also 'notMember`. // // > member 5 (fromList [(5,'a`), (3,'b`)]) == True // > member 1 (fromList [(5,'a`), (3,'b`)]) == False member :: !k !(Map k a) -> Bool | < k member _ Tip = False member k (Bin _ kx _ l r) = if (k < kx) (member k l) (if (k > kx) (member k r) True) // | /O(log n)/. Is the key not a member of the map? See also 'member`. // // > notMember 5 (fromList [(5,'a`), (3,'b`)]) == False // > notMember 1 (fromList [(5,'a`), (3,'b`)]) == True //notMember :: !k !(Map k a) -> Bool | < k // | /O(log n)/. Find the value at a key. // Calls 'abort` when the element can not be found. find :: !k !(Map k a) -> a | < k find _ Tip = abort "Map.!: given key is not an element in the map" find k (Bin _ kx x l r) = if (k < kx) (find k l) (if (k > kx) (find k r) x) // | /O(log n)/. The expression @('findWithDefault` def k map)@ returns // the value at key @k@ or returns default value @def@ // when the key is not in the map. // // > findWithDefault 'x` 1 (fromList [(5,'a`), (3,'b`)]) == 'x` // > findWithDefault 'x` 5 (fromList [(5,'a`), (3,'b`)]) == 'a` findWithDefault :: !a !k !(Map k a) -> a | < k findWithDefault def _ Tip = def findWithDefault def k (Bin _ kx x l r) = if (k < kx) (findWithDefault def k l) (if (k > kx) (findWithDefault def k r) x) // | /O(log n)/. Find largest key smaller than the given one and return the // corresponding (key, value) pair. // // > getLT 3 (fromList [(3,'a`), (5,'b`)]) == Nothing // > getLT 4 (fromList [(3,'a`), (5,'b`)]) == Just (3, 'a`) getLT :: !k !(Map k v) -> Maybe (!k, !v) | < k getLT k m = goNothing k m where goNothing :: !k !(Map k v) -> Maybe (!k, !v) | < k goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l | otherwise = goJust k kx x r goJust :: !k !k !v !(Map k v) -> Maybe (!k, !v) | < k goJust _ kx` x` Tip = Just (kx`, x`) goJust k kx` x` (Bin _ kx x l r) | k <= kx = goJust k kx` x` l | otherwise = goJust k kx x r // | /O(log n)/. Find smallest key greater than the given one and return the // corresponding (key, value) pair. // // > getGT 4 (fromList [(3,'a`), (5,'b`)]) == Just (5, 'b`) // > getGT 5 (fromList [(3,'a`), (5,'b`)]) == Nothing getGT :: !k !(Map k v) -> Maybe (!k, !v) | < k getGT k m = goNothing k m where goNothing :: !k !(Map k v) -> Maybe (!k, !v) | < k goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l | otherwise = goNothing k r goJust :: !k !k !v !(Map k v) -> Maybe (!k, !v) | < k goJust _ kx` x` Tip = Just (kx`, x`) goJust k kx` x` (Bin _ kx x l r) | k < kx = goJust k kx x l | otherwise = goJust k kx` x` r // | /O(log n)/. Find largest key smaller or equal to the given one and return // the corresponding (key, value) pair. // // > getLE 2 (fromList [(3,'a`), (5,'b`)]) == Nothing // > getLE 4 (fromList [(3,'a`), (5,'b`)]) == Just (3, 'a`) // > getLE 5 (fromList [(3,'a`), (5,'b`)]) == Just (5, 'b`) getLE :: !k !(Map k v) -> Maybe (!k, !v) | < k getLE k m = goNothing k m where goNothing :: !k !(Map k v) -> Maybe (!k, !v) | < k goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = if (k < kx) (goNothing k l) (if (k > kx) (goJust k kx x r) (Just (kx, x))) goJust :: !k !k !v !(Map k v) -> Maybe (!k, !v) | < k goJust _ kx` x` Tip = Just (kx`, x`) goJust k kx` x` (Bin _ kx x l r) = if (k < kx) (goJust k kx` x` l) (if (k > kx) (goJust k kx x r) (Just (kx, x))) // | /O(log n)/. Find smallest key greater or equal to the given one and return // the corresponding (key, value) pair. // // > getGE 3 (fromList [(3,'a`), (5,'b`)]) == Just (3, 'a`) // > getGE 4 (fromList [(3,'a`), (5,'b`)]) == Just (5, 'b`) // > getGE 6 (fromList [(3,'a`), (5,'b`)]) == Nothing getGE :: !k !(Map k v) -> Maybe (!k, !v) | < k getGE k m = goNothing k m where goNothing :: !k !(Map k v) -> Maybe (!k, !v) | < k goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case lexOrd k kx of LT -> goJust k kx x l EQ -> Just (kx, x) GT -> goNothing k r goJust :: !k !k !v !(Map k v) -> Maybe (!k, !v) | < k goJust _ kx` x` Tip = Just (kx`, x`) goJust k kx` x` (Bin _ kx x l r) = case lexOrd k kx of LT -> goJust k kx x l EQ -> Just (kx, x) GT -> goJust k kx` x` r ////////////////////////////////////////////////////////////////////// // Construction ////////////////////////////////////////////////////////////////////// // | /O(1)/. The newMap map. // // > newMap == fromList [] // > mapSize newMap == 0 newMap :: w:(Map k u:v), [ w <= u] newMap = Tip // | /O(1)/. A map with a single element. // // > singleton 1 'a` == fromList [(1, 'a`)] // > mapSize (singleton 1 'a`) == 1 singleton :: !k !a -> Map k a singleton k x = Bin 1 k x Tip Tip ////////////////////////////////////////////////////////////////////// // Insertion ////////////////////////////////////////////////////////////////////// // | /O(log n)/. Insert a new key and value in the map. // If the key is already present in the map, the associated value is // replaced with the supplied value. 'put` is equivalent to // @'putWith' 'const`=:. // // > put 5 'x` (fromList [(5,'a`), (3,'b`)]) == fromList [(3, 'b`), (5, 'x`)] // > put 7 'x` (fromList [(5,'a`), (3,'b`)]) == fromList [(3, 'b`), (5, 'a`), (7, 'x`)] // > put 5 'x` newMap == singleton 5 'x` // See Note: Type of local 'go' function put :: !k !a !(Map k a) -> Map k a | < k put kx x Tip = singleton kx x put kx x (Bin sz ky y l r) = if (kx < ky) (balanceL ky y (put kx x l) r) (if (kx > ky) (balanceR ky y l (put kx x r)) (Bin sz kx x l r)) // Insert a new key and value in the map if it is not already present. // Used by `union`. // See Note: Type of local 'go' function putR :: !k !a !(Map k a) -> Map k a | < k putR kx x Tip = singleton kx x putR kx x t=:(Bin _ ky y l r) = if (kx < ky) (balanceL ky y (putR kx x l) r) (if (kx > ky) (balanceR ky y l (putR kx x r)) t) // | /O(log n)/. Insert with a function, combining new value and old value. // @'putWith' f key value mp@ // will put the pair (key, value) into @mp@ if key does // not exist in the map. If the key does exist, the function will // put the pair @(key, f new_value old_value)@. // // > putWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] // > putWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] // > putWith (++) 5 "xxx" newMap == singleton 5 "xxx" putWith :: !(a a -> a) !k !a !(Map k a) -> Map k a | < k putWith f k v m = putWithKey (\_ x` y` -> f x` y`) k v m // | /O(log n)/. Insert with a function, combining key, new value and old value. // @'putWithKey` f key value mp@ // will put the pair (key, value) into @mp@ if key does // not exist in the map. If the key does exist, the function will // put the pair @(key,f key new_value old_value)@. // Note that the key passed to f is the same key passed to 'putWithKey`. // // > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value // > putWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] // > putWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] // > putWithKey f 5 "xxx" newMap == singleton 5 "xxx" // See Note: Type of local 'go' function putWithKey :: !(k a a -> a) !k !a !(Map k a) -> Map k a | < k putWithKey _ kx x Tip = singleton kx x putWithKey f kx x (Bin sy ky y l r) = if (kx < ky) (balanceL ky y (putWithKey f kx x l) r) (if (kx > ky) (balanceR ky y l (putWithKey f kx x r)) (Bin sy kx (f kx x y) l r)) ////////////////////////////////////////////////////////////////////// // Deletion ////////////////////////////////////////////////////////////////////// // | /O(log n)/. Delete a key and its value from the map. When the key is not // a member of the map, the original map is returned. // // > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" // > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > delete 5 newMap == newMap // See Note: Type of local 'go' function del :: !k !(Map k a) -> Map k a | < k del _ Tip = Tip del k (Bin _ kx x l r) = if (k < kx) (balanceR kx x (del k l) r) (if (k > kx) (balanceL kx x l (del k r)) (glue l r)) // | /O(log n)/. Update a value at a specific key with the result of the provided function. // When the key is not // a member of the map, the original map is returned. // // > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] // > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > adjust ("new " ++) 7 newMap == newMap adjust :: !(a -> a) !k !(Map k a) -> Map k a | < k adjust f k m = adjustWithKey (\_ x -> f x) k m // | /O(log n)/. Adjust a value at a specific key. When the key is not // a member of the map, the original map is returned. // // > let f key x = (show key) ++ ":new " ++ x // > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] // > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > adjustWithKey f 7 newMap == newMap adjustWithKey :: !(k a -> a) !k !(Map k a) -> Map k a | < k adjustWithKey f k m = updateWithKey (\k` x` -> Just (f k` x`)) k m // | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ // at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is // deleted. If it is (@'Just` y@), the key @k@ is bound to the new value @y@. // // > let f x = if x == "a" then Just "new a" else Nothing // > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] // > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: !(a -> Maybe a) !k !(Map k a) -> Map k a | < k update f k m = updateWithKey (\_ x -> f x) k m // | /O(log n)/. The expression (@'updateWithKey` f k map@) updates the // value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', // the element is deleted. If it is (@'Just` y@), the key @k@ is bound // to the new value @y@. // // > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing // > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] // > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" // See Note: Type of local 'go' function updateWithKey :: !(k a -> Maybe a) !k !(Map k a) -> Map k a | < k updateWithKey _ _ Tip = Tip updateWithKey f k (Bin sx kx x l r) = if (k < kx) (balanceR kx x (updateWithKey f k l) r) (if (k > kx) (balanceL kx x l (updateWithKey f k r)) (case f kx x of Just x` -> Bin sx kx x` l r Nothing -> glue l r)) // | /O(log n)/. Lookup and update. See also 'updateWithKey`. // The function returns changed value, if it is updated. // Returns the original key value if the map entry is deleted. // // > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing // > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")]) // > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) // > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") // See Note: Type of local 'go' function updateLookupWithKey :: !(k a -> Maybe a) !k !(Map k a) -> (Maybe a,Map k a) | < k updateLookupWithKey _ _ Tip = (Nothing,Tip) updateLookupWithKey f k (Bin sx kx x l r) = case lexOrd k kx of LT -> let (found,l`) = updateLookupWithKey f k l in (found,balanceR kx x l` r) GT -> let (found,r`) = updateLookupWithKey f k r in (found,balanceL kx x l r`) EQ -> case f kx x of Just x` -> (Just x`,Bin sx kx x` l r) Nothing -> (Just x,glue l r) // | /O(log n)/. The expression (@'alter` f k map@) alters the value @x@ at @k@, or absence thereof. // 'alter` can be used to put, delete, or update a value in a 'Map'. // In short : @'get' k ('alter` f k m) = f ('get' k m)@. // // > let f _ = Nothing // > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] // > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" // > // > let f _ = Just "c" // > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] // > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] // See Note: Type of local 'go' function alter :: !((Maybe a) -> Maybe a) !k !(Map k a) -> Map k a | < k alter f k Tip = case f Nothing of Nothing -> Tip Just x -> singleton k x alter f k (Bin sx kx x l r) = case lexOrd k kx of LT -> balance kx x (alter f k l) r GT -> balance kx x l (alter f k r) EQ -> case f (Just x) of Just x` -> Bin sx kx x` l r Nothing -> glue l r ////////////////////////////////////////////////////////////////////// // Indexing ////////////////////////////////////////////////////////////////////// // | /O(log n)/. Return the /index/ of a key, which is its zero-based index in // the sequence sorted by keys. The index is a number from /0/ up to, but not // including, the 'mapSize' of the map. Calls 'abort` when the key is not // a 'member` of the map. // // > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map // > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0 // > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1 // > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map // See Note: Type of local 'go' function findIndex :: !k !(Map k a) -> Int | < k findIndex k m = go 0 k m where go :: !Int !k !(Map k a) -> Int | < k go _ _ Tip = abort "Map.findIndex: element is not in the map" go idx k (Bin _ kx _ l r) = case lexOrd k kx of LT -> go idx k l GT -> go (idx + mapSize l + 1) k r EQ -> idx + mapSize l // | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in // the sequence sorted by keys. The index is a number from /0/ up to, but not // including, the 'mapSize' of the map. // // > isJust (getIndex 2 (fromList [(5,"a"), (3,"b")])) == False // > fromJust (getIndex 3 (fromList [(5,"a"), (3,"b")])) == 0 // > fromJust (getIndex 5 (fromList [(5,"a"), (3,"b")])) == 1 // > isJust (getIndex 6 (fromList [(5,"a"), (3,"b")])) == False // See Note: Type of local 'go' function getIndex :: !k !(Map k a) -> Maybe Int | < k getIndex k m = go 0 k m where go :: !Int !k !(Map k a) -> Maybe Int | < k go _ _ Tip = Nothing go idx k (Bin _ kx _ l r) = case lexOrd k kx of LT -> go idx k l GT -> go (idx + mapSize l + 1) k r EQ -> Just (idx + mapSize l) // | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based // index in the sequence sorted by keys. If the /index/ is out of range (less // than zero, greater or equal to 'mapSize' of the map), 'abort` is called. // // > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b") // > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a") // > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range elemAt :: !Int !(Map k a) -> (!k, !a) elemAt _ Tip = abort "Map.elemAt: index out of range" elemAt i (Bin _ kx x l r) #! mapSizeL = mapSize l = case lexOrd i mapSizeL of LT -> elemAt i l GT -> elemAt (i - mapSizeL - 1) r EQ -> (kx,x) // | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in // the sequence sorted by keys. If the /index/ is out of range (less than zero, // greater or equal to 'mapSize' of the map), 'abort` is called. // // > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] // > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")] // > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range // > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range // > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" // > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" // > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range // > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range updateAt :: !(k a -> Maybe a) !Int !(Map k a) -> Map k a updateAt f i t = case t of Tip -> abort "Map.updateAt: index out of range" Bin sx kx x l r -> let mapSizeL = mapSize l in case lexOrd i mapSizeL of LT -> balanceR kx x (updateAt f i l) r GT -> balanceL kx x l (updateAt f (i-mapSizeL-1) r) EQ -> case f kx x of Just x` -> Bin sx kx x` l r Nothing -> glue l r // | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in // the sequence sorted by keys. If the /index/ is out of range (less than zero, // greater or equal to 'mapSize' of the map), 'abort` is called. // // > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" // > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" // > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range // > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range deleteAt :: !Int !(Map k a) -> Map k a deleteAt i t = case t of Tip -> abort "Map.deleteAt: index out of range" Bin _ kx x l r -> let mapSizeL = mapSize l in case lexOrd i mapSizeL of LT -> balanceR kx x (deleteAt i l) r GT -> balanceL kx x l (deleteAt (i-mapSizeL-1) r) EQ -> glue l r ////////////////////////////////////////////////////////////////////// // Minimal, Maximal ////////////////////////////////////////////////////////////////////// // | /O(log n)/. The minimal key of the map. Calls 'abort` if the map is newMap. // // > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b") // > findMin newMap Error: newMap map has no minimal element findMin :: !(Map k a) -> (!k, !a) findMin (Bin _ kx x Tip _) = (kx,x) findMin (Bin _ _ _ l _) = findMin l findMin Tip = abort "Map.findMin: newMap map has no minimal element" // | /O(log n)/. The maximal key of the map. Calls 'abort` if the map is newMap. // // > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") // > findMax newMap Error: newMap map has no maximal element findMax :: !(Map k a) -> (!k, !a) findMax (Bin _ kx x _ Tip) = (kx,x) findMax (Bin _ _ _ _ r) = findMax r findMax Tip = abort "Map.findMax: newMap map has no maximal element" // | /O(log n)/. Delete the minimal key. Returns an newMap map if the map is newMap. // // > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")] // > deleteMin newMap == newMap deleteMin :: !(Map k a) -> Map k a deleteMin (Bin _ _ _ Tip r) = r deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r deleteMin Tip = Tip // | /O(log n)/. Delete the maximal key. Returns an newMap map if the map is newMap. // // > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")] // > deleteMax newMap == newMap deleteMax :: !(Map k a) -> Map k a deleteMax (Bin _ _ _ l Tip) = l deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r) deleteMax Tip = Tip // | /O(log n)/. Update the value at the minimal key. // // > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] // > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: !(a -> Maybe a) !(Map k a) -> Map k a updateMin f m = updateMinWithKey (\_ x -> f x) m // | /O(log n)/. Update the value at the maximal key. // // > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] // > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: !(a -> Maybe a) !(Map k a) -> Map k a updateMax f m = updateMaxWithKey (\_ x -> f x) m // | /O(log n)/. Update the value at the minimal key. // // > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] // > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: !(k a -> Maybe a) !(Map k a) -> Map k a updateMinWithKey _ Tip = Tip updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of Nothing -> r Just x` -> Bin sx kx x` Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r // | /O(log n)/. Update the value at the maximal key. // // > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] // > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: !(k a -> Maybe a) !(Map k a) -> Map k a updateMaxWithKey _ Tip = Tip updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of Nothing -> l Just x` -> Bin sx kx x` l Tip updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) // | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and // the map stripped of that element, or 'Nothing' if passed an newMap map. // // > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") // > minViewWithKey newMap == Nothing minViewWithKey :: !(Map k a) -> Maybe (!(!k, !a), !Map k a) minViewWithKey Tip = Nothing minViewWithKey x = Just (deleteFindMin x) // | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and // the map stripped of that element, or 'Nothing' if passed an newMap map. // // > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") // > maxViewWithKey newMap == Nothing maxViewWithKey :: !(Map k a) -> Maybe (!(!k, !a), !Map k a) maxViewWithKey Tip = Nothing maxViewWithKey x = Just (deleteFindMax x) // | /O(log n)/. Retrieves the value associated with minimal key of the // map, and the map stripped of that element, or 'Nothing' if passed an // newMap map. // // > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a") // > minView newMap == Nothing minView :: !(Map k a) -> Maybe (!a, !Map k a) minView Tip = Nothing minView x = Just (first snd (deleteFindMin x)) // | /O(log n)/. Retrieves the value associated with maximal key of the // map, and the map stripped of that element, or 'Nothing' if passed an // // > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b") // > maxView newMap == Nothing maxView :: !(Map k a) -> Maybe (!a, !Map k a) maxView Tip = Nothing maxView x = Just (first snd (deleteFindMax x)) // Update the 1st component of a tuple (special case of Control.Arrow.first) first :: !(a -> b) !(!a, !c) -> (!b, !c) first f (x,y) = (f x, y) ////////////////////////////////////////////////////////////////////// // Union. ////////////////////////////////////////////////////////////////////// // | The union of a list of maps: // (@'unions' == 'Prelude.foldl` 'union' 'newMap`@). // // > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] // > == fromList [(3, "b"), (5, "a"), (7, "C")] // > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] // > == fromList [(3, "B3"), (5, "A3"), (7, "C")] //unions :: ![Map k a] -> Map k a | < k // | The union of a list of maps, with a combining operation: // (@'unionsWith' f == 'Prelude.foldl` ('unionWith' f) 'newMap`@). // // > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] // > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] //unionsWith :: !(a a -> a) ![Map k a] -> Map k a | < k // | /O(n+m)/. // The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. // It prefers @t1@ when duplicate keys are encountered, // i.e. (@'union' == 'unionWith' 'const`=:). // The implementation uses the efficient /hedge-union/ algorithm. // // > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] union :: !(Map k a) !(Map k a) -> Map k a | < k union Tip t2 = t2 union t1 Tip = t1 union t1 t2 = hedgeUnion Nothing Nothing t1 t2 unions :: ![Map k a] -> Map k a | < k unions ts = foldlStrict union newMap ts unionsWith :: !(a a -> a) ![Map k a] -> Map k a | < k unionsWith f ts = foldlStrict (unionWith f) newMap ts unionWith :: !(a a -> a) !(Map k a) !(Map k a) -> Map k a | < k unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 unionWithKey :: !(k a a -> a) !(Map k a) !(Map k a) -> Map k a | < k unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id t1 t2 // left-biased hedge union hedgeUnion :: !(Maybe a) !(Maybe a) !(Map a b) !(Map a b) -> Map a b | < a hedgeUnion _ _ t1 Tip = t1 hedgeUnion blo bhi Tip (Bin _ kx x l r) = link kx x (filterGt blo l) (filterLt bhi r) hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = putR kx x t1 // According to benchmarks, this special case increases // performance up to 30%. It does not help in difference or intersection. hedgeUnion blo bhi (Bin _ kx x l r) t2 = link kx x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = Just kx ////////////////////////////////////////////////////////////////////// // Union with a combining function ////////////////////////////////////////////////////////////////////// // | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. // // > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] //unionWith :: !(a a -> a) !(Map k a) !(Map k a) -> Map k a | < k // | /O(n+m)/. // Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. // // > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value // > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] //unionWithKey :: !(k a a -> a) !(Map k a) !(Map k a) -> Map k a | < k ////////////////////////////////////////////////////////////////////// // Difference ////////////////////////////////////////////////////////////////////// // | /O(n+m)/. Difference of two maps. // Return elements of the first map not existing in the second map. // The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. // // > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" difference :: !(Map k a) !(Map k b) -> Map k a | < k difference Tip _ = Tip difference t1 Tip = t1 difference t1 t2 = hedgeDiff Nothing Nothing t1 t2 hedgeDiff :: !(Maybe a) !(Maybe a) !(Map a b) !(Map a c) -> Map a b | < a hedgeDiff _ _ Tip _ = Tip hedgeDiff blo bhi (Bin _ kx x l r) Tip = link kx x (filterGt blo l) (filterLt bhi r) hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) (hedgeDiff bmi bhi (trim bmi bhi t) r) where bmi = Just kx // | /O(n+m)/. Difference with a combining function. // When two equal keys are // encountered, the combining function is applied to the values of these keys. // If it returns 'Nothing', the element is discarded (proper set difference). If // it returns (@'Just` y@), the element is updated with a new value @y@. // The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. // // > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing // > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) // > == singleton 3 "b:B" differenceWith :: !(a b -> Maybe a) !(Map k a) !(Map k b) -> Map k a | < k differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 // | /O(n+m)/. Difference with a combining function. When two equal keys are // encountered, the combining function is applied to the key and both values. // If it returns 'Nothing', the element is discarded (proper set difference). If // it returns (@'Just` y@), the element is updated with a new value @y@. // The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. // // > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing // > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) // > == singleton 3 "3:b|B" differenceWithKey :: !(k a b -> Maybe a) !(Map k a) !(Map k b) -> Map k a | < k differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2 ////////////////////////////////////////////////////////////////////// // Intersection ////////////////////////////////////////////////////////////////////// // | /O(n+m)/. Intersection of two maps. // Return data in the first map for the keys existing in both maps. // (@'intersection' m1 m2 == 'intersectionWith' 'const` m1 m2@). // The implementation uses an efficient /hedge/ algorithm comparable with // /hedge-union/. // // > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" intersection :: !(Map k a) !(Map k b) -> Map k a | < k intersection Tip _ = Tip intersection _ Tip = Tip intersection t1 t2 = hedgeInt Nothing Nothing t1 t2 hedgeInt :: !(Maybe k) !(Maybe k) !(Map k a) !(Map k b) -> Map k a | < k hedgeInt _ _ _ Tip = Tip hedgeInt _ _ Tip _ = Tip hedgeInt blo bhi (Bin _ kx x l r) t2 = let l` = hedgeInt blo bmi l (trim blo bmi t2) r` = hedgeInt bmi bhi r (trim bmi bhi t2) in if (member kx t2) (link kx x l` r`) (merge l` r`) where bmi = Just kx // | /O(n+m)/. Intersection with a combining function. The implementation uses // an efficient /hedge/ algorithm comparable with /hedge-union/. // // > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" intersectionWith :: !(a b -> c) !(Map k a) !(Map k b) -> Map k c | < k intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 // | /O(n+m)/. Intersection with a combining function. The implementation uses // an efficient /hedge/ algorithm comparable with /hedge-union/. // // > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar // > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" intersectionWithKey :: !(k a b -> c) !(Map k a) !(Map k b) -> Map k c | < k intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const Tip) (const Tip) t1 t2 ////////////////////////////////////////////////////////////////////// // MergeWithKey ////////////////////////////////////////////////////////////////////// // | /O(n+m)/. A high-performance universal combining function. This function // is used to define 'unionWith', 'unionWithKey`, 'differenceWith', // 'differenceWithKey`, 'intersectionWith', 'intersectionWithKey` and can be // used to define other custom combine functions. // // Please make sure you know what is going on when using 'mergeWithKey`, // otherwise you can be surprised by unexpected code growth or even // corruption of the data structure. // // When 'mergeWithKey` is given three arguments, it is inlined to the call // site. You should therefore use 'mergeWithKey` only to define your custom // combining functions. For example, you could define 'unionWithKey`, // 'differenceWithKey` and 'intersectionWithKey` as // // > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 // > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const newMap) m1 m2 // > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const newMap) (const newMap) m1 m2 // // When calling @'mergeWithKey` combine only1 only2@, a function combining two // 'IntMap's is created, such that // // * if a key is present in both maps, it is passed with both corresponding // values to the @combine@ function. Depending on the result, the key is either // present in the result with specified value, or is left out; // // * a nonnewMap subtree present only in the first map is passed to @only1@ and // the output is added to the result; // // * a nonnewMap subtree present only in the second map is passed to @only2@ and // the output is added to the result. // // The @only1@ and @only2@ methods /must return a map with a subset (possibly newMap) of the keys of the given map/. // The values can be modified arbitrarily. Most common variants of @only1@ and // @only2@ are 'id' and @'const` 'newMap`@, but for example @'map' f@ or // @'filterWithKey` f@ could be used for any @f@. mergeWithKey :: !(k a b -> Maybe c) !((Map k a) -> Map k c) !((Map k b) -> Map k c) !(Map k a) !(Map k b) -> Map k c | < k mergeWithKey f g1 g2 Tip t2 = g2 t2 mergeWithKey f g1 g2 t1 Tip = g1 t1 mergeWithKey f g1 g2 t1 t2 = hedgeMerge f g1 g2 Nothing Nothing t1 t2 hedgeMerge :: !(a b c -> Maybe d) !((Map a b) -> Map a d) !((Map a c) -> Map a d) !(Maybe a) !(Maybe a) !(Map a b) !(Map a c) -> Map a d | < a hedgeMerge f g1 g2 _ _ t1 Tip = g1 t1 hedgeMerge f g1 g2 blo bhi Tip (Bin _ kx x l r) = g2 (link kx x (filterGt blo l) (filterLt bhi r)) hedgeMerge f g1 g2 blo bhi (Bin _ kx x l r) t2 #! bmi = Just kx #! l` = hedgeMerge f g1 g2 blo bmi l (trim blo bmi t2) #! (found, trim_t2) = trimLookupLo kx bhi t2 #! r` = hedgeMerge f g1 g2 bmi bhi r trim_t2 = case found of Nothing -> case g1 (singleton kx x) of Tip -> merge l` r` (Bin _ _ x` Tip Tip) -> link kx x` l` r` _ -> abort "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> merge l` r` Just x` -> link kx x` l` r` ////////////////////////////////////////////////////////////////////// // Submap ////////////////////////////////////////////////////////////////////// // | /O(n+m)/. // This function is defined as (@'isSubmapOf' = 'isSubmapOfBy` (==)@). // isSubmapOf :: !(Map k a) !(Map k a) -> Bool | < k & Eq a isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 /* | /O(n+m)/. The expression (@'isSubmapOfBy` f t1 t2@) returns 'True' if all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': > isSubmapOfBy (==) (fromList [('a`,1)]) (fromList [('a`,1),('b`,2)]) > isSubmapOfBy (<=) (fromList [('a`,1)]) (fromList [('a`,1),('b`,2)]) > isSubmapOfBy (==) (fromList [('a`,1),('b`,2)]) (fromList [('a`,1),('b`,2)]) But the following are all 'False': > isSubmapOfBy (==) (fromList [('a`,2)]) (fromList [('a`,1),('b`,2)]) > isSubmapOfBy (<) (fromList [('a`,1)]) (fromList [('a`,1),('b`,2)]) > isSubmapOfBy (==) (fromList [('a`,1),('b`,2)]) (fromList [('a`,1)]) */ isSubmapOfBy :: !(a b -> Bool) !(Map k a) !(Map k b) -> Bool | < k isSubmapOfBy f t1 t2 = (mapSize t1 <= mapSize t2) && (submap` f t1 t2) submap` :: !(b c -> Bool) !(Map a b) !(Map a c) -> Bool | < a submap` _ Tip _ = True submap` _ _ Tip = False submap` f (Bin _ kx x l r) t = case found of Nothing -> False Just y -> f x y && submap` f l lt && submap` f r gt where (lt,found,gt) = splitLookup kx t // | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). // Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy` (==)@). isProperSubmapOf :: !(Map k a) !(Map k a) -> Bool | < k & Eq a isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2 /* | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy` f m1 m2@) returns 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) But the following are all 'False': > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) */ isProperSubmapOfBy :: !(a b -> Bool) !(Map k a) !(Map k b) -> Bool | < k isProperSubmapOfBy f t1 t2 = (mapSize t1 < mapSize t2) && (submap` f t1 t2) ////////////////////////////////////////////////////////////////////// // Filter and partition ////////////////////////////////////////////////////////////////////// // | /O(n)/. Filter all values that satisfy the predicate. // // > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" // > filter (> "x") (fromList [(5,"a"), (3,"b")]) == newMap // > filter (< "a") (fromList [(5,"a"), (3,"b")]) == newMap filter :: !(a -> Bool) !(Map k a) -> Map k a filter p m = filterWithKey (\_ x -> p x) m // | /O(n)/. Filter all keys\/values that satisfy the predicate. // // > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" // TODO : Optimize? filterWithKey :: !(k a -> Bool) !(Map k a) -> Map k a filterWithKey _ Tip = Tip filterWithKey p (Bin _ kx x l r) | p kx x = link kx x (filterWithKey p l) (filterWithKey p r) | otherwise = merge (filterWithKey p l) (filterWithKey p r) // | /O(n)/. Partition the map according to a predicate. The first // map contains all elements that satisfy the predicate, the second all // elements that fail the predicate. See also 'split`. // // > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") // > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], newMap) // > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (newMap, fromList [(3, "b"), (5, "a")]) partition :: !(a -> Bool) !(Map k a) -> (!Map k a, !Map k a) partition p m = partitionWithKey (\_ x -> p x) m // | /O(n)/. Partition the map according to a predicate. The first // map contains all elements that satisfy the predicate, the second all // elements that fail the predicate. See also 'split`. // // > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") // > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], newMap) // > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (newMap, fromList [(3, "b"), (5, "a")]) partitionWithKey :: !(k a -> Bool) !(Map k a) -> (!Map k a, !Map k a) partitionWithKey _ Tip = (Tip, Tip) partitionWithKey p (Bin _ kx x l r) #! (l1, l2) = partitionWithKey p l #! (r1, r2) = partitionWithKey p r | p kx x = (link kx x l1 r1, merge l2 r2) | otherwise = (merge l1 r1, link kx x l2 r2) // | /O(n)/. Map values and collect the 'Just` results. // // > let f x = if x == "a" then Just "new a" else Nothing // > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" mapMaybe :: !(a -> Maybe b) !(Map k a) -> Map k b mapMaybe f m = mapMaybeWithKey (\_ x -> f x) m // | /O(n)/. Map keys\/values and collect the 'Just` results. // // > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing // > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: !(k a -> Maybe b) !(Map k a) -> Map k b mapMaybeWithKey _ Tip = Tip mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) // | /O(n)/. Map values and separate the 'Left` and 'Right` results. // // > let f a = if a < "c" then Left a else Right a // > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) // > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) // > // > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) // > == (newMap, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) mapEither :: !(a -> Either b c) !(Map k a) -> (!Map k b, !Map k c) mapEither f m = mapEitherWithKey (\_ x -> f x) m // | /O(n)/. Map keys\/values and separate the 'Left` and 'Right` results. // // > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) // > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) // > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) // > // > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) // > == (newMap, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) mapEitherWithKey :: !(k a -> Either b c) !(Map k a) -> (!Map k b, !Map k c) mapEitherWithKey _ Tip = (Tip, Tip) mapEitherWithKey f (Bin _ kx x l r) #! (l1, l2) = mapEitherWithKey f l #! (r1, r2) = mapEitherWithKey f r = case f kx x of Left y -> (link kx y l1 r1, merge l2 r2) Right z -> (merge l1 r1, link kx z l2 r2) ////////////////////////////////////////////////////////////////////// // Mapping ////////////////////////////////////////////////////////////////////// // | /O(n)/. Map a function over all values in the map. // // > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: !(a -> b) !(Map k a) -> Map k b map _ Tip = Tip map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r) // | /O(n)/. Map a function over all values in the map. // // > let f key x = (show key) ++ ":" ++ x // > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: !(k a -> b) !(Map k a) -> Map k b mapWithKey _ Tip = Tip mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) // | /O(n)/. // @'traverseWithKey` f s == 'fromList` <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList` m)@ // That is, behaves exactly like a regular 'traverse' except that the traversing // function also has access to the key associated with a value. // // > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a`), (5, 'e')]) == Just (fromList [(1, 'b`), (5, 'f')]) // > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing traverseWithKey :: !(k a -> t b) !(Map k a) -> t (Map k b) | Applicative t traverseWithKey _ Tip = pure Tip traverseWithKey f (Bin 1 k v _ _) = (\v` -> Bin 1 k v` Tip Tip) <$> f k v traverseWithKey f (Bin s k v l r) = flip (Bin s k) <$> traverseWithKey f l <*> f k v <*> traverseWithKey f r // | /O(n)/. The function 'mapAccum' threads an accumulating // argument through the map in ascending order of keys. // // > let f a b = (a ++ b, b ++ "X") // > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum :: !(a b -> (!a, !c)) !a !(Map k b) -> (!a, !Map k c) mapAccum f a m = mapAccumWithKey (\a` _ x` -> f a` x`) a m // | /O(n)/. The function 'mapAccumWithKey` threads an accumulating // argument through the map in ascending order of keys. // // > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") // > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) mapAccumWithKey :: !(a k b -> (!a, !c)) !a !(Map k b) -> (!a, !Map k c) mapAccumWithKey f a t = mapAccumL f a t // | /O(n)/. The function 'mapAccumL' threads an accumulating // argument through the map in ascending order of keys. mapAccumL :: !(a k b -> (!a, !c)) !a !(Map k b) -> (!a, !Map k c) mapAccumL _ a Tip = (a,Tip) mapAccumL f a (Bin sx kx x l r) #! (a1,l`) = mapAccumL f a l #! (a2,x`) = f a1 kx x #! (a3,r`) = mapAccumL f a2 r = (a3, Bin sx kx x` l` r`) // | /O(n)/. The function 'mapAccumR' threads an accumulating // argument through the map in descending order of keys. mapAccumRWithKey :: !(a k b -> (!a, !c)) !a !(Map k b) -> (!a, !Map k c) mapAccumRWithKey _ a Tip = (a,Tip) mapAccumRWithKey f a (Bin sx kx x l r) #! (a1,r`) = mapAccumRWithKey f a r #! (a2,x`) = f a1 kx x #! (a3,l`) = mapAccumRWithKey f a2 l = (a3, Bin sx kx x` l` r`) // | /O(n*log n)/. // @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. // // The mapSize of the result may be smaller if @f@ maps two or more distinct // keys to the same new key. In this case the value at the greatest of the // original keys is retained. // // > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] // > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" // > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" mapKeys :: !(k1 -> k2) !(Map k1 a) -> Map k2 a | < k1 & < k2 & == k1 & == k2 mapKeys f m = fromList (foldrWithKey (\k x xs -> [(f k, x) : xs]) [] m) // | /O(n*log n)/. // @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. // // The mapSize of the result may be smaller if @f@ maps two or more distinct // keys to the same new key. In this case the associated values will be // combined using @c@. // // > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" // > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" mapKeysWith :: !(a a -> a) !(k1 -> k2) !(Map k1 a) -> Map k2 a | < k1 & < k2 mapKeysWith c f m = fromListWith c (foldrWithKey (\k x xs -> [(f k, x) : xs]) [] m) // | /O(n)/. // @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ // is strictly monotonic. // That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. // /The precondition is not checked./ // Semi-formally, we have: // // > and [x < y ==> f x < f y | x <- ls, y <- ls] // > ==> mapKeysMonotonic f s == mapKeys f s // > where ls = keys s // // This means that @f@ maps distinct original keys to distinct resulting keys. // This function has better performance than 'mapKeys'. // // > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] // > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True // > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False mapKeysMonotonic :: !(k1 -> k2) !(Map k1 a) -> Map k2 a mapKeysMonotonic _ Tip = Tip mapKeysMonotonic f (Bin sz k x l r) = Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) ////////////////////////////////////////////////////////////////////// // Folds ////////////////////////////////////////////////////////////////////// // | /O(n)/. Fold the values in the map using the given right-associative // binary operator, such that @'foldr` f z == 'Prelude.foldr` f z . 'elems'@. // // For example, // // > elems map = foldr (:) [] map // // > let f a len = len + (length a) // > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 foldr :: !(a b -> b) !b (Map k a) -> b foldr f z` Tip = z` foldr f z` (Bin _ _ x l r) = foldr f (f x (foldr f z` r)) l // | /O(n)/. A strict version of 'foldr`. Each application of the operator is // evaluated before using the result in the next application. This // function is strict in the starting value. foldr` :: !(a b -> b) !b !(Map k a) -> b foldr` f z` Tip = z` foldr` f z` (Bin _ _ x l r) = foldr` f (f x (foldr` f z` r)) l // | /O(n)/. Fold the values in the map using the given left-associative // binary operator, such that @'foldl` f z == 'Prelude.foldl` f z . 'elems'@. // // For example, // // > elems = reverse . foldl (flip (:)) [] // // > let f len a = len + (length a) // > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 foldl :: !(a b -> a) !a !(Map k b) -> a foldl f z` Tip = z` foldl f z` (Bin _ _ x l r) = foldl f (f (foldl f z` l) x) r // | /O(n)/. A strict version of 'foldl`. Each application of the operator is // evaluated before using the result in the next application. This // function is strict in the starting value. foldl` :: !(a b -> a) !a (Map k b) -> a foldl` f z` Tip = z` foldl` f z` (Bin _ _ x l r) = foldl` f (f (foldl` f z` l) x) r // | /O(n)/. Fold the keys and values in the map using the given right-associative // binary operator, such that // @'foldrWithKey` f z == 'Prelude.foldr` ('uncurry` f) z . 'toAscList`=:. // // For example, // // > keys map = foldrWithKey (\k x ks -> k:ks) [] map // // > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" // > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" foldrWithKey :: !(k v u:a -> u:a) !u:a !(Map k v) -> u:a foldrWithKey f z` Tip = z` foldrWithKey f z` (Bin _ kx x l r) = foldrWithKey f (f kx x (foldrWithKey f z` r)) l // | /O(n)/. A strict version of 'foldrWithKey`. Each application of the operator is // evaluated before using the result in the next application. This // function is strict in the starting value. foldrWithKey` :: !(k a b -> b) !b !(Map k a) -> b foldrWithKey` f z` Tip = z` foldrWithKey` f z` (Bin _ kx x l r) = foldrWithKey` f (f kx x (foldrWithKey` f z` r)) l // | /O(n)/. Fold the keys and values in the map using the given left-associative // binary operator, such that // @'foldlWithKey` f z == 'Prelude.foldl` (\\z` (kx, x) -> f z` kx x) z . 'toAscList`=:. // // For example, // // > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] // // > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" // > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" foldlWithKey :: !(u:a k v -> u:a) !u:a !(Map k v) -> u:a foldlWithKey f z` Tip = z` foldlWithKey f z` (Bin _ kx x l r) = foldlWithKey f (f (foldlWithKey f z` l) kx x) r // | /O(n)/. A strict version of 'foldlWithKey`. Each application of the operator is // evaluated before using the result in the next application. This // function is strict in the starting value. foldlWithKey` :: !(a k b -> a) !a !(Map k b) -> a foldlWithKey` f z` Tip = z` foldlWithKey` f z` (Bin _ kx x l r) = foldlWithKey` f (f (foldlWithKey` f z` l) kx x) r // | /O(n)/. Fold the keys and values in the map using the given monoid, such that // // @'foldMapWithKey` f = 'Prelude.fold' . 'mapWithKey` f@ // // This can be an asymptotically faster than 'foldrWithKey` or 'foldlWithKey` for some monoids. foldMapWithKey :: !(k a -> m) !(Map k a) -> m | Monoid m foldMapWithKey f Tip = mempty foldMapWithKey f (Bin 1 k v _ _) = f k v foldMapWithKey f (Bin _ k v l r) = mappend (foldMapWithKey f l) (mappend (f k v) (foldMapWithKey f r)) ////////////////////////////////////////////////////////////////////// // List variations ////////////////////////////////////////////////////////////////////// // | /O(n)/. // Return all elements of the map in the ascending order of their keys. // Subject to list fusion. // // > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] // > elems newMap == [] //elems :: !(Map k a) -> [a] // | /O(n)/. Return all keys of the map in ascending order. Subject to list // fusion. // // > keys (fromList [(5,"a"), (3,"b")]) == [3,5] // > keys newMap == [] //keys :: !(Map k a) -> [k] // | /O(n)/. An alias for 'toAscList`. Return all key\/value pairs in the map // in ascending key order. Subject to list fusion. // // > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] // > assocs newMap == [] assocs :: !(Map k a) -> [(!k, !a)] assocs m = toAscList m // | /O(n)/. The set of all keys of the map. // // > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5] // > keysSet newMap == Data.Set.newMap keysSet :: !(Map k a) -> Set k keysSet Tip = 'DS'.Tip keysSet (Bin sz kx _ l r) = 'DS'.Bin sz kx (keysSet l) (keysSet r) // | /O(n)/. Build a map from a set of keys and a function which for each key // computes its value. // // > fromSet (\k -> replicate k 'a`) (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] // > fromSet undefined Data.Set.newMap == newMap fromSet :: !(k -> a) !(Set k) -> Map k a fromSet _ 'DS'.Tip = Tip fromSet f ('DS'.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) ////////////////////////////////////////////////////////////////////// // Lists // use [foldlStrict] to reduce demand on the control-stack ////////////////////////////////////////////////////////////////////// // | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList`. // If the list contains more than one value for the same key, the last value // for the key is retained. // // If the keys of the list are ordered, linear-time implementation is used, // with the performance equal to 'fromDistinctAscList`. // // > fromList [] == newMap // > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] // > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] // For some reason, when 'singleton' is used in fromList or in // create, it is not inlined, so we inline it manually. //fromList :: !w:[x:(!k,u:v)] -> y:(Map k u:v) | == k & < k, [x y <= u, w <= x, w <= y] fromList :: !u:[v:(!a, !b)] -> Map a b | == a & < a, [u <= v] fromList [] = Tip fromList [(kx, x)] = Bin 1 kx x Tip Tip fromList [(kx0, x0) : xs0] | not_ordered kx0 xs0 = fromList` (Bin 1 kx0 x0 Tip Tip) xs0 | otherwise = go 1 (Bin 1 kx0 x0 Tip Tip) xs0 where not_ordered :: !a !u:[v:(!a, !b)] -> Bool | == a & < a, [u <= v] not_ordered _ [] = False not_ordered kx [(ky,_) : _] = kx >= ky fromList` :: !(Map a b) !u:[v:(!a, !b)] -> Map a b | == a & < a, [u <= v] fromList` t0 xs = foldlStrict ins t0 xs where ins t (k,x) = put k x t go :: !Int !(Map a b) !u:[v:(!a, !b)] -> Map a b | == a & < a, [u <= v] go _ t [] = t go _ t [(kx, x)] = putMax kx x t go s l xs=:[(kx, x) : xss] | not_ordered kx xss = fromList` l xs | otherwise = case create s xss of (r, ys, []) -> go (s << 1) (link kx x l r) ys (r, _, ys) -> fromList` (link kx x l r) ys // The create is returning a triple (tree, xs, ys). Both xs and ys // represent not yet processed elements and only one of them can be nonnewMap. // If ys is nonnewMap, the keys in ys are not ordered with respect to tree // and must be puted using fromList`. Otherwise the keys have been // ordered so far. create :: !Int !u:[v:(!a, !b)] -> (!Map a b, ![(!a, !b)], ![(!a, !b)]) | == a & < a, [u <= v] create _ [] = (Tip, [], []) create s xs=:[xp : xss] | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss) | otherwise -> (Bin 1 kx x Tip Tip, xss, []) | otherwise = case create (s >> 1) xs of res=:(_, [], _) -> res (l, [(ky, y)], zs) -> (putMax ky y l, [], zs) (l, ys=:[(ky, y):yss], _) | not_ordered ky yss -> (l, [], ys) | otherwise -> case create (s >> 1) yss of (r, zs, ws) -> (link ky y l r, zs, ws) // | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. // // > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] // > fromListWith (++) [] == newMap //fromListWith :: !(a a -> a) ![(!k, !a)] -> Map k a | < k fromListWith f xs :== fromListWithKey (\_ x y -> f x y) xs // | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey`. // // > let f k a1 a2 = (toString k) ++ a1 ++ a2 // > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] // > fromListWithKey f [] == newMap fromListWithKey :: !(k a a -> a) ![(!k, !a)] -> Map k a | < k fromListWithKey f xs = foldlStrict ins newMap xs where ins t (k, x) = putWithKey f k x t // | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion. // // > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] // > toList newMap == [] //toList :: !(Map k a) -> [(!k, !a)] //toList m = toAscList m // | /O(n)/. Convert the map to a list of key\/value pairs where the keys are // in ascending order. Subject to list fusion. // // > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] //toAscList :: !(Map k a) -> [(!k, !a)] // | /O(n)/. Convert the map to a list of key\/value pairs where the keys // are in descending order. Subject to list fusion. // // > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] toDescList :: !(Map k a) -> [(!k, !a)] toDescList m = foldlWithKey (\xs k x -> [(k,x):xs]) [] m ////////////////////////////////////////////////////////////////////// // Building trees from ascending/descending lists can be done in linear time. // // Note that if [xs] is ascending that: // fromAscList xs == fromList xs // fromAscListWith f xs == fromListWith f xs ////////////////////////////////////////////////////////////////////// // | /O(n)/. Build a map from an ascending list in linear time. // /The precondition (input list is ascending) is not checked./ // // > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] // > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] // > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True // > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False fromAscList :: ![(!k, !a)] -> Map k a | == k fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs // | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. // /The precondition (input list is ascending) is not checked./ // // > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] // > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True // > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromAscListWith :: !(a a -> a) ![(!k, !a)] -> Map k a | == k fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs // | /O(n)/. Build a map from an ascending list in linear time with a // combining function for equal keys. // /The precondition (input list is ascending) is not checked./ // // > let f k a1 a2 = (toString k) ++ ":" ++ a1 ++ a2 // > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] // > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True // > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromAscListWithKey :: !(k a a -> a) ![(!k, !a)] -> Map k a | == k fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) where // [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] combineEq _ xs` = case xs` of [] -> [] [x] -> [x] [x:xx] -> combineEq` x xx combineEq` z [] = [z] combineEq` z=:(kz,zz) [x=:(kx,xx):xs`] | kx == kz = let yy = f kx xx zz in combineEq` (kx,yy) xs` | otherwise = [z:combineEq` x xs`] // | /O(n)/. Build a map from an ascending list of distinct elements in linear time. // /The precondition is not checked./ // // > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] // > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True // > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False // For some reason, when 'singleton' is used in fromDistinctAscList or in // create, it is not inlined, so we inline it manually. fromDistinctAscList :: ![(!k, !a)] -> Map k a fromDistinctAscList [] = Tip fromDistinctAscList [(kx0, x0) : xs0] = go 1 (Bin 1 kx0 x0 Tip Tip) xs0 where go :: !Int !(Map a b) ![(!a, !b)] -> Map a b go _ t [] = t go s l [(kx, x) : xs] = case create s xs of (r, ys) -> go (s << 1) (link kx x l r) ys create :: !Int ![(!a, !b)] -> (!Map a b, ![(!a, !b)]) create _ [] = (Tip, []) create s xs=:[x` : xs`] | s == 1 = case x` of (kx, x) -> (Bin 1 kx x Tip Tip, xs`) | otherwise = case create (s >> 1) xs of res=:(_, []) -> res (l, [(ky, y):ys]) -> case create (s >> 1) ys of (r, zs) -> (link ky y l r, zs) ////////////////////////////////////////////////////////////////////// // Utility functions that return sub-ranges of the original // tree. Some functions take a `Maybe value` as an argument to // allow comparisons against infinite values. These are called `blow` // (Nothing is -\infty) and `bhigh` (here Nothing is +\infty). // We use Maybe value, which is a Maybe strict in the Just case. // // [trim blow bhigh t] A tree that is either newMap or where [x > blow] // and [x < bhigh] for the value [x] of the root. // [filterGt blow t] A tree where for all values [k]. [k > blow] // [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] // // [split k t] Returns two trees [l] and [r] where all keys // in [l] are <[k] and all keys in [r] are >[k]. // [splitLookup k t] Just like [split] but also returns whether [k] // was found in the tree. ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// // [trim blo bhi t] trims away all subtrees that surely contain no // values between the range [blo] to [bhi]. The returned tree is either // newMap or the key of the root is between @blo@ and @bhi@. ////////////////////////////////////////////////////////////////////// trim :: !(Maybe k) !(Maybe k) !(Map k a) -> Map k a | < k trim Nothing Nothing t = t trim (Just lk) Nothing t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r greater _ t` = t` trim Nothing (Just hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l lesser _ t` = t` trim (Just lk) (Just hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l middle _ _ t` = t` // Helper function for 'mergeWithKey`. The @'trimLookupLo' lk hk t@ performs both // @'trim' (Just lk) hk t@ and @'get' lk t@. trimLookupLo :: !k !(Maybe k) !(Map k a) -> (!Maybe a, !Map k a) | < k trimLookupLo lk Nothing t = greater lk t where greater :: !k (Map k a) -> (Maybe a, Map k a) | < k greater lo t`=:(Bin _ kx x l r) = if (lo < kx) (get lo l, t`) (if (lo > kx) (greater lo r) (Just x, r)) greater _ Tip = (Nothing, Tip) trimLookupLo lk (Just hk) t = middle lk hk t where middle :: !k !k (Map k a) -> (Maybe a, Map k a) | < k middle lo hi t`=:(Bin _ kx x l r) = if (lo < kx) (if (kx < hi) (get lo l, t`) (middle lo hi l)) (if (lo > kx) (middle lo hi r) (Just x, lesser hi r)) middle _ _ Tip = (Nothing, Tip) lesser :: !k (Map k a) -> Map k a | < k lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l lesser _ t` = t` ////////////////////////////////////////////////////////////////////// // [filterGt b t] filter all keys >[b] from tree [t] // [filterLt b t] filter all keys <[b] from tree [t] ////////////////////////////////////////////////////////////////////// filterGt :: !(Maybe k) !(Map k v) -> Map k v | < k filterGt Nothing t = t filterGt (Just b) t = filter` b t where filter` :: !k !(Map k a) -> Map k a | < k filter` _ Tip = Tip filter` b` (Bin _ kx x l r) = if (b` < kx) (link kx x (filter` b` l) r) (if (b` > kx) (filter` b` r) r) filterLt :: !(Maybe k) !(Map k v) -> Map k v | < k filterLt Nothing t = t filterLt (Just b) t = filter` b t where filter` :: !k !(Map k a) -> Map k a | < k filter` _ Tip = Tip filter` b` (Bin _ kx x l r) = if (kx < b`) (link kx x l (filter` b` r)) (if (kx > b`) (filter` b` l) l) ////////////////////////////////////////////////////////////////////// // Split ////////////////////////////////////////////////////////////////////// // | /O(log n)/. The expression (@'split` k map@) is a pair @(map1,map2)@ where // the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. // Any key equal to @k@ is found in neither @map1@ nor @map2@. // // > split 2 (fromList [(5,"a"), (3,"b")]) == (newMap, fromList [(3,"b"), (5,"a")]) // > split 3 (fromList [(5,"a"), (3,"b")]) == (newMap, singleton 5 "a") // > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") // > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", newMap) // > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], newMap) split :: !k !(Map k a) -> (!Map k a, !Map k a) | < k split k Tip = (Tip, Tip) split k (Bin _ kx x l r) = case lexOrd k kx of LT #! (lt, gt) = split k l = (lt, link kx x gt r) GT #! (lt, gt) = split k r = (link kx x l lt, gt) EQ = (l, r) // | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just // like 'split` but also returns @'get' k map@. // // > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (newMap, Nothing, fromList [(3,"b"), (5,"a")]) // > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (newMap, Just "b", singleton 5 "a") // > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a") // > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", newMap) // > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, newMap) splitLookup :: !k !(Map k a) -> (!Map k a, !Maybe a, !Map k a) | < k splitLookup k t = case t of Tip -> (Tip,Nothing,Tip) Bin _ kx x l r -> case lexOrd k kx of LT #! (lt,z,gt) = splitLookup k l #! gt` = link kx x gt r = (lt,z,gt`) GT #! (lt,z,gt) = splitLookup k r #! lt` = link kx x l lt = (lt`,z,gt) EQ = (l,Just x,r) ////////////////////////////////////////////////////////////////////// // Utility functions that maintain the balance properties of the tree. // All constructors assume that all values in [l] < [k] and all values // in [r] > [k], and that [l] and [r] are valid trees. // // In order of sophistication: // [Bin sz k x l r] The type constructor. // [bin k x l r] Maintains the correct mapSize, assumes that both [l] // and [r] are balanced with respect to each other. // [balance k x l r] Restores the balance and mapSize. // Assumes that the original tree was balanced and // that [l] or [r] has changed by at most one element. // [link k x l r] Restores balance and mapSize. // // Furthermore, we can construct a new tree from two trees. Both operations // assume that all values in [l] < all values in [r] and that [l] and [r] // are valid: // [glue l r] Glues [l] and [r] together. Assumes that [l] and // [r] are already balanced with respect to each other. // [merge l r] Merges two trees and restores balance. // // Note: in contrast to Adam's paper, we use (<=) comparisons instead // of (<) comparisons in [link], [merge] and [balance]. // Quickcheck (on [difference]) showed that this was necessary in order // to maintain the invariants. It is quite unsatisfactory that I haven't // been able to find out why this is actually the case! Fortunately, it // doesn't hurt to be a bit more conservative. ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// // Link ////////////////////////////////////////////////////////////////////// link :: !k !a !(Map k a) !(Map k a) -> Map k a link kx x Tip r = putMin kx x r link kx x l Tip = putMax kx x l link kx x l=:(Bin mapSizeL ky y ly ry) r=:(Bin mapSizeR kz z lz rz) | delta*mapSizeL < mapSizeR = balanceL kz z (link kx x l lz) rz | delta*mapSizeR < mapSizeL = balanceR ky y ly (link kx x ry r) | otherwise = bin kx x l r // putMin and putMax don't perform potentially expensive comparisons. putMax :: !k !a !(Map k a) -> Map k a putMax kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceR ky y l (putMax kx x r) putMin :: !k !a !(Map k a) -> Map k a putMin kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceL ky y (putMin kx x l) r //////////////////////////////////////////////////////////////////// // [merge l r]: merges two trees. //////////////////////////////////////////////////////////////////// merge :: !(Map k a) !(Map k a) -> Map k a merge Tip r = r merge l Tip = l merge l=:(Bin mapSizeL kx x lx rx) r=:(Bin mapSizeR ky y ly ry) | delta*mapSizeL < mapSizeR = balanceL ky y (merge l ly) ry | delta*mapSizeR < mapSizeL = balanceR kx x lx (merge rx r) | otherwise = glue l r //////////////////////////////////////////////////////////////////// // [glue l r]: glues two trees together. // Assumes that [l] and [r] are already balanced with respect to each other. //////////////////////////////////////////////////////////////////// glue :: !(Map k a) !(Map k a) -> Map k a glue Tip r = r glue l Tip = l glue l r | mapSize l > mapSize r #! ((km, m), l`) = deleteFindMax l = balanceR km m l` r | otherwise #! ((km, m), r`) = deleteFindMin r = balanceL km m l r` // | /O(log n)/. Delete and find the minimal element. // // > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) // > deleteFindMin Error: can not return the minimal element of an newMap map deleteFindMin :: !(Map k a) -> (!(!k, !a), !Map k a) deleteFindMin t = case t of Bin _ k x Tip r = ((k, x), r) Bin _ k x l r #! (km,l`) = deleteFindMin l = (km, balanceR k x l` r) Tip = (abort "Map.deleteFindMin: can not return the minimal element of an newMap map", Tip) // | /O(log n)/. Delete and find the maximal element. // // > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")]) // > deleteFindMax newMap Error: can not return the maximal element of an newMap map deleteFindMax :: !(Map k a) -> (!(!k, !a), !Map k a) deleteFindMax t = case t of Bin _ k x l Tip = ((k, x), l) Bin _ k x l r #! (km,r`) = deleteFindMax r = (km, balanceL k x l r`) Tip = (abort "Map.deleteFindMax: can not return the maximal element of an newMap map", Tip) //////////////////////////////////////////////////////////////////// // [balance l x r] balances two trees with value x. // The mapSizes of the trees should balance after decreasing the // mapSize of one of them. (a rotation). // // [delta] is the maximal relative difference between the mapSizes of // two trees, it corresponds with the [w] in Adams' paper. // [ratio] is the ratio between an outer and inner sibling of the // heavier subtree in an unbalanced setting. It determines // whether a double or single rotation should be performed // to restore balance. It is corresponds with the inverse // of $\alpha$ in Adam's article. // // Note that according to the Adam's paper: // - [delta] should be larger than 4.646 with a [ratio] of 2. // - [delta] should be larger than 3.745 with a [ratio] of 1.534. // // But the Adam's paper is erroneous: // - It can be proved that for delta=2 and delta>=5 there does // not exist any ratio that would work. // - Delta=4.5 and ratio=2 does not work. // // That leaves two reasonable variants, delta=3 and delta=4, // both with ratio=2. // // - A lower [delta] leads to a more 'perfectly` balanced tree. // - A higher [delta] performs less rebalancing. // // In the benchmarks, delta=3 is faster on put operations, // and delta=4 has slightly better deletes. As the put speedup // is larger, we currently use delta=3. // //////////////////////////////////////////////////////////////////// //delta :: Int delta :== 3 //ratio :: Int ratio :== 2 // The balance function is equivalent to the following: // // balance :: k -> a -> Map k a -> Map k a -> Map k a // balance k x l r // | mapSizeL + mapSizeR <= 1 = Bin mapSizeX k x l r // | mapSizeR > delta*mapSizeL = rotateL k x l r // | mapSizeL > delta*mapSizeR = rotateR k x l r // | otherwise = Bin mapSizeX k x l r // where // mapSizeL = mapSize l // mapSizeR = mapSize r // mapSizeX = mapSizeL + mapSizeR + 1 // // rotateL :: a -> b -> Map a b -> Map a b -> Map a b // rotateL k x l r=:(Bin _ _ _ ly ry) | mapSize ly < ratio*mapSize ry = singleL k x l r // | otherwise = doubleL k x l r // // rotateR :: a -> b -> Map a b -> Map a b -> Map a b // rotateR k x l@(Bin _ _ _ ly ry) r | mapSize ry < ratio*mapSize ly = singleR k x l r // | otherwise = doubleR k x l r // // singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b // singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 // singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) // // doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b // doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) // doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) // // It is only written in such a way that every node is pattern-matched only once. balance :: !k !a !(Map k a) !(Map k a) -> Map k a balance k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr=:(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl=:(Bin rls rlk rlx rll rlr) rr=:(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+mapSize rll) k x Tip rll) (Bin (1+rrs+mapSize rlr) rk rx rlr rr) (Bin ls lk lx ll lr) -> case r of Tip -> case (ll, lr) of (Tip, Tip) -> Bin 2 k x l Tip (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+mapSize lrl) lk lx ll lrl) (Bin (1+mapSize lrr) k x lrr Tip) (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+mapSize rll) k x l rll) (Bin (1+rrs+mapSize rlr) rk rx rlr rr) (_, _) -> abort "Failure in Data.Map.balance" | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+mapSize lrl) lk lx ll lrl) (Bin (1+rs+mapSize lrr) k x lrr r) (_, _) -> abort "Failure in Data.Map.balance" | otherwise -> Bin (1+ls+rs) k x l r // Functions balanceL and balanceR are specialised versions of balance. // balanceL only checks whether the left subtree is too big, // balanceR only checks whether the right subtree is too big. // balanceL is called when left subtree might have been puted to or when // right subtree might have been deleted from. balanceL :: !k !a !(Map k a) !(Map k a) -> Map k a balanceL k x l r = case r of Tip -> case l of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) (Bin _ lk lx ll=:(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) (Bin ls lk lx ll=:(Bin lls _ _ _ _) lr=:(Bin lrs lrk lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+mapSize lrl) lk lx ll lrl) (Bin (1+mapSize lrr) k x lrr Tip) (Bin rs _ _ _ _) -> case l of Tip -> Bin (1+rs) k x Tip r (Bin ls lk lx ll lr) | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+mapSize lrl) lk lx ll lrl) (Bin (1+rs+mapSize lrr) k x lrr r) (_, _) -> abort "Failure in Data.Map.balanceL" | otherwise -> Bin (1+ls+rs) k x l r // balanceR is called when right subtree might have been puted to or when // left subtree might have been deleted from. balanceR :: !k !a !(Map k a) !(Map k a) -> Map k a balanceR k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr=:(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl=:(Bin rls rlk rlx rll rlr) rr=:(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+mapSize rll) k x Tip rll) (Bin (1+rrs+mapSize rlr) rk rx rlr rr) (Bin ls _ _ _ _) -> case r of Tip -> Bin (1+ls) k x l Tip (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+mapSize rll) k x l rll) (Bin (1+rrs+mapSize rlr) rk rx rlr rr) (_, _) -> abort "Failure in Data.Map.balanceR" | otherwise -> Bin (1+ls+rs) k x l r //////////////////////////////////////////////////////////////////// // The bin constructor maintains the mapSize of the tree //////////////////////////////////////////////////////////////////// bin :: !k !a !(Map k a) !(Map k a) -> Map k a bin k x l r = Bin (mapSize l + mapSize r + 1) k x l r //////////////////////////////////////////////////////////////////// // Eq converts the tree to a list. In a lazy setting, this // actually seems one of the faster methods to gLexOrd{|*|} two trees // and it is certainly the simplest :-) //////////////////////////////////////////////////////////////////// instance == (Map k a) | == k & == a where (==) t1 t2 = (mapSize t1 == mapSize t2) && (toAscList t1 == toAscList t2) instance == (a, b) | == a & == b where (==) (x1, y1) (x2, y2) = x1 == x2 && y1 == y2 //////////////////////////////////////////////////////////////////// // Functor //////////////////////////////////////////////////////////////////// instance Functor (Map k) where fmap f m = map f m // TODO //instance Traversable (Map k) where //traverse f = traverseWithKey (\_ -> f) //instance Foldable (Map k) where //fold t = go t //where go Tip = mnewMap //go (Bin 1 _ v _ _) = v //go (Bin _ _ v l r) = mappend (go l) (mappend v (go r)) //foldr = foldr //foldl = foldl //foldMap f t = go t //where go Tip = mnewMap //go (Bin 1 _ v _ _) = f v //go (Bin _ _ v l r) = mappend (go l) (mappend (f v) (go r)) //////////////////////////////////////////////////////////////////// // Show //////////////////////////////////////////////////////////////////// instance toString (Map k a) | toString k & toString a where toString m = "" // TODO showParen False (showString "fromList " o shows (toList m)) // | /O(n)/. Show the tree that implements the map. The tree is shown // in a compressed, hanging format. See 'showTreeWith'. showTree :: !(Map k a) -> String | toString k & toString a showTree m = showTreeWith showElem True False m where showElem k x = toString k +++ ":=" +++ toString x shows :: !a -> (String -> String) | toString a shows x = showsPrec 0 x showString :: !String -> (String -> String) showString str = \str` -> str +++ str` showParen :: !Bool !(String -> String) -> (String -> String) showParen b p = if b (showChar '(' o p o showChar ')') p showChar :: !Char -> (String -> String) showChar x = \str -> toString x +++ str showsPrec _ x s = toString x +++ s /* | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] > Map> putStrLn $ showTreeWith (\k x -> toString (k,x)) True False t > (4,()) > +//(2,()) > | +//(1,()) > | +//(3,()) > +//(5,()) > > Map> putStrLn $ showTreeWith (\k x -> toString (k,x)) True True t > (4,()) > | > +//(2,()) > | | > | +//(1,()) > | | > | +//(3,()) > | > +//(5,()) > > Map> putStrLn $ showTreeWith (\k x -> toString (k,x)) False True t > +//(5,()) > | > (4,()) > | > | +//(3,()) > | | > +//(2,()) > | > +//(1,()) */ showTreeWith :: !(k a -> String) !Bool !Bool !(Map k a) -> String showTreeWith showelem hang wide t | hang = (showsTreeHang showelem wide [] t) "" | otherwise = (showsTree showelem wide [] [] t) "" showsTree :: !(k a -> String) !Bool ![String] ![String] !(Map k a) -> (String -> String) showsTree showelem wide lbars rbars t = case t of Tip -> showsBars lbars o showString "|\n" Bin _ kx x Tip Tip -> showsBars lbars o showString (showelem kx x) o showString "\n" Bin _ kx x l r -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r o showWide wide rbars o showsBars lbars o showString (showelem kx x) o showString "\n" o showWide wide lbars o showsTree showelem wide (withEmpty lbars) (withBar lbars) l showsTreeHang :: !(k a -> String) !Bool ![String] !(Map k a) -> (String -> String) showsTreeHang showelem wide bars t = case t of Tip -> showsBars bars o showString "|\n" Bin _ kx x Tip Tip -> showsBars bars o showString (showelem kx x) o showString "\n" Bin _ kx x l r -> showsBars bars o showString (showelem kx x) o showString "\n" o showWide wide bars o showsTreeHang showelem wide (withBar bars) l o showWide wide bars o showsTreeHang showelem wide (withEmpty bars) r showWide :: !Bool ![String] !String -> String showWide wide bars s | wide = "" // TODO showString (foldr (+++) "" (reverse bars)) (showString "|\n" s) | otherwise = s showsBars :: ![String] -> (String -> String) showsBars bars = case bars of [] -> id _ -> id // TODO showString (foldr (+++) "" (reverse (tail bars))) o showString node node :: String node = "+//" withBar :: ![String] -> [String] withBar bars = ["| ":bars] withEmpty :: ![String] -> [String] withEmpty bars = [" ":bars] //////////////////////////////////////////////////////////////////// // Assertions //////////////////////////////////////////////////////////////////// // | /O(n)/. Test if the internal map structure is valid. // // > valid (fromAscList [(3,"b"), (5,"a")]) == True // > valid (fromAscList [(5,"a"), (3,"b")]) == False valid :: !(Map k a) -> Bool | < k valid t = balanced t && ordered t && validmapSize t ordered :: !(Map a b) -> Bool | < a ordered t = bounded (const True) (const True) t where bounded :: !(a -> .Bool) !(a -> .Bool) !(Map a b) -> Bool | < a bounded lo hi t` = case t` of Tip -> True Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (\x -> x < kx) l && bounded (\x -> x > kx) hi r balanced :: !(Map k a) -> Bool balanced Tip = True balanced (Bin _ _ _ l r) = (mapSize l + mapSize r <= 1 || (mapSize l <= delta*mapSize r && mapSize r <= delta*mapSize l)) && balanced l && balanced r validmapSize :: !(Map a b) -> Bool validmapSize t = (realmapSize t == Just (mapSize t)) where realmapSize :: !(Map a b) -> Maybe Int realmapSize Tip = Just 0 realmapSize (Bin sz _ _ l r) = case (realmapSize l, realmapSize r) of (Just n,Just m) | n+m+1 == sz -> Just sz _ -> Nothing //////////////////////////////////////////////////////////////////// // Utilities //////////////////////////////////////////////////////////////////// foldlStrict :: !(a b -> a) !a ![b] -> a foldlStrict f acc [] = acc foldlStrict f acc [x:xs] #! z` = f acc x = foldlStrict f z` xs // | /O(1)/. Decompose a map into pieces based on the structure of the underlying // tree. This function is useful for consuming a map in parallel. // // No guarantee is made as to the mapSizes of the pieces; an internal, but // deterministic process determines this. However, it is guaranteed that the pieces // returned will be in ascending order (all elements in the first submap less than all // elements in the second, and so on). // // Examples: // // > splitRoot (fromList (zip [1..6] ['a`..])) == // > [fromList [(1,'a`),(2,'b`),(3,'c')],fromList [(4,'d')],fromList [(5,'e'),(6,'f')]] // // > splitRoot newMap == [] // // Note that the current implementation does not return more than three submaps, // but you should not depend on this behaviour because it can change in the // future without notice. splitRoot :: !(Map k b) -> [Map k b] splitRoot Tip = [] splitRoot (Bin _ k v l r) = [l, singleton k v, r] // BC funs //putList :: !u:[v:(!a, !b)] !u:(Map a b) -> Map a b | == a & < a, [u <= v] //delList :: ![a] !.(Map a b) -> Map a b | == a & < a //foldlNoKey :: !(a -> b -> a) !a !(Map c b) -> a //foldrNoKey :: !(v u:a -> u:a) !u:a !(Map k v) -> u:a getU :: !k !w:(Map k v) -> x:(!Maybe v, !y:(Map k v)) | == k & < k, [ x <= y, w <= y] getU k Tip = (Nothing, Tip) getU k (Bin h nk nv left right) | k == nk = (Just nv, Bin h nk nv left right) | k < nk #! (mbv, left) = getU k left = (mbv, Bin h nk nv left right) | otherwise #! (mbv, right) = getU k right = (mbv, Bin h nk nv left right) //:: Map k a //= Bin !Size !k a !(Map k a) !(Map k a) //| Tip delU :: !a !.(Map a b) -> u:(!v:(Maybe b), !Map a b) | == a & < a, [u <= v] // !k !w:(Map k u:v) -> x:(Maybe u:v, !y:(Map k u:v)) | == k & < k, [ w y <= u, x <= y, w <= y] delU k Tip = (Nothing, Tip) //Do nothing delU k (Bin h nk nv Tip Tip) //A node with just leaves as children can be safely removed | k == nk = (Just nv, Tip) = (Nothing, Bin h nk nv Tip Tip) delU k (Bin h nk nv Tip right) //A node without smaller items | k == nk = (Just nv, right) //When found, just remove | k < nk = (Nothing, Bin h nk nv Tip right) //Do nothing, k is not in the mapping | otherwise #! (mbv, right) = delU k right #! (hright, right) = height right = (mbv, balance nk nv Tip right) delU k (Bin h nk nv left Tip) //A node without larger items | k == nk = (Just nv, left) //When found just remove | k < nk #! (mbv,left) = delU k left #! (hleft,left) = height left = (mbv, balance nk nv left Tip) | otherwise = (Nothing, Bin h nk nv left Tip) //Do nothing, k is not in hte mapping delU k (Bin h nk nv left right) //A node with both larger and smaller items | k == nk #! (left,k,v) = takeMax left #! (h,left,right) = parentHeight left right = (Just nv, balance k v left right) //Replace with the largest of the smaller items and rebalance | k < nk #! (mbv, left) = delU k left #! (h,left,right) = parentHeight left right = (mbv, balance nk nv left right) | otherwise #! (mbv, right) = delU k right #! (h,left,right) = parentHeight left right = (mbv, balance nk nv left right) where // TODO //Takes the k and v values from the maximum node in the tree and removes that node takeMax :: !(Map a b) -> (!Map a b, !a, !b) takeMax Tip = abort "takeMax of leaf evaluated" takeMax (Bin _ nk nv left Tip) = (left, nk, nv) takeMax (Bin _ nk nv left right) # (right,k,v) = takeMax right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (balance nk nv left right, k, v) //Determines the height of the parent node of two sub trees parentHeight :: !(Map a b) !(Map c d) -> (!Int, !Map a b, !Map c d) parentHeight left right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (h, left, right) height :: !u:(Map k w:v) -> x:(!Int, !y:(Map k w:v)), [u y <= w, x <= y, u <= y] height Tip = (0, Tip) height (Bin h k v left right) = (h, Bin h k v left right) /* gLessThan x y = (gLexOrd{|*|} x y) == LT singleton :: k v -> Map k v | Eq k & gLexOrd{|*|} k singleton k v = put k v newMap newMap :: (Map k v) -> Bool newMap MLeaf = True newMap _ = False mapSize :: (Map k v) -> Int mapSize MLeaf = 0 mapSize (MNode left _ _ _ right) = 1 + mapSize left + mapSize right //Insert function put :: !k u:v !w:(Map k u:v) -> x:(Map k u:v) | Eq k & gLexOrd{|*|} k, [w x <= u, w <= x] put k v MLeaf = MNode MLeaf k 1 v MLeaf put k v (MNode left nk h nv right) | k == nk = (MNode left k h v right) | k < nk # left = put k v left = update left nk nv right | otherwise # right = put k v right = update left nk nv right where update left nk nv right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = balance (MNode left nk h nv right) gPut :: !k u:v !w:(Map k u:v) -> x:(Map k u:v) | == k & gLexOrd{|*|} k, [w x <= u, w <= x] gPut k v MLeaf = MNode MLeaf k 1 v MLeaf gPut k v (MNode left nk h nv right) | k === nk = (MNode left k h v right) | gLessThan k nk # left = gPut k v left = update left nk nv right | otherwise # right = gPut k v right = update left nk nv right where update left nk nv right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = balance (MNode left nk h nv right) //Lookup function, non-unique version get :: !k !(Map k v) -> Maybe v | Eq k & gLexOrd{|*|} k get k MLeaf = Nothing get k (MNode left nk _ nv right) | k == nk = Just nv | k < nk = get k left = get k right gGet :: !k !(Map k v) -> Maybe v | == k & gLexOrd{|*|} k gGet k MLeaf = Nothing gGet k (MNode left nk _ nv right) | k === nk = Just nv | gLessThan k nk = gGet k left | otherwise = gGet k right //Lookup function, possibly spine unique version getU :: !k !w:(Map k v) -> x:(Maybe v,!y:(Map k v)) | Eq k & gLexOrd{|*|} k, [ x <= y, w <= y] getU k MLeaf = (Nothing, MLeaf) getU k (MNode left nk h nv right) | k == nk = (Just nv, MNode left nk h nv right) | k < nk # (mbv, left) = getU k left = (mbv, MNode left nk h nv right) | otherwise # (mbv, right) = getU k right = (mbv, MNode left nk h nv right) ggetu :: !k !w:(map k v) -> x:(maybe v,!y:(map k v)) | geq{|*|} k & glexord{|*|} k, [ x <= y, w <= y] gGetU k MLeaf = (Nothing, MLeaf) gGetU k (MNode left nk h nv right) | k === nk = (Just nv, MNode left nk h nv right) | gLessThan k nk # (mbv, left) = gGetU k left = (mbv, MNode left nk h nv right) | otherwise # (mbv, right) = gGetU k right = (mbv, MNode left nk h nv right) //Delete function, only spine unique version del :: !k !w:(Map k v) -> x:(Map k v) | Eq k & gLexOrd{|*|} k, [ w <= x] del k mapping = snd (delU k mapping) gDel :: !k !w:(Map k v) -> x:(Map k v) | == k & gLexOrd{|*|} k, [ w <= x] gDel k mapping = snd (gDelU k mapping) //Delete function delU :: !k !w:(Map k u:v) -> x:(Maybe u:v, !y:(Map k u:v)) | Eq k & gLexOrd{|*|} k, [ w y <= u, x <= y, w <= y] delU k MLeaf = (Nothing, MLeaf) //Do nothing delU k (MNode MLeaf nk h nv MLeaf) //A node with just leaves as children can be safely removed | k == nk = (Just nv, MLeaf) = (Nothing, MNode MLeaf nk h nv MLeaf) delU k (MNode MLeaf nk h nv right) //A node without smaller items | k == nk = (Just nv, right) //When found, just remove | k < nk = (Nothing, MNode MLeaf nk h nv right) //Do nothing, k is not in the mapping | otherwise # (mbv,right) = delU k right # (hright,right) = height right # h = hright + 1 = (mbv, balance (MNode MLeaf nk h nv right)) delU k (MNode left nk h nv MLeaf) //A node without larger items | k == nk = (Just nv, left) //When found just remove | k < nk # (mbv,left) = delU k left # (hleft,left) = height left # h = hleft + 1 = (mbv, balance (MNode left nk h nv MLeaf)) | otherwise = (Nothing, MNode left nk h nv MLeaf) //Do nothing, k is not in hte mapping delU k (MNode left nk h nv right) //A node with both larger and smaller items | k == nk # (left,k,v) = takeMax left # (h,left,right) = parentHeight left right = (Just nv, balance (MNode left k h v right)) //Replace with the largest of the smaller items and rebalance | k < nk # (mbv, left) = delU k left # (h,left,right) = parentHeight left right = (mbv, balance (MNode left nk h nv right)) | otherwise # (mbv, right) = delU k right # (h,left,right) = parentHeight left right = (mbv, balance (MNode left nk h nv right)) where //Takes the k and v values from the maximum node in the tree and removes that node takeMax MLeaf = abort "takeMax of leaf evaluated" takeMax (MNode left nk _ nv MLeaf) = (left, nk, nv) takeMax (MNode left nk _ nv right) # (right,k,v) = takeMax right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (balance (MNode left nk h nv right), k, v) //Determines the height of the parent node of two sub trees parentHeight left right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (h, left, right) gDelU :: !k !w:(Map k u:v) -> x:(Maybe u:v, !y:(Map k u:v)) | == k & gLexOrd{|*|} k, [ w y <= u, x <= y, w <= y] gDelU k MLeaf = (Nothing, MLeaf) //Do nothing gDelU k (MNode MLeaf nk h nv MLeaf) //A node with just leaves as children can be safely removed | k === nk = (Just nv, MLeaf) | otherwise = (Nothing, MNode MLeaf nk h nv MLeaf) gDelU k (MNode MLeaf nk h nv right) //A node without smaller items | k === nk = (Just nv, right) //When found, just remove | gLessThan k nk = (Nothing, MNode MLeaf nk h nv right) //Do nothing, k is not in the mapping | otherwise # (mbv,right) = gDelU k right # (hright,right) = height right # h = hright + 1 = (mbv, balance (MNode MLeaf nk h nv right)) gDelU k (MNode left nk h nv MLeaf) //A node without larger items | k === nk = (Just nv, left) //When found just remove | gLessThan k nk # (mbv,left) = gDelU k left # (hleft,left) = height left # h = hleft + 1 = (mbv, balance (MNode left nk h nv MLeaf)) | otherwise = (Nothing, MNode left nk h nv MLeaf) //Do nothing, k is not in hte mapping gDelU k (MNode left nk h nv right) //A node with both larger and smaller items | k === nk # (left,k,v) = takeMax left # (h,left,right) = parentHeight left right = (Just nv, balance (MNode left k h v right)) //Replace with the largest of the smaller items and rebalance | gLessThan k nk # (mbv, left) = gDelU k left # (h,left,right) = parentHeight left right = (mbv, balance (MNode left nk h nv right)) | otherwise # (mbv, right) = gDelU k right # (h,left,right) = parentHeight left right = (mbv, balance (MNode left nk h nv right)) where //Takes the k and v values from the maximum node in the tree and removes that node takeMax MLeaf = abort "takeMax of leaf evaluated" takeMax (MNode left nk _ nv MLeaf) = (left, nk, nv) takeMax (MNode left nk _ nv right) # (right,k,v) = takeMax right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (balance (MNode left nk h nv right), k, v) //Determines the height of the parent node of two sub trees parentHeight left right # (hleft,left) = height left # (hright,right) = height right # h = (max hleft hright) + 1 = (h, left, right) foldrWithKey :: (k v u:a -> u:a) u:a (Map k v) -> u:a foldrWithKey f z m = go z m where go z` MLeaf = z` go z` (MNode l k _ v r) = go (f k v (go z` r)) l foldrNoKey :: (v u:a -> u:a) u:a (Map k v) -> u:a foldrNoKey f z m = go z m where go z` MLeaf = z` go z` (MNode l _ _ v r) = go (f v (go z` r)) l foldlWithKey :: (u:a k v -> u:a) u:a (Map k v) -> u:a foldlWithKey f z m = go z m where go z` MLeaf = z` go z` (MNode l k _ v r) = go (f (go z` l) k v) r foldlNoKey :: (u:a v -> u:a) u:a (Map k v) -> u:a foldlNoKey f z m = go z m where go z` MLeaf = z` go z` (MNode l _ _ v r) = go (f (go z` l) v) r // TODO Replace this with an efficient implementation that does not require Eq and Ord filterWithKey :: (k a -> Bool) (Map k a) -> Map k a filterWithKey p m = fromList [(k, v) \\ (k, v) <- toList m | p k v] keys :: (Map k a) -> [k] keys m = foldrWithKey (\k _ ks -> [k : ks]) [] m elems :: (Map k a) -> [a] elems m = foldrNoKey (\x xs -> [x:xs]) [] m //Conversion functions toList :: !w:(Map k u:v) -> x:[y:(!k,u:v)] , [w y <= u, x <= y, w <= x] toList m = toList` m [] where toList` MLeaf c = c toList` (MNode left k h v right) c = toList` left [(k,v): toList` right c] fromList :: !w:[x:(!k,u:v)] -> y:(Map k u:v) | Eq k & gLexOrd{|*|} k, [x y <= u, w <= x, w <= y] fromList [] = newMap fromList [(k,v):xs] = put k v (fromList xs) gFromList :: !w:[x:(!k,u:v)] -> y:(Map k u:v) | == k & gLexOrd{|*|} k, [x y <= u, w <= x, w <= y] gFromList [] = newMap gFromList [(k,v):xs] = gPut k v (gFromList xs) putList :: !w:[x:(!k,u:v)] !w:(Map k u:v) -> y:(Map k u:v) | Eq k & gLexOrd{|*|} k, [x y <= u, w <= x, w <= y] putList [] map = map putList [(k,v):xs] map = putList xs (put k v map) gPutList :: !w:[x:(!k,u:v)] !w:(Map k u:v) -> y:(Map k u:v) | == k & gLexOrd{|*|} k, [x y <= u, w <= x, w <= y] gPutList [] map = map gPutList [(k,v):xs] map = gPutList xs (gPut k v map) delList :: ![k] !w:(Map k u:v) -> y:(Map k u:v) | Eq k & gLexOrd{|*|} k, [w y <= u, w <= y] delList list map = seq [\map -> snd (delU key map) \\ key <- list] map gDelList :: ![k] !w:(Map k u:v) -> y:(Map k u:v) | == k & gLexOrd{|*|} k, [w y <= u, w <= y] gDelList list map = seq [\map -> snd (gDelU key map) \\ key <- list] map //Helper functions //Determine the height of a tree //This information is stored inside the tree to prevent complete traversals of the tree height :: !u:(Map k w:v) -> x:(!Int, y:(Map k w:v)), [u y <= w, x <= y, u <= y] height MLeaf = (0,MLeaf) height (MNode left k h v right) = (h, MNode left k h v right) //Balance a tree locally (E.g. not recursive. only inspect and rearrange the top of the tree) balance :: !u:(Map k w:v) -> x:(Map k w:v), [u x <= w, u <= x] balance MLeaf = MLeaf balance (MNode left k h v right) # (hleft,left) = height left # (hright,right) = height right # balanceFactor = hright - hleft | balanceFactor < -1 # (ld, left) = leftDeepest left | ld = leftleftRotate (MNode left k h v right) //Left-left rotate = leftrightRotate (MNode left k h v right) //Left-right rotate | balanceFactor > 1 # (ld, right) = leftDeepest right | ld = rightleftRotate (MNode left k h v right) //Right-left rotate = rightrightRotate (MNode left k h v right) //Right-right rotate | otherwise = MNode left k h v right //Already balanced where leftDeepest MLeaf = (False,MLeaf) leftDeepest (MNode left k h v right) # (hleft,left) = height left # (hright,right) = height right = (hleft > hright,(MNode left k h v right)) leftleftRotate (MNode (MNode (MNode d xk xh xv c) pk _ pv b ) rk _ rv a) # (ah,a) = height a # (bh,b) = height b # rh = (max bh ah) + 1 # ph = (max xh rh) + 1 = MNode (MNode d xk xh xv c) pk ph pv (MNode b rk rh rv a) leftleftRotate node = node leftrightRotate (MNode (MNode b rk _ rv (MNode c pk _ pv d)) xk _ xv a) # (bh,b) = height b # (ch,c) = height c # rh = (max bh ch) + 1 # (dh,d) = height d # (ah,a) = height a # xh = (max dh ah) + 1 # ph = (max rh xh) + 1 = MNode (MNode b rk rh rv c) pk ph pv (MNode d xk xh xv a) leftrightRotate node = node rightleftRotate (MNode a xk _ xv (MNode (MNode d pk _ pv c) rk _ rv b)) # (ah,a) = height a # (dh,d) = height d # xh = (max ah dh) + 1 # (ch,c) = height c # (bh,b) = height b # rh = (max ch bh) + 1 # ph = (max xh rh) + 1 = MNode (MNode a xk xh xv d) pk ph pv (MNode c rk rh rv b) rightleftRotate node = node rightrightRotate (MNode a rk _ rv (MNode b pk _ pv (MNode c xk xh xv d))) # (ah,a) = height a # (bh,b) = height b # rh = (max ah bh) + 1 # ph = (max rh xh) + 1 = MNode (MNode a rk rh rv b) pk ph pv (MNode c xk xh xv d) rightrightRotate node = node */ derive JSONEncode Map derive JSONDecode Map derive gEq Map