content: 
  
  
  
  
  
  
  
  
  module GenUtils (
  
          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 Data.Array -- 1.3
  import Data.Ix    -- 1.3
  
  import Debug.Trace ( trace )
  
  
  -- -------------------------------------------------------------------------
  
  -- Here are two defs that everyone seems to define ...
  -- HBC has it in one of its builtin modules
  
  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 utilities involving arrays.
  -- Here is a version of @elem@ that uses partial 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 partial 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
  
  
  
  