-- __________ __________ __________ __________ ________ -- / _______/ / ____ / / _______/ / _______/ / ____ \ -- / / _____ / / / / / /______ / /______ / /___/ / -- / / /_ / / / / / / _______/ / _______/ / __ __/ -- / /___/ / / /___/ / / / / /______ / / \ \ -- /_________/ /_________/ /__/ /_________/ /__/ \__\ -- -- Functional programming environment, Version 2.21 -- Copyright Mark P Jones 1991. -- -- Standard prelude for use of overloaded values using type classes. -- Based on the Haskell standard prelude version 1.1. help = "press :? for a list of commands" -- Operator precedence table: ----------------------------------------------- infixl 9 !! infixr 9 . infixr 8 ^ infixl 7 * infix 7 /, `div`, `rem`, `mod` infixl 6 +, - infix 5 \\ infixr 5 ++, : infix 4 ==, /=, <, <=, >=, > infix 4 `elem`, `notElem` infixr 3 && infixr 2 || -- Standard combinators: ---------------------------------------------------- primitive strict "primStrict" :: (a -> b) -> a -> b const :: a -> b -> a const k x = k id :: a -> a id x = x curry :: ((a,b) -> c) -> a -> b -> c curry f a b = f (a,b) uncurry :: (a -> b -> c) -> (a,b) -> c uncurry f (a,b) = f a b fst :: (a,b) -> a fst (x,_) = x snd :: (a,b) -> b snd (_,y) = y fst3 :: (a,b,c) -> a fst3 (x,_,_) = x snd3 :: (a,b,c) -> b snd3 (_,x,_) = x thd3 :: (a,b,c) -> c thd3 (_,_,x) = x (.) :: (b -> c) -> (a -> b) -> (a -> c) (f . g) x = f (g x) flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x -- Boolean functions: ------------------------------------------------------- (&&), (||) :: Bool -> Bool -> Bool False && x = False True && x = x False || x = x True || x = True not :: Bool -> Bool not True = False not False = True and, or :: [Bool] -> Bool and = foldr (&&) True or = foldr (||) False any, all :: (a -> Bool) -> [a] -> Bool any p = or . map p all p = and . map p otherwise :: Bool otherwise = True -- Character functions: ----------------------------------------------------- primitive ord "primCharToInt" :: Char -> Int primitive chr "primIntToChar" :: Int -> Char isAscii, isControl, isPrint, isSpace :: Char -> Bool isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool isAscii c = ord c < 128 isControl c = c < ' ' || c == '\DEL' isPrint c = c >= ' ' && c <= '~' isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v' isUpper c = c >= 'A' && c <= 'Z' isLower c = c >= 'a' && c <= 'z' isAlpha c = isUpper c || isLower c isDigit c = c >= '0' && c <= '9' isAlphanum c = isAlpha c || isDigit c toUpper, toLower :: Char -> Char toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A') | otherwise = c toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a') | otherwise = c -- Standard type classes: --------------------------------------------------- class Eq a where (==), (/=) :: a -> a -> Bool x /= y = not (x == y) class Eq a => Ord a where (<), (<=), (>), (>=) :: a -> a -> Bool max, min :: a -> a -> a x < y = x <= y && x /= y x >= y = y <= x x > y = y < x max x y | x >= y = x | y >= x = y min x y | x <= y = x | y <= x = y class Ord a => Ix a where range :: (a,a) -> [a] index :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool class Ord a => Enum a where enumFrom :: a -> [a] -- [n..] enumFromThen :: a -> a -> [a] -- [n,m..] enumFromTo :: a -> a -> [a] -- [n..m] enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] enumFromTo n m = takeWhile (m>=) (enumFrom n) enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m) (enumFromThen n n') class Eq a => Num a where -- simplified numeric class (+), (-), (*), (/) :: a -> a -> a negate :: a -> a fromInteger :: Int -> a -- Type class instances: ---------------------------------------------------- primitive primEqInt "primEqInt", primLeInt "primLeInt" :: Int -> Int -> Bool primitive primPlusInt "primPlusInt", primMinusInt "primMinusInt", primDivInt "primDivInt", primMulInt "primMulInt" :: Int -> Int -> Int primitive primNegInt "primNegInt" :: Int -> Int instance Eq Int where (==) = primEqInt instance Ord Int where (<=) = primLeInt instance Ix Int where range (m,n) = [m..n] index (m,n) i = i - m inRange (m,n) i = m <= i && i <= n instance Enum Int where enumFrom n = iterate (1+) n enumFromThen n m = iterate ((m-n)+) n instance Num Int where (+) = primPlusInt (-) = primMinusInt (*) = primMulInt (/) = primDivInt negate = primNegInt fromInteger x = x {- PC version off -} primitive primEqFloat "primEqFloat", primLeFloat "primLeFloat" :: Float -> Float -> Bool primitive primPlusFloat "primPlusFloat", primMinusFloat "primMinusFloat", primDivFloat "primDivFloat", primMulFloat "primMulFloat" :: Float -> Float -> Float primitive primNegFloat "primNegFloat" :: Float -> Float primitive primIntToFloat "primIntToFloat" :: Int -> Float instance Eq Float where (==) = primEqFloat instance Ord Float where (<=) = primLeFloat instance Enum Float where enumFrom n = iterate (1.0+) n enumFromThen n m = iterate ((m-n)+) n instance Num Float where (+) = primPlusFloat (-) = primMinusFloat (*) = primMulFloat (/) = primDivFloat negate = primNegFloat fromInteger = primIntToFloat {- PC version on -} instance Eq Char where c == d = ord c == ord d instance Ord Char where c <= d = ord c <= ord d instance Ix Char where range (c,c') = [c..c'] index (c,c') ci = ord ci - ord c inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci instance Enum Char where enumFrom c = map chr [ord c ..] enumFromThen c c' = map chr [ord c, ord c' ..] instance Eq a => Eq [a] where [] == [] = True [] == (y:ys) = False (x:xs) == [] = False (x:xs) == (y:ys) = x==y && xs==ys instance Ord a => Ord [a] where [] <= _ = True (_:_) <= [] = False (x:xs) <= (y:ys) = x Eq (a,b) where (x,y) == (u,v) = x==u && y==v instance (Ord a, Ord b) => Ord (a,b) where (x,y) <= (u,v) = x Int -> Int subtract :: Num a => a -> a -> a subtract = flip (-) even, odd :: Int -> Bool even x = x `rem` 2 == 0 odd = not . even gcd :: Int -> Int -> Int gcd x y = gcd' (abs x) (abs y) where gcd' x 0 = x gcd' x y = gcd' y (x `rem` y) lcm :: Int -> Int -> Int lcm _ 0 = 0 lcm 0 _ = 0 lcm x y = abs ((x `div` gcd x y) * y) (^) :: Int -> Int -> Int x ^ 0 = 1 x ^ (n+1) = f x n x where f _ 0 y = y f x n y = g x n where g x n | even n = g (x*x) (n`div`2) | otherwise = f x (n-1) (x*y) abs :: Int -> Int abs x | x >= 0 = x | x < 0 = - x signum :: Int -> Int signum x | x == 0 = 0 | x > 0 = 1 | x < 0 = -1 sum, product :: [Int] -> Int sum = foldl' (+) 0 product = foldl' (*) 1 sums, products :: [Int] -> [Int] sums = scanl (+) 0 products = scanl (*) 1 -- Standard list processing functions: -------------------------------------- head :: [a] -> a head (x:_) = x last :: [a] -> a last [x] = x last (_:xs) = last xs tail :: [a] -> [a] tail (_:xs) = xs init :: [a] -> [a] init [x] = [] init (x:xs) = x : init xs (++) :: [a] -> [a] -> [a] -- append lists. Associative with [] ++ ys = ys -- left and right identity []. (x:xs) ++ ys = x:(xs++ys) length :: [a] -> Int -- calculate length of list length = foldl' (\n _ -> n+1) 0 (!!) :: [a] -> Int -> a -- xs!!n selects the nth element of (x:_) !! 0 = x -- the list xs (first element xs!!0) (_:xs) !! (n+1) = xs !! n -- for any n < length xs. iterate :: (a -> a) -> a -> [a] -- generate the infinite list iterate f x = x : iterate f (f x) -- [x, f x, f (f x), ... repeat :: a -> [a] -- generate the infinite list repeat x = xs where xs = x:xs -- [x, x, x, x, ... cycle :: [a] -> [a] -- generate the infinite list cycle xs = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ... copy :: Int -> a -> [a] -- make list of n copies of x copy n x = take n xs where xs = x:xs nub :: Eq a => [a] -> [a] -- remove duplicates from list nub [] = [] nub (x:xs) = x : nub (filter (x/=) xs) reverse :: [a] -> [a] -- reverse elements of list reverse = foldl (flip (:)) [] elem, notElem :: Eq a => a -> [a] -> Bool elem = any . (==) -- test for membership in list notElem = all . (/=) -- test for non-membership maximum, minimum :: Ord a => [a] -> a maximum = foldl1 max -- max element in non-empty list minimum = foldl1 min -- min element in non-empty list concat :: [[a]] -> [a] -- concatenate list of lists concat = foldr (++) [] transpose :: [[a]] -> [[a]] -- transpose list of lists transpose = foldr (\xs xss -> zipWith (:) xs (xss ++ repeat [])) [] -- null provides a simple and efficient way of determining whether a given -- list is empty, without using (==) and hence avoiding a constraint of the -- form Eq [a]. null :: [a] -> Bool null [] = True null (_:_) = False -- (\\) is used to remove the first occurrence of each element in the second -- list from the first list. It is a kind of inverse of (++) in the sense -- that (xs ++ ys) \\ xs = ys for any finite list xs of proper values xs. (\\) :: Eq a => [a] -> [a] -> [a] (\\) = foldl del where [] `del` _ = [] (x:xs) `del` y | x == y = xs | otherwise = x : xs `del` y -- map f xs applies the function f to each element of the list xs returning -- the corresponding list of results. filter p xs returns the sublist of xs -- containing those elements which satisfy the predicate p. map :: (a -> b) -> [a] -> [b] map f [] = [] map f (x:xs) = f x : map f xs filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) | p x = x : xs' | otherwise = xs' where xs' = filter p xs -- Fold primitives: The foldl and scanl functions, variants foldl1 and -- scanl1 for non-empty lists, and strict variants foldl' scanl' describe -- common patterns of recursion over lists. Informally: -- -- foldl f a [x1, x2, ..., xn] = f (...(f (f a x1) x2)...) xn -- = (...((a `f` x1) `f` x2)...) `f` xn -- etc... -- -- The functions foldr, scanr and variants foldr1, scanr1 are duals of these -- functions: -- e.g. foldr f a xs = foldl (flip f) a (reverse xs) for finite lists xs. foldl :: (a -> b -> a) -> a -> [b] -> a foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs foldl' :: (a -> b -> a) -> a -> [b] -> a foldl' f a [] = a foldl' f a (x:xs) = strict (foldl' f) (f a x) xs scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f q xs = q : (case xs of [] -> [] x:xs -> scanl f (f q x) xs) scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 f (x:xs) = scanl f x xs scanl' :: (a -> b -> a) -> a -> [b] -> [a] scanl' f q xs = q : (case xs of [] -> [] x:xs -> strict (scanl' f) (f q x) xs) foldr :: (a -> b -> b) -> b -> [a] -> b foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) foldr1 :: (a -> a -> a) -> [a] -> a foldr1 f [x] = x foldr1 f (x:xs) = f x (foldr1 f xs) scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr f q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs scanr1 :: (a -> a -> a) -> [a] -> [a] scanr1 f [x] = [x] scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs -- List breaking functions: -- -- take n xs returns the first n elements of xs -- drop n xs returns the remaining elements of xs -- splitAt n xs = (take n xs, drop n xs) -- -- takeWhile p xs returns the longest initial segment of xs whose -- elements satisfy p -- dropWhile p xs returns the remaining portion of the list -- span p xs = (takeWhile p xs, dropWhile p xs) -- -- takeUntil p xs returns the list of elements upto and including the -- first element of xs which satisfies p take :: Int -> [a] -> [a] take 0 _ = [] take _ [] = [] take (n+1) (x:xs) = x : take n xs drop :: Int -> [a] -> [a] drop 0 xs = xs drop _ [] = [] drop (n+1) (_:xs) = drop n xs splitAt :: Int -> [a] -> ([a], [a]) splitAt 0 xs = ([],xs) splitAt _ [] = ([],[]) splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile p [] = [] takeWhile p (x:xs) | p x = x : takeWhile p xs | otherwise = [] takeUntil :: (a -> Bool) -> [a] -> [a] takeUntil p [] = [] takeUntil p (x:xs) | p x = [x] | otherwise = x : takeUntil p xs dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile p [] = [] dropWhile p xs@(x:xs') | p x = dropWhile p xs' | otherwise = xs span, break :: (a -> Bool) -> [a] -> ([a],[a]) span p [] = ([],[]) span p xs@(x:xs') | p x = let (ys,zs) = span p xs' in (x:ys,zs) | otherwise = ([],xs) break p = span (not . p) -- Text processing: -- lines s returns the list of lines in the string s. -- words s returns the list of words in the string s. -- unlines ls joins the list of lines ls into a single string -- with lines separated by newline characters. -- unwords ws joins the list of words ws into a single string -- with words separated by spaces. lines :: String -> [String] lines "" = [] lines s = l : (if null s' then [] else lines (tail s')) where (l, s') = break ('\n'==) s words :: String -> [String] words s = case dropWhile isSpace s of "" -> [] s' -> w : words s'' where (w,s'') = break isSpace s' unlines :: [String] -> String unlines = concat . map (\l -> l ++ "\n") unwords :: [String] -> String unwords [] = [] unwords ws = foldr1 (\w s -> w ++ ' ':s) ws -- Merging and sorting lists: merge :: Ord a => [a] -> [a] -> [a] merge [] ys = ys merge xs [] = xs merge (x:xs) (y:ys) | x <= y = x : merge xs (y:ys) | otherwise = y : merge (x:xs) ys sort :: Ord a => [a] -> [a] sort = foldr insert [] insert :: Ord a => a -> [a] -> [a] insert x [] = [x] insert x (y:ys) | x <= y = x:y:ys | otherwise = y:insert x ys qsort :: Ord a => [a] -> [a] qsort [] = [] qsort (x:xs) = qsort [ u | u<-xs, u=x ] -- zip and zipWith families of functions: zip :: [a] -> [b] -> [(a,b)] zip = zipWith (\a b -> (a,b)) zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 = zipWith3 (\a b c -> (a,b,c)) zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] zip4 = zipWith4 (\a b c d -> (a,b,c,d)) zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)] zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f)) zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)] zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g)) zipWith :: (a->b->c) -> [a]->[b]->[c] zipWith z (a:as) (b:bs) = z a b : zipWith z as bs zipWith _ _ _ = [] zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs zipWith3 _ _ _ _ = [] zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4 z as bs cs ds zipWith4 _ _ _ _ _ = [] zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f] zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e : zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = [] zipWith6 :: (a->b->c->d->e->f->g) -> [a]->[b]->[c]->[d]->[e]->[f]->[g] zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = z a b c d e f : zipWith6 z as bs cs ds es fs zipWith6 _ _ _ _ _ _ _ = [] zipWith7 :: (a->b->c->d->e->f->g->h) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = z a b c d e f g : zipWith7 z as bs cs ds es fs gs zipWith7 _ _ _ _ _ _ _ _ = [] -- Formatted output: -------------------------------------------------------- primitive primPrint "primPrint" :: Int -> a -> String -> String show' :: a -> String show' x = primPrint 0 x [] cjustify, ljustify, rjustify :: Int -> String -> String cjustify n s = space halfm ++ s ++ space (m - halfm) where m = n - length s halfm = m `div` 2 ljustify n s = s ++ space (n - length s) rjustify n s = space (n - length s) ++ s space :: Int -> String space n = copy n ' ' layn :: [String] -> String layn = lay 1 where lay _ [] = [] lay n (x:xs) = rjustify 4 (show n) ++ ") " ++ x ++ "\n" ++ lay (n+1) xs -- Miscellaneous: ----------------------------------------------------------- until :: (a -> Bool) -> (a -> a) -> a -> a until p f x | p x = x | otherwise = until p f (f x) until' :: (a -> Bool) -> (a -> a) -> a -> [a] until' p f = takeUntil p . iterate f error :: String -> a error msg | False = error msg undefined :: a undefined | False = undefined asTypeOf :: a -> a -> a x `asTypeOf` _ = x -- A trimmed down version of the Haskell Text class: ------------------------ type ShowS = String -> String class Text a where showsPrec :: Int -> a -> ShowS showList :: [a] -> ShowS showsPrec = primPrint showList [] = showString "[]" showList (x:xs) = showChar '[' . shows x . showl xs where showl [] = showChar ']' showl (x:xs) = showChar ',' . shows x . showl xs shows :: Text a => a -> ShowS shows = showsPrec 0 show :: Text a => a -> String show x = shows x "" showChar :: Char -> ShowS showChar = (:) showString :: String -> ShowS showString = (++) instance Text () instance Text Int {- PC version off -} instance Text Float {- PC version on -} instance Text Char where showList cs = showChar '"' . showl cs where showl "" = showChar '"' showl ('"':cs) = showString "\\\"" . showl cs showl (c:cs) = showChar c . showl cs -- Haskell has showLitChar c . showl cs instance Text a => Text [a] where showsPrec p = showList instance (Text a, Text b) => Text (a,b) where showsPrec p (x,y) = showChar '(' . shows x . showChar ',' . shows y . showChar ')' -- I/O functions and definitions: ------------------------------------------- stdin = "stdin" stdout = "stdout" stderr = "stderr" stdecho = "stdecho" data Request = -- file system requests: ReadFile String | WriteFile String String | AppendFile String String -- channel system requests: | ReadChan String | AppendChan String String -- environment requests: | Echo Bool data Response = Success | Str String | Failure IOError data IOError = WriteError String | ReadError String | SearchError String | FormatError String | OtherError String type Dialogue = [Response] -> [Request] type SuccCont = Dialogue type StrCont = String -> Dialogue type FailCont = IOError -> Dialogue done :: Dialogue readFile :: String -> FailCont -> StrCont -> Dialogue writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue readChan :: String -> FailCont -> StrCont -> Dialogue appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue echo :: Bool -> FailCont -> SuccCont -> Dialogue done resps = [] readFile name fail succ resps = (ReadFile name) : strDispatch fail succ resps writeFile name contents fail succ resps = (WriteFile name contents) : succDispatch fail succ resps appendFile name contents fail succ resps = (AppendFile name contents) : succDispatch fail succ resps readChan name fail succ resps = (ReadChan name) : strDispatch fail succ resps appendChan name contents fail succ resps = (AppendChan name contents) : succDispatch fail succ resps echo bool fail succ resps = (Echo bool) : succDispatch fail succ resps strDispatch fail succ (resp:resps) = case resp of Str val -> succ val resps Failure msg -> fail msg resps succDispatch fail succ (resp:resps) = case resp of Success -> succ resps Failure msg -> fail msg resps abort :: FailCont abort err = done exit :: FailCont exit err = appendChan stdout msg abort done where msg = case err of ReadError s -> s WriteError s -> s SearchError s -> s FormatError s -> s OtherError s -> s print :: Text a => a -> Dialogue print x = appendChan stdout (show x) abort done prints :: Text a => a -> String -> Dialogue prints x s = appendChan stdout (shows x s) abort done interact :: (String -> String) -> Dialogue interact f = readChan stdin abort (\x -> appendChan stdout (f x) abort done) run :: (String -> String) -> Dialogue run f = echo False abort (interact f) -- End of Gofer standard prelude: --------------------------------------------