ghc/lib/misc/Bag.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Bags]{@Bag@: an unordered collection with duplicates}
   5
   6 \begin{code}
   7 module Bag (
   8         Bag,    -- abstract type
   9
  10         emptyBag, unitBag, unionBags, unionManyBags,
  11         mapBag,
  12         elemBag,
  13
  14         filterBag, partitionBag, concatBag, foldBag,
  15         isEmptyBag, consBag, snocBag,
  16         listToBag, bagToList
  17     ) where
  18
  19 import List(partition)
  20
  21 data Bag a
  22   = EmptyBag
  23   | UnitBag     a
  24   | TwoBags     (Bag a) (Bag a) -- The ADT guarantees that at least
  25                                 -- one branch is non-empty
  26   | ListBag     [a]             -- The list is non-empty
  27   | ListOfBags  [Bag a]         -- The list is non-empty
  28
  29 emptyBag = EmptyBag
  30 unitBag  = UnitBag
  31
  32 elemBag :: Eq a => a -> Bag a -> Bool
  33
  34 elemBag x EmptyBag        = False
  35 elemBag x (UnitBag y)     = x==y
  36 elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
  37 elemBag x (ListBag ys)    = any (x ==) ys
  38 elemBag x (ListOfBags bs) = any (x `elemBag`) bs
  39
  40 unionManyBags [] = EmptyBag
  41 unionManyBags xs = ListOfBags xs
  42
  43 -- This one is a bit stricter! The bag will get completely evaluated.
  44
  45 unionBags EmptyBag b = b
  46 unionBags b EmptyBag = b
  47 unionBags b1 b2      = TwoBags b1 b2
  48
  49 consBag :: a -> Bag a -> Bag a
  50 snocBag :: Bag a -> a -> Bag a
  51
  52 consBag elt bag = (unitBag elt) `unionBags` bag
  53 snocBag bag elt = bag `unionBags` (unitBag elt)
  54
  55 isEmptyBag EmptyBag         = True
  56 isEmptyBag (UnitBag x)      = False
  57 isEmptyBag (TwoBags b1 b2)  = isEmptyBag b1 && isEmptyBag b2    -- Paranoid, but safe
  58 isEmptyBag (ListBag xs)     = null xs                           -- Paranoid, but safe
  59 isEmptyBag (ListOfBags bs)  = all isEmptyBag bs
  60
  61 filterBag :: (a -> Bool) -> Bag a -> Bag a
  62 filterBag pred EmptyBag = EmptyBag
  63 filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
  64 filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
  65                                where
  66                                  sat1 = filterBag pred b1
  67                                  sat2 = filterBag pred b2
  68 filterBag pred (ListBag vs)    = listToBag (filter pred vs)
  69 filterBag pred (ListOfBags bs) = ListOfBags sats
  70                                 where
  71                                  sats = [filterBag pred b | b <- bs]
  72
  73 concatBag :: Bag (Bag a) -> Bag a
  74
  75 concatBag EmptyBag          = EmptyBag
  76 concatBag (UnitBag b)       = b
  77 concatBag (TwoBags b1 b2)   = concatBag b1 `TwoBags` concatBag b2
  78 concatBag (ListBag bs)      = ListOfBags bs
  79 concatBag (ListOfBags bbs)  = ListOfBags (map concatBag bbs)
  80
  81 partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
  82                                          Bag a {- Don't -})
  83 partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
  84 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
  85 partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
  86                                   where
  87                                     (sat1,fail1) = partitionBag pred b1
  88                                     (sat2,fail2) = partitionBag pred b2
  89 partitionBag pred (ListBag vs)    = (listToBag sats, listToBag fails)
  90                                   where
  91                                     (sats,fails) = partition pred vs
  92 partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
  93                                   where
  94                                     (sats, fails) = unzip [partitionBag pred b | b <- bs]
  95
  96
  97 foldBag :: (r -> r -> r)        -- Replace TwoBags with this; should be associative
  98         -> (a -> r)             -- Replace UnitBag with this
  99         -> r                    -- Replace EmptyBag with this
 100         -> Bag a
 101         -> r
 102
 103 {- Standard definition
 104 foldBag t u e EmptyBag        = e
 105 foldBag t u e (UnitBag x)     = u x
 106 foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
 107 foldBag t u e (ListBag xs)    = foldr (t.u) e xs
 108 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
 109 -}
 110
 111 -- More tail-recursive definition, exploiting associativity of "t"
 112 foldBag t u e EmptyBag        = e
 113 foldBag t u e (UnitBag x)     = u x `t` e
 114 foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
 115 foldBag t u e (ListBag xs)    = foldr (t.u) e xs
 116 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
 117
 118
 119 mapBag :: (a -> b) -> Bag a -> Bag b
 120 mapBag f EmptyBag        = EmptyBag
 121 mapBag f (UnitBag x)     = UnitBag (f x)
 122 mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
 123 mapBag f (ListBag xs)    = ListBag (map f xs)
 124 mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
 125
 126
 127 listToBag :: [a] -> Bag a
 128 listToBag [] = EmptyBag
 129 listToBag vs = ListBag vs
 130
 131 bagToList :: Bag a -> [a]
 132 bagToList EmptyBag     = []
 133 bagToList (ListBag vs) = vs
 134 bagToList b = bagToList_append b []
 135
 136     -- (bagToList_append b xs) flattens b and puts xs on the end.
 137     -- (not exported)
 138 bagToList_append EmptyBag        xs = xs
 139 bagToList_append (UnitBag x)     xs = x:xs
 140 bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
 141 bagToList_append (ListBag xx)    xs = xx++xs
 142 bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
 143 \end{code}