home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.uni-stuttgart.de/pub/systems/acorn/
/
Acorn.tar
/
Acorn
/
acornet
/
dev
/
gofer.spk
/
!Gofer
/
preludes
/
gcwmin
< prev
next >
Wrap
Text File
|
1994-05-20
|
19KB
|
628 lines
-- __________ __________ __________ __________ ________
-- / _______/ / ____ / / _______/ / _______/ / ____ \
-- / / _____ / / / / / /______ / /______ / /___/ /
-- / / /_ / / / / / / _______/ / _______/ / __ __/
-- / /___/ / / /___/ / / / / /______ / / \ \
-- /_________/ /_________/ /__/ /_________/ /__/ \__\
--
-- Functional programming environment, Version 2.28
-- Copyright Mark P Jones 1991-1993.
--
-- Minimal Gofer prelude for experimentation with different approaches
-- to standard operations.
--
-- Any Gofer prelude file should typically include at least the following
-- definitions:
infixr 5 :
infixr 3 &&
infixr 2 ||
(&&), (||) :: Bool -> Bool -> Bool
False && _ = False -- (&&) and (||) names predefined in Gofer
True && x = x
False || x = x
True || _ = True
flip :: (a -> b -> c) -> b -> a -> c
flip f x y = f y x
-- Primitives -----------------------------------------------------------
primitive error "primError" :: String -> a
-- End of minimal prelude ----------------------------------------------
primitive strict "primStrict" :: (a -> b) -> a -> b
-- Format primitives ----------------------------------------------------
primitive primPrint "primPrint" :: Int -> a -> String -> String
primitive primShowsInt "primShowsInt" :: Int -> Int -> String -> String
primitive primShowsFloat "primShowsFloat" ::
Int -> Float -> String -> String
-- Character primitives -------------------------------------------------
primitive primEqChar "primEqChar",
primLeChar "primLeChar" :: Char -> Char -> Bool
primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char
-- Integer primitives --------------------------------------------------
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
primitive quot "primQuotInt",
rem "primRemInt",
mod "primModInt" :: Int -> Int -> Int
-- Float primitives ---------------------------------------------------
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
primitive truncate "primFloatToInt" :: Float -> Int
-- Trigonometric primitives ------------------------------------
primitive sin "primSinFloat", asin "primAsinFloat",
cos "primCosFloat", acos "primAcosFloat",
tan "primTanFloat", atan "primAtanFloat",
primLogFloat "primLogFloat", log10 "primLog10Float",
primExpFloat "primExpFloat", sqrt "primSqrtFloat"
:: Float -> Float
primitive atan2 "primAtan2Float" :: Float -> Float -> Float
-- IO ------------------------------------------------------------
stdin = "stdin"
stdout = "stdout"
stderr = "stderr"
stdecho = "stdecho"
{- The Dialogue, Request, Response and IOError datatypes are now built-in:
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
| GetArgs
| GetProgName
| GetEnv String
data Response = Success
| Str String
| Failure IOError
| StrList [String]
data IOError = WriteError String
| ReadError String
| SearchError String
| FormatError String
| OtherError String
type Dialogue = [Response] -> [Request]
-}
run :: (String -> String) -> Dialogue
run f ~(Success : ~(Str kbd : _))
= [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)]
primitive primFopen "primFopen" :: String -> a -> (String -> a) -> a
openfile :: String -> String
openfile f = primFopen f (error ("can't open file "++f)) id
--- Fixities ------------------------------------------------------------
infixl 9 !!
infixr 9 .
infixr 8 ^
infixl 7 *, :/, /
infix 7 `quot`, `rem`, `mod`
infixl 6 +, -, :+!
infixr 5 ++
infix 4 ==, /=, <, <=, >=, >
infixl 2 `bind`, `hcf`
-- Standard synonyms --------------------
type Rel a = a -> a -> Bool
type BinOp a = a -> a -> a
-- Standard type classes: -----------------------------------------------
class Eq a where
(==), (/=) :: Rel a
x /= y = not (x == y)
-- (x == x) === True
-- (x == y) === (y == x)
-- (x == y) && (y == z) ==> (x == z)
class Eq a => Ord a where
(<), (<=), (>), (>=) :: Rel a
max, min :: BinOp 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
-- x <= x === True
-- (x <= y) && (y <= z) ==> (x <= z)
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 LeftMul a b where
(*) :: a -> b -> b
class Add a where
(+),(-) :: BinOp a
negate :: a -> a
zero :: a
negate x = zero - x
-- x + (y + z) === (x + y) + z
-- x + y === y + x
-- zero + x === x
-- x + zero === x
-- x - x === zero
class LeftMul a a => Mult a where
unit :: a
(^) :: a -> Int -> a
x ^ 0 = unit
x ^ 1 = x
x ^ (2*n) = (x*x)^n
x ^ (2*n+1) = x*(x*x)^n
-- x*(y*z) === (x*y)*z
-- unit*x === x
class Div a b where
(/) :: a -> b -> a
class (Div a a, Add a, Mult a, Div a Int, LeftMul Int a) => Exp a where
exp, log, cosh, sinh, tanh :: a -> a
cosh x = (exp(x) + exp(-x))/2
sinh x = (exp(x) - exp(-x))/2
tanh x = (a-unit)/(a+unit) where a = exp(2*x)
class Functor f where
map :: (a -> b) -> (f a -> f b)
-- map (u.v) === (map u).(map v)
-- map id === id
class Functor m => Monad m where
result :: a -> m a
join :: m (m a) -> m a
bind :: m a -> (a -> m b) -> m b
join x = bind x (\y->y)
x `bind` f = join (map f x)
-- (map u).result === result.(map u)
-- (map u).join === join.(map (map u))
-- join.(map result) === id
-- join.result === id
-- join.join === join.(map join)
class Monad m => Monad0 m where
nil :: m a
-- map _ nil === nil
-- join nil === nil
class Monad0 c => MonadPlus c where
(++) :: c a -> c a -> c a
-- nil ++ x === x
-- x ++ (y ++ z) === (x ++ y) ++ z
-- 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 = (++)
-- Type class instances: -------------------------------------------
instance Eq () where () == () = True
instance Ord () where () <= () = True
instance Eq Int where (==) = primEqInt
instance Ord Int where (<=) = primLeInt
instance Ix Int where
range (m,n) = [m..n]
index (m,n) i = primMinusInt i m
inRange (m,n) i = m <= i && i <= n
instance Enum Int where
enumFrom n = iterate (primPlusInt 1) n
enumFromThen n m = iterate (primPlusInt (primMinusInt m n)) n
instance Eq Float where (==) = primEqFloat
instance Ord Float where (<=) = primLeFloat
instance Enum Float where
enumFrom n = iterate (primPlusFloat 1.0) n
enumFromThen n m = iterate (primPlusFloat (primMinusFloat m n)) n
instance Eq Char where (==) = primEqChar -- c == d = ord c == ord d
instance Ord Char where (<=) = primLeChar -- c <= d = ord c <= ord d
instance Ix Char where
range (c,c') = [c..c']
index (c,c') ci = primMinusInt (ord ci) (ord c)
inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci
instance Enum Char where
enumFrom c = [chr n | n <- [ord c .. 255]]
enumFromThen c c' = [chr n | n <- [ord c, ord c' .. ord lastChar]]
where lastChar = if c' < c then (chr 0) else (chr 255)
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<y || (x==y && xs<=ys)
instance (Eq a, Eq b) => Eq (a,b) where
(x,y) == (u,v) = x==u && y==v
instance (Eq a, Eq b, Eq c) => Eq (a,b,c) where
(x,y,z) == (u,v,w) = x == u && y == v && z == w
instance (Ord a, Ord b) => Ord (a,b) where
(x,y) <= (u,v) = x<u || (x==u && y<=v)
instance (Ord a, Ord b, Ord c) => Ord (a,b,c) where
(x,y,z) <= (u,v,w) = x<u || (x == u && ( y<v || (y==v && z<=w)))
instance Eq Bool where
True == True = True
False == False = True
_ == _ = False
instance Ord Bool where
False <= x = True
True <= x = x
instance LeftMul Int Int where
(*) = primMulInt
instance LeftMul Int Float where
(*) n = primMulFloat(primIntToFloat n)
instance LeftMul Float Float where
(*) = primMulFloat
instance (LeftMul a b, LeftMul a c) => LeftMul a (b,c)
where a * (b,c) = (a*b, a*c)
instance (LeftMul a b, LeftMul a c, LeftMul a d) => LeftMul a (b,c,d)
where a * (b,c,d) = (a*b, a*c, a*d)
instance LeftMul (a->a) (b->a)
where (*) = (.)
instance Add Int
where (+) = primPlusInt
(-) = primMinusInt
negate = primNegInt
zero = 0
instance Add Float
where (+) = primPlusFloat
(-) = primMinusFloat
negate = primNegFloat
zero = 0.0
instance (Add a, Add b) => Add (a,b)
where (a,b) + (a',b') = (a+a',b+b')
(a,b) - (a',b') = (a-a',b-b')
negate (a,b) = (-a,-b)
zero = (zero,zero)
instance (Add a, Add b, Add c) => Add (a,b,c)
where (a,b,c) + (a',b',c') = (a+a',b+b',c+c')
(a,b,c) - (a',b',c') = (a-a',b-b',c-c')
negate (a,b,c) = (-a,-b,-c)
zero = (zero,zero,zero)
instance Add a => Add (b->a)
where f + f' = \b -> (f b)+(f' b)
f - f' = \b -> (f b)-(f' b)
- f = \b -> -(f b)
zero = \b -> zero
instance Mult Int
where unit = 1
instance Mult Float
where unit = 1.0
instance Mult (a->a)
where unit = \x -> x
instance Div Int Int
where (/) = primDivInt
instance Div Float Float
where (/) = primDivFloat
instance Div Float Int
where x/n = x/(primIntToFloat n)
instance Exp Float
where exp = primExpFloat
log = primLogFloat
instance Functor [] where map f [] = []
map f (x:xs) = f x : map f xs
instance Monad [] where result x = [x]
[] `bind` f = []
(x:xs) `bind` f = f x ++ (xs `bind` f)
instance Monad0 [] where nil = []
instance MonadPlus [] where [] ++ ys = ys
(x:xs) ++ ys = x : (xs ++ ys)
instance Text () where
showsPrec d () = showString "()"
instance Text Bool where
showsPrec d True = showString "True"
showsPrec d False = showString "False"
instance Text Int where showsPrec = primShowsInt
instance Text Float where showsPrec = primShowsFloat
instance Text Char where
showsPrec p c = showString [q, c, q] where q = '\''
showList cs = showChar '"' . showl cs
where showl "" = showChar '"'
showl ('"':cs) = showString "\\\"" . showl cs
showl (c:cs) = showChar 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 ')'
----- standard list functions used in prelude ----------------
(!!) :: [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), ...
take :: Int -> [a] -> [a]
take 0 _ = []
take _ [] = []
take (n+1) (x:xs) = x : take n xs
takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile p [] = []
takeWhile p (x:xs)
| p x = x : takeWhile p xs
| otherwise = []
----- standard Boolean values used in prelude -------------------
otherwise :: Bool
otherwise = True
not :: Bool -> Bool
not True = False
not False = True
------- standard arithmetic functions ------------------
abs :: (Add a, Ord a) => a -> a
abs x | x < zero = -x
| otherwise = x
signum :: (Add a, Ord a) => a -> Int
signum x | x > zero = 1
| x < zero = -1
| x == zero = 0
hcf :: BinOp Int
hcf x 0 = x
hcf x y = hcf y (x `mod` y)
sum :: Add a => [a] -> a
sum [] = zero
sum (x:xs) = x + sum xs
product :: Mult a => [a] -> a
product [] = unit
product (x:xs) = x*product xs
pi :: Float
pi = 3.1415926535
------- standard combinators ----------------------
(.) :: (b -> c) -> (a -> b) -> (a -> c)
(f . g) x = f (g x)
id :: a -> a
id x = x
undefined :: a
undefined | False = undefined
---- Rationals -------------------------------------
data Rational = Int :/ Int
instance Eq Rational where
(n :/ d) == (n' :/ d') = n*d' == n'*d
instance LeftMul Rational Rational where
(n :/ d) * (n' :/ d') = lowest ((n*n') :/ (d*d'))
instance LeftMul Int Rational where
m * (n :/ d) = lowest ((m*n) :/ d)
instance LeftMul Rational Float where
(n :/ d) * x = n*(x/(primIntToFloat d))
instance Add Rational where
(n :/ d) + (n' :/ d') = lowest ((n*d'+n'*d) :/ (d*d'))
(n :/ d) - (n' :/ d') = lowest ((n*d'-n'*d) :/ (d*d'))
negate (n :/ d) = ((-n) :/ d)
zero = 0 :/ 1
instance Mult Rational where
unit = 1 :/ 1
instance Div Rational Int where
(n :/ d) / m = lowest (n :/ (d*m))
instance Div Rational Rational where
(n :/ d) / (n' :/ d') = lowest ((n*d') :/ (n'*d))
instance Div Float Rational where
x / (n :/ d) = (d*x)/n
instance Ord Rational where
(n :/ d) <= (n' :/ d') | d*d' > 0 = n*d' <= n'*d
| otherwise = n*d' >= n'*d
instance Enum Rational where
enumFrom q = iterate (\(n:/d)->(n+d):/d) q
enumFromThen q r = iterate (+ (r-q)) q
instance Text Rational where
showsPrec p (n :/ d) | d' == 1 = shows n'
| otherwise = shows n'.showChar '/'.shows d'
where (n' :/ d') = lowest (n :/ d)
lowest (n :/ d) = (n/q) :/ (d/q) where q = (hcf n d)*(signum d)
------ Complexes -----------------------------------------------
data Gauss a = a :+! a
type Complex = Gauss Float
instance (Eq a) => Eq (Gauss a) where
(x :+! y) == (x' :+! y') = (x==x') && (y==y')
instance (Mult a, Add a) => Mult (Gauss a) where
unit = unit :+! zero
instance (Add a) => Add (Gauss a) where
(x :+! y) + (x' :+! y') = (x+x') :+! (y+y')
(x :+! y) - (x' :+! y') = (x-x') :+! (y-y')
negate (x :+! y) = (-x) :+! (-y)
zero = zero :+! zero
instance (LeftMul a b) => LeftMul a (Gauss b) where
x * (y :+! z) = (x*y) :+! (x*z)
instance (LeftMul a b, Add b) => LeftMul (Gauss a) (Gauss b) where
(x :+! y) * (x' :+! y') = (x*x' - y*y') :+! (x*y' + y*x')
instance Div a b => Div (Gauss a) b where
(x :+! y)/d = (x/d) :+! (y/d)
instance (Div a b, Add a, Add b, LeftMul b a, LeftMul b b, LeftMul a a)
=> Div (Gauss a) (Gauss b)
where z / z' = (x/d) :+! (y/d)
where x = u'*u+v'*v
y = u'*v-v'*u
d = u'*u'+v'*v'
u:+!v = z
u':+!v' = z'
instance Exp Complex where
exp (x :+! y) = let r = exp(x) in (r*cos(y)) :+! (r*(sin(y)))
log (x :+! y) = let r=sqrt(x*x+y*y) in (log(r)) :+! (atan2 y x)
instance (Text a, Add a, Mult a, Ord a) => Text (Gauss a)
where
showsPrec n (x :+! y) | y == zero = shows x
| x == zero = showIm y
| y > zero = shows x. showChar '+'. showIm y
| y < zero = shows x. showChar '-'. showIm (-y)
where showIm y | y == unit = showChar 'i'
| y == (-unit) = showString "-i"
| otherwise = shows y.showChar 'i'
norm :: (Add a, LeftMul a a) => (Gauss a) -> a
norm (x :+! y) = x*x + y*y
conjugate :: Add a => (Gauss a) -> (Gauss a)
conjugate (x :+! y) = x :+! (-y)
i :: (Add a, Mult a) => (Gauss a)
i = zero :+! unit
-- end of gcwmin ------------------------------------------------