-lookupWithDefaultFM fm deflt key
- = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Listifying @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
-keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm
-eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The implementation of balancing}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Basic construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBranch@ simply gets the size component right. This is the ONLY
-(non-trivial) place the Branch object is built, so the ASSERTion
-recursively checks consistency. (The trivial use of Branch is in
-@unitFM@.)
-
-\begin{code}
-sIZE_RATIO :: Int
-sIZE_RATIO = 5
-
-mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
- => Int
- -> key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBranch which key elt fm_l fm_r
- = --ASSERT( left_ok && right_ok && balance_ok )
-#if defined(DEBUG_FINITEMAPS)
- if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show which)
- (vcat [ppr [left_ok, right_ok, balance_ok],
- ppr key,
- ppr fm_l,
- ppr fm_r])
- else
-#endif
- let
- result = Branch key elt (1 + left_size + right_size) fm_l fm_r
- in
--- if sizeFM result <= 8 then
- result
--- else
--- pprTrace ("mkBranch:"++(show which)) (ppr result) (
--- result
--- )
- where
- left_ok = case fm_l of
- EmptyFM -> True
- Branch left_key _ _ _ _ -> let
- biggest_left_key = fst (findMax fm_l)
- in
- biggest_left_key < key
- right_ok = case fm_r of
- EmptyFM -> True
- Branch right_key _ _ _ _ -> let
- smallest_right_key = fst (findMin fm_r)
- in
- key < smallest_right_key
- balance_ok = True -- sigh
-{- LATER:
- balance_ok
- = -- Both subtrees have one or no elements...
- (left_size + right_size <= 1)
--- NO || left_size == 0 -- ???
--- NO || right_size == 0 -- ???
- -- ... or the number of elements in a subtree does not exceed
- -- sIZE_RATIO times the number of elements in the other subtree
- || (left_size * sIZE_RATIO >= right_size &&
- right_size * sIZE_RATIO >= left_size)
--}
-
- left_size = sizeFM fm_l
- right_size = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{{\em Balanced} construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
-out of whack.
-
-\begin{code}
-mkBalBranch :: (Ord key OUTPUTABLE_key)
- => 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
- Branch _ _ _ fm_rl fm_rr
- | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
- | otherwise -> double_L fm_L fm_R
- -- Other case impossible
-
- | size_l > sIZE_RATIO * size_r -- Left tree too big
- = case fm_L of
- Branch _ _ _ fm_ll fm_lr
- | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
- | otherwise -> double_R fm_L fm_R
- -- Other case impossible
-
- | 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 (Branch 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
-
- double_L fm_l (Branch key_r elt_r _ (Branch 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)
-
- single_R (Branch 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)
-
- double_R (Branch key_l elt_l _ fm_ll (Branch 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)
-\end{code}
-
-
-\begin{code}
-mkVBalBranch :: (Ord key OUTPUTABLE_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 key elt EmptyFM fm_r = addToFM fm_r key elt
-mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
-
-mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
-
- | otherwise
- = mkBranch 13{-which-} key elt fm_l fm_r
-
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Gluing two trees together}
-%* *
-%************************************************************************
-
-@glueBal@ assumes its two arguments aren't too far out of whack, just
-like @mkBalBranch@. But: all keys in first arg are $<$ all keys in
-second.
-
-\begin{code}
-glueBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueBal EmptyFM fm2 = fm2
-glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
- -- 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.
- | sizeFM fm2 > sizeFM fm1
- = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
- | otherwise
- = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
- where
- (mid_key1, mid_elt1) = findMax fm1
- (mid_key2, mid_elt2) = findMin fm2
-\end{code}
-
-@glueVBal@ copes with arguments which can be of any size.
-But: all keys in first arg are $<$ all keys in second.
-
-\begin{code}
-glueVBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueVBal EmptyFM fm2 = fm2
-glueVBal fm1 EmptyFM = fm1
-glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
-
- | otherwise -- We now need the same two cases as in glueBal above.
- = glueBal fm_l fm_r
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utilities}
-%* *
-%************************************************************************
-
-\begin{code}
-splitLT, splitGT :: (Ord key OUTPUTABLE_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 split_key = emptyFM
-splitLT (Branch key elt _ fm_l fm_r) split_key
- = case compare split_key key of
- LT -> splitLT fm_l split_key
- GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- EQ -> fm_l
-
-splitGT EmptyFM split_key = emptyFM
-splitGT (Branch key elt _ fm_l fm_r) split_key
- = case compare split_key key of
- GT -> splitGT fm_r split_key
- LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- EQ -> fm_r
-
-findMin :: FiniteMap key elt -> (key,elt)
-findMin (Branch key elt _ EmptyFM _) = (key,elt)
-findMin (Branch key elt _ fm_l _) = findMin fm_l
-
-deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
-deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
-
-findMax :: FiniteMap key elt -> (key,elt)
-findMax (Branch key elt _ _ EmptyFM) = (key,elt)
-findMax (Branch key elt _ _ fm_r) = findMax fm_r
-
-deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
-deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)