--- /dev/null
+implementation module StdEnvExt\r
+\r
+/** Collection of functions of more general purpose.\r
+*/\r
+import StdEnv\r
+import StdMaybe\r
+\r
+/** const2 a _ _ = a\r
+ is a frequently occurring version of the const function.\r
+*/\r
+const2 :: !.a .b .c -> .a\r
+const2 a _ _ = a\r
+\r
+/** iterateSt f x\r
+ is the state based version of iterate (StdList):\r
+ iterateSt f x_0\r
+ [y_1,y_2,y_3,y_4...]\r
+ where\r
+ (y_i,x_i) = f x_{i-1}\r
+*/\r
+iterateSt :: !(s -> (a,s)) !s -> [a]\r
+iterateSt f s = let (a,s1) = f s in [a:iterateSt f s1]\r
+\r
+/** iterateStn n f x\r
+ is the finite version of iterateSt.\r
+*/\r
+iterateStn :: !Int !(s -> (a,s)) !s -> (![a],!s)\r
+iterateStn 0 _ s = ([],s)\r
+iterateStn n f s\r
+ # (a, s) = f s\r
+ # (as,s) = iterateStn (n-1) f s\r
+ = ([a:as],s)\r
+\r
+/** State strict version of seq:\r
+*/\r
+sseq :: ![.(.s -> .s)] !.s -> .s\r
+sseq [f:fs] s = sseq fs (f s)\r
+sseq [] s = s\r
+\r
+\r
+/** State strict version of seqList:\r
+*/\r
+sseqList:: ![St .s .a] !.s -> (![.a],!.s)\r
+sseqList [f:fs] s\r
+ #! (x, s) = f s\r
+ #! (xs,s) = sseqList fs s\r
+ = ([x:xs],s)\r
+sseqList _ s\r
+ = ([],s)\r
+\r
+/** apply x [f_0 ... f_n] = [f_0 x, ..., f_n x]\r
+*/\r
+apply :: a ![a->.b] -> [.b]\r
+apply x fs = [f x \\ f<-fs]\r
+\r
+/** State passing version of map:\r
+*/\r
+mapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],.s) -> (![.b],.s)\r
+mapSt f ([],s)\r
+ = ([],s)\r
+mapSt f ([a:as],s)\r
+ # (b, s) = f (a,s)\r
+ # (bs,s) = mapSt f (as,s)\r
+ = ([b:bs],s)\r
+\r
+/** Strict state passing version of map:\r
+*/\r
+smapSt :: !(.(.a,.s) -> .(.b,.s)) !(![.a],!.s) -> (![.b],!.s)\r
+smapSt f ([],s)\r
+ = ([],s)\r
+smapSt f ([a:as],s)\r
+ #! (b, s) = f (a,s)\r
+ #! (bs,s) = smapSt f (as,s)\r
+ = ([b:bs],s)\r
+\r
+/** 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}])]\r
+*/\r
+singleOutElems :: ![a] -> [(a,[a])]\r
+singleOutElems as\r
+ = singleOut [] as\r
+where\r
+ singleOut :: [a] [a] -> [(a,[a])]\r
+ singleOut _ [] = []\r
+ singleOut prefix [a:as]\r
+ = [(a,prefix++as) : singleOut (prefix++[a]) as]\r
+\r
+/** hdtl [a:as] = (a,as)\r
+*/\r
+hdtl :: ![a] -> (a,[a])\r
+hdtl [a:as] = (a,as)\r
+\r
+/** isSingleton [_] = True;\r
+ isSingleton _ = False.\r
+*/\r
+isSingleton :: ![a] -> Bool\r
+isSingleton [_] = True\r
+isSingleton _ = False\r
+\r
+\r
+/** filterSt cond xs st\r
+ filters all elements from xs using a state parameter st that is threaded along.\r
+*/\r
+filterSt :: (a .s -> (Bool,.s)) !.[a] !.s -> (.[a],.s)\r
+filterSt cond [] s\r
+ = ([],s)\r
+filterSt cond [x:xs] s\r
+# (b, s) = cond x s\r
+# (yes,s) = filterSt cond xs s\r
+| b = ([x:yes],s)\r
+| otherwise = ( yes, s)\r
+\r
+/** spanfilter cond xs = (filter cond xs, filter (not o cond) xs)\r
+*/\r
+spanfilter :: (a -> Bool) !.[a] -> (.[a],.[a])\r
+spanfilter cond []\r
+ = ([],[])\r
+spanfilter cond [x:xs]\r
+ | cond x = ([x:yes],no)\r
+ | otherwise = (yes,[x:no])\r
+where\r
+ (yes,no) = spanfilter cond xs\r
+\r
+spanfilterSt :: (a .s -> (Bool,.s)) !.[a] .s -> (.(.[a],.[a]),.s)\r
+spanfilterSt cond [] s\r
+ = (([],[]),s)\r
+spanfilterSt cond [x:xs] s\r
+ # (ok,s) = cond x s\r
+ # ((yes,no),s) = spanfilterSt cond xs s\r
+ | ok = (([x:yes],no),s)\r
+ | otherwise = ((yes,[x:no]),s)\r
+\r
+/** find1 cond (A ++ [a] ++ B) = a\r
+ where for each x in A: not (cond x) /\ cond a\r
+*/\r
+find1 :: !(a -> Bool) ![a] -> a\r
+find1 c as = case filter c as of\r
+ [a:_] = a\r
+ none = abort "find1: no elements found.\n"\r
+\r
+/** break cond (A ++ B ++ C) = (A,B,C)\r
+ where for each x in A: not cond x /\\r
+ for each x in B: cond x /\\r
+ if C=[x:_]: not cond x\r
+*/\r
+break :: !(a -> Bool) ![a] -> (![a],![a],![a])\r
+break c xs\r
+ # (no,yes) = span (not o c) xs\r
+ # (yes,no`) = span c yes\r
+ = (no,yes,no`)\r
+\r
+/** break1 cond (A ++ [B] ++ C) = (A,B,C)\r
+ where for each x in A: not cond x /\ \r
+ cond B /\ \r
+ if C=[x:_]: not cond x\r
+*/\r
+break1 :: !(a -> Bool) ![a] -> (![a],!a,![a])\r
+break1 c xs\r
+ = case break c xs of\r
+ (a,[b],c) = (a,b,c)\r
+ (a,b,c) = abort ("break1: [B] is of length: " <+++ length b <+++ "\n")\r
+\r
+/** unbreak (a,b,c) = a ++ b ++ c\r
+*/\r
+unbreak :: !(![a],![a],![a]) -> [a]\r
+unbreak (a,b,c) = a ++ b ++ c\r
+\r
+\r
+/** unbreak1 (a,b,c) = a ++ [b] ++ c\r
+*/\r
+unbreak1 :: !(![a],!a,![a]) -> [a]\r
+unbreak1 (a,b,c) = a ++ [b] ++ c\r
+\r
+/** [a_1..x..a_n] x = i\r
+ where\r
+ a_j <> x for all j<i\r
+ a_j == x for j==i\r
+*/\r
+(??) infixl 9 :: ![a] !a -> Int | == a\r
+(??) ys x = search ((==) x) ys 0\r
+\r
+(???) infixl 9 :: ![a] !(a -> Bool) -> Int\r
+(???) ys c = search c ys 0\r
+\r
+search :: !(a -> Bool) ![a] !Int -> Int\r
+search _ [] _ = -1\r
+search c [y:ys] i\r
+ | c y = i\r
+ | otherwise = search c ys (i+1)\r
+\r
+/** weave [a_1..a_n] [b_1..b_m]\r
+ = [a_1,b_1, a_2,b_2, ... a_k,b_k] with k = min(m,n)\r
+*/\r
+weave :: ![a] [a] -> [a]\r
+weave [a:as] [b:bs] = [a,b:weave as bs]\r
+weave _ _ = []\r
+\r
+/** unweave [a_1,a_2..a_n]\r
+ = ([a_1,a_3..],[a_2,a_4..])\r
+*/\r
+unweave :: ![a] -> ([a],[a])\r
+unweave [x,y:zs] = ([x:xs],[y:ys])\r
+where\r
+ (xs,ys) = unweave zs\r
+unweave [x] = ([x],[])\r
+unweave [] = ([],[])\r
+\r
+/** unweave_n n [a_1..a_n, a_{n+1}..a_{2n} ..]\r
+ = [[a_1,a_{n+1}..],[a_2,a_{n+2}..] ..]\r
+*/\r
+unweave_n :: !Int [a] -> [[a]]\r
+unweave_n nrLists zs \r
+ | length first_n < nrLists\r
+ = repeatn nrLists []\r
+ | otherwise\r
+ = glue first_n (unweave_n nrLists after_n)\r
+where\r
+ (first_n,after_n) = splitAt nrLists zs\r
+ \r
+ glue :: ![a] [[a]] -> [[a]] // must be non-strict in its second argument in order to work for streams\r
+ glue [] _ = []\r
+ glue [a:as] xss = [[a:hd xss]:glue as (tl xss)]\r
+\r
+\r
+/** Immediate instances of toString for (,) and (,,)\r
+*/\r
+instance toString (a,b) | toString a & toString b where toString (a,b) = "(" <+++ a <+++ "," <+++ b <+++ ")"\r
+instance toString (a,b,c) | toString a & toString b & toString c where toString (a,b,c) = "(" <+++ a <+++ "," <+++ b <+++ "," <+++ c <+++ ")"\r
+instance toString (Maybe a) | toString a where toString (Just a) = "(Just " <+++ a <+++ ")"\r
+ toString nothing = "Nothing"\r
+\r
+/** Useful string concatenation function\r
+*/\r
+(<+++) infixl :: !String !a -> String | toString a\r
+(<+++) str x = str +++ toString x\r
+\r
+(+++>) infixr :: !a !String -> String | toString a\r
+(+++>) x str = toString x +++ str\r
+\r
+\r
+/** showList inf [x_0 ... x_n] = "<x_0><inf>...<inf><x_n>"\r
+ showListF inf f [x_0 ... x_n] = "<f x_0><inf>...<inf><f x_n>"\r
+*/\r
+showList :: !String !.[a] -> String | toString a\r
+showList inf [] = ""\r
+showList inf [x] = toString x\r
+showList inf [x:xs] = x +++> inf +++> showList inf xs\r
+\r
+showListF :: !String !(a -> String) !.[a] -> String\r
+showListF inf f [] = ""\r
+showListF inf f [x] = f x\r
+showListF inf f [x:xs] = f x +++> inf +++> showListF inf f xs\r
+\r
+\r
+/** lookup k [...(k,v)...] = Just v\r
+ lookup k _ = Nothing\r
+*/\r
+lookup :: !k !(AssocList k v) -> Maybe v | Eq k\r
+lookup k assocl\r
+ = case [v \\ (k`,v)<-assocl | k==k`] of\r
+ [v:_] = Just v\r
+ _ = Nothing\r
+\r
+/** lookup _ k [...(k,v)...] = v\r
+ lookup v k _ = v\r
+*/\r
+lookupd :: v !k !(AssocList k v) -> v | Eq k\r
+lookupd v k assocl\r
+ = case [v` \\ (k`,v`)<-assocl | k==k`] of\r
+ [v`:_] = v`\r
+ _ = v\r
+\r
+/** keymember k [...(k,v)...] = True\r
+ keymember _ _ = False\r
+*/\r
+keymember :: !k !(AssocList k v) -> Bool | Eq k\r
+keymember k assocl\r
+ = isJust (lookup k assocl)\r
+\r
+/** addkeyvalue (k,v) [...(k,_)...] = [...(k,v)...]\r
+ addkeyvalue _ assocl = assocl ++ [(k,v)]\r
+*/\r
+addkeyvalue :: !(!k,v) !(AssocList k v) -> AssocList k v | Eq k\r
+addkeyvalue (k,v) assocl\r
+ = case span (\(k`,_) -> k<>k`) assocl of\r
+ (before,[_:after]) = before ++ [(k,v):after]\r
+ (before,empty) = before ++ [(k,v)]\r
+\r
+/** updkeyvalue k f [...(k,v)...] = [...(k,f v)...]\r
+ updkeyvalue _ _ assocl = assocl\r
+*/\r
+updkeyvalue :: !k !(v -> v) !(AssocList k v) -> AssocList k v | Eq k\r
+updkeyvalue k f assocl\r
+ = case span (\(k`,_) -> k<>k`) assocl of\r
+ (before,[(k,v):after]) = before ++ [(k,f v):after]\r
+ (before,empty) = before\r
+\r
+/** deletekeyvalue k [...(k,v)...] = [... ...]\r
+ deletekeyvalue _ assocl = assocl\r
+*/\r
+deletekeyvalue :: !k !(AssocList k v) -> AssocList k v | Eq k\r
+deletekeyvalue k assocl\r
+ = case span (\(k`,_) -> k<>k`) assocl of\r
+ (before,[_:after]) = before ++ after\r
+ (before,empty) = before\r
+\r
+/** isAllMember xs ys is true iff all elements of xs are member of ys.\r
+*/\r
+isAllMember :: ![a] [a] -> Bool | Eq a\r
+isAllMember xs ys = and (map (\x -> isMember x ys) xs)\r
+\r
+/** zipWith f as bs = [f a_0 b_0, f a_1 b_1, ..., f a_n b_n]\r
+*/\r
+zipWith :: (a b -> c) ![a] ![b] -> [c]\r
+zipWith f as bs = [f a b \\ a<-as & b<-bs]\r
+\r
+/** setbetween x low up\r
+ returns x iff low <= x <= up\r
+ returns low iff low > x\r
+ returns up iff x > up\r
+*/\r
+setbetween :: !a !a !a -> a | Ord a\r
+setbetween x low up\r
+ | low > x = low\r
+ | x > up = up\r
+ | otherwise = x\r
+\r
+/** isbetween x low up\r
+ returns True iff low <= x <= up\r
+*/\r
+isbetween :: !a !a !a -> Bool | Ord a\r
+isbetween x low up\r
+ = low <= x && x <= up\r
+\r
+/** minmax (a,b) = (a,b) if a<=b; (b,a) otherwise\r
+*/\r
+minmax :: !(!a,!a) -> (!a,!a) | Ord a\r
+minmax (a,b)\r
+ | a<=b = (a,b)\r
+ | otherwise = (b,a)\r
+\r
+\r
+/** swap (a,b) = (b,a)\r
+*/\r
+swap :: !(.a,.b) -> (.b,.a)\r
+swap (a,b) = (b,a)\r
+\r
+/** modulo int\r
+*/\r
+instance mod Int where\r
+ (mod) a b = a - b * (a/b)\r
+\r
+/** foldl1 f xs folds f to the left over non-empty list xs.\r
+*/\r
+foldl1 :: !(a -> a -> a) ![a] -> a\r
+foldl1 f [x : xs] = foldl f x xs\r
+\r
+/** foldr1 f xs folds f to the right over non-empty list xs.\r
+*/\r
+foldr1 :: !(a -> a -> a) ![a] -> a\r
+foldr1 f [x] = x\r
+foldr1 f [x:xs] = f x (foldr1 f xs)\r
+ \r
+removeQuotes :: !{#Char} -> String\r
+removeQuotes "" = ""\r
+removeQuotes s = removeQuotes` s 0\r
+where\r
+ removeQuotes` :: !{#Char} Int -> String\r
+ removeQuotes` s i \r
+ | i == size s\r
+ = ""\r
+ | otherwise\r
+ # c = select s i\r
+ | c == '\"' || c == '\\'\r
+ = removeQuotes` s (inc i)\r
+ | otherwise\r
+ = toString c +++ removeQuotes` s (inc i)\r
+ \r
+replaceInString :: !String !String !String -> String\r
+replaceInString toReplace replacement s \r
+ # result = replaceInString` (fromString toReplace) (fromString replacement) (fromString s)\r
+ = charlist2string "" result\r
+where\r
+ replaceInString` :: ![Char] ![Char] ![Char] -> [Char]\r
+ replaceInString` toReplace replacement [] = []\r
+ replaceInString` toReplace replacement s=:[x:xs] \r
+ | length toReplace > length s = s\r
+ # firstPart = take (length toReplace) s\r
+ # lastPart = drop (length toReplace) s\r
+ | firstPart == toReplace = replacement ++ replaceInString` toReplace replacement lastPart\r
+ | otherwise = [x:replaceInString` toReplace replacement xs]\r
+ \r
+ charlist2string :: !String ![Char] -> String\r
+ charlist2string str [] = str\r
+ charlist2string str [x:xs] = charlist2string (str+++toString x) xs\r
+\r
+/** stringStarts s1 prefix yields true iff s1 = prefix +++ s for some s.\r
+*/\r
+stringStarts :: !String !String -> Bool\r
+stringStarts s1 prefix = size s1 >= size prefix && s1%(0,size prefix-1) == prefix\r
+\r
+/** removePrefix str prefix yields (Just s) iff str = prefix +++ s, and Nothing otherwise.\r
+*/\r
+removePrefix :: !String !String -> Maybe String\r
+removePrefix s1 prefix = if (stringStarts s1 prefix) (Just (s1%(size prefix,size s1-1))) Nothing\r
+\r
+/** isSorted [x_0..x_n] holds iff x_i <= x_{i+1} for each x_i in [x_0..x_{n-1}].\r
+*/\r
+isSorted :: ![a] -> Bool | Ord a\r
+isSorted [] = True\r
+isSorted xs = and [x <= y \\ x <- xs & y <- tl xs]\r
+\r
+/** perhaps p Nothing = False, and perhaps p (Just a) = p a\r
+*/\r
+perhaps :: !(a -> Bool) !(Maybe a) -> Bool\r
+perhaps _ Nothing = False\r
+perhaps p (Just a) = p a\r
+\r
+/** instance ~ Bool is not\r
+*/\r
+instance ~ Bool where (~) b = not b\r
+\r
+/** instance fromString Int = toInt\r
+*/\r
+instance fromString Int where fromString str = toInt str\r
+\r
+/** test and access functions for choice values:\r
+*/\r
+:: ThisOrThat a b = This a | That b\r
+\r
+isThis :: !(ThisOrThat a b) -> Bool\r
+isThis (This _) = True\r
+isThis _ = False\r
+\r
+isThat :: !(ThisOrThat a b) -> Bool\r
+isThat (That _) = True\r
+isThat _ = False\r
+\r
+this :: !(ThisOrThat a b) -> a\r
+this (This a) = a\r
+this _ = abort "this [StdEnvExt]: applied to That pattern instead of This pattern."\r
+\r
+that :: !(ThisOrThat a b) -> b\r
+that (That b) = b\r
+that _ = abort "that [StdEnvExt]: applied to This pattern instead of That pattern."\r
+\r
+instance sinus Real where sinus x = sin x\r
+instance cosinus Real where cosinus x = cos x\r
+instance tangens Real where tangens x = tan x\r
+instance arcsinus Real where arcsinus a = asin a\r
+instance arccosinus Real where arccosinus a = acos a\r
+instance arctangens Real where arctangens a = atan a\r
repositories / fp1415-soccerfun.git / blobdiff