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 _ 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:_) | a `eq` b = a
 106 >       match (_:c)              = match c
 107 >       match [] = error "GenUtils.mkClosure: Can't happen"
 108
 109 > foldb :: (a -> a -> a) -> [a] -> a
 110 > foldb _ [] = error "can't reduce an empty list using foldb"
 111 > foldb _ [x] = x
 112 > foldb f l  = foldb f (foldb' l)
 113 >    where
 114 >       foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
 115 >       foldb' (x:y:xs) = f x y : foldb' xs
 116 >       foldb' xs = xs
 117
 118 Merge two ordered lists into one ordered list.
 119
 120 > mergeWith               :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 121 > mergeWith _ []     ys      = ys
 122 > mergeWith _ xs     []      = xs
 123 > mergeWith le (x:xs) (y:ys)
 124 >        | x `le` y  = x : mergeWith le xs (y:ys)
 125 >        | otherwise = y : mergeWith le (x:xs) ys
 126
 127 > insertWith              :: (a -> a -> Bool) -> a -> [a] -> [a]
 128 > insertWith _ x []          = [x]
 129 > insertWith le x (y:ys)
 130 >        | x `le` y     = x:y:ys
 131 >        | otherwise    = y:insertWith le x ys
 132
 133 Sorting is something almost every program needs, and this is the
 134 quickest sorting function I know of.
 135
 136 > sortWith :: (a -> a -> Bool) -> [a] -> [a]
 137 > sortWith _ [] = []
 138 > sortWith le lst = foldb (mergeWith le) (splitList lst)
 139 >   where
 140 >       splitList (a1:a2:a3:a4:a5:xs) =
 141 >                insertWith le a1
 142 >               (insertWith le a2
 143 >               (insertWith le a3
 144 >               (insertWith le a4 [a5]))) : splitList xs
 145 >       splitList [] = []
 146 >       splitList (r:rs) = [foldr (insertWith le) [r] rs]
 147
 148 > sort :: (Ord a) => [a] -> [a]
 149 > sort = sortWith (<=)
 150
 151 > returnMaybe :: a -> Maybe a
 152 > returnMaybe = Just
 153
 154 > handleMaybe :: Maybe a -> Maybe a -> Maybe a
 155 > handleMaybe m k = case m of
 156 >                Nothing -> k
 157 >                _ -> m
 158
 159 > findJust :: (a -> Maybe b) -> [a] -> Maybe b
 160 > findJust f = foldr handleMaybe Nothing . map f
 161
 162
 163 Gofer-like stuff:
 164
 165 > fst3 :: (a, b, c) -> a
 166 > fst3 (a, _, _) = a
 167 > snd3 :: (a, b, c) -> b
 168 > snd3 (_, a, _) = a
 169 > thd3 :: (a, b, c) -> c
 170 > thd3 (_, _, a) = a
 171
 172 > cjustify, ljustify, rjustify :: Int -> String -> String
 173 > cjustify n s = space halfm ++ s ++ space (m - halfm)
 174 >                where m     = n - length s
 175 >                      halfm = m `div` 2
 176 > ljustify n s = s ++ space (n - length s)
 177 > rjustify n s = let s' = take n s in space (n - length s') ++ s'
 178
 179 > space       :: Int -> String
 180 > space n | n < 0 = ""
 181 >         | otherwise = copy n ' '
 182
 183 > copy  :: Int -> a -> [a]      -- make list of n copies of x
 184 > copy n x = take n xs where xs = x:xs
 185
 186 > partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]
 187 > partition' _ [] = []
 188 > partition' _ [x] = [[x]]
 189 > partition' f (x:x':xs) | f x == f x'
 190 >    = tack x (partition' f (x':xs))
 191 >                       | otherwise
 192 >    = [x] : partition' f (x':xs)
 193
 194 > tack :: a -> [[a]] -> [[a]]
 195 > tack x xss = (x : head xss) : tail xss
 196
 197 > combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
 198 > combinePairs xs =
 199 >       combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
 200 >  where
 201 >       combine [] = []
 202 >       combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
 203 >       combine (a:r) = a : combine r
 204 >
 205
 206 #if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
 207
 208 > lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
 209 > lookup k env = case [ val | (key,val) <- env, k == key] of
 210 >                [] -> Nothing
 211 >                (val:vs) -> Just val
 212 >
 213
 214 > data Cmp = LT | EQ | GT
 215
 216 > compare a b | a <  b    = LT
 217 >             | a == b    = EQ
 218 >             | otherwise = GT
 219
 220 > isJust :: Maybe a -> Bool
 221 > isJust (Just _) = True
 222 > isJust _        = False
 223
 224 #endif
 225
 226 > assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
 227 > assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
 228 >                        [] -> Failed "assoc: "
 229 >                        (val:_) -> Succeeded val
 230
 231 Now some utilties involving arrays.
 232 Here is a version of @elem@ that uses partual application
 233 to optimise lookup.
 234
 235 > arrElem :: (Ix a) => [a] -> a -> Bool
 236 > arrElem obj = \x -> inRange size x && arr ! x
 237 >   where
 238 >       obj' = sort obj
 239 >       size = (head obj',last obj')
 240 >       arr = listArray size [ i `elem` obj | i <- range size ]
 241
 242
 243 You can use this function to simulate memoisation. For example:
 244
 245       > fib = memoise (0,100) fib'
 246       >   where
 247       >       fib' 0 = 0
 248       >       fib' 1 = 0
 249       >       fib' n = fib (n-1) + fib (n-2)
 250
 251 will give a very efficent variation of the fib function.
 252
 253
 254 > memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
 255 > memoise bds f = (!) arr
 256 >   where arr = array bds [ ASSOC(t, f t) | t <- range bds ]
 257