--         __________   __________   __________   __________   ________
--        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
--       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
--      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
--     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \ 
--    /_________/  /_________/  /__/         /_________/  /__/    \__\
--
--    Functional programming environment, Version 2.21
--    Copyright Mark P Jones 1991.
--
--    Simplified prelude, without any type classes and overloaded values
--    Based on the Haskell standard prelude version 1.1.
--
--    This prelude file shows one approach to using Gofer without the
--    use of overloaded implementations of show, <=, == etc.
--
--    Needless to say, some (most) of the Gofer demonstration programs
--    cannot be used inconnection with this prelude ... but a wide
--    family of programs can be used without needing to worry about
--    type classes at all.
--

-- 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:

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,y)       = x

snd            :: (a,b) -> b
snd (x,y)       = y

(.)	       :: (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

otherwise      :: Bool
otherwise       = True

-- Essentials and builtin primitives:

primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char

primitive (==) "primGenericEq",
          (/=) "primGenericNe",
          (<=) "primGenericLe",
          (<)  "primGenericLt",
          (>=) "primGenericGe",
          (>)  "primGenericGt"  :: a -> a -> Bool

max x y | x >= y    = x
        | otherwise = y
min x y | x <= y    = x
        | otherwise = y

enumFrom n           = iterate (1+) n				   -- [n..]
enumFromThen n m     = iterate ((m-n)+) n			   -- [n,m..]
enumFromTo n m       = takeWhile (m>=) (enumFrom n)		   -- [n..m]
enumFromThenTo n o m = takeWhile ((if o>=n then (>=) else (<=)) m) -- [n,o..m]
                                 (enumFromThen n o)

primitive (+)    "primPlusInt",
	  (-)    "primMinusInt",
          (/)    "primDivInt",
	  div    "primDivInt",
          rem    "primRemInt",
          mod    "primModInt",
	  (*)    "primMulInt"   :: Int -> Int -> Int
primitive negate "primNegInt"   :: Int -> Int

-- Character functions

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 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

subtract   = flip (-)
even x     = x `rem` 2 == 0
odd        = not . even

gcd x y    = gcd' (abs x) (abs y)
             where gcd' x 0 = x
                   gcd' x y = gcd' y (x `rem` y)

lcm _ 0    = 0
lcm 0 _    = 0
lcm x y    = abs ((x `div` gcd x y) * y)

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 x    | x >= 0 = x
         | x <  0 = - x

signum x | x == 0 = 0
         | x > 0  = 1
         | x < 0  = -1

-- Standard functions

until p f x | p x       = x
            | otherwise = until p f (f x)

error             :: String -> a
error msg | False  = error msg

asTypeOf      :: a -> a -> a
x `asTypeOf` _ = x

-- Standard list functions

head (x:_)        = x

last [x]          = x
last (_:xs)       = last xs

tail (_:xs)       = xs

init [x]          = []
init (x:xs)       = x : init xs

null []           = True
null (_:_)        = False

[]     ++ ys      = ys
(x:xs) ++ ys      = x:(xs++ys)

(\\)              = foldl del
                    where []     `del` _  = []
                          (x:xs) `del` y
                             | x == y     = xs
                             | otherwise  = x : xs `del` y

length            = foldl' (\n _ -> n+1) 0

(x:_)  !! 0       = x
(_:xs) !! (n+1)   = xs !! n

map f []          = []
map f (x:xs)      = f x : map f xs

filter _ []       = []
filter p (x:xs)
    | p x         = x : xs'
    | otherwise   = xs'
                  where xs' = filter p xs

foldl f z []      = z
foldl f z (x:xs)  = foldl f (f z x) xs

foldl1 f (x:xs)   = foldl f x xs

scanl f q xs      = q : (case xs of
                         []   -> []
                         x:xs -> scanl f (f q x) xs)

scanl1 f (x:xs)   = scanl f x xs


foldr f z []      = z
foldr f z (x:xs)  = f x (foldr f z xs)

foldr1 f [x]      = x
foldr1 f (x:xs)   = f x (foldr1 f xs)

scanr f q0 []     = [q0]
scanr f q0 (x:xs) = f x q : qs
                    where qs@(q:_) = scanr f q0 xs

scanr1 f [x]      = [x]
scanr1 f (x:xs)   = f x q : qs
                    where qs@(q:_) = scanr1 f xs

iterate f x       = x : iterate f (f x)

repeat x          = xs where xs = x:xs

cycle xs          = xs' where xs' = xs++xs'

take 0     _      = []
take _     []     = []
take (n+1) (x:xs) = x : take n xs

drop 0     xs     = xs
drop _     []     = []
drop (n+1) (_:xs) = drop n xs

splitAt 0     xs     = ([],xs)
splitAt _     []     = ([],[])
splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs

takeWhile p []          = []
takeWhile p (x:xs)
            | p x       = x : takeWhile p xs
            | otherwise = []

dropWhile p []          = []
dropWhile p xs@(x:xs')
            | p x       = dropWhile p xs'
            | otherwise = xs

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)

lines ""          = []
lines s           = l : (if null s' then [] else lines (tail s'))
                    where (l, s') = break ('\n'==) s

words s           = case dropWhile isSpace s of
                         "" -> []
                         s' -> w : words s''
                               where (w,s'') = break isSpace s'

unlines           = concat . map (\l -> l ++ "\n")

unwords []        = []
unwords ws        = foldr1 (\w s -> w ++ ' ':s) ws

nub []            = []
nub (x:xs)        = x : nub (filter (x/=) xs)

reverse           = foldl (flip (:)) []

and               = foldr (&&) True
or                = foldr (||) False

any p             = or  . map p
all p             = and . map p

elem              = any . (==)
notElem           = all . (/=)

sum               = foldl' (+) 0
product           = foldl' (*) 1

sums              = scanl (+) 0
products          = scanl (*) 1

maximum           = foldl1 max
minimum           = foldl1 min

concat            = foldr (++) []

transpose         = foldr
                      (\xs xss -> zipWith (:) xs (xss ++ repeat []))
                      []

zip                       = zipWith  (\a b -> (a,b))
zip3                      = zipWith3 (\a b c -> (a,b,c))
zip4                      = zipWith4 (\a b c d -> (a,b,c,d))
zip5                      = zipWith5 (\a b c d e -> (a,b,c,d,e))
zip6                      = zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
zip7                      = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))

zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
zipWith _ _      _        = []

zipWith3 z (a:as) (b:bs) (c:cs)
                          = z a b c : zipWith3 z as bs cs
zipWith3 _ _ _ _          = []

zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
                          = z a b c d : zipWith4 z as bs cs ds
zipWith4 _ _ _ _ _        = []

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 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 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 _ _ _ _ _ _ _ _  = []


-- Additional B+W/Orwell prelude functions

primitive strict    "primStrict" :: (a -> b) -> a -> b
primitive primPrint "primPrint"  :: Int -> a -> String -> String

show x                        =  primPrint 0 x []

copy n x                      =  take n xs where xs = x:xs

foldl' f a []                 =  a
foldl' f a (x:xs)             =  strict (foldl' f) (f a x) xs

scanl' f q xs                 = q : (case xs of
                                    []   -> []
                                    x:xs -> strict (scanl' f) (f q x) xs)

merge []         ys           =  ys
merge xs         []           =  xs
merge xs'@(x:xs) ys'@(y:ys)
                 | x <= y     =  x : merge xs ys'
                 | otherwise  =  y : merge xs' ys

sort                          = foldr insert []
insert x []                   = [x]
insert x (y:ys)  | x <= y     = x:y:ys
                 | otherwise  = y:insert x ys

space n         =  copy n ' '

qsort []        =  []
qsort (x:xs)    =  qsort [ u | u<-xs, u<x ] ++
                         [ x ] ++
                   qsort [ u | u<-xs, u>=x ]

undefined | False =  undefined

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

layn = lay 1
 where lay _ []     = []
       lay n (x:xs) = rjustify 4 (show n) ++ ") " ++ x ++ "\n" ++ lay (n+1) xs

-- I/O functions and definitions:
-- This is the minimum required for bootstrapping and execution of
-- interactive programs.

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

-- Continuation-based I/O:

type Dialogue    =  [Response] -> [Request]

run		:: (String -> String) -> Dialogue
run f ~(Success : ~(Str kbd : _))
                 = [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)]
---
--- End of Gofer simplified prelude
---