|
sourcecode:
|
module Data.FiniteMap (
FM, -- abstract type
emptyFM,
unitFM,
listToFM,
addToFM,
addToFM_C,
addListToFM,
addListToFM_C,
delFromFM,
delListFromFM,
splitFM,
plusFM,
plusFM_C,
minusFM,
intersectFM,
intersectFM_C,
foldFM,
mapFM,
filterFM,
sizeFM,
eqFM,
isEmptyFM,
elemFM,
lookupFM,
lookupWithDefaultFM,
keyOrder,
fmToList,
keysFM,
eltsFM,
fmSortBy,
minFM,maxFM,updFM, fmToListPreOrder,
showFM, readFM
) where
import Data.Maybe
--- order predicates are boolean
type LeKey key = key -> key -> Bool
-----------------------------------------------
-- BUILDING finite maps
-----------------------------------------------
--- The empty finite map.
--- @param le an irreflexive order predicate on the keys.
--- @result an empty finite map
emptyFM :: (LeKey key) -> FM key _
emptyFM le = FM le EmptyFM
--- Construct a finite map with only a single element.
--- @param le an irreflexive order predicate on the keys.
--- @param key key of
--- @param elt the single element to form
--- @result a finite map with only a single element
unitFM :: (LeKey key) -> key -> elt -> FM key elt
unitFM le key elt = FM le (unitFM' key elt)
unitFM' :: key -> elt -> FiniteMap key elt
unitFM' key elt = BranchFM key elt 1 EmptyFM EmptyFM
--- Builts a finite map from given list of tuples (key,element).
--- For multiple occurences of key, the last corresponding
--- element of the list is taken.
--- @param le an irreflexive order predicate on the keys.
listToFM :: Eq key => (LeKey key) -> [(key,elt)] -> FM key elt
listToFM le = addListToFM (emptyFM le)
-----------------------------------------------
-- ADDING AND DELETING
-----------------------------------------------
--- Throws away any previous binding and stores the new one given.
addToFM :: Eq key => FM key elt -> key -> elt -> FM key elt
addToFM (FM le fm) key elt = FM le (addToFM' le fm key elt)
addToFM' :: Eq key => (LeKey key) -> FiniteMap key elt -> key -> elt
-> FiniteMap key elt
addToFM' le fm key elt = addToFM_C' le (\ _ new -> new) fm key elt
addToFM_C' :: Eq key => (LeKey key) -> (elt -> elt -> elt)
-> FiniteMap key elt -> key -> elt -> FiniteMap key elt
addToFM_C' _ _ EmptyFM key elt = unitFM' key elt
addToFM_C' le combiner (BranchFM key elt size fm_l fm_r) new_key new_elt
= if le new_key key
then mkBalBranch key elt (addToFM_C' le combiner fm_l new_key new_elt) fm_r
else
if new_key==key
then BranchFM new_key (combiner elt new_elt) size fm_l fm_r
else mkBalBranch key elt fm_l (addToFM_C' le combiner fm_r new_key new_elt)
--- Throws away any previous bindings and stores the new ones given.
--- The items are added starting with the first one in the list
addListToFM :: Eq key => FM key elt -> [(key,elt)] -> FM key elt
addListToFM (FM le fm) key_elt_pairs =
FM le (addListToFM' le fm key_elt_pairs)
addListToFM' :: Eq key => (LeKey key) -> FiniteMap key elt
-> [(key, elt)] -> FiniteMap key elt
addListToFM' le fm key_elt_pairs =
addListToFM_C' le (\ _ new -> new) fm key_elt_pairs
addListToFM_C' :: Eq key => (LeKey key) -> (elt -> elt -> elt)
-> FiniteMap key elt -> [(key, elt)] -> FiniteMap key elt
addListToFM_C' le combiner fm key_elt_pairs
= foldl add fm key_elt_pairs -- foldl adds from the left
where
add fmap (key,elt) = addToFM_C' le combiner fmap key elt
--- Instead of throwing away the old binding,
--- addToFM_C combines the new element with the old one.
--- @param combiner a function combining to elements
--- @param fm a finite map
--- @param key the key of the elements to be combined
--- @param elt the new element
--- @result a modified finite map
addToFM_C :: Eq key => (elt -> elt -> elt) -> FM key elt -> key -> elt
-> FM key elt
addToFM_C combiner (FM le fm) key elt =
FM le (addToFM_C' le combiner fm key elt)
--- Combine with a list of tuples (key,element), cf. addToFM_C
addListToFM_C :: Eq key => (elt -> elt -> elt) -> FM key elt -> [(key,elt)]
-> FM key elt
addListToFM_C combiner (FM le fm) key_elt_pairs =
FM le (addListToFM_C' le combiner fm key_elt_pairs)
--- Deletes key from finite map.
--- Deletion doesn't complain if you try to delete something
--- which isn't there
delFromFM :: Eq key => FM key elt -> key -> FM key elt
delFromFM (FM le fm) del_key = FM le (delFromFM' le fm del_key)
delFromFM' :: Eq key => (LeKey key) -> FiniteMap key elt -> key
-> FiniteMap key elt
delFromFM' _ EmptyFM _ = EmptyFM
delFromFM' le (BranchFM key elt _ fm_l fm_r) del_key
= if le del_key key
then mkBalBranch key elt (delFromFM' le fm_l del_key) fm_r
else
if del_key==key
then glueBal le fm_l fm_r
else mkBalBranch key elt fm_l (delFromFM' le fm_r del_key)
--- Deletes a list of keys from finite map.
--- Deletion doesn't complain if you try to delete something
--- which isn't there
delListFromFM :: Eq key => FM key elt -> [key] -> FM key elt
delListFromFM (FM le fm) keys = FM le (foldl (delFromFM' le) fm keys)
--- Applies a function to element bound to given key.
updFM :: Eq a => FM a b -> a -> (b -> b) -> FM a b
updFM (FM lt fm) i f = FM lt (upd fm)
where
upd EmptyFM = EmptyFM
upd (BranchFM k x h l r)
| i == k = BranchFM k (f x) h l r
| lt i k = BranchFM k x h (upd l) r
| otherwise = BranchFM k x h l (upd r)
--- Combines delFrom and lookup.
splitFM :: Eq a => FM a b -> a -> Maybe (FM a b,(a,b))
splitFM g v = maybe Nothing (\x->Just (delFromFM g v,(v,x))) (lookupFM g v)
-------------------------------------------------
-- COMBINING finite maps
-------------------------------------------------
--- Efficiently add key/element mappings of two maps into a single one.
--- Bindings in right argument shadow those in the left
plusFM :: Eq key => FM key elt -> FM key elt -> FM key elt
plusFM (FM le1 fm1) (FM _ fm2) = FM le1 (plusFM' le1 fm1 fm2)
plusFM' :: Eq key => (LeKey key)
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
plusFM' _ EmptyFM fm2 = fm2
plusFM' _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM =
(BranchFM split_key1 elt1 s1 left1 right1)
plusFM' le (BranchFM split_key1 elt1 s1 left1 right1)
(BranchFM split_key elt2 _ left right)
= mkVBalBranch le split_key elt2 (plusFM' le lts left) (plusFM' le gts right)
where
fm1 = BranchFM split_key1 elt1 s1 left1 right1
lts = splitLT le fm1 split_key
gts = splitGT le fm1 split_key
--- Efficiently combine key/element mappings of two maps into a single one,
--- cf. addToFM_C
plusFM_C :: Eq key => (elt -> elt -> elt)
-> FM key elt -> FM key elt -> FM key elt
plusFM_C combiner (FM le1 fm1) (FM _ fm2) =
FM le1 (plusFM_C' le1 combiner fm1 fm2)
plusFM_C' :: Eq key => LeKey key -> (elt -> elt -> elt)
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
plusFM_C' _ _ EmptyFM fm2 = fm2
plusFM_C' _ _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM =
BranchFM split_key1 elt1 s1 left1 right1
plusFM_C' le combiner (BranchFM split_key1 elt1 s1 left1 right1)
(BranchFM split_key elt2 _ left right)
= mkVBalBranch le split_key new_elt
(plusFM_C' le combiner lts left)
(plusFM_C' le combiner gts right)
where
fm1 = BranchFM split_key1 elt1 s1 left1 right1
lts = splitLT le fm1 split_key
gts = splitGT le fm1 split_key
new_elt = case lookupFM' le fm1 split_key of
Nothing -> elt2
Just elt1' -> combiner elt1' elt2
--- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
minusFM :: Eq key => FM key elt -> FM key elt -> FM key elt
minusFM (FM le1 fm1) (FM _ fm2) = FM le1 (minusFM' le1 fm1 fm2)
minusFM' :: Eq key => (LeKey key)
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
minusFM' _ EmptyFM _ = EmptyFM
minusFM' _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM =
BranchFM split_key1 elt1 s1 left1 right1
minusFM' le (BranchFM split_key1 elt1 s1 left1 right1)
(BranchFM split_key _ _ left right)
= glueVBal le (minusFM' le lts left) (minusFM' le gts right)
-- The two can be way different, so we need glueVBal
where
fm1 = BranchFM split_key1 elt1 s1 left1 right1
lts = splitLT le fm1 split_key -- NB gt and lt, so the equal ones
gts = splitGT le fm1 split_key -- are not in either.
--- Filters only those keys that are bound in both of the given maps.
--- The elements will be taken from the second map.
intersectFM :: Eq key => FM key elt -> FM key elt -> FM key elt
intersectFM (FM le1 fm1) (FM _ fm2) = FM le1 (intersectFM' le1 fm1 fm2)
intersectFM' :: Eq key => LeKey key
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
intersectFM' le fm1 fm2 = intersectFM_C' le (\ _ right -> right) fm1 fm2
--- Filters only those keys that are bound in both of the given maps
--- and combines the elements as in addToFM_C.
intersectFM_C :: Eq key => (elt -> elt2 -> elt3) -> FM key elt -> FM key elt2
-> FM key elt3
intersectFM_C combiner (FM le1 fm1) (FM _ fm2) =
FM le1 (intersectFM_C' le1 combiner fm1 fm2)
intersectFM_C' :: Eq key => LeKey key -> (elt -> elt2 -> elt3)
-> FiniteMap key elt -> FiniteMap key elt2 -> FiniteMap key elt3
intersectFM_C' _ _ _ EmptyFM = EmptyFM
intersectFM_C' _ _ EmptyFM (BranchFM _ _ _ _ _) = EmptyFM
intersectFM_C' le combiner (BranchFM split_key1 elt1 s1 left1 right1)
(BranchFM split_key elt2 _ left right)
| isJust maybe_elt1 -- split_elt *is* in intersection
= mkVBalBranch le split_key (combiner elt1' elt2)
(intersectFM_C' le combiner lts left)
(intersectFM_C' le combiner gts right)
| otherwise -- split_elt is *not* in intersection
= glueVBal le (intersectFM_C' le combiner lts left)
(intersectFM_C' le combiner gts right)
where
fm1 = BranchFM split_key1 elt1 s1 left1 right1
lts = splitLT le fm1 split_key -- NB gt and lt, so the equal ones
gts = splitGT le fm1 split_key -- are not in either.
maybe_elt1 = lookupFM' le fm1 split_key
Just elt1' = maybe_elt1
-------------------------------------------------------------
-- MAPPING, FOLDING, FILTERING on finite maps
-------------------------------------------------------------
--- Folds finite map by given function.
foldFM :: (key -> elt -> a -> a) -> a -> FM key elt -> a
foldFM k z (FM le fm) = foldFM' le k z fm
foldFM' :: LeKey key -> (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
foldFM' _ _ z EmptyFM = z
foldFM' le k z (BranchFM key elt _ fm_l fm_r)
= foldFM' le k (k key elt (foldFM' le k z fm_r)) fm_l
--- Applies a given function on every element in the map.
mapFM :: (key -> elt1 -> elt2) -> FM key elt1 -> FM key elt2
mapFM f (FM le fm) = FM le (mapFM' le f fm)
mapFM' :: LeKey key -> (key -> elt1 -> elt2)
-> FiniteMap key elt1 -> FiniteMap key elt2
mapFM' _ _ EmptyFM = EmptyFM
mapFM' le f (BranchFM key elt size fm_l fm_r)
= BranchFM key (f key elt) size (mapFM' le f fm_l) (mapFM' le f fm_r)
--- Yields a new finite map with only those key/element pairs matching the
--- given predicate.
filterFM :: Eq key => (key -> elt -> Bool) -> FM key elt -> FM key elt
filterFM p (FM le fm) = FM le (filterFM' le p fm)
filterFM' :: Eq key => LeKey key -> (key -> elt -> Bool)
-> FiniteMap key elt -> FiniteMap key elt
filterFM' _ _ EmptyFM = EmptyFM
filterFM' le p (BranchFM key elt _ fm_l fm_r)
| p key elt -- Keep the item
= mkVBalBranch le key elt (filterFM' le p fm_l) (filterFM' le p fm_r)
| otherwise -- Drop the item
= glueVBal le (filterFM' le p fm_l) (filterFM' le p fm_r)
-----------------------------------------------------
-- INTERROGATING finite maps
-----------------------------------------------------
--- How many elements does given map contain?
sizeFM :: FM _ _ -> Int
sizeFM (FM _ EmptyFM) = 0
sizeFM (FM _ (BranchFM _ _ size _ _)) = size
sizeFM' :: FiniteMap _ _ -> Int
sizeFM' EmptyFM = 0
sizeFM' (BranchFM _ _ size _ _) = size
--- Do two given maps contain the same key/element pairs?
eqFM :: (Eq key, Eq elt) => FM key elt -> FM key elt -> Bool
fm_1 `eqFM` fm_2 =
(sizeFM fm_1 == sizeFM fm_2) && -- quick test
(fmToList fm_1 == fmToList fm_2)
--- Is the given finite map empty?
isEmptyFM :: FM _ _ -> Bool
isEmptyFM fm = sizeFM fm == 0
--- Does given map contain given key?
elemFM :: Eq key => key -> FM key _ -> Bool
key `elemFM` fm = isJust (lookupFM fm key)
--- Retrieves element bound to given key
lookupFM :: Eq key => FM key elt -> key -> Maybe elt
lookupFM (FM le fm) key = lookupFM' le fm key
lookupFM' :: Eq key => LeKey key -> FiniteMap key elt -> key -> Maybe elt
lookupFM' _ EmptyFM _ = Nothing
lookupFM' le (BranchFM key elt _ fm_l fm_r) key_to_find
= if le key_to_find key
then lookupFM' le fm_l key_to_find
else if key_to_find==key
then Just elt
else lookupFM' le fm_r key_to_find
--- Retrieves element bound to given key.
--- If the element is not contained in map, return
--- default value.
lookupWithDefaultFM :: Eq key => FM key elt -> elt -> key -> elt
lookupWithDefaultFM fm deflt key
= case lookupFM fm key of
Nothing -> deflt
Just elt -> elt
--- Retrieves the ordering on which the given finite map is built.
keyOrder :: FM key _ -> (key->key->Bool)
keyOrder (FM lt _) = lt
--- Retrieves the smallest key/element pair in the finite map
--- according to the basic key ordering.
minFM :: FM a b -> Maybe (a,b)
minFM = min . tree
where
min EmptyFM = Nothing
min (BranchFM k x _ l _) | isBranchFM l = min l
| otherwise = Just (k,x)
--- Retrieves the greatest key/element pair in the finite map
--- according to the basic key ordering.
maxFM :: FM a b -> Maybe (a,b)
maxFM = max . tree
where
max EmptyFM = Nothing
max (BranchFM k x _ _ r) | isBranchFM r = max r
| otherwise = Just (k,x)
----------------------------------------------------
-- LISTIFYING: transform finite maps to lists
----------------------------------------------------
--- Builds a list of key/element pairs. The list is ordered
--- by the initially given irreflexive order predicate on keys.
fmToList :: FM key elt -> [(key,elt)]
fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
--- Retrieves a list of keys contained in finite map.
--- The list is ordered
--- by the initially given irreflexive order predicate on keys.
keysFM :: FM key _ -> [key]
keysFM fm = foldFM (\ key _ rest -> key : rest) [] fm
--- Retrieves a list of elements contained in finite map.
--- The list is ordered
--- by the initially given irreflexive order predicate on keys.
eltsFM :: FM _ elt -> [elt]
eltsFM fm = foldFM (\ _ elt rest -> elt : rest) [] fm
--- Retrieves list of key/element pairs in preorder of the internal tree.
--- Useful for lists that will be retransformed into a tree or to match
--- any elements regardless of basic order.
fmToListPreOrder :: FM key elt -> [(key,elt)]
fmToListPreOrder (FM _ fm) = pre fm []
where
pre EmptyFM xs = xs
pre (BranchFM k x _ l r) xs = (k,x):pre l (pre r xs)
--- Sorts a given list by inserting and retrieving from finite map.
--- Duplicates are deleted.
fmSortBy :: Eq key => LeKey key -> [key] -> [key]
fmSortBy p l = keysFM (listToFM p (zip l (repeat ())))
-----------------------------------------------------
-- reading/showing finite maps
-----------------------------------------------------
--- Transforms a finite map into a string. For efficiency reasons,
--- the tree structure is shown which is valid for reading only if one
--- uses the same ordering predicate.
showFM :: (Show k, Show v) => FM k v -> String
showFM (FM _ fm) = show fm
--- Transforms a string representation of a finite map into a finite map.
--- One has two provide the same ordering predicate as used in the
--- original finite map.
readFM :: (Read key, Read val) => LeKey key -> String -> FM key val
readFM p s = FM p (read s)
-----------------------------------------------------
-- internal Implementation
-----------------------------------------------------
data FM key elt = FM (LeKey key) (FiniteMap key elt)
tree :: FM key elt -> FiniteMap key elt
tree (FM _ fm) = fm
data FiniteMap key elt
= EmptyFM
| BranchFM key elt -- Key and elt stored here
Int{-STRICT-} -- Size >= 1
(FiniteMap key elt) -- Children
(FiniteMap key elt)
deriving (Show, Read)
isEmptyFM' :: FiniteMap _ _ -> Bool
isEmptyFM' fm = sizeFM' fm == 0
isBranchFM :: FiniteMap _ _ -> Bool
isBranchFM (BranchFM _ _ _ _ _) = True
isBranchFM EmptyFM = False
-------------------------------------------------------------------------
-- -
-- The implementation of balancing -
-- -
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-- -
-- Basic construction of a FiniteMap -
-- -
-------------------------------------------------------------------------
sIZE_RATIO :: Int
sIZE_RATIO = 5
mkBranch :: Int
-> key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
mkBranch _{-which-} key elt fm_l fm_r =
let result = BranchFM key elt (unbox (1 + left_size + right_size)) fm_l fm_r
in
result
-- if sizeFM result <= 8 then
-- result
-- else
-- pprTrace ("mkBranch:"++(show which)) (ppr result) (
-- result
-- )
where
{-left_ok = case fm_l of
EmptyFM -> True
BranchFM _ _ _ _ _ -> cmpWithBiggest_left_key key
cmpWithBiggest_left_key key' = le (fst (findMax fm_l)) key'
right_ok = case fm_r of
EmptyFM -> True
BranchFM _ _ _ _ _ -> cmpWithSmallest_right_key key
cmpWithSmallest_right_key key' = le key' (fst (findMin fm_r))
balance_ok = True -- sigh-}
left_size = sizeFM' fm_l
right_size = sizeFM' fm_r
unbox :: Int -> Int
unbox x = x
-------------------------------------------------------------------------
-- -
-- Balanced construction of a FiniteMap -
-- -
-------------------------------------------------------------------------
mkBalBranch :: key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
mkBalBranch key elt fm_L fm_R
| size_l + size_r < 2
= mkBranch 1{-which-} key elt fm_L fm_R
| size_r > sIZE_RATIO * size_l -- Right tree too big
= case fm_R of
BranchFM _ _ _ fm_rl fm_rr ->
if sizeFM' fm_rl < 2 * sizeFM' fm_rr
then single_L fm_L fm_R
else double_L fm_L fm_R
-- Other case impossible
EmptyFM -> error "FiniteMap.mkBalBranch"
| size_l > sIZE_RATIO * size_r -- Left tree too big
= case fm_L of
BranchFM _ _ _ fm_ll fm_lr ->
if sizeFM' fm_lr < 2 * sizeFM' fm_ll
then single_R fm_L fm_R
else double_R fm_L fm_R
-- Other case impossible
EmptyFM -> error "FiniteMap.mkBalBranch"
| otherwise -- No imbalance
= mkBranch 2{-which-} key elt fm_L fm_R
where
size_l = sizeFM' fm_L
size_r = sizeFM' fm_R
single_L fm_l (BranchFM key_r elt_r _ fm_rl fm_rr)
= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
single_L _ EmptyFM = error "FiniteMap.single_L"
double_L fm_l (BranchFM key_r elt_r _ (BranchFM key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
(mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
double_L _ EmptyFM = error "FiniteMap.double_L"
double_L _ (BranchFM _ _ _ EmptyFM _) = error "FiniteMap.double_L"
single_R (BranchFM key_l elt_l _ fm_ll fm_lr) fm_r
= mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
single_R EmptyFM _ = error "FiniteMap.single_R"
double_R (BranchFM key_l elt_l _ fm_ll (BranchFM key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
= mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl)
(mkBranch 12{-which-} key elt fm_lrr fm_r)
double_R EmptyFM _ = error "FiniteMap.double_R"
double_R (BranchFM _ _ _ _ EmptyFM) _ = error "FiniteMap.double_R"
mkVBalBranch :: Eq key => (LeKey key)
-> key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
-- Assert: in any call to (mkVBalBranch_C comb key elt l r),
-- (a) all keys in l are < all keys in r
-- (b) all keys in l are < key
-- (c) all keys in r are > key
mkVBalBranch le key elt EmptyFM fm_r = addToFM' le fm_r key elt
mkVBalBranch le key elt (BranchFM key_l elt_l s_l fm_ll fm_lr) EmptyFM =
addToFM' le (BranchFM key_l elt_l s_l fm_ll fm_lr) key elt
mkVBalBranch le key elt (BranchFM key_l elt_l s_l fm_ll fm_lr)
(BranchFM key_r elt_r s_r fm_rl fm_rr)
| sIZE_RATIO * size_l < size_r
= mkBalBranch key_r elt_r (mkVBalBranch le key elt fm_l fm_rl) fm_rr
| sIZE_RATIO * size_r < size_l
= mkBalBranch key_l elt_l fm_ll (mkVBalBranch le key elt fm_lr fm_r)
| otherwise
= mkBranch 13{-which-} key elt fm_l fm_r
where
fm_l = BranchFM key_l elt_l s_l fm_ll fm_lr
fm_r = BranchFM key_r elt_r s_r fm_rl fm_rr
size_l = sizeFM' fm_l
size_r = sizeFM' fm_r
-------------------------------------------------------------------------
-- -
-- Gluing two trees together -
-- -
-------------------------------------------------------------------------
glueBal :: (LeKey key)
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
glueBal le fm1 fm2 =
if isEmptyFM' fm1
then fm2
else if isEmptyFM' fm2
then fm1
else
-- The case analysis here (absent in Adams' program) is really to deal
-- with the case where fm2 is a singleton. Then deleting the minimum means
-- we pass an empty tree to mkBalBranch, which breaks its invariant.
let (mid_key1, mid_elt1) = findMax fm1
(mid_key2, mid_elt2) = findMin fm2
in
if sizeFM' fm2 > sizeFM' fm1
then mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin le fm2)
else mkBalBranch mid_key1 mid_elt1 (deleteMax le fm1) fm2
glueVBal :: (LeKey key)
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
glueVBal le fm_l fm_r =
if isEmptyFM' fm_l
then fm_r
else if isEmptyFM' fm_r
then fm_l
else
let BranchFM key_l elt_l _ fm_ll fm_lr = fm_l
BranchFM key_r elt_r _ fm_rl fm_rr = fm_r
--(mid_key_l,mid_elt_l) = findMax fm_l
--(mid_key_r,mid_elt_r) = findMin fm_r
size_l = sizeFM' fm_l
size_r = sizeFM' fm_r
in
if sIZE_RATIO * size_l < size_r
then
mkBalBranch key_r elt_r (glueVBal le fm_l fm_rl) fm_rr
else if sIZE_RATIO * size_r < size_l
then
mkBalBranch key_l elt_l fm_ll (glueVBal le fm_lr fm_r)
-- We now need the same two cases as in glueBal above.
else glueBal le fm_l fm_r
-------------------------------------------------------------------------
-- -
-- Local utilities -
-- -
-------------------------------------------------------------------------
splitLT, splitGT :: Eq key => (LeKey key) -> FiniteMap key elt -> key
-> FiniteMap key elt
-- splitLT fm split_key = fm restricted to keys < split_key
-- splitGT fm split_key = fm restricted to keys > split_key
splitLT _ EmptyFM _ = EmptyFM
splitLT le (BranchFM key elt _ fm_l fm_r) split_key
= if le split_key key
then splitLT le fm_l split_key
else if split_key == key
then fm_l
else mkVBalBranch le key elt fm_l (splitLT le fm_r split_key)
splitGT _ EmptyFM _ = EmptyFM
splitGT le (BranchFM key elt _ fm_l fm_r) split_key
= if le split_key key
then mkVBalBranch le key elt (splitGT le fm_l split_key) fm_r
else if split_key == key
then fm_r
else splitGT le fm_r split_key
findMin :: FiniteMap key elt -> (key,elt)
findMin EmptyFM = error "FiniteMap.findMin: empty map"
findMin (BranchFM key elt _ EmptyFM _) = (key,elt)
findMin (BranchFM _ _ _ (BranchFM key_l elt_l s_l fm_ll fm_lr)_) =
findMin (BranchFM key_l elt_l s_l fm_ll fm_lr)
deleteMin :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt
deleteMin _ EmptyFM = error "FiniteMap.deleteMin: empty map"
deleteMin _ (BranchFM _ _ _ EmptyFM fm_r) = fm_r
deleteMin le (BranchFM key elt _ (BranchFM key_l elt_l s_l fm_ll fm_lr) fm_r) =
mkBalBranch key elt (deleteMin le (BranchFM key_l elt_l s_l fm_ll fm_lr))
fm_r
findMax :: FiniteMap key elt -> (key,elt)
findMax EmptyFM = error "FiniteMap.findMax: empty map"
findMax (BranchFM key elt _ _ EmptyFM) = (key,elt)
findMax (BranchFM _ _ _ _ (BranchFM key_r elt_r s_r fm_rl fm_rr)) =
findMax (BranchFM key_r elt_r s_r fm_rl fm_rr)
deleteMax :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt
deleteMax _ EmptyFM = error "FiniteMap.deleteMax: empty map"
deleteMax _ (BranchFM _ _ _ fm_l EmptyFM) = fm_l
deleteMax le (BranchFM key elt _ fm_l (BranchFM key_r elt_r s_r fm_rl fm_rr)) =
mkBalBranch key elt fm_l
(deleteMax le (BranchFM key_r elt_r s_r fm_rl fm_rr))
-------------------------------------------------------------------------
-- -
-- FiniteSets---a thin veneer -
-- -
-------------------------------------------------------------------------
type FiniteSet key = FM key ()
emptySet :: (LeKey key) -> FiniteSet key
mkSet :: Eq key => (LeKey key) -> [key] -> FiniteSet key
isEmptySet :: FiniteSet _ -> Bool
elementOf :: Eq key => key -> FiniteSet key -> Bool
minusSet :: Eq key => FiniteSet key -> FiniteSet key -> FiniteSet key
setToList :: FiniteSet key -> [key]
union :: Eq key => FiniteSet key -> FiniteSet key -> FiniteSet key
emptySet = emptyFM
mkSet le xs = listToFM le [ (x, ()) | x <- xs]
isEmptySet = isEmptyFM
elementOf = elemFM
minusSet = minusFM
setToList = keysFM
union = plusFM
|