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 :: Bag a
  30 emptyBag = EmptyBag
  31
  32 unitBag :: a -> Bag a
  33 unitBag  = UnitBag
  34
  35 elemBag :: Eq a => a -> Bag a -> Bool
  36 elemBag _ EmptyBag        = False
  37 elemBag x (UnitBag y)     = x==y
  38 elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
  39 elemBag x (ListBag ys)    = any (x ==) ys
  40 elemBag x (ListOfBags bs) = any (x `elemBag`) bs
  41
  42 unionManyBags :: [Bag a] -> Bag a
  43 unionManyBags [] = EmptyBag
  44 unionManyBags xs = ListOfBags xs
  45
  46 -- This one is a bit stricter! The bag will get completely evaluated.
  47
  48 unionBags :: Bag a -> Bag a -> Bag a
  49 unionBags EmptyBag b = b
  50 unionBags b EmptyBag = b
  51 unionBags b1 b2      = TwoBags b1 b2
  52
  53 consBag :: a -> Bag a -> Bag a
  54 snocBag :: Bag a -> a -> Bag a
  55
  56 consBag elt bag = (unitBag elt) `unionBags` bag
  57 snocBag bag elt = bag `unionBags` (unitBag elt)
  58
  59 isEmptyBag :: Bag a -> Bool
  60 isEmptyBag EmptyBag         = True
  61 isEmptyBag (UnitBag _)      = False
  62 isEmptyBag (TwoBags b1 b2)  = isEmptyBag b1 && isEmptyBag b2    -- Paranoid, but safe
  63 isEmptyBag (ListBag xs)     = null xs                           -- Paranoid, but safe
  64 isEmptyBag (ListOfBags bs)  = all isEmptyBag bs
  65
  66 filterBag :: (a -> Bool) -> Bag a -> Bag a
  67 filterBag _ EmptyBag           = EmptyBag
  68 filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
  69 filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
  70                                where
  71                                  sat1 = filterBag pred b1
  72                                  sat2 = filterBag pred b2
  73 filterBag pred (ListBag vs)    = listToBag (filter pred vs)
  74 filterBag pred (ListOfBags bs) = ListOfBags sats
  75                                 where
  76                                  sats = [filterBag pred b | b <- bs]
  77
  78 concatBag :: Bag (Bag a) -> Bag a
  79
  80 concatBag EmptyBag          = EmptyBag
  81 concatBag (UnitBag b)       = b
  82 concatBag (TwoBags b1 b2)   = concatBag b1 `TwoBags` concatBag b2
  83 concatBag (ListBag bs)      = ListOfBags bs
  84 concatBag (ListOfBags bbs)  = ListOfBags (map concatBag bbs)
  85
  86 partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
  87                                          Bag a {- Don't -})
  88 partitionBag _    EmptyBag = (EmptyBag, EmptyBag)
  89 partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
  90 partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
  91                                   where
  92                                     (sat1,fail1) = partitionBag pred b1
  93                                     (sat2,fail2) = partitionBag pred b2
  94 partitionBag pred (ListBag vs)    = (listToBag sats, listToBag fails)
  95                                   where
  96                                     (sats,fails) = partition pred vs
  97 partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
  98                                   where
  99                                     (sats, fails) = unzip [partitionBag pred b | b <- bs]
 100
 101
 102 foldBag :: (r -> r -> r)        -- Replace TwoBags with this; should be associative
 103         -> (a -> r)             -- Replace UnitBag with this
 104         -> r                    -- Replace EmptyBag with this
 105         -> Bag a
 106         -> r
 107
 108 {- Standard definition
 109 foldBag _ _ e EmptyBag        = e
 110 foldBag t u e (UnitBag x)     = u x
 111 foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
 112 foldBag t u e (ListBag xs)    = foldr (t.u) e xs
 113 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
 114 -}
 115
 116 -- More tail-recursive definition, exploiting associativity of "t"
 117 foldBag _ _ e EmptyBag        = e
 118 foldBag t u e (UnitBag x)     = u x `t` e
 119 foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
 120 foldBag t u e (ListBag xs)    = foldr (t.u) e xs
 121 foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
 122
 123
 124 mapBag :: (a -> b) -> Bag a -> Bag b
 125 mapBag _ EmptyBag        = EmptyBag
 126 mapBag f (UnitBag x)     = UnitBag (f x)
 127 mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
 128 mapBag f (ListBag xs)    = ListBag (map f xs)
 129 mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
 130
 131
 132 listToBag :: [a] -> Bag a
 133 listToBag [] = EmptyBag
 134 listToBag vs = ListBag vs
 135
 136 bagToList :: Bag a -> [a]
 137 bagToList EmptyBag     = []
 138 bagToList (ListBag vs) = vs
 139 bagToList b = bagToList_append b []
 140
 141     -- (bagToList_append b xs) flattens b and puts xs on the end.
 142     -- (not exported)
 143 bagToList_append :: Bag a -> [a] -> [a]
 144 bagToList_append EmptyBag        xs = xs
 145 bagToList_append (UnitBag x)     xs = x:xs
 146 bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
 147 bagToList_append (ListBag xx)    xs = xx++xs
 148 bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
 149 \end{code}