1 
    2 
    3 
    4   module Utilities( 
    5         Assn, assLookup,
    6         NameSupply, initialNameSupply, newName,
    7         Set, setFromList, setEmpty, setSingleton, setToList,
    8                 setUnion, setIntersect, setDifference, setUnionList,
    9         Bag, bagFromList, bagEmpty, bagSingleton, bagToList,
   10                 bagInsert, bagUnion,
   11         mapAccuml
   12   ) where
   13  
   14 
   15 
   16 
   17 
   18 
   19 
   20   type Assn key value = [(key, value)]
   21  
   22   assLookup :: Eq key => Assn key value -> key -> value
   23   assLookup alist key = head [value | (key',value) <- alist, key == key']
   24 
   25 
   26 
   27   data NameSupply = MkNS Int
   28  
   29   initialNameSupply :: NameSupply
   30   initialNameSupply = MkNS 0
   31 
   32   newName :: NameSupply -> String -> (NameSupply, String)
   33   newName (MkNS n) prefix = (MkNS (n+1), prefix ++ show n)
   34 
   35 
   36 
   37 
   38 
   39 
   40   data Set a = MkSet [a]
   41 
   42 
   43 
   44 
   45 
   46 
   47 
   48   setFromList xs = MkSet (sortNoDups xs)
   49   setEmpty = MkSet []   
   50   setSingleton x = MkSet [x]
   51   setToList (MkSet xs) = xs
   52 
   53 
   54 
   55   setUnion (MkSet xs) (MkSet ys) =
   56     MkSet (merge xs ys) where
   57         merge xs [] = xs
   58         merge [] ys = ys
   59         merge xs@(x:xs') ys@(y:ys') | x<y   = x : merge xs' ys
   60                                     | x==y  = x : merge xs' ys'
   61                                     | x>y   = y : merge xs ys'
   62 
   63   setIntersect (MkSet xs) (MkSet ys) =
   64     MkSet (intersect xs ys) where
   65         intersect [] ys = []
   66         intersect xs [] = []
   67         intersect xs@(x:xs') ys@(y:ys') | x<y   = intersect xs' ys
   68                                         | x==y  = x : intersect xs' ys'
   69                                         | x>y   = intersect xs ys'
   70 
   71   setDifference (MkSet xs) (MkSet ys) = 
   72     MkSet (difference xs ys) where
   73         difference [] ys = []
   74         difference xs [] = xs
   75         difference xs@(x:xs') ys@(y:ys') | x<y   = x : difference xs' ys
   76                                          | x==y  = difference xs' ys'
   77                                          | x>y   = difference xs ys'
   78 
   79   setUnionList ss = foldr setUnion setEmpty ss
   80 
   81 
   82 
   83 
   84 
   85   data Bag a = MkBag [a]
   86   bagEmpty = MkBag []
   87   bagSingleton x = MkBag [x]
   88   bagFromList xs = MkBag xs
   89   bagToList (MkBag xs) = xs
   90   bagInsert x (MkBag xs) = MkBag (x:xs)
   91   bagUnion (MkBag xs) (MkBag ys) = MkBag (xs ++ ys)
   92 
   93 
   94 
   95 
   96   mapAccuml :: (b -> a -> (b, c))       -- Function of elt of input list
   97                                         -- and accumulator, returning new
   98                                         -- accumulator and elt of result list
   99             -> b                -- Initial accumulator
  100             -> [a]              -- Input list
  101             -> (b, [c])         -- Final accumulator and result list
  102  
  103   mapAccuml f b []     = (b, [])
  104   mapAccuml f b (x:xs) = (b'', x':xs') where 
  105                                           (b', x') = f b x 
  106                                           (b'', xs') = mapAccuml f b' xs
  107 
  108 
  109 
  110   sortNoDups :: Ord a => [a] -> [a]
  111   sortNoDups [] = []
  112   sortNoDups (x:xs) = sortNoDups [y | y <- xs, y < x] 
  113                       ++ [x] ++
  114                       sortNoDups [y | y <- xs, y > x]
  115 
  116