-- ==========================================================--
-- === Utilities File: utils.m (1) ===--
-- ==========================================================--
module Utils where
import MyUtils
import BaseDefs
-- ====================================--
-- === Haskell compatability ===--
-- ====================================--
-- ==========================================================--
--
copy :: Int -> a -> [a]
copy n x = take (max 0 n) xs where xs = x:xs
-- ==========================================================--
--
sort :: (Ord a) => [a] -> [a]
sort [] = []
sort (a:x) = insert a (sort x)
where
insert :: (Ord a) => a -> [a] -> [a]
insert a [] = [a]
insert a (b:x) | a <=b = a:b:x
| otherwise = b:insert a x
-- ==========================================================--
--
layn :: [[Char]] -> [Char]
layn x = f 1 x
where
f :: Int -> [[Char]] -> [Char]
f n [] = []
f n (a:x) = rjustify 4 (show n) ++") "++a++"\n"++f (n+1) x
-- ==========================================================--
--
rjustify :: Int -> [Char] -> [Char]
rjustify n s = spaces (n - length s)++s
where
spaces :: Int -> [Char]
spaces m = copy m ' '
-- ==========================================================--
--
ljustify :: Int -> [Char] -> [Char]
ljustify n s = s ++ spaces (n - length s)
where
spaces :: Int -> [Char]
spaces m = copy m ' '
-- ==========================================================--
--
utRandomInts :: Int -> Int -> [Int]
utRandomInts s1 s2
= let seed1_ok = 1 <= s1 && s1 <= 2147483562
seed2_ok = 1 <= s2 && s2 <= 2147483398
rands :: Int -> Int -> [Int]
rands s1 s2
= let k = s1 `div` 53668
s1' = 40014 * (s1 - k * 53668) - k * 12211
s1'' = if s1' < 0 then s1' + 2147483563 else s1'
k' = s2 `div` 52774
s2' = 40692 * (s2 - k' * 52774) - k' * 3791
s2'' = if s2' < 0 then s2' + 2147483399 else s2'
z = s1'' - s2''
in
if z < 1
then z + 2147483562 : rands s1'' s2''
else z : rands s1'' s2''
in
if seed1_ok && seed2_ok
then rands s1 s2
else panic "utRandomInts: bad seeds"
-- ====================================--
-- === Projection functions for ===--
-- === the static component ===--
-- ====================================--
utSCdexprs :: StaticComponent -> DExprEnv
utSCdexprs (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= dexprs
utSCdomains :: StaticComponent -> DSubst
utSCdomains (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= domains
utSCconstrelems :: StaticComponent -> AList Naam [ConstrElem]
utSCconstrelems (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= constrelems
utSCfreevars :: StaticComponent -> AList Naam [Naam]
utSCfreevars (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= freevars
utSCflags :: StaticComponent -> [Flag]
utSCflags (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= flags
utSClims :: StaticComponent -> (Int, Int, Int, Int, Int)
utSClims (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= lims
utSCsizes :: StaticComponent -> AList Domain Int
utSCsizes (dexprs, domains, constrelems, freevars, flags, lims, sizes)
= sizes
-- ====================================--
-- === Association lists ===--
-- ====================================--
-- ==========================================================--
--
utLookup [] k' = Nothing
utLookup ((k,v):bs) k' | k == k' = Just v
| otherwise = utLookup bs k'
-- ==========================================================--
--
utSureLookup [] msg k'
= panic ( "utSureLookup: key not found in " ++ msg )
utSureLookup ((k,v):bs) msg k'
| k == k' = v
| otherwise = utSureLookup bs msg k'
-- ==========================================================--
--
utLookupDef [] k' defawlt = defawlt
utLookupDef ((k,v):bs) k' defawlt | k == k' = v
| otherwise = utLookupDef bs k' defawlt
-- ==========================================================--
--
utEmpty = []
-- ==========================================================--
--
utDomain al = map first al
-- ==========================================================--
--
utRange al = map second al
-- ==========================================================--
--
utLookupAll [] k' = []
utLookupAll ((k,v):bs) k' | k == k' = v: utLookupAll bs k'
| otherwise = utLookupAll bs k'
-- ====================================--
-- === nameSupply ===--
-- ====================================--
-- ==========================================================--
--
utInitialNameSupply :: NameSupply
utInitialNameSupply = 0
-- ==========================================================--
--
utGetName :: NameSupply -> [Char] -> (NameSupply, [Char])
utGetName name_supply prefix
= (name_supply+1, utMakeName prefix name_supply)
-- ==========================================================--
--
utGetNames :: NameSupply -> [[Char]] -> (NameSupply, [[Char]])
utGetNames name_supply prefixes
= (name_supply + length prefixes,
zipWith utMakeName prefixes (myIntsFrom name_supply))
-- ==========================================================--
--
utMakeName prefix ns = prefix ++ ")" ++ show ns
-- ====================================--
-- === iseq ===--
-- ====================================--
-- ==========================================================--
--
utiConcat :: [Iseq] -> Iseq
utiConcat = foldr utiAppend utiNil
-- ==========================================================--
--
utiInterleave :: Iseq -> [Iseq] -> Iseq
utiInterleave is [] = utiNil
utiInterleave is iss = foldl1 glue iss
where glue is1 is2 = is1 `utiAppend` (is `utiAppend` is2)
foldl1 f (x:xs) = foldl f x xs
-- ==========================================================--
--
utiLayn :: [Iseq] -> Iseq
utiLayn iss = utiLaynN 1 iss
where
utiLaynN :: Int -> [Iseq] -> Iseq
utiLaynN n [] = utiNil
utiLaynN n (is:isz)
= utiConcat [ (utiLjustify 4 (utiAppend (utiNum n) (utiStr ") "))),
(utiIndent is),
(utiLaynN (n+1) isz)
]
-- ==========================================================--
--
utiLjustify :: Int -> Iseq -> Iseq
utiLjustify n s
= s `utiAppend` (utiStr (utpspaces (n - length (utiMkStr s)) ""))
-- ==========================================================--
--
utiNum :: Int -> Iseq
utiNum = utiStr . show
-- ==========================================================--
--
utiFWNum :: Int -> Int -> Iseq
utiFWNum width n
= utiStr (utpspaces spaces_reqd digits)
where
digits = show {-num-} n
spaces_reqd | length digits >= width = 0
| otherwise = width - length digits
-- ====================================--
-- === oseq ===--
-- ====================================--
-- ==========================================================--
--
utoEmpty :: Oseq -- An empty oseq
utoEmpty indent col = []
-- ==========================================================--
--
utoMkstr :: Oseq -> [Char]
utoMkstr oseq = oseq 0 0
-- ==========================================================--
--
utiNil = id
-- ==========================================================--
--
utiAppend = (.)
-- ==========================================================--
--
utiStr = foldr (utiAppend . utiChar) utiNil
-- ==========================================================--
--
utiMkStr iseq = utoMkstr (iseq utoEmpty)
-- ==========================================================--
--
utiChar :: Char -> Iseq
utiChar '\n' rest indent col = '\n' : rest indent 0
utiChar c rest indent col
| col>=indent = c : rest indent (col+1)
| otherwise = utpspaces (indent - col) (c : rest indent (indent+1))
-- ==========================================================--
--
utiIndent iseq oseq indent col
= iseq oseq' (max col indent) col
where
oseq' indent' col' = oseq indent col'
-- Ignore the indent passed along to oseq;
-- use the original indent instead.
-- ==========================================================--
--
utpspaces :: Int -> [Char] -> [Char]
utpspaces n cs | n <= 0 = cs
| otherwise = ' ' : utpspaces (n-1) cs
-- ====================================--
-- === set ===--
-- ====================================--
-- ==========================================================--
--
--unMkSet :: (Ord a) => Set a -> [a]
unMkSet (MkSet s) = s
-- ==========================================================--
--
--utSetEmpty :: (Ord a) => Set a
utSetEmpty = MkSet []
-- ==========================================================--
--
--utSetIsEmpty :: (Ord a) => Set a -> Bool
utSetIsEmpty (MkSet s) = s == []
-- ==========================================================--
--
--utSetSingleton :: (Ord a) => a -> Set a
utSetSingleton x = MkSet [x]
-- ==========================================================--
--
--utSetFromList :: (Ord a) => [a] -> Set a
utSetFromList x = (MkSet . rmdup . sort) x
where rmdup [] = []
rmdup [x] = [x]
rmdup (x:y:xs) | x==y = rmdup (y:xs)
| otherwise = x: rmdup (y:xs)
-- ==========================================================--
--
--utSetToList :: (Ord a) => Set a -> [a]
utSetToList (MkSet xs) = xs
-- ==========================================================--
--
--utSetUnion :: (Ord a) => Set a -> Set a -> Set a
utSetUnion (MkSet []) (MkSet []) = (MkSet [])
utSetUnion (MkSet []) (MkSet (b:bs)) = (MkSet (b:bs))
utSetUnion (MkSet (a:as)) (MkSet []) = (MkSet (a:as))
utSetUnion (MkSet (a:as)) (MkSet (b:bs))
| a < b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet (b:bs)))))
| a == b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet bs))))
| a > b = MkSet (b: (unMkSet (utSetUnion (MkSet (a:as)) (MkSet bs))))
-- ==========================================================--
--
--utSetIntersection :: (Ord a) => Set a -> Set a -> Set a
utSetIntersection (MkSet []) (MkSet []) = (MkSet [])
utSetIntersection (MkSet []) (MkSet (b:bs)) = (MkSet [])
utSetIntersection (MkSet (a:as)) (MkSet []) = (MkSet [])
utSetIntersection (MkSet (a:as)) (MkSet (b:bs))
| a < b = utSetIntersection (MkSet as) (MkSet (b:bs))
| a == b = MkSet (a: (unMkSet (utSetIntersection (MkSet as) (MkSet bs))))
| a > b = utSetIntersection (MkSet (a:as)) (MkSet bs)
-- ==========================================================--
--
--utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a
utSetSubtraction (MkSet []) (MkSet []) = (MkSet [])
utSetSubtraction (MkSet []) (MkSet (b:bs)) = (MkSet [])
utSetSubtraction (MkSet (a:as)) (MkSet []) = (MkSet (a:as))
utSetSubtraction (MkSet (a:as)) (MkSet (b:bs))
| a < b = MkSet (a: (unMkSet (utSetSubtraction (MkSet as) (MkSet (b:bs)))))
| a == b = utSetSubtraction (MkSet as) (MkSet bs)
| a > b = utSetSubtraction (MkSet (a:as)) (MkSet bs)
-- ==========================================================--
--
--utSetElementOf :: (Ord a) => a -> Set a -> Bool
utSetElementOf x (MkSet []) = False
utSetElementOf x (MkSet (y:ys)) = x==y || (x>y && utSetElementOf x (MkSet ys))
-- ==========================================================--
--
--utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool
utSetSubsetOf (MkSet []) (MkSet bs) = True
utSetSubsetOf (MkSet (a:as)) (MkSet bs)
= utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs)
-- ==========================================================--
--
--utSetUnionList :: (Ord a) => [Set a] -> Set a
utSetUnionList setList = foldl utSetUnion utSetEmpty setList
-- ====================================--
-- === bag ===--
-- ====================================--
-- ==========================================================--
--
utBagUnion :: Bag a -> Bag a -> Bag a
utBagUnion as bs = as ++ bs
-- ==========================================================--
--
utBagInsert :: a -> Bag a -> Bag a
utBagInsert a as = a:as
-- ==========================================================--
--
utBagToList :: Bag a -> [a]
utBagToList xs = xs
-- ==========================================================--
--
utBagFromList :: [a] -> Bag a
utBagFromList xs = xs
-- ==========================================================--
--
utBagSingleton :: a -> Bag a
utBagSingleton x = [x]
-- ==========================================================--
--
utBagEmpty :: Bag a
utBagEmpty = []
-- ====================================--
-- === Useful stuff ===--
-- ====================================--
-- ================================================--
--
splitList :: (a -> Bool) -> [a] -> ([a], [a])
splitList p [] = ([],[])
splitList p (x:xs) = case splitList p xs of
(ayes, noes) ->
if p x then (x:ayes, noes) else (ayes, x:noes)
-- ================================================--
--
first (a,b) = a
-- ================================================--
--
second (a,b) = b
-- ================================================--
--
mapAccuml :: (a -> b -> (a, c)) -- Function of accumulator and element
-- input list, returning new
-- accumulator and element of result list
-> a -- Initial accumulator
-> [b] -- Input list
-> (a, [c]) -- Final accumulator and result list
mapAccuml f acc [] = (acc, [])
mapAccuml f acc (x:xs) = (acc2, x':xs')
where (acc1, x') = f acc x
(acc2, xs') = mapAccuml f acc1 xs
-- ================================================--
--
unzip2 :: [(a,b)] -> ([a], [b])
unzip2 [] = ([],[])
unzip2 ((a,b):abs) = ( (a:as), (b:bs) )
where (as,bs) = unzip2 abs
-- ================================================--
--
map1st :: (a -> b) -> [(a,c)] -> [(b,c)]
map1st f [] = []
map1st f ((a,b):abs) = (f a,b): map1st f abs
-- ================================================--
--
map2nd :: (a -> b) -> [(c,a)] -> [(c,b)]
map2nd f [] = []
map2nd f ((a,b):abs) = (a,f b): map2nd f abs
-- ================================================--
--
interleave :: [a] -> [[a]] -> [a]
interleave e [] = []
interleave e [xs] = xs
interleave e (xs:xs2:xss) = xs ++ e ++ (interleave e (xs2:xss))
-- ====================================--
-- === State monad generics ===--
-- ====================================--
returnS :: a -> ST a b
returnS a s0 = (a, s0)
thenS :: ST a c -> (a -> ST b c) -> ST b c
thenS m k s0 = case m s0 of (a, s1) -> k a s1
fetchS :: ST a a
fetchS s = (s, s)
assignS :: a -> ST () a
assignS snew s = ((), snew)
doStatefulOp1 :: (a -> ST b b) -> b -> a -> (b, b)
doStatefulOp1 f initState initValue1
= f initValue1 initState
doStatefulOp2 :: (a -> b -> ST c d) -> d -> a -> b -> (c, d)
doStatefulOp2 f initState initValue1 initValue2
= f initValue1 initValue2 initState
-- ==========================================================--
-- === End utils.m (1) ===--
-- ==========================================================--
|
