src/StdLibExt/StdEnvExt.icl

   1 implementation module StdEnvExt
   2
   3 /** Collection of functions of more general purpose.
   4 */
   5 import StdEnv
   6 import StdMaybe
   7
   8 /** const2 a _ _ = a
   9                 is a frequently occurring version of the const function.
  10 */
  11 const2 :: !.a .b .c -> .a
  12 const2 a _ _ = a
  13
  14 /**     iterateSt f x
  15                 is the state based version of iterate (StdList):
  16         iterateSt f x_0
  17                 [y_1,y_2,y_3,y_4...]
  18         where
  19                 (y_i,x_i) = f x_{i-1}
  20 */
  21 iterateSt :: !(s -> (a,s)) !s -> [a]
  22 iterateSt f s = let (a,s1) = f s in [a:iterateSt f s1]
  23
  24 /** iterateStn n f x
  25                 is the finite version of iterateSt.
  26 */
  27 iterateStn :: !Int !(s -> (a,s)) !s -> (![a],!s)
  28 iterateStn 0 _ s        = ([],s)
  29 iterateStn n f s
  30         # (a, s)                = f s
  31         # (as,s)                = iterateStn (n-1) f s
  32         = ([a:as],s)
  33
  34 /** State strict version of seq:
  35 */
  36 sseq :: ![.(.s -> .s)] !.s -> .s
  37 sseq [f:fs] s = sseq fs (f s)
  38 sseq []     s = s
  39
  40
  41 /** State strict version of seqList:
  42 */
  43 sseqList:: ![St .s .a] !.s -> (![.a],!.s)
  44 sseqList [f:fs] s
  45         #! (x, s) = f s
  46         #! (xs,s) = sseqList fs s
  47         =  ([x:xs],s)
  48 sseqList _ s
  49         = ([],s)
  50
  51 /** apply x [f_0 ... f_n] = [f_0 x, ..., f_n x]
  52 */
  53 apply :: a ![a->.b] -> [.b]
  54 apply x fs      = [f x \\ f<-fs]
  55
  56 /**     State passing version of map:
  57 */
  58 mapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],.s) -> (![.b],.s)
  59 mapSt f ([],s)
  60         = ([],s)
  61 mapSt f ([a:as],s)
  62         # (b, s)        = f (a,s)
  63         # (bs,s)        = mapSt f (as,s)
  64         = ([b:bs],s)
  65
  66 /**     Strict state passing version of map:
  67 */
  68 smapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],!.s) -> (![.b],!.s)
  69 smapSt f ([],s)
  70         = ([],s)
  71 smapSt f ([a:as],s)
  72         #! (b, s)       = f (a,s)
  73         #! (bs,s)       = smapSt f (as,s)
  74         = ([b:bs],s)
  75
  76 /**     singleOutElems [a_1..a_n] = [(a_1,[a_2..a_n]),(a_2,[a_1,a_3..a_n])..(a_n,[a_1..a_{n-1}])]
  77 */
  78 singleOutElems :: ![a] -> [(a,[a])]
  79 singleOutElems as
  80         = singleOut [] as
  81 where
  82         singleOut :: [a] [a] -> [(a,[a])]
  83         singleOut _ [] = []
  84         singleOut prefix [a:as]
  85                 = [(a,prefix++as) : singleOut (prefix++[a]) as]
  86
  87 /**     hdtl [a:as] = (a,as)
  88 */
  89 hdtl :: ![a] -> (a,[a])
  90 hdtl [a:as] = (a,as)
  91
  92 /** isSingleton [_] = True;
  93         isSingleton  _  = False.
  94 */
  95 isSingleton :: ![a] -> Bool
  96 isSingleton [_]         = True
  97 isSingleton  _          = False
  98
  99
 100 /** filterSt cond xs st
 101                 filters all elements from xs using a state parameter st that is threaded along.
 102 */
 103 filterSt     :: (a .s -> (Bool,.s)) !.[a] !.s -> (.[a],.s)
 104 filterSt cond [] s
 105         = ([],s)
 106 filterSt cond [x:xs] s
 107 # (b,  s)               = cond x s
 108 # (yes,s)               = filterSt cond xs s
 109 | b                             = ([x:yes],s)
 110 | otherwise             = (   yes, s)
 111
 112 /**     spanfilter cond xs = (filter cond xs, filter (not o cond) xs)
 113 */
 114 spanfilter :: (a -> Bool) !.[a] -> (.[a],.[a])
 115 spanfilter cond []
 116         = ([],[])
 117 spanfilter cond [x:xs]
 118         | cond x        = ([x:yes],no)
 119         | otherwise     = (yes,[x:no])
 120 where
 121         (yes,no)        = spanfilter cond xs
 122
 123 spanfilterSt :: (a .s -> (Bool,.s)) !.[a] .s -> (.(.[a],.[a]),.s)
 124 spanfilterSt cond [] s
 125         = (([],[]),s)
 126 spanfilterSt cond [x:xs] s
 127         # (ok,s)                = cond x s
 128         # ((yes,no),s)  = spanfilterSt cond xs s
 129         | ok                    = (([x:yes],no),s)
 130         | otherwise             = ((yes,[x:no]),s)
 131
 132 /**     find1 cond (A ++ [a] ++ B) = a
 133         where for each x in A: not (cond x) /\ cond a
 134 */
 135 find1 :: !(a -> Bool) ![a] -> a
 136 find1 c as                      = case filter c as of
 137                                                 [a:_]   = a
 138                                                 none    = abort "find1: no elements found.\n"
 139
 140 /** break cond (A ++ B ++ C) = (A,B,C)
 141         where for each x in A: not cond x     /\
 142               for each x in B:     cond x     /\
 143               if C=[x:_]:      not cond x
 144 */
 145 break :: !(a -> Bool) ![a] -> (![a],![a],![a])
 146 break c xs
 147         # (no,yes)      = span (not o c) xs
 148         # (yes,no`)     = span c yes
 149         = (no,yes,no`)
 150
 151 /** break1 cond (A ++ [B] ++ C) = (A,B,C)
 152         where for each x in A: not cond x     /\
 153                                    cond B     /\
 154               if C=[x:_]:      not cond x
 155 */
 156 break1 :: !(a -> Bool) ![a] -> (![a],!a,![a])
 157 break1 c xs
 158         = case break c xs of
 159                 (a,[b],c)       = (a,b,c)
 160                 (a,b,c)         = abort ("break1: [B] is of length: " <+++ length b <+++ "\n")
 161
 162 /** unbreak (a,b,c) = a ++ b ++ c
 163 */
 164 unbreak :: !(![a],![a],![a]) -> [a]
 165 unbreak (a,b,c) = a ++ b ++ c
 166
 167
 168 /** unbreak1 (a,b,c) = a ++ [b] ++ c
 169 */
 170 unbreak1 :: !(![a],!a,![a]) -> [a]
 171 unbreak1 (a,b,c) = a ++ [b] ++ c
 172
 173 /** [a_1..x..a_n] x = i
 174         where
 175                 a_j <> x for all j<i
 176                 a_j == x for j==i
 177 */
 178 (??) infixl 9 :: ![a] !a -> Int | == a
 179 (??) ys x = search ((==) x) ys 0
 180
 181 (???) infixl 9 :: ![a] !(a -> Bool) -> Int
 182 (???) ys c = search c ys 0
 183
 184 search :: !(a -> Bool) ![a] !Int -> Int
 185 search _ [] _   = -1
 186 search c [y:ys] i
 187         | c y           = i
 188         | otherwise     = search c ys (i+1)
 189
 190 /**     weave [a_1..a_n] [b_1..b_m]
 191                 = [a_1,b_1, a_2,b_2, ... a_k,b_k] with k = min(m,n)
 192 */
 193 weave :: ![a] [a] -> [a]
 194 weave [a:as] [b:bs] = [a,b:weave as bs]
 195 weave _      _          = []
 196
 197 /** unweave [a_1,a_2..a_n]
 198                 = ([a_1,a_3..],[a_2,a_4..])
 199 */
 200 unweave :: ![a] -> ([a],[a])
 201 unweave [x,y:zs]        = ([x:xs],[y:ys])
 202 where
 203         (xs,ys)                 = unweave zs
 204 unweave [x]                     = ([x],[])
 205 unweave []                      = ([],[])
 206
 207 /** unweave_n n [a_1..a_n, a_{n+1}..a_{2n} ..]
 208                 = [[a_1,a_{n+1}..],[a_2,a_{n+2}..] ..]
 209 */
 210 unweave_n :: !Int [a] -> [[a]]
 211 unweave_n nrLists zs
 212         | length first_n < nrLists
 213                 = repeatn nrLists []
 214         | otherwise
 215                 = glue first_n (unweave_n nrLists after_n)
 216 where
 217         (first_n,after_n)       = splitAt nrLists zs
 218
 219         glue :: ![a] [[a]] -> [[a]]             // must be non-strict in its second argument in order to work for streams
 220         glue []     _   = []
 221         glue [a:as] xss = [[a:hd xss]:glue as (tl xss)]
 222
 223
 224 /** Immediate instances of toString for (,) and (,,)
 225 */
 226 instance toString (a,b)     | toString a & toString b              where toString (a,b)    = "(" <+++ a <+++ "," <+++ b <+++ ")"
 227 instance toString (a,b,c)   | toString a & toString b & toString c where toString (a,b,c)  = "(" <+++ a <+++ "," <+++ b <+++ "," <+++ c <+++ ")"
 228 instance toString (Maybe a) | toString a                           where toString (Just a) = "(Just " <+++ a <+++ ")"
 229                                                                          toString nothing  = "Nothing"
 230
 231 /**     Useful string concatenation function
 232 */
 233 (<+++) infixl :: !String !a -> String | toString a
 234 (<+++) str x = str +++ toString x
 235
 236 (+++>) infixr :: !a !String -> String | toString a
 237 (+++>) x str = toString x +++ str
 238
 239
 240 /** showList  inf   [x_0 ... x_n] = "<x_0><inf>...<inf><x_n>"
 241         showListF inf f [x_0 ... x_n] = "<f x_0><inf>...<inf><f x_n>"
 242 */
 243 showList :: !String !.[a] -> String | toString a
 244 showList inf []                 = ""
 245 showList inf [x]                = toString x
 246 showList inf [x:xs]             = x +++> inf +++> showList inf xs
 247
 248 showListF :: !String !(a -> String) !.[a] -> String
 249 showListF inf f []              = ""
 250 showListF inf f [x]             = f x
 251 showListF inf f [x:xs]  = f x +++> inf +++> showListF inf f xs
 252
 253
 254 /** lookup k [...(k,v)...] = Just v
 255         lookup k _             = Nothing
 256 */
 257 lookup :: !k !(AssocList k v) -> Maybe v | Eq k
 258 lookup k assocl
 259         = case [v \\ (k`,v)<-assocl | k==k`] of
 260                 [v:_]   = Just v
 261                 _               = Nothing
 262
 263 /** lookup _ k [...(k,v)...] = v
 264         lookup v k _             = v
 265 */
 266 lookupd :: v !k !(AssocList k v) -> v | Eq k
 267 lookupd v k assocl
 268         = case [v` \\ (k`,v`)<-assocl | k==k`] of
 269                 [v`:_]  = v`
 270                 _               = v
 271
 272 /** keymember k [...(k,v)...] = True
 273         keymember _ _             = False
 274 */
 275 keymember :: !k !(AssocList k v) -> Bool | Eq k
 276 keymember k assocl
 277         = isJust (lookup k assocl)
 278
 279 /** addkeyvalue (k,v) [...(k,_)...] = [...(k,v)...]
 280         addkeyvalue _     assocl        = assocl ++ [(k,v)]
 281 */
 282 addkeyvalue :: !(!k,v) !(AssocList k v) -> AssocList k v | Eq k
 283 addkeyvalue (k,v) assocl
 284         = case span (\(k`,_) -> k<>k`) assocl of
 285                 (before,[_:after])      = before ++ [(k,v):after]
 286                 (before,empty)          = before ++ [(k,v)]
 287
 288 /** updkeyvalue k f [...(k,v)...] = [...(k,f v)...]
 289         updkeyvalue _ _ assocl        = assocl
 290 */
 291 updkeyvalue :: !k !(v -> v) !(AssocList k v) -> AssocList k v | Eq k
 292 updkeyvalue k f assocl
 293         = case span (\(k`,_) -> k<>k`) assocl of
 294                 (before,[(k,v):after])  = before ++ [(k,f v):after]
 295                 (before,empty)                  = before
 296
 297 /** deletekeyvalue k [...(k,v)...] = [... ...]
 298         deletekeyvalue _ assocl        = assocl
 299 */
 300 deletekeyvalue :: !k !(AssocList k v) -> AssocList k v | Eq k
 301 deletekeyvalue k assocl
 302         = case span (\(k`,_) -> k<>k`) assocl of
 303                 (before,[_:after])              = before ++ after
 304                 (before,empty)                  = before
 305
 306 /** isAllMember xs ys is true iff all elements of xs are member of ys.
 307 */
 308 isAllMember :: ![a] [a] -> Bool | Eq a
 309 isAllMember xs ys = and (map (\x -> isMember x ys) xs)
 310
 311 /** zipWith f as bs = [f a_0 b_0, f a_1 b_1, ..., f a_n b_n]
 312 */
 313 zipWith :: (a b -> c) ![a] ![b] -> [c]
 314 zipWith f as bs = [f a b \\ a<-as & b<-bs]
 315
 316 /** setbetween x low up
 317                 returns x   iff low <= x <= up
 318                 returns low iff low > x
 319                 returns up  iff x > up
 320 */
 321 setbetween :: !a !a !a -> a | Ord a
 322 setbetween x low up
 323         | low > x       = low
 324         | x > up        = up
 325         | otherwise     = x
 326
 327 /** isbetween x low up
 328                 returns True iff low <= x <= up
 329 */
 330 isbetween :: !a !a !a -> Bool | Ord a
 331 isbetween x low up
 332         = low <= x && x <= up
 333
 334 /** minmax (a,b) = (a,b) if a<=b; (b,a) otherwise
 335 */
 336 minmax :: !(!a,!a) -> (!a,!a) | Ord a
 337 minmax (a,b)
 338         | a<=b          = (a,b)
 339         | otherwise     = (b,a)
 340
 341
 342 /** swap (a,b) = (b,a)
 343 */
 344 swap :: !(.a,.b) -> (.b,.a)
 345 swap (a,b) = (b,a)
 346
 347 /** modulo int
 348 */
 349 instance mod Int where
 350         (mod) a b       = a - b * (a/b)
 351
 352 /**     foldl1 f xs folds f to the left over non-empty list xs.
 353 */
 354 foldl1 :: !(a -> a -> a) ![a] -> a
 355 foldl1 f [x : xs]       = foldl f x xs
 356
 357 /** foldr1 f xs folds f to the right over non-empty list xs.
 358 */
 359 foldr1 :: !(a -> a -> a) ![a] -> a
 360 foldr1 f [x]    = x
 361 foldr1 f [x:xs] = f x (foldr1 f xs)
 362
 363 removeQuotes :: !{#Char} -> String
 364 removeQuotes "" = ""
 365 removeQuotes s = removeQuotes` s 0
 366 where
 367         removeQuotes` :: !{#Char} Int -> String
 368         removeQuotes` s i
 369                 | i == size s
 370                         = ""
 371                 | otherwise
 372                         # c = select s i
 373                         | c == '\"' || c == '\\'
 374                                 = removeQuotes` s (inc i)
 375                         | otherwise
 376                                 = toString c +++ removeQuotes` s (inc i)
 377
 378 replaceInString :: !String !String !String -> String
 379 replaceInString toReplace replacement s
 380         # result = replaceInString` (fromString toReplace) (fromString replacement) (fromString s)
 381         = charlist2string "" result
 382 where
 383         replaceInString` :: ![Char] ![Char] ![Char] -> [Char]
 384         replaceInString` toReplace replacement []       = []
 385         replaceInString` toReplace replacement s=:[x:xs]
 386                 | length toReplace > length s   = s
 387                 # firstPart = take (length toReplace) s
 388                 # lastPart = drop (length toReplace) s
 389                 | firstPart == toReplace        = replacement ++ replaceInString` toReplace replacement lastPart
 390                 | otherwise                                     = [x:replaceInString` toReplace replacement xs]
 391
 392         charlist2string :: !String ![Char] -> String
 393         charlist2string str []  = str
 394         charlist2string str [x:xs]      = charlist2string (str+++toString x) xs
 395
 396 /** stringStarts s1 prefix yields true iff s1 = prefix +++ s for some s.
 397 */
 398 stringStarts :: !String !String -> Bool
 399 stringStarts s1 prefix = size s1 >= size prefix && s1%(0,size prefix-1) == prefix
 400
 401 /** removePrefix str prefix yields (Just s) iff str = prefix +++ s, and Nothing otherwise.
 402 */
 403 removePrefix :: !String !String -> Maybe String
 404 removePrefix s1 prefix = if (stringStarts s1 prefix) (Just (s1%(size prefix,size s1-1))) Nothing
 405
 406 /** isSorted [x_0..x_n] holds iff x_i <= x_{i+1} for each x_i in [x_0..x_{n-1}].
 407 */
 408 isSorted :: ![a] -> Bool | Ord a
 409 isSorted []                             = True
 410 isSorted xs                             = and [x <= y \\ x <- xs & y <- tl xs]
 411
 412 /** perhaps p Nothing = False, and perhaps p (Just a) = p a
 413 */
 414 perhaps :: !(a -> Bool) !(Maybe a) -> Bool
 415 perhaps _ Nothing               = False
 416 perhaps p (Just a)              = p a
 417
 418 /** instance ~ Bool is not
 419 */
 420 instance ~ Bool where (~) b             = not b
 421
 422 /** instance fromString Int = toInt
 423 */
 424 instance fromString Int where fromString str = toInt str
 425
 426 /**     test and access functions for choice values:
 427 */
 428 ::      ThisOrThat a b  = This a | That b
 429
 430 isThis :: !(ThisOrThat a b) -> Bool
 431 isThis (This _)         = True
 432 isThis _                        = False
 433
 434 isThat :: !(ThisOrThat a b) -> Bool
 435 isThat (That _)         = True
 436 isThat _                        = False
 437
 438 this :: !(ThisOrThat a b) -> a
 439 this (This a)           = a
 440 this _                          = abort "this [StdEnvExt]: applied to That pattern instead of This pattern."
 441
 442 that :: !(ThisOrThat a b) -> b
 443 that (That b)           = b
 444 that _                          = abort "that [StdEnvExt]: applied to This pattern instead of That pattern."
 445
 446 instance sinus      Real where sinus      x = sin  x
 447 instance cosinus    Real where cosinus    x = cos  x
 448 instance tangens    Real where tangens    x = tan  x
 449 instance arcsinus   Real where arcsinus   a = asin a
 450 instance arccosinus Real where arccosinus a = acos a
 451 instance arctangens Real where arctangens a = atan a