glafp-utils/nofib-analyse/GenUtils.lhs

   1 -----------------------------------------------------------------------------
   2 -- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
   3
   4 -- Some General Utilities, including sorts, etc.
   5 -- This is realy just an extended prelude.
   6 -- All the code below is understood to be in the public domain.
   7 -----------------------------------------------------------------------------
   8
   9 > module GenUtils (
  10
  11 >       partition', tack,
  12 >       assocMaybeErr,
  13 >       arrElem,
  14 >       memoise,
  15 >       returnMaybe,handleMaybe, findJust,
  16 >       MaybeErr(..),
  17 >       maybeMap,
  18 >       joinMaybe,
  19 >       mkClosure,
  20 >       foldb,
  21 >       sortWith,
  22 >       sort,
  23 >       cjustify,
  24 >       ljustify,
  25 >       rjustify,
  26 >       space,
  27 >       copy,
  28 >       combinePairs,
  29 >       --trace,                -- re-export it
  30 >       fst3,
  31 >       snd3,
  32 >       thd3
  33
  34 #if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
  35
  36 >       ,Cmp(..), compare, lookup, isJust
  37
  38 #endif
  39
  40 >        ) where
  41
  42 #if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 )
  43
  44 > import Ix    ( Ix(..) )
  45 > import Array ( listArray, array, (!) )
  46
  47 #define Text Show
  48 #define ASSOC(a,b) (a , b)
  49 #else
  50 #define ASSOC(a,b) (a := b)
  51 #endif
  52
  53 %------------------------------------------------------------------------------
  54
  55 Here are two defs that everyone seems to define ...
  56 HBC has it in one of its builtin modules
  57
  58 #ifdef __GOFER__
  59
  60  primitive primPrint "primPrint" :: Int -> a -> ShowS
  61
  62 #endif
  63
  64 #ifdef __GOFER__
  65
  66  primitive primGenericEq "primGenericEq",
  67            primGenericNe "primGenericNe",
  68            primGenericLe "primGenericLe",
  69            primGenericLt "primGenericLt",
  70            primGenericGe "primGenericGe",
  71            primGenericGt "primGenericGt"   :: a -> a -> Bool
  72
  73  instance Text (Maybe a) where { showsPrec = primPrint }
  74  instance Eq (Maybe a) where
  75        (==) = primGenericEq
  76        (/=) = primGenericNe
  77
  78  instance (Ord a) => Ord (Maybe a)
  79    where
  80        Nothing  <=  _       = True
  81        _        <=  Nothing = True
  82        (Just a) <= (Just b) = a <= b
  83
  84 #endif
  85
  86 > maybeMap :: (a -> b) -> Maybe a -> Maybe b
  87 > maybeMap f (Just a) = Just (f a)
  88 > maybeMap f Nothing  = Nothing
  89
  90 > joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
  91 > joinMaybe _ Nothing  Nothing  = Nothing
  92 > joinMaybe _ (Just g) Nothing  = Just g
  93 > joinMaybe _ Nothing  (Just g) = Just g
  94 > joinMaybe f (Just g) (Just h) = Just (f g h)
  95
  96 > data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text)
  97
  98 @mkClosure@ makes a closure, when given a comparison and iteration loop.
  99 Be careful, because if the functional always makes the object different,
 100 This will never terminate.
 101
 102 > mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
 103 > mkClosure eq f = match . iterate f
 104 >   where
 105 >       match (a:b:c) | a `eq` b = a
 106 >       match (_:c)              = match c
 107
 108 > foldb :: (a -> a -> a) -> [a] -> a
 109 > foldb f [] = error "can't reduce an empty list using foldb"
 110 > foldb f [x] = x
 111 > foldb f l  = foldb f (foldb' l)
 112 >    where
 113 >       foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
 114 >       foldb' (x:y:xs) = f x y : foldb' xs
 115 >       foldb' xs = xs
 116
 117 Merge two ordered lists into one ordered list.
 118
 119 > mergeWith               :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 120 > mergeWith _ []     ys      = ys
 121 > mergeWith _ xs     []      = xs
 122 > mergeWith le (x:xs) (y:ys)
 123 >        | x `le` y  = x : mergeWith le xs (y:ys)
 124 >        | otherwise = y : mergeWith le (x:xs) ys
 125
 126 > insertWith              :: (a -> a -> Bool) -> a -> [a] -> [a]
 127 > insertWith _ x []          = [x]
 128 > insertWith le x (y:ys)
 129 >        | x `le` y     = x:y:ys
 130 >        | otherwise    = y:insertWith le x ys
 131
 132 Sorting is something almost every program needs, and this is the
 133 quickest sorting function I know of.
 134
 135 > sortWith :: (a -> a -> Bool) -> [a] -> [a]
 136 > sortWith le [] = []
 137 > sortWith le lst = foldb (mergeWith le) (splitList lst)
 138 >   where
 139 >       splitList (a1:a2:a3:a4:a5:xs) =
 140 >                insertWith le a1
 141 >               (insertWith le a2
 142 >               (insertWith le a3
 143 >               (insertWith le a4 [a5]))) : splitList xs
 144 >       splitList [] = []
 145 >       splitList (r:rs) = [foldr (insertWith le) [r] rs]
 146
 147 > sort :: (Ord a) => [a] -> [a]
 148 > sort = sortWith (<=)
 149
 150 > returnMaybe :: a -> Maybe a
 151 > returnMaybe = Just
 152
 153 > handleMaybe :: Maybe a -> Maybe a -> Maybe a
 154 > handleMaybe m k = case m of
 155 >                Nothing -> k
 156 >                _ -> m
 157
 158 > findJust :: (a -> Maybe b) -> [a] -> Maybe b
 159 > findJust f = foldr handleMaybe Nothing . map f
 160
 161
 162 Gofer-like stuff:
 163
 164 > fst3 (a,_,_) = a
 165 > snd3 (_,a,_) = a
 166 > thd3 (_,a,_) = a
 167
 168 > cjustify, ljustify, rjustify :: Int -> String -> String
 169 > cjustify n s = space halfm ++ s ++ space (m - halfm)
 170 >                where m     = n - length s
 171 >                      halfm = m `div` 2
 172 > ljustify n s = s ++ space (n - length s)
 173 > rjustify n s = let s' = take n s in space (n - length s') ++ s'
 174
 175 > space       :: Int -> String
 176 > space n | n < 0 = ""
 177 >         | otherwise = copy n ' '
 178
 179 > copy  :: Int -> a -> [a]      -- make list of n copies of x
 180 > copy n x = take n xs where xs = x:xs
 181
 182 > partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]
 183 > partition' f [] = []
 184 > partition' f [x] = [[x]]
 185 > partition' f (x:x':xs) | f x == f x'
 186 >    = tack x (partition' f (x':xs))
 187 >                       | otherwise
 188 >    = [x] : partition' f (x':xs)
 189
 190 > tack x xss = (x : head xss) : tail xss
 191
 192 > combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
 193 > combinePairs xs =
 194 >       combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
 195 >  where
 196 >       combine [] = []
 197 >       combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
 198 >       combine (a:r) = a : combine r
 199 >
 200
 201 #if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
 202
 203 > lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
 204 > lookup k env = case [ val | (key,val) <- env, k == key] of
 205 >                [] -> Nothing
 206 >                (val:vs) -> Just val
 207 >
 208
 209 > data Cmp = LT | EQ | GT
 210
 211 > compare a b | a <  b    = LT
 212 >             | a == b    = EQ
 213 >             | otherwise = GT
 214
 215 > isJust :: Maybe a -> Bool
 216 > isJust (Just _) = True
 217 > isJust _        = False
 218
 219 #endif
 220
 221 > assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
 222 > assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
 223 >                        [] -> Failed "assoc: "
 224 >                        (val:vs) -> Succeeded val
 225 >
 226
 227 Now some utilties involving arrays.
 228 Here is a version of @elem@ that uses partual application
 229 to optimise lookup.
 230
 231 > arrElem :: (Ix a) => [a] -> a -> Bool
 232 > arrElem obj = \x -> inRange size x && arr ! x
 233 >   where
 234 >       obj' = sort obj
 235 >       size = (head obj',last obj')
 236 >       arr = listArray size [ i `elem` obj | i <- range size ]
 237
 238
 239 You can use this function to simulate memoisation. For example:
 240
 241       > fib = memoise (0,100) fib'
 242       >   where
 243       >       fib' 0 = 0
 244       >       fib' 1 = 0
 245       >       fib' n = fib (n-1) + fib (n-2)
 246
 247 will give a very efficent variation of the fib function.
 248
 249
 250 > memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
 251 > memoise bds f = (!) arr
 252 >   where arr = array bds [ ASSOC(t, f t) | t <- range bds ]
 253
 254 > mapAccumR :: (acc -> x -> (acc, y))         -- Function of elt of input list
 255 >                                     -- and accumulator, returning new
 256 >                                     -- accumulator and elt of result list
 257 >         -> acc                      -- Initial accumulator
 258 >         -> [x]                      -- Input list
 259 >         -> (acc, [y])               -- Final accumulator and result list
 260 >
 261 > mapAccumR f b []     = (b, [])
 262 > mapAccumR f b (x:xs) = (b'', x':xs') where
 263 >                                       (b'', x') = f b' x
 264 >                                       (b', xs') = mapAccumR f b xs
 265
 266 > mapAccumL :: (acc -> x -> (acc, y))   -- Function of elt of input list
 267 >                                       -- and accumulator, returning new
 268 >                                       -- accumulator and elt of result list
 269 >           -> acc                      -- Initial accumulator
 270 >           -> [x]                      -- Input list
 271 >           -> (acc, [y])               -- Final accumulator and result list
 272 >
 273 > mapAccumL f b []     = (b, [])
 274 > mapAccumL f b (x:xs) = (b'', x':xs') where
 275 >                                         (b', x') = f b x
 276 >                                         (b'', xs') = mapAccumL f b' xs
 277
 278 Here is the bi-directional version ...
 279
 280 > mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 281 >                                       -- Function of elt of input list
 282 >                                       -- and accumulator, returning new
 283 >                                       -- accumulator and elt of result list
 284 >           -> accl                     -- Initial accumulator from left
 285 >           -> accr                     -- Initial accumulator from right
 286 >           -> [x]                      -- Input list
 287 >           -> (accl, accr, [y])        -- Final accumulator and result list
 288 >
 289 > mapAccumB f a b []     = (a,b,[])
 290 > mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 291 >    where
 292 >       (a',b'',y)    = f a b' x
 293 >       (a'',b',ys) = mapAccumB f a' b xs
 294
 295
 296 > assert False x = error "assert Failed"
 297 > assert True  x = x