1 -----------------------------------------------------------------------------
2 -- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
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 -----------------------------------------------------------------------------
15 > returnMaybe,handleMaybe, findJust,
29 > --trace, -- re-export it
34 #if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
36 > ,Cmp(..), compare, lookup, isJust
42 #if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 )
44 > import Ix ( Ix(..) )
45 > import Array ( listArray, array, (!) )
48 #define ASSOC(a,b) (a , b)
50 #define ASSOC(a,b) (a := b)
53 %------------------------------------------------------------------------------
55 Here are two defs that everyone seems to define ...
56 HBC has it in one of its builtin modules
60 primitive primPrint "primPrint" :: Int -> a -> ShowS
66 primitive primGenericEq "primGenericEq",
67 primGenericNe "primGenericNe",
68 primGenericLe "primGenericLe",
69 primGenericLt "primGenericLt",
70 primGenericGe "primGenericGe",
71 primGenericGt "primGenericGt" :: a -> a -> Bool
73 instance Text (Maybe a) where { showsPrec = primPrint }
74 instance Eq (Maybe a) where
78 instance (Ord a) => Ord (Maybe a)
82 (Just a) <= (Just b) = a <= b
86 > maybeMap :: (a -> b) -> Maybe a -> Maybe b
87 > maybeMap f (Just a) = Just (f a)
88 > maybeMap _ Nothing = Nothing
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)
96 > data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text)
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.
102 > mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
103 > mkClosure eq f = match . iterate f
105 > match (a:b:_) | a `eq` b = a
106 > match (_:c) = match c
107 > match [] = error "GenUtils.mkClosure: Can't happen"
109 > foldb :: (a -> a -> a) -> [a] -> a
110 > foldb _ [] = error "can't reduce an empty list using foldb"
112 > foldb f l = foldb f (foldb' l)
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
118 Merge two ordered lists into one ordered list.
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
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
133 Sorting is something almost every program needs, and this is the
134 quickest sorting function I know of.
136 > sortWith :: (a -> a -> Bool) -> [a] -> [a]
138 > sortWith le lst = foldb (mergeWith le) (splitList lst)
140 > splitList (a1:a2:a3:a4:a5:xs) =
144 > (insertWith le a4 [a5]))) : splitList xs
146 > splitList (r:rs) = [foldr (insertWith le) [r] rs]
148 > sort :: (Ord a) => [a] -> [a]
149 > sort = sortWith (<=)
151 > returnMaybe :: a -> Maybe a
154 > handleMaybe :: Maybe a -> Maybe a -> Maybe a
155 > handleMaybe m k = case m of
159 > findJust :: (a -> Maybe b) -> [a] -> Maybe b
160 > findJust f = foldr handleMaybe Nothing . map f
165 > fst3 :: (a, b, c) -> a
167 > snd3 :: (a, b, c) -> b
169 > thd3 :: (a, b, c) -> c
172 > cjustify, ljustify, rjustify :: Int -> String -> String
173 > cjustify n s = space halfm ++ s ++ space (m - halfm)
174 > where m = n - length s
176 > ljustify n s = s ++ space (n - length s)
177 > rjustify n s = let s' = take n s in space (n - length s') ++ s'
179 > space :: Int -> String
180 > space n | n < 0 = ""
181 > | otherwise = copy n ' '
183 > copy :: Int -> a -> [a] -- make list of n copies of x
184 > copy n x = take n xs where xs = x:xs
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))
192 > = [x] : partition' f (x':xs)
194 > tack :: a -> [[a]] -> [[a]]
195 > tack x xss = (x : head xss) : tail xss
197 > combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
199 > combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
202 > combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
203 > combine (a:r) = a : combine r
206 #if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
208 > lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
209 > lookup k env = case [ val | (key,val) <- env, k == key] of
211 > (val:vs) -> Just val
214 > data Cmp = LT | EQ | GT
216 > compare a b | a < b = LT
220 > isJust :: Maybe a -> Bool
221 > isJust (Just _) = True
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
231 Now some utilties involving arrays.
232 Here is a version of @elem@ that uses partual application
235 > arrElem :: (Ix a) => [a] -> a -> Bool
236 > arrElem obj = \x -> inRange size x && arr ! x
239 > size = (head obj',last obj')
240 > arr = listArray size [ i `elem` obj | i <- range size ]
243 You can use this function to simulate memoisation. For example:
245 > fib = memoise (0,100) fib'
249 > fib' n = fib (n-1) + fib (n-2)
251 will give a very efficent variation of the fib function.
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 ]