Commit 075e0c07 authored by andy's avatar andy

[project @ 2000-03-09 05:59:48 by andy]

Changing use literate programming, to allow hugs to compile this program.
parent ca8c3818
......@@ -2,242 +2,246 @@ 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 (
Changed to use \begin\end code, to help
as a test example for STG Hugs.
trace,
\begin{code}
module GenUtils (
> assocMaybe, assocMaybeErr,
> arrElem,
> arrCond,
> memoise,
> Maybe(..),
> MaybeErr(..),
> mapMaybe,
> mapMaybeFail,
> maybeToBool,
> maybeToObj,
> maybeMap,
> joinMaybe,
> mkClosure,
> foldb,
> mapAccumL,
> sortWith,
> sort,
> cjustify,
> ljustify,
> rjustify,
> space,
> copy,
> combinePairs,
> formatText ) where
> import Array -- 1.3
> import Ix -- 1.3
>#ifndef __GLASGOW_HASKELL__
> import {-fool mkdependHS-}
> Trace
>#endif
%------------------------------------------------------------------------------
Here are two defs that everyone seems to define ...
HBC has it in one of its builtin modules
>#if defined(__GLASGOW_HASKELL__) || defined(__GOFER__)
> --in 1.3: data Maybe a = Nothing | Just a deriving (Eq,Ord,Text)
>#endif
> infix 1 =: -- 1.3
> type Assoc a b = (a,b) -- 1.3
> (=:) a b = (a,b)
> mapMaybe :: (a -> Maybe b) -> [a] -> [b]
> mapMaybe f [] = []
> mapMaybe f (a:r) = case f a of
> Nothing -> mapMaybe f r
> Just b -> b : mapMaybe f r
This version returns nothing, if *any* one fails.
> mapMaybeFail f (x:xs) = case f x of
> Just x' -> case mapMaybeFail f xs of
> Just xs' -> Just (x':xs')
> Nothing -> Nothing
> Nothing -> Nothing
> mapMaybeFail f [] = Just []
> maybeToBool :: Maybe a -> Bool
> maybeToBool (Just _) = True
> maybeToBool _ = False
> maybeToObj :: Maybe a -> a
> maybeToObj (Just a) = a
> maybeToObj _ = error "Trying to extract object from a Nothing"
> 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,Show{-was: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
fold-binary.
It combines the element of the list argument in balanced mannerism.
> 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 (<=)
Gofer-like stuff:
> 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 (max 0 (n - length s))
> rjustify n s = space (max 0 (n - length s)) ++ s
> space :: Int -> String
> space n = copy n ' '
> copy :: Int -> a -> [a] -- make list of n copies of x
> copy n x = take n xs where xs = x:xs
> 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
>
>
> assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
> assocMaybe env k = case [ val | (key,val) <- env, k == key] of
> [] -> Nothing
> (val:vs) -> Just val
>
> 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
>
> deSucc (Succeeded e) = e
> mapAccumL :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a)
> mapAccumL f s [] = ([],s)
> mapAccumL f s (b:bs) = (c:cs,s'')
> where
> (c,s') = f s b
> (cs,s'') = mapAccumL f s' bs
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
> size = (maximum obj,minimum obj)
> arr = listArray size [ i `elem` obj | i <- range size ]
Here is the functional version of a multi-way conditional,
again using arrays, of course. Remember @b@ can be a function !
Note again the use of partiual application.
> arrCond :: (Ix a)
> => (a,a) -- the bounds
> -> [(Assoc [a] b)] -- the simple lookups
> -> [(Assoc (a -> Bool) b)] -- the functional lookups
> -> b -- the default
> -> a -> b -- the (functional) result
> arrCond bds pairs fnPairs def = (!) arr'
> where
> arr' = array bds [ t =: head
> ([ r | (p, r) <- pairs, elem t p ] ++
> [ r | (f, r) <- fnPairs, f t ] ++
> [ def ])
> | t <- range bds ]
> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
> memoise bds f = (!) arr
> where arr = array bds [ t =: f t | t <- range bds ]
Quite neat this. Formats text to fit in a column.
> formatText :: Int -> [String] -> [String]
> formatText n = map unwords . cutAt n []
> where
> cutAt :: Int -> [String] -> [String] -> [[String]]
> cutAt m wds [] = [reverse wds]
> cutAt m wds (wd:rest) = if len <= m || null wds
> then cutAt (m-(len+1)) (wd:wds) rest
> else reverse wds : cutAt n [] (wd:rest)
> where len = length wd
trace,
assocMaybe, assocMaybeErr,
arrElem,
arrCond,
memoise,
Maybe(..),
MaybeErr(..),
mapMaybe,
mapMaybeFail,
maybeToBool,
maybeToObj,
maybeMap,
joinMaybe,
mkClosure,
foldb,
mapAccumL,
sortWith,
sort,
cjustify,
ljustify,
rjustify,
space,
copy,
combinePairs,
formatText ) where
import Array -- 1.3
import Ix -- 1.3
#ifndef __GLASGOW_HASKELL__
import {-fool mkdependHS-}
IOExts( trace )
#endif
-- -------------------------------------------------------------------------
-- Here are two defs that everyone seems to define ...
-- HBC has it in one of its builtin modules
#if defined(__GLASGOW_HASKELL__) || defined(__GOFER__)
--in 1.3: data Maybe a = Nothing | Just a deriving (Eq,Ord,Text)
#endif
infix 1 =: -- 1.3
type Assoc a b = (a,b) -- 1.3
(=:) a b = (a,b)
mapMaybe :: (a -> Maybe b) -> [a] -> [b]
mapMaybe f [] = []
mapMaybe f (a:r) = case f a of
Nothing -> mapMaybe f r
Just b -> b : mapMaybe f r
-- This version returns nothing, if *any* one fails.
mapMaybeFail f (x:xs) = case f x of
Just x' -> case mapMaybeFail f xs of
Just xs' -> Just (x':xs')
Nothing -> Nothing
Nothing -> Nothing
mapMaybeFail f [] = Just []
maybeToBool :: Maybe a -> Bool
maybeToBool (Just _) = True
maybeToBool _ = False
maybeToObj :: Maybe a -> a
maybeToObj (Just a) = a
maybeToObj _ = error "Trying to extract object from a Nothing"
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,Show{-was: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
-- fold-binary.
-- It combines the element of the list argument in balanced mannerism.
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 (<=)
-- Gofer-like stuff:
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 (max 0 (n - length s))
rjustify n s = space (max 0 (n - length s)) ++ s
space :: Int -> String
space n = copy n ' '
copy :: Int -> a -> [a] -- make list of n copies of x
copy n x = take n xs where xs = x:xs
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
assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
assocMaybe env k = case [ val | (key,val) <- env, k == key] of
[] -> Nothing
(val:vs) -> Just val
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
deSucc (Succeeded e) = e
mapAccumL :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a)
mapAccumL f s [] = ([],s)
mapAccumL f s (b:bs) = (c:cs,s'')
where
(c,s') = f s b
(cs,s'') = mapAccumL f s' bs
-- 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
size = (maximum obj,minimum obj)
arr = listArray size [ i `elem` obj | i <- range size ]
-- Here is the functional version of a multi-way conditional,
-- again using arrays, of course. Remember @b@ can be a function !
-- Note again the use of partiual application.
arrCond :: (Ix a)
=> (a,a) -- the bounds
-> [(Assoc [a] b)] -- the simple lookups
-> [(Assoc (a -> Bool) b)] -- the functional lookups
-> b -- the default
-> a -> b -- the (functional) result
arrCond bds pairs fnPairs def = (!) arr'
where
arr' = array bds [ t =: head
([ r | (p, r) <- pairs, elem t p ] ++
[ r | (f, r) <- fnPairs, f t ] ++
[ def ])
| t <- range bds ]
memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
memoise bds f = (!) arr
where arr = array bds [ t =: f t | t <- range bds ]
-- Quite neat this. Formats text to fit in a column.
formatText :: Int -> [String] -> [String]
formatText n = map unwords . cutAt n []
where
cutAt :: Int -> [String] -> [String] -> [[String]]
cutAt m wds [] = [reverse wds]
cutAt m wds (wd:rest) = if len <= m || null wds
then cutAt (m-(len+1)) (wd:wds) rest
else reverse wds : cutAt n [] (wd:rest)
where len = length wd
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment