-\begin{code}
-plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
-
-plusUFM_C _ EmptyUFM tr = tr
-plusUFM_C _ tr EmptyUFM = tr
-plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
- where
- mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
- mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
-
- mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = mix_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' (C j j')
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' j j'
- -- / \ / \
- -- t1 t2 t1' t2'
- -- Fast, Ehh !
- --
- mix_branches (NewRoot nd False)
- = mkLLNodeUFM nd left_t right_t
- mix_branches (NewRoot nd True)
- = mkLLNodeUFM nd right_t left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- mix_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (mix_trees t1 t1')
- (mix_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2 + j'
- -- / \
- -- t1' t2'
- mix_branches (LeftRoot Leftt) -- | trace "LL" True
- = mkSLNodeUFM
- (NodeUFMData j p)
- (mix_trees t1 right_t)
- t2
-
- mix_branches (LeftRoot Rightt) -- | trace "LR" True
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (mix_trees t2 right_t)
-
- mix_branches (RightRoot Leftt) -- | trace "RL" True
- = mkSLNodeUFM
- (NodeUFMData j' p')
- (mix_trees left_t t1')
- t2'
-
- mix_branches (RightRoot Rightt) -- | trace "RR" True
- = mkLSNodeUFM
- (NodeUFMData j' p')
- t1'
- (mix_trees left_t t2')
-
- mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
-\end{code}
-
-And ways of subtracting them. First the base cases,
-then the full D&C approach.
-
-\begin{code}
-minusUFM EmptyUFM _ = EmptyUFM
-minusUFM t1 EmptyUFM = t1
-minusUFM fm1 fm2 = minus_trees fm1 fm2
- where
- --
- -- Notice the asymetry of subtraction
- --
- minus_trees lf@(LeafUFM i _a) t2 =
- case lookUp t2 i of
- Nothing -> lf
- Just _ -> EmptyUFM
-
- minus_trees t1 (LeafUFM i _) = delete t1 i
-
- minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = minus_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2
- --
- --
- -- Fast, Ehh !
- --
- minus_branches (NewRoot _ _) = left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- minus_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (minus_trees t1 t1')
- (minus_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- -- again, with asymatry
-
- --
- -- The left is above the right
- --
- minus_branches (LeftRoot Leftt)
- = mkSLNodeUFM
- (NodeUFMData j p)
- (minus_trees t1 right_t)
- t2
- minus_branches (LeftRoot Rightt)
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (minus_trees t2 right_t)
-
- --
- -- The right is above the left
- --
- minus_branches (RightRoot Leftt)
- = minus_trees left_t t1'
- minus_branches (RightRoot Rightt)
- = minus_trees left_t t2'
-
- minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
-\end{code}
-
-And taking the intersection of two UniqFM's.
-
-\begin{code}
-intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
-intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
-
-intersectUFM_C _ EmptyUFM _ = EmptyUFM
-intersectUFM_C _ _ EmptyUFM = EmptyUFM
-intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
- where
- intersect_trees (LeafUFM i a) t2 =
- case lookUp t2 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f a b)
-
- intersect_trees t1 (LeafUFM i a) =
- case lookUp t1 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f b a)
-
- intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = intersect_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j'
- -- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
- -- Fast, Ehh !
- --
- intersect_branches (NewRoot _nd _) = EmptyUFM
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
- intersect_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (intersect_trees t1 t1')
- (intersect_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' t2 + j'
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1' t2'
- --
- -- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Leftt)
- = intersect_trees t1 right_t
- intersect_branches (LeftRoot Rightt)
- = intersect_trees t2 right_t
- intersect_branches (RightRoot Leftt)
- = intersect_trees left_t t1'
- intersect_branches (RightRoot Rightt)
- = intersect_trees left_t t2'
-
- intersect_trees _ _ = panic ("EmptyUFM found when intersecting trees")
-\end{code}
-
-Now the usual set of `collection' operators, like map, fold, etc.
-
-\begin{code}
-foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
-foldUFM f a (LeafUFM _ obj) = f obj a
-foldUFM _ a EmptyUFM = a
-\end{code}
-
-\begin{code}
-mapUFM _fn EmptyUFM = EmptyUFM
-mapUFM fn fm = map_tree fn fm
-
-filterUFM _fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree (\_ e -> fn e) fm
-
-filterUFM_Directly _fn EmptyUFM = EmptyUFM
-filterUFM_Directly fn fm = filter_tree pred fm
- where
- pred i e = fn (mkUniqueGrimily (iBox i)) e
-\end{code}
-
-Note, this takes a long time, O(n), but
-because we dont want to do this very often, we put up with this.
-O'rable, but how often do we look at the size of
-a finite map?
-
-\begin{code}
-sizeUFM EmptyUFM = 0
-sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
-sizeUFM (LeafUFM _ _) = 1
-
-isNullUFM EmptyUFM = True
-isNullUFM _ = False
-
--- hashing is used in VarSet.uniqAway, and should be fast
--- We use a cheap and cheerful method for now
-hashUFM EmptyUFM = 0
-hashUFM (NodeUFM n _ _ _) = iBox n
-hashUFM (LeafUFM n _) = iBox n
-\end{code}
-
-looking up in a hurry is the {\em whole point} of this binary tree lark.
-Lookup up a binary tree is easy (and fast).
-
-\begin{code}
-elemUFM key fm = maybeToBool (lookupUFM fm key)
-elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
-
-lookupUFM fm key = lookUp fm (getKeyFastInt (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKeyFastInt key)
-
-lookupWithDefaultUFM fm deflt key
- = case lookUp fm (getKeyFastInt (getUnique key)) of
- Nothing -> deflt
- Just elt -> elt
-
-lookupWithDefaultUFM_Directly fm deflt key
- = case lookUp fm (getKeyFastInt key) of
- Nothing -> deflt
- Just elt -> elt
-
-lookUp :: UniqFM a -> FastInt -> Maybe a
-lookUp EmptyUFM _ = Nothing
-lookUp fm i = lookup_tree fm
- where
- lookup_tree :: UniqFM a -> Maybe a
-
- lookup_tree (LeafUFM j b)
- | j ==# i = Just b
- | otherwise = Nothing
- lookup_tree (NodeUFM j _ t1 t2)
- | j ># i = lookup_tree t1
- | otherwise = lookup_tree t2
-
- lookup_tree EmptyUFM = panic "lookup Failed"
-\end{code}
-
-folds are *wonderful* things.
-
-\begin{code}
-eltsUFM fm = foldUFM (:) [] fm
-keysUFM fm = foldUFM_Directly (\u _ l -> u : l) [] fm
-ufmToList fm = foldUFM_Directly (\u e l -> (u, e) : l) [] fm
-foldUFM_Directly f = fold_tree (\iu e a -> f (mkUniqueGrimily (iBox iu)) e a)
-
-fold_tree :: (FastInt -> elt -> a -> a) -> a -> UniqFM elt -> a
-fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
-fold_tree f a (LeafUFM iu obj) = f iu obj a
-fold_tree _ a EmptyUFM = a