%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
-#include "HsVersions.h"
-
module Bag (
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
mapBag,
elemBag,
- filterBag, partitionBag, concatBag, foldBag, foldrBag,
- isEmptyBag, consBag, snocBag,
- listToBag, bagToList
+ filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
+ isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
+ listToBag, bagToList,
+ mapBagM, mapAndUnzipBagM
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
+
+import Outputable
+import Util ( isSingleton )
+import List ( partition )
+\end{code}
-import Outputable --( interpp'SP )
-import Pretty
+\begin{code}
data Bag a
= EmptyBag
| UnitBag a
- | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
- -- one branch is non-empty
- | ListBag [a] -- The list is non-empty
- | ListOfBags [Bag a] -- The list is non-empty
+ | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
+ | ListBag [a] -- INVARIANT: the list is non-empty
emptyBag = EmptyBag
unitBag = UnitBag
elemBag x (UnitBag y) = x==y
elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
elemBag x (ListBag ys) = any (x ==) ys
-elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-unionManyBags [] = EmptyBag
-unionManyBags xs = ListOfBags xs
+unionManyBags :: [Bag a] -> Bag a
+unionManyBags xs = foldr unionBags EmptyBag xs
-- This one is a bit stricter! The bag will get completely evaluated.
+unionBags :: Bag a -> Bag a -> Bag a
unionBags EmptyBag b = b
unionBags b EmptyBag = b
unionBags b1 b2 = TwoBags b1 b2
consBag elt bag = (unitBag elt) `unionBags` bag
snocBag bag elt = bag `unionBags` (unitBag elt)
-isEmptyBag EmptyBag = True
-isEmptyBag (UnitBag x) = False
-isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe
-isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe
-isEmptyBag (ListOfBags bs) = all isEmptyBag bs
+isEmptyBag EmptyBag = True
+isEmptyBag other = False -- NB invariants
+
+isSingletonBag :: Bag a -> Bool
+isSingletonBag EmptyBag = False
+isSingletonBag (UnitBag x) = True
+isSingletonBag (TwoBags b1 b2) = False -- Neither is empty
+isSingletonBag (ListBag xs) = isSingleton xs
filterBag :: (a -> Bool) -> Bag a -> Bag a
filterBag pred EmptyBag = EmptyBag
sat1 = filterBag pred b1
sat2 = filterBag pred b2
filterBag pred (ListBag vs) = listToBag (filter pred vs)
-filterBag pred (ListOfBags bs) = ListOfBags sats
- where
- sats = [filterBag pred b | b <- bs]
-concatBag :: Bag (Bag a) -> Bag a
+anyBag :: (a -> Bool) -> Bag a -> Bool
+anyBag p EmptyBag = False
+anyBag p (UnitBag v) = p v
+anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2
+anyBag p (ListBag xs) = any p xs
+concatBag :: Bag (Bag a) -> Bag a
concatBag EmptyBag = EmptyBag
concatBag (UnitBag b) = b
-concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2
-concatBag (ListBag bs) = ListOfBags bs
-concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs)
+concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2
+concatBag (ListBag bs) = unionManyBags bs
partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
Bag a {- Don't -})
partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
where
(sats,fails) = partition pred vs
-partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
- where
- (sats, fails) = unzip [partitionBag pred b | b <- bs]
foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
foldBag t u e (UnitBag x) = u x
foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
foldBag t u e (ListBag xs) = foldr (t.u) e xs
-foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
-}
-- More tail-recursive definition, exploiting associativity of "t"
foldBag t u e (UnitBag x) = u x `t` e
foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
foldBag t u e (ListBag xs) = foldr (t.u) e xs
-foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
foldrBag :: (a -> r -> r) -> r
-> Bag a
foldrBag k z (UnitBag x) = k x z
foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1
foldrBag k z (ListBag xs) = foldr k z xs
-foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z bs
+
+foldlBag :: (r -> a -> r) -> r
+ -> Bag a
+ -> r
+
+foldlBag k z EmptyBag = z
+foldlBag k z (UnitBag x) = k z x
+foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
+foldlBag k z (ListBag xs) = foldl k z xs
mapBag :: (a -> b) -> Bag a -> Bag b
mapBag f (UnitBag x) = UnitBag (f x)
mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
mapBag f (ListBag xs) = ListBag (map f xs)
-mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
+mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b)
+mapBagM f EmptyBag = return EmptyBag
+mapBagM f (UnitBag x) = do { r <- f x; return (UnitBag r) }
+mapBagM f (TwoBags b1 b2) = do { r1 <- mapBagM f b1; r2 <- mapBagM f b2; return (TwoBags r1 r2) }
+mapBagM f (ListBag xs) = do { rs <- mapM f xs; return (ListBag rs) }
+
+mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)
+mapAndUnzipBagM f EmptyBag = return (EmptyBag, EmptyBag)
+mapAndUnzipBagM f (UnitBag x) = do { (r,s) <- f x; return (UnitBag r, UnitBag s) }
+mapAndUnzipBagM f (TwoBags b1 b2) = do { (r1,s1) <- mapAndUnzipBagM f b1
+ ; (r2,s2) <- mapAndUnzipBagM f b2
+ ; return (TwoBags r1 r2, TwoBags s1 s2) }
+mapAndUnzipBagM f (ListBag xs) = do { ts <- mapM f xs
+ ; let (rs,ss) = unzip ts
+ ; return (ListBag rs, ListBag ss) }
listToBag :: [a] -> Bag a
listToBag [] = EmptyBag
\begin{code}
instance (Outputable a) => Outputable (Bag a) where
- ppr sty EmptyBag = ptext SLIT("emptyBag")
- ppr sty (UnitBag a) = ppr sty a
- ppr sty (TwoBags b1 b2) = hsep [ppr sty b1 <> comma, ppr sty b2]
- ppr sty (ListBag as) = interpp'SP sty as
- ppr sty (ListOfBags bs) = brackets (interpp'SP sty bs)
-
+ ppr EmptyBag = ptext SLIT("emptyBag")
+ ppr (UnitBag a) = ppr a
+ ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2]
+ ppr (ListBag as) = interpp'SP as
\end{code}
projects / ghc-hetmet.git / blobdiff