1 -- ==========================================================-- 2 -- === Utilities File: utils.m (1) ===-- 3 -- ==========================================================-- 4 5 module Utils where 6 import MyUtils 7 import BaseDefs 8 9 -- ====================================-- 10 -- === Haskell compatability ===-- 11 -- ====================================-- 12 13 14 -- ==========================================================-- 15 -- 16 copy :: Int -> a -> [a] 17 18 copy n x = take (max 0 n) xs where xs = x:xs 19 20 21 -- ==========================================================-- 22 -- 23 sort :: (Ord a) => [a] -> [a] 24 25 sort [] = [] 26 sort (a:x) = insert a (sort x) 27 where 28 insert :: (Ord a) => a -> [a] -> [a] 29 insert a [] = [a] 30 insert a (b:x) | a <=b = a:b:x 31 | otherwise = b:insert a x 32 33 34 -- ==========================================================-- 35 -- 36 layn :: [[Char]] -> [Char] 37 38 layn x = f 1 x 39 where 40 f :: Int -> [[Char]] -> [Char] 41 f n [] = [] 42 f n (a:x) = rjustify 4 (show n) ++") "++a++"\n"++f (n+1) x 43 44 45 46 -- ==========================================================-- 47 -- 48 rjustify :: Int -> [Char] -> [Char] 49 rjustify n s = spaces (n - length s)++s 50 where 51 spaces :: Int -> [Char] 52 spaces m = copy m ' ' 53 54 55 -- ==========================================================-- 56 -- 57 ljustify :: Int -> [Char] -> [Char] 58 ljustify n s = s ++ spaces (n - length s) 59 where 60 spaces :: Int -> [Char] 61 spaces m = copy m ' ' 62 63 64 -- ==========================================================-- 65 -- 66 utRandomInts :: Int -> Int -> [Int] 67 68 utRandomInts s1 s2 69 = let seed1_ok = 1 <= s1 && s1 <= 2147483562 70 seed2_ok = 1 <= s2 && s2 <= 2147483398 71 72 rands :: Int -> Int -> [Int] 73 rands s1 s2 74 = let k = s1 `div` 53668 75 s1' = 40014 * (s1 - k * 53668) - k * 12211 76 s1'' = if s1' < 0 then s1' + 2147483563 else s1' 77 k' = s2 `div` 52774 78 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 79 s2'' = if s2' < 0 then s2' + 2147483399 else s2' 80 z = s1'' - s2'' 81 in 82 if z < 1 83 then z + 2147483562 : rands s1'' s2'' 84 else z : rands s1'' s2'' 85 in 86 if seed1_ok && seed2_ok 87 then rands s1 s2 88 else panic "utRandomInts: bad seeds" 89 90 91 92 -- ====================================-- 93 -- === Projection functions for ===-- 94 -- === the static component ===-- 95 -- ====================================-- 96 97 utSCdexprs :: StaticComponent -> DExprEnv 98 utSCdexprs (dexprs, domains, constrelems, freevars, flags, lims, sizes) 99 = dexprs 100 101 utSCdomains :: StaticComponent -> DSubst 102 utSCdomains (dexprs, domains, constrelems, freevars, flags, lims, sizes) 103 = domains 104 105 utSCconstrelems :: StaticComponent -> AList Naam [ConstrElem] 106 utSCconstrelems (dexprs, domains, constrelems, freevars, flags, lims, sizes) 107 = constrelems 108 109 utSCfreevars :: StaticComponent -> AList Naam [Naam] 110 utSCfreevars (dexprs, domains, constrelems, freevars, flags, lims, sizes) 111 = freevars 112 113 utSCflags :: StaticComponent -> [Flag] 114 utSCflags (dexprs, domains, constrelems, freevars, flags, lims, sizes) 115 = flags 116 117 utSClims :: StaticComponent -> (Int, Int, Int, Int, Int) 118 utSClims (dexprs, domains, constrelems, freevars, flags, lims, sizes) 119 = lims 120 121 utSCsizes :: StaticComponent -> AList Domain Int 122 utSCsizes (dexprs, domains, constrelems, freevars, flags, lims, sizes) 123 = sizes 124 125 126 -- ====================================-- 127 -- === Association lists ===-- 128 -- ====================================-- 129 130 -- ==========================================================-- 131 -- 132 utLookup [] k' = Nothing 133 utLookup ((k,v):bs) k' | k == k' = Just v 134 | otherwise = utLookup bs k' 135 136 137 -- ==========================================================-- 138 -- 139 utSureLookup [] msg k' 140 = panic ( "utSureLookup: key not found in " ++ msg ) 141 utSureLookup ((k,v):bs) msg k' 142 | k == k' = v 143 | otherwise = utSureLookup bs msg k' 144 145 146 -- ==========================================================-- 147 -- 148 utLookupDef [] k' defawlt = defawlt 149 utLookupDef ((k,v):bs) k' defawlt | k == k' = v 150 | otherwise = utLookupDef bs k' defawlt 151 152 153 -- ==========================================================-- 154 -- 155 utEmpty = [] 156 157 158 -- ==========================================================-- 159 -- 160 utDomain al = map first al 161 162 163 -- ==========================================================-- 164 -- 165 utRange al = map second al 166 167 168 -- ==========================================================-- 169 -- 170 utLookupAll [] k' = [] 171 utLookupAll ((k,v):bs) k' | k == k' = v: utLookupAll bs k' 172 | otherwise = utLookupAll bs k' 173 174 175 -- ====================================-- 176 -- === nameSupply ===-- 177 -- ====================================-- 178 179 -- ==========================================================-- 180 -- 181 utInitialNameSupply :: NameSupply 182 183 utInitialNameSupply = 0 184 185 186 -- ==========================================================-- 187 -- 188 utGetName :: NameSupply -> [Char] -> (NameSupply, [Char]) 189 190 utGetName name_supply prefix 191 = (name_supply+1, utMakeName prefix name_supply) 192 193 194 195 -- ==========================================================-- 196 -- 197 utGetNames :: NameSupply -> [[Char]] -> (NameSupply, [[Char]]) 198 199 utGetNames name_supply prefixes 200 = (name_supply + length prefixes, 201 zipWith utMakeName prefixes (myIntsFrom name_supply)) 202 203 204 205 -- ==========================================================-- 206 -- 207 utMakeName prefix ns = prefix ++ ")" ++ show ns 208 209 210 211 -- ====================================-- 212 -- === iseq ===-- 213 -- ====================================-- 214 215 -- ==========================================================-- 216 -- 217 utiConcat :: [Iseq] -> Iseq 218 219 utiConcat = foldr utiAppend utiNil 220 221 222 223 -- ==========================================================-- 224 -- 225 utiInterleave :: Iseq -> [Iseq] -> Iseq 226 227 utiInterleave is [] = utiNil 228 utiInterleave is iss = foldl1 glue iss 229 where glue is1 is2 = is1 `utiAppend` (is `utiAppend` is2) 230 foldl1 f (x:xs) = foldl f x xs 231 232 233 -- ==========================================================-- 234 -- 235 utiLayn :: [Iseq] -> Iseq 236 237 utiLayn iss = utiLaynN 1 iss 238 where 239 utiLaynN :: Int -> [Iseq] -> Iseq 240 utiLaynN n [] = utiNil 241 utiLaynN n (is:isz) 242 = utiConcat [ (utiLjustify 4 (utiAppend (utiNum n) (utiStr ") "))), 243 (utiIndent is), 244 (utiLaynN (n+1) isz) 245 ] 246 247 248 -- ==========================================================-- 249 -- 250 utiLjustify :: Int -> Iseq -> Iseq 251 252 utiLjustify n s 253 = s `utiAppend` (utiStr (utpspaces (n - length (utiMkStr s)) "")) 254 255 256 257 -- ==========================================================-- 258 -- 259 utiNum :: Int -> Iseq 260 261 utiNum = utiStr . show 262 263 264 265 -- ==========================================================-- 266 -- 267 utiFWNum :: Int -> Int -> Iseq 268 269 utiFWNum width n 270 = utiStr (utpspaces spaces_reqd digits) 271 where 272 digits = show {-num-} n 273 spaces_reqd | length digits >= width = 0 274 | otherwise = width - length digits 275 276 277 -- ====================================-- 278 -- === oseq ===-- 279 -- ====================================-- 280 281 -- ==========================================================-- 282 -- 283 utoEmpty :: Oseq -- An empty oseq 284 285 utoEmpty indent col = [] 286 287 288 -- ==========================================================-- 289 -- 290 utoMkstr :: Oseq -> [Char] 291 292 utoMkstr oseq = oseq 0 0 293 294 295 -- ==========================================================-- 296 -- 297 utiNil = id 298 299 300 -- ==========================================================-- 301 -- 302 utiAppend = (.) 303 304 305 -- ==========================================================-- 306 -- 307 utiStr = foldr (utiAppend . utiChar) utiNil 308 309 310 -- ==========================================================-- 311 -- 312 utiMkStr iseq = utoMkstr (iseq utoEmpty) 313 314 315 316 -- ==========================================================-- 317 -- 318 utiChar :: Char -> Iseq 319 320 utiChar '\n' rest indent col = '\n' : rest indent 0 321 utiChar c rest indent col 322 | col>=indent = c : rest indent (col+1) 323 | otherwise = utpspaces (indent - col) (c : rest indent (indent+1)) 324 325 326 -- ==========================================================-- 327 -- 328 utiIndent iseq oseq indent col 329 = iseq oseq' (max col indent) col 330 where 331 oseq' indent' col' = oseq indent col' 332 -- Ignore the indent passed along to oseq; 333 -- use the original indent instead. 334 335 336 337 -- ==========================================================-- 338 -- 339 utpspaces :: Int -> [Char] -> [Char] 340 utpspaces n cs | n <= 0 = cs 341 | otherwise = ' ' : utpspaces (n-1) cs 342 343 344 -- ====================================-- 345 -- === set ===-- 346 -- ====================================-- 347 348 -- ==========================================================-- 349 -- 350 --unMkSet :: (Ord a) => Set a -> [a] 351 352 unMkSet (MkSet s) = s 353 354 355 -- ==========================================================-- 356 -- 357 --utSetEmpty :: (Ord a) => Set a 358 359 utSetEmpty = MkSet [] 360 361 362 -- ==========================================================-- 363 -- 364 --utSetIsEmpty :: (Ord a) => Set a -> Bool 365 366 utSetIsEmpty (MkSet s) = s == [] 367 368 369 -- ==========================================================-- 370 -- 371 --utSetSingleton :: (Ord a) => a -> Set a 372 373 utSetSingleton x = MkSet [x] 374 375 376 -- ==========================================================-- 377 -- 378 --utSetFromList :: (Ord a) => [a] -> Set a 379 380 utSetFromList x = (MkSet . rmdup . sort) x 381 where rmdup [] = [] 382 rmdup [x] = [x] 383 rmdup (x:y:xs) | x==y = rmdup (y:xs) 384 | otherwise = x: rmdup (y:xs) 385 386 387 -- ==========================================================-- 388 -- 389 --utSetToList :: (Ord a) => Set a -> [a] 390 391 utSetToList (MkSet xs) = xs 392 393 394 -- ==========================================================-- 395 -- 396 --utSetUnion :: (Ord a) => Set a -> Set a -> Set a 397 398 utSetUnion (MkSet []) (MkSet []) = (MkSet []) 399 utSetUnion (MkSet []) (MkSet (b:bs)) = (MkSet (b:bs)) 400 utSetUnion (MkSet (a:as)) (MkSet []) = (MkSet (a:as)) 401 utSetUnion (MkSet (a:as)) (MkSet (b:bs)) 402 | a < b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet (b:bs))))) 403 | a == b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet bs)))) 404 | a > b = MkSet (b: (unMkSet (utSetUnion (MkSet (a:as)) (MkSet bs)))) 405 406 407 -- ==========================================================-- 408 -- 409 --utSetIntersection :: (Ord a) => Set a -> Set a -> Set a 410 411 utSetIntersection (MkSet []) (MkSet []) = (MkSet []) 412 utSetIntersection (MkSet []) (MkSet (b:bs)) = (MkSet []) 413 utSetIntersection (MkSet (a:as)) (MkSet []) = (MkSet []) 414 utSetIntersection (MkSet (a:as)) (MkSet (b:bs)) 415 | a < b = utSetIntersection (MkSet as) (MkSet (b:bs)) 416 | a == b = MkSet (a: (unMkSet (utSetIntersection (MkSet as) (MkSet bs)))) 417 | a > b = utSetIntersection (MkSet (a:as)) (MkSet bs) 418 419 420 -- ==========================================================-- 421 -- 422 --utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a 423 424 utSetSubtraction (MkSet []) (MkSet []) = (MkSet []) 425 utSetSubtraction (MkSet []) (MkSet (b:bs)) = (MkSet []) 426 utSetSubtraction (MkSet (a:as)) (MkSet []) = (MkSet (a:as)) 427 utSetSubtraction (MkSet (a:as)) (MkSet (b:bs)) 428 | a < b = MkSet (a: (unMkSet (utSetSubtraction (MkSet as) (MkSet (b:bs))))) 429 | a == b = utSetSubtraction (MkSet as) (MkSet bs) 430 | a > b = utSetSubtraction (MkSet (a:as)) (MkSet bs) 431 432 433 -- ==========================================================-- 434 -- 435 --utSetElementOf :: (Ord a) => a -> Set a -> Bool 436 437 utSetElementOf x (MkSet []) = False 438 utSetElementOf x (MkSet (y:ys)) = x==y || (x>y && utSetElementOf x (MkSet ys)) 439 440 441 -- ==========================================================-- 442 -- 443 --utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool 444 445 utSetSubsetOf (MkSet []) (MkSet bs) = True 446 utSetSubsetOf (MkSet (a:as)) (MkSet bs) 447 = utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs) 448 449 450 -- ==========================================================-- 451 -- 452 --utSetUnionList :: (Ord a) => [Set a] -> Set a 453 454 utSetUnionList setList = foldl utSetUnion utSetEmpty setList 455 456 457 -- ====================================-- 458 -- === bag ===-- 459 -- ====================================-- 460 461 -- ==========================================================-- 462 -- 463 utBagUnion :: Bag a -> Bag a -> Bag a 464 465 utBagUnion as bs = as ++ bs 466 467 468 -- ==========================================================-- 469 -- 470 utBagInsert :: a -> Bag a -> Bag a 471 472 utBagInsert a as = a:as 473 474 475 -- ==========================================================-- 476 -- 477 utBagToList :: Bag a -> [a] 478 479 utBagToList xs = xs 480 481 482 -- ==========================================================-- 483 -- 484 utBagFromList :: [a] -> Bag a 485 486 utBagFromList xs = xs 487 488 489 -- ==========================================================-- 490 -- 491 utBagSingleton :: a -> Bag a 492 493 utBagSingleton x = [x] 494 495 496 -- ==========================================================-- 497 -- 498 utBagEmpty :: Bag a 499 500 utBagEmpty = [] 501 502 503 -- ====================================-- 504 -- === Useful stuff ===-- 505 -- ====================================-- 506 507 -- ================================================-- 508 -- 509 splitList :: (a -> Bool) -> [a] -> ([a], [a]) 510 511 splitList p [] = ([],[]) 512 splitList p (x:xs) = case splitList p xs of 513 (ayes, noes) -> 514 if p x then (x:ayes, noes) else (ayes, x:noes) 515 516 517 518 -- ================================================-- 519 -- 520 first (a,b) = a 521 522 523 -- ================================================-- 524 -- 525 second (a,b) = b 526 527 528 -- ================================================-- 529 -- 530 mapAccuml :: (a -> b -> (a, c)) -- Function of accumulator and element 531 -- input list, returning new 532 -- accumulator and element of result list 533 -> a -- Initial accumulator 534 -> [b] -- Input list 535 -> (a, [c]) -- Final accumulator and result list 536 537 mapAccuml f acc [] = (acc, []) 538 mapAccuml f acc (x:xs) = (acc2, x':xs') 539 where (acc1, x') = f acc x 540 (acc2, xs') = mapAccuml f acc1 xs 541 542 543 -- ================================================-- 544 -- 545 unzip2 :: [(a,b)] -> ([a], [b]) 546 unzip2 [] = ([],[]) 547 unzip2 ((a,b):abs) = ( (a:as), (b:bs) ) 548 where (as,bs) = unzip2 abs 549 550 551 -- ================================================-- 552 -- 553 map1st :: (a -> b) -> [(a,c)] -> [(b,c)] 554 map1st f [] = [] 555 map1st f ((a,b):abs) = (f a,b): map1st f abs 556 557 558 -- ================================================-- 559 -- 560 map2nd :: (a -> b) -> [(c,a)] -> [(c,b)] 561 map2nd f [] = [] 562 map2nd f ((a,b):abs) = (a,f b): map2nd f abs 563 564 565 -- ================================================-- 566 -- 567 interleave :: [a] -> [[a]] -> [a] 568 569 interleave e [] = [] 570 interleave e [xs] = xs 571 interleave e (xs:xs2:xss) = xs ++ e ++ (interleave e (xs2:xss)) 572 573 574 -- ====================================-- 575 -- === State monad generics ===-- 576 -- ====================================-- 577 578 returnS :: a -> ST a b 579 returnS a s0 = (a, s0) 580 581 thenS :: ST a c -> (a -> ST b c) -> ST b c 582 thenS m k s0 = case m s0 of (a, s1) -> k a s1 583 584 fetchS :: ST a a 585 fetchS s = (s, s) 586 587 assignS :: a -> ST () a 588 assignS snew s = ((), snew) 589 590 doStatefulOp1 :: (a -> ST b b) -> b -> a -> (b, b) 591 doStatefulOp1 f initState initValue1 592 = f initValue1 initState 593 594 doStatefulOp2 :: (a -> b -> ST c d) -> d -> a -> b -> (c, d) 595 doStatefulOp2 f initState initValue1 initValue2 596 = f initValue1 initValue2 initState 597 598 599 -- ==========================================================-- 600 -- === End utils.m (1) ===-- 601 -- ==========================================================--