summaryrefslogtreecommitdiff
path: root/utils/nofib-analyse/GenUtils.lhs
diff options
context:
space:
mode:
Diffstat (limited to 'utils/nofib-analyse/GenUtils.lhs')
-rw-r--r--utils/nofib-analyse/GenUtils.lhs297
1 files changed, 297 insertions, 0 deletions
diff --git a/utils/nofib-analyse/GenUtils.lhs b/utils/nofib-analyse/GenUtils.lhs
new file mode 100644
index 0000000000..540199f972
--- /dev/null
+++ b/utils/nofib-analyse/GenUtils.lhs
@@ -0,0 +1,297 @@
+-----------------------------------------------------------------------------
+-- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
+
+-- Some General Utilities, including sorts, etc.
+-- This is realy just an extended prelude.
+-- All the code below is understood to be in the public domain.
+-----------------------------------------------------------------------------
+
+> module GenUtils (
+
+> partition', tack,
+> assocMaybeErr,
+> arrElem,
+> memoise,
+> returnMaybe,handleMaybe, findJust,
+> MaybeErr(..),
+> maybeMap,
+> joinMaybe,
+> mkClosure,
+> foldb,
+> sortWith,
+> sort,
+> cjustify,
+> ljustify,
+> rjustify,
+> space,
+> copy,
+> combinePairs,
+> --trace, -- re-export it
+> fst3,
+> snd3,
+> thd3
+
+#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
+
+> ,Cmp(..), compare, lookup, isJust
+
+#endif
+
+> ) where
+
+#if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 )
+
+> import Ix ( Ix(..) )
+> import Array ( listArray, array, (!) )
+
+#define Text Show
+#define ASSOC(a,b) (a , b)
+#else
+#define ASSOC(a,b) (a := b)
+#endif
+
+%------------------------------------------------------------------------------
+
+Here are two defs that everyone seems to define ...
+HBC has it in one of its builtin modules
+
+#ifdef __GOFER__
+
+ primitive primPrint "primPrint" :: Int -> a -> ShowS
+
+#endif
+
+#ifdef __GOFER__
+
+ primitive primGenericEq "primGenericEq",
+ primGenericNe "primGenericNe",
+ primGenericLe "primGenericLe",
+ primGenericLt "primGenericLt",
+ primGenericGe "primGenericGe",
+ primGenericGt "primGenericGt" :: a -> a -> Bool
+
+ instance Text (Maybe a) where { showsPrec = primPrint }
+ instance Eq (Maybe a) where
+ (==) = primGenericEq
+ (/=) = primGenericNe
+
+ instance (Ord a) => Ord (Maybe a)
+ where
+ Nothing <= _ = True
+ _ <= Nothing = True
+ (Just a) <= (Just b) = a <= b
+
+#endif
+
+> maybeMap :: (a -> b) -> Maybe a -> Maybe b
+> maybeMap f (Just a) = Just (f a)
+> maybeMap f Nothing = Nothing
+
+> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
+> joinMaybe _ Nothing Nothing = Nothing
+> joinMaybe _ (Just g) Nothing = Just g
+> joinMaybe _ Nothing (Just g) = Just g
+> joinMaybe f (Just g) (Just h) = Just (f g h)
+
+> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text)
+
+@mkClosure@ makes a closure, when given a comparison and iteration loop.
+Be careful, because if the functional always makes the object different,
+This will never terminate.
+
+> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
+> mkClosure eq f = match . iterate f
+> where
+> match (a:b:c) | a `eq` b = a
+> match (_:c) = match c
+
+> foldb :: (a -> a -> a) -> [a] -> a
+> foldb f [] = error "can't reduce an empty list using foldb"
+> foldb f [x] = x
+> foldb f l = foldb f (foldb' l)
+> where
+> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
+> foldb' (x:y:xs) = f x y : foldb' xs
+> foldb' xs = xs
+
+Merge two ordered lists into one ordered list.
+
+> mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+> mergeWith _ [] ys = ys
+> mergeWith _ xs [] = xs
+> mergeWith le (x:xs) (y:ys)
+> | x `le` y = x : mergeWith le xs (y:ys)
+> | otherwise = y : mergeWith le (x:xs) ys
+
+> insertWith :: (a -> a -> Bool) -> a -> [a] -> [a]
+> insertWith _ x [] = [x]
+> insertWith le x (y:ys)
+> | x `le` y = x:y:ys
+> | otherwise = y:insertWith le x ys
+
+Sorting is something almost every program needs, and this is the
+quickest sorting function I know of.
+
+> sortWith :: (a -> a -> Bool) -> [a] -> [a]
+> sortWith le [] = []
+> sortWith le lst = foldb (mergeWith le) (splitList lst)
+> where
+> splitList (a1:a2:a3:a4:a5:xs) =
+> insertWith le a1
+> (insertWith le a2
+> (insertWith le a3
+> (insertWith le a4 [a5]))) : splitList xs
+> splitList [] = []
+> splitList (r:rs) = [foldr (insertWith le) [r] rs]
+
+> sort :: (Ord a) => [a] -> [a]
+> sort = sortWith (<=)
+
+> returnMaybe :: a -> Maybe a
+> returnMaybe = Just
+
+> handleMaybe :: Maybe a -> Maybe a -> Maybe a
+> handleMaybe m k = case m of
+> Nothing -> k
+> _ -> m
+
+> findJust :: (a -> Maybe b) -> [a] -> Maybe b
+> findJust f = foldr handleMaybe Nothing . map f
+
+
+Gofer-like stuff:
+
+> fst3 (a,_,_) = a
+> snd3 (_,a,_) = a
+> thd3 (_,a,_) = a
+
+> cjustify, ljustify, rjustify :: Int -> String -> String
+> cjustify n s = space halfm ++ s ++ space (m - halfm)
+> where m = n - length s
+> halfm = m `div` 2
+> ljustify n s = s ++ space (n - length s)
+> rjustify n s = let s' = take n s in space (n - length s') ++ s'
+
+> space :: Int -> String
+> space n | n < 0 = ""
+> | otherwise = copy n ' '
+
+> copy :: Int -> a -> [a] -- make list of n copies of x
+> copy n x = take n xs where xs = x:xs
+
+> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]
+> partition' f [] = []
+> partition' f [x] = [[x]]
+> partition' f (x:x':xs) | f x == f x'
+> = tack x (partition' f (x':xs))
+> | otherwise
+> = [x] : partition' f (x':xs)
+
+> tack x xss = (x : head xss) : tail xss
+
+> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
+> combinePairs xs =
+> combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
+> where
+> combine [] = []
+> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
+> combine (a:r) = a : combine r
+>
+
+#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
+
+> lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
+> lookup k env = case [ val | (key,val) <- env, k == key] of
+> [] -> Nothing
+> (val:vs) -> Just val
+>
+
+> data Cmp = LT | EQ | GT
+
+> compare a b | a < b = LT
+> | a == b = EQ
+> | otherwise = GT
+
+> isJust :: Maybe a -> Bool
+> isJust (Just _) = True
+> isJust _ = False
+
+#endif
+
+> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
+> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
+> [] -> Failed "assoc: "
+> (val:vs) -> Succeeded val
+>
+
+Now some utilties involving arrays.
+Here is a version of @elem@ that uses partual application
+to optimise lookup.
+
+> arrElem :: (Ix a) => [a] -> a -> Bool
+> arrElem obj = \x -> inRange size x && arr ! x
+> where
+> obj' = sort obj
+> size = (head obj',last obj')
+> arr = listArray size [ i `elem` obj | i <- range size ]
+
+
+You can use this function to simulate memoisation. For example:
+
+ > fib = memoise (0,100) fib'
+ > where
+ > fib' 0 = 0
+ > fib' 1 = 0
+ > fib' n = fib (n-1) + fib (n-2)
+
+will give a very efficent variation of the fib function.
+
+
+> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
+> memoise bds f = (!) arr
+> where arr = array bds [ ASSOC(t, f t) | t <- range bds ]
+
+> mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> acc -- Initial accumulator
+> -> [x] -- Input list
+> -> (acc, [y]) -- Final accumulator and result list
+>
+> mapAccumR f b [] = (b, [])
+> mapAccumR f b (x:xs) = (b'', x':xs') where
+> (b'', x') = f b' x
+> (b', xs') = mapAccumR f b xs
+
+> mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> acc -- Initial accumulator
+> -> [x] -- Input list
+> -> (acc, [y]) -- Final accumulator and result list
+>
+> mapAccumL f b [] = (b, [])
+> mapAccumL f b (x:xs) = (b'', x':xs') where
+> (b', x') = f b x
+> (b'', xs') = mapAccumL f b' xs
+
+Here is the bi-directional version ...
+
+> mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
+> -- Function of elt of input list
+> -- and accumulator, returning new
+> -- accumulator and elt of result list
+> -> accl -- Initial accumulator from left
+> -> accr -- Initial accumulator from right
+> -> [x] -- Input list
+> -> (accl, accr, [y]) -- Final accumulator and result list
+>
+> mapAccumB f a b [] = (a,b,[])
+> mapAccumB f a b (x:xs) = (a'',b'',y:ys)
+> where
+> (a',b'',y) = f a b' x
+> (a'',b',ys) = mapAccumB f a' b xs
+
+
+> assert False x = error "assert Failed"
+> assert True x = x
View Lorry Controller Status