1 implementation module StdEnvExt
3 /** Collection of functions of more general purpose.
9 is a frequently occurring version of the const function.
11 const2 :: !.a .b .c -> .a
15 is the state based version of iterate (StdList):
21 iterateSt :: !(s -> (a,s)) !s -> [a]
22 iterateSt f s = let (a,s1) = f s in [a:iterateSt f s1]
25 is the finite version of iterateSt.
27 iterateStn :: !Int !(s -> (a,s)) !s -> (![a],!s)
28 iterateStn 0 _ s = ([],s)
31 # (as,s) = iterateStn (n-1) f s
34 /** State strict version of seq:
36 sseq :: ![.(.s -> .s)] !.s -> .s
37 sseq [f:fs] s = sseq fs (f s)
41 /** State strict version of seqList:
43 sseqList:: ![St .s .a] !.s -> (![.a],!.s)
46 #! (xs,s) = sseqList fs s
51 /** apply x [f_0 ... f_n] = [f_0 x, ..., f_n x]
53 apply :: a ![a->.b] -> [.b]
54 apply x fs = [f x \\ f<-fs]
56 /** State passing version of map:
58 mapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],.s) -> (![.b],.s)
63 # (bs,s) = mapSt f (as,s)
66 /** Strict state passing version of map:
68 smapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],!.s) -> (![.b],!.s)
73 #! (bs,s) = smapSt f (as,s)
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}])]
78 singleOutElems :: ![a] -> [(a,[a])]
82 singleOut :: [a] [a] -> [(a,[a])]
84 singleOut prefix [a:as]
85 = [(a,prefix++as) : singleOut (prefix++[a]) as]
87 /** hdtl [a:as] = (a,as)
89 hdtl :: ![a] -> (a,[a])
92 /** isSingleton [_] = True;
93 isSingleton _ = False.
95 isSingleton :: ![a] -> Bool
96 isSingleton [_] = True
100 /** filterSt cond xs st
101 filters all elements from xs using a state parameter st that is threaded along.
103 filterSt :: (a .s -> (Bool,.s)) !.[a] !.s -> (.[a],.s)
106 filterSt cond [x:xs] s
108 # (yes,s) = filterSt cond xs s
110 | otherwise = ( yes, s)
112 /** spanfilter cond xs = (filter cond xs, filter (not o cond) xs)
114 spanfilter :: (a -> Bool) !.[a] -> (.[a],.[a])
117 spanfilter cond [x:xs]
118 | cond x = ([x:yes],no)
119 | otherwise = (yes,[x:no])
121 (yes,no) = spanfilter cond xs
123 spanfilterSt :: (a .s -> (Bool,.s)) !.[a] .s -> (.(.[a],.[a]),.s)
124 spanfilterSt cond [] s
126 spanfilterSt cond [x:xs] s
128 # ((yes,no),s) = spanfilterSt cond xs s
129 | ok = (([x:yes],no),s)
130 | otherwise = ((yes,[x:no]),s)
132 /** find1 cond (A ++ [a] ++ B) = a
133 where for each x in A: not (cond x) /\ cond a
135 find1 :: !(a -> Bool) ![a] -> a
136 find1 c as = case filter c as of
138 none = abort "find1: no elements found.\n"
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
145 break :: !(a -> Bool) ![a] -> (![a],![a],![a])
147 # (no,yes) = span (not o c) xs
148 # (yes,no`) = span c yes
151 /** break1 cond (A ++ [B] ++ C) = (A,B,C)
152 where for each x in A: not cond x /\
154 if C=[x:_]: not cond x
156 break1 :: !(a -> Bool) ![a] -> (![a],!a,![a])
160 (a,b,c) = abort ("break1: [B] is of length: " <+++ length b <+++ "\n")
162 /** unbreak (a,b,c) = a ++ b ++ c
164 unbreak :: !(![a],![a],![a]) -> [a]
165 unbreak (a,b,c) = a ++ b ++ c
168 /** unbreak1 (a,b,c) = a ++ [b] ++ c
170 unbreak1 :: !(![a],!a,![a]) -> [a]
171 unbreak1 (a,b,c) = a ++ [b] ++ c
173 /** [a_1..x..a_n] x = i
178 (??) infixl 9 :: ![a] !a -> Int | == a
179 (??) ys x = search ((==) x) ys 0
181 (???) infixl 9 :: ![a] !(a -> Bool) -> Int
182 (???) ys c = search c ys 0
184 search :: !(a -> Bool) ![a] !Int -> Int
188 | otherwise = search c ys (i+1)
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)
193 weave :: ![a] [a] -> [a]
194 weave [a:as] [b:bs] = [a,b:weave as bs]
197 /** unweave [a_1,a_2..a_n]
198 = ([a_1,a_3..],[a_2,a_4..])
200 unweave :: ![a] -> ([a],[a])
201 unweave [x,y:zs] = ([x:xs],[y:ys])
204 unweave [x] = ([x],[])
207 /** unweave_n n [a_1..a_n, a_{n+1}..a_{2n} ..]
208 = [[a_1,a_{n+1}..],[a_2,a_{n+2}..] ..]
210 unweave_n :: !Int [a] -> [[a]]
212 | length first_n < nrLists
215 = glue first_n (unweave_n nrLists after_n)
217 (first_n,after_n) = splitAt nrLists zs
219 glue :: ![a] [[a]] -> [[a]] // must be non-strict in its second argument in order to work for streams
221 glue [a:as] xss = [[a:hd xss]:glue as (tl xss)]
224 /** Immediate instances of toString for (,) and (,,)
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"
231 /** Useful string concatenation function
233 (<+++) infixl :: !String !a -> String | toString a
234 (<+++) str x = str +++ toString x
236 (+++>) infixr :: !a !String -> String | toString a
237 (+++>) x str = toString x +++ str
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>"
243 showList :: !String !.[a] -> String | toString a
245 showList inf [x] = toString x
246 showList inf [x:xs] = x +++> inf +++> showList inf xs
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
254 /** lookup k [...(k,v)...] = Just v
257 lookup :: !k !(AssocList k v) -> Maybe v | Eq k
259 = case [v \\ (k`,v)<-assocl | k==k`] of
263 /** lookup _ k [...(k,v)...] = v
266 lookupd :: v !k !(AssocList k v) -> v | Eq k
268 = case [v` \\ (k`,v`)<-assocl | k==k`] of
272 /** keymember k [...(k,v)...] = True
273 keymember _ _ = False
275 keymember :: !k !(AssocList k v) -> Bool | Eq k
277 = isJust (lookup k assocl)
279 /** addkeyvalue (k,v) [...(k,_)...] = [...(k,v)...]
280 addkeyvalue _ assocl = assocl ++ [(k,v)]
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)]
288 /** updkeyvalue k f [...(k,v)...] = [...(k,f v)...]
289 updkeyvalue _ _ assocl = assocl
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
297 /** deletekeyvalue k [...(k,v)...] = [... ...]
298 deletekeyvalue _ assocl = assocl
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
306 /** isAllMember xs ys is true iff all elements of xs are member of ys.
308 isAllMember :: ![a] [a] -> Bool | Eq a
309 isAllMember xs ys = and (map (\x -> isMember x ys) xs)
311 /** zipWith f as bs = [f a_0 b_0, f a_1 b_1, ..., f a_n b_n]
313 zipWith :: (a b -> c) ![a] ![b] -> [c]
314 zipWith f as bs = [f a b \\ a<-as & b<-bs]
316 /** setbetween x low up
317 returns x iff low <= x <= up
318 returns low iff low > x
319 returns up iff x > up
321 setbetween :: !a !a !a -> a | Ord a
327 /** isbetween x low up
328 returns True iff low <= x <= up
330 isbetween :: !a !a !a -> Bool | Ord a
332 = low <= x && x <= up
334 /** minmax (a,b) = (a,b) if a<=b; (b,a) otherwise
336 minmax :: !(!a,!a) -> (!a,!a) | Ord a
342 /** swap (a,b) = (b,a)
344 swap :: !(.a,.b) -> (.b,.a)
349 instance mod Int where
350 (mod) a b = a - b * (a/b)
352 /** foldl1 f xs folds f to the left over non-empty list xs.
354 foldl1 :: !(a -> a -> a) ![a] -> a
355 foldl1 f [x : xs] = foldl f x xs
357 /** foldr1 f xs folds f to the right over non-empty list xs.
359 foldr1 :: !(a -> a -> a) ![a] -> a
361 foldr1 f [x:xs] = f x (foldr1 f xs)
363 removeQuotes :: !{#Char} -> String
365 removeQuotes s = removeQuotes` s 0
367 removeQuotes` :: !{#Char} Int -> String
373 | c == '\"' || c == '\\'
374 = removeQuotes` s (inc i)
376 = toString c +++ removeQuotes` s (inc i)
378 replaceInString :: !String !String !String -> String
379 replaceInString toReplace replacement s
380 # result = replaceInString` (fromString toReplace) (fromString replacement) (fromString s)
381 = charlist2string "" result
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]
392 charlist2string :: !String ![Char] -> String
393 charlist2string str [] = str
394 charlist2string str [x:xs] = charlist2string (str+++toString x) xs
396 /** stringStarts s1 prefix yields true iff s1 = prefix +++ s for some s.
398 stringStarts :: !String !String -> Bool
399 stringStarts s1 prefix = size s1 >= size prefix && s1%(0,size prefix-1) == prefix
401 /** removePrefix str prefix yields (Just s) iff str = prefix +++ s, and Nothing otherwise.
403 removePrefix :: !String !String -> Maybe String
404 removePrefix s1 prefix = if (stringStarts s1 prefix) (Just (s1%(size prefix,size s1-1))) Nothing
406 /** isSorted [x_0..x_n] holds iff x_i <= x_{i+1} for each x_i in [x_0..x_{n-1}].
408 isSorted :: ![a] -> Bool | Ord a
410 isSorted xs = and [x <= y \\ x <- xs & y <- tl xs]
412 /** perhaps p Nothing = False, and perhaps p (Just a) = p a
414 perhaps :: !(a -> Bool) !(Maybe a) -> Bool
415 perhaps _ Nothing = False
416 perhaps p (Just a) = p a
418 /** instance ~ Bool is not
420 instance ~ Bool where (~) b = not b
422 /** instance fromString Int = toInt
424 instance fromString Int where fromString str = toInt str
426 /** test and access functions for choice values:
428 :: ThisOrThat a b = This a | That b
430 isThis :: !(ThisOrThat a b) -> Bool
431 isThis (This _) = True
434 isThat :: !(ThisOrThat a b) -> Bool
435 isThat (That _) = True
438 this :: !(ThisOrThat a b) -> a
440 this _ = abort "this [StdEnvExt]: applied to That pattern instead of This pattern."
442 that :: !(ThisOrThat a b) -> b
444 that _ = abort "that [StdEnvExt]: applied to This pattern instead of That pattern."
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