
module PPrel where

-- Standard types, classes, instances and related functions

-- Numeric classes

class (Num a, Ord a) => RealK a where
    toRational' :: a -> Rational


class (RealK a, Enum a) => IntegralK a where
    quot', rem' :: a -> a -> a
    div', mod' :: a -> a -> a
    quotRem', divMod' :: a -> a -> (a, a)
    toInteger' :: a -> Integer

        {- Minimal complete definition:
        quotRem, toInteger -}
    n `quot'` d = fst (quotRem' n d)
    n `rem'` d = snd (quotRem' n d)
    n `div'` d = fst (divMod' n d)
    n `mod'` d = snd (divMod' n d)
    divMod' n d = let qr = quotRem' n d
                             q = fst qr
                             r = snd qr
                         in if signum r == (0 - signum d) then
                            (q - 1, r + d) else quotRem' n d
{- if signum r == - signum d then (q-1, r+d)
else quotRem n d -}

class (Num a) => FractionalK a where
    (/#) :: a -> a -> a
    recip' :: a -> a
    fromRational' :: Rational -> a

        {- Minimal complete definition:
        fromRational and (recip or (/)) -}
    recip' x = 1 /# x
    x /# y = x * recip' y

-- Numeric functions

{- subtract'         :: (Num a) => a -> a -> a
subtract'         =  flip' (-) -}

even', odd' :: (IntegralK a) => a -> Bool
even' n = n `rem'` 2 == 0
odd' = not . even'

gcd' :: (IntegralK a) => a -> a -> a
gcd' 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
gcd' x y = gcdH (abs x) (abs y)

gcdH :: (IntegralK a) => a -> a -> a
gcdH x 0 = x
gcdH x y = gcdH y (x `rem'` y)

lcm' :: (IntegralK a) => a -> a -> a
lcm' _ 0 = 0
lcm' 0 _ = 0
lcm' x y = abs ((x `quot'` (gcd' x y)) * y)

(^#) :: (Num a, IntegralK b) => a -> b -> a
x ^# 0 = 1
x ^# n | n > 0 = powAux x (n - 1) x
_ ^# _ = error "Prelude.^: negative exponent"

powAux :: (Num a, IntegralK b) => a -> b -> a -> a
powAux _ 0 y = y
powAux x n y = powBux x n y

powBux :: (Num a, IntegralK b) => a -> b -> a -> a
powBux x n y | even' n = powBux (x * x) (n `quot'` 2) y
            | otherwise' = powAux x (n - 1) (x * y)

(^^#) :: (FractionalK a, IntegralK b) => a -> b -> a
x ^^# n = if n >= 0 then x ^# n else recip' (x ^# (0 - n))

fromIntegral' :: (IntegralK a, Num b) => a -> b
fromIntegral' = fromInteger . toInteger'

realToFrac' :: (RealK a, FractionalK b) => a -> b
realToFrac' = fromRational' . toRational'

-- Trivial type

{- data  ()  =  ()  deriving (Eq, Ord, Enum, Bounded)
Not legal Haskell; for illustration only -}

-- Function type

-- identity function

id' :: a -> a
id' x = x

-- constant function

const' :: a -> b -> a
const' x _ = x

-- function composition

{- (.)              :: (b -> c) -> (a -> b) -> a -> c
f . g            =  \ x -> f (g x) -}

-- flip f  takes its (first) two arguments in the reverse order of f.

{- flip'             :: (a -> b -> c) -> b -> a -> c
flip' f x y       =  f y x -}

{-
seq :: a -> b -> b
seq = ...       -- Primitive
-}

{- right-associating infix application operators
(useful in continuation-passing style) -}

{- ($), ($!) :: (a -> b) -> a -> b
f $  x    =  f x
f $! x    =  P.seq x (f x) -}

-- Boolean type

-- data  Bool  =  False | True     deriving (P.Eq, P.Ord, P.Enum, P.Bounded)

-- Boolean functions

otherwise' :: Bool
otherwise' = True

{- primIntToChar = undefined'
primCharToInt = undefined'
primUnicodeMaxChar = undefined' -}

maybe' :: b -> (a -> b) -> Maybe a -> b
maybe' n f Nothing = n
maybe' n f (Just x) = f x

either' :: (a -> c) -> (b -> c) -> Either a b -> c
either' f g (Left x) = f x
either' f g (Right y) = g y

{- curry converts an uncurried function to a curried function;
uncurry converts a curried function to a function on pairs. -}

curry' :: ((a, b) -> c) -> a -> b -> c
curry' f x y = f (x, y)

uncurry' :: (a -> b -> c) -> ((a, b) -> c)
uncurry' f p = f (fst p) (snd p)

-- Misc functions

-- until p f  yields the result of applying f until p holds.

until' :: (a -> Bool) -> (a -> a) -> a -> a
until' p f x
     | p x = x
     | otherwise' = until' p f (f x)

{- asTypeOf is a type-restricted version of const.  It is usually used
as an infix operator, and its typing forces its first argument
(which is usually overloaded) to have the same type as the second. -}

asTypeOf' :: a -> a -> a
asTypeOf' = const'

-- error stops execution and displays an error message

{- error'            :: String -> a
error'            =  primError -}

{- It is expected that compilers will recognize this and insert error
messages that are more appropriate to the context in which undefined
appears. -}

undefined' :: a
undefined' = error "Prelude.undefined"

-- Standard list functions

-- Map and append

head' :: [a] -> a
head' (x : _) = x
head' [] = error "Prelude.head: empty list"

tail' :: [a] -> [a]
tail' (_ : xs) = xs
tail' [] = error "Prelude.tail: empty list"

{- map' :: (a -> b) -> [a] -> [b]
map' f []     = []
map' f (x:xs) = f x : map' f xs -}

(++#) :: [a] -> [a] -> [a]
[] ++# ys = ys
(x : xs) ++# ys = x : (xs ++# ys)

filter' :: (a -> Bool) -> [a] -> [a]
filter' p [] = []
filter' p (x : xs) | p x = x : filter' p xs
                 | otherwise' = filter' p xs

concat' :: [[a]] -> [a]
concat' xss = foldr' (++#) [] xss

concatMap' :: (a -> [b]) -> [a] -> [b]
concatMap' f = concat' . map f

{- head and tail extract the first element and remaining elements,
respectively, of a list, which must be non-empty.  last and init
are the dual functions working from the end of a finite list,
rather than the beginning. -}

last' :: [a] -> a
last' [x] = x
last' (_ : xs) = last' xs
last' [] = error "Prelude.last: empty list"

init' :: [a] -> [a]
init' [x] = []
init' (x : xs) = x : init' xs
init' [] = error "Prelude.init: empty list"

null' :: [a] -> Bool
null' [] = True
null' (_ : _) = False

-- length returns the length of a finite list as an Int.

length' :: [a] -> Int
length' [] = 0
length' (_ : l) = 1 + length' l

-- List index (subscript) operator, 0-origin

(!!#) :: [a] -> Int -> a
xs !!# n | n < 0 = error "Prelude.!!: negative index"
[] !!# _ = error "Prelude.!!: index too large"
(x : _) !!# 0 = x
(_ : xs) !!# n = xs !!# (n - 1)

{- foldl, applied to a binary operator, a starting value (typically the
left-identity of the operator), and a list, reduces the list using
the binary operator, from left to right:
foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
foldl1 is a variant that has no starting value argument, and  thus must
be applied to non-empty lists.  scanl is similar to foldl, but returns
a list of successive reduced values from the left:
scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
Note that  last (scanl f z xs) == foldl f z xs.
scanl1 is similar, again without the starting element:
scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] -}

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
foldl1' _ [] = error "Prelude.foldl1: empty list"

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

{- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
above functions. -}

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)
foldr1' _ [] = error "Prelude.foldr1: empty list"

scanr' :: (a -> b -> b) -> b -> [a] -> [b]
scanr' f q0 [] = [q0]
scanr' f q0 (x : xs) = let qs = scanr' f q0 xs
    in f x (head' qs) : qs
-- where qs@(q:_) = scanr f q0 xs

scanr1' :: (a -> a -> a) -> [a] -> [a]
scanr1' f [] = []
scanr1' f [x] = [x]
scanr1' f (x : xs) = let qs = scanr1' f xs
    in f x (head' qs) : qs

{- iterate f x returns an infinite list of repeated applications of f to x:
iterate f x == [x, f x, f (f x), ...] -}

iterate' :: (a -> a) -> a -> [a]
iterate' f x = x : iterate' f (f x)

-- repeat x is an infinite list, with x the value of every element.

repeat' :: a -> [a]
repeat' x = x : (repeat' x)

-- replicate n x is a list of length n with x the value of every element

replicate' :: Int -> a -> [a]
replicate' n x = take' n (repeat' x)

{- cycle ties a finite list into a circular one, or equivalently,
the infinite repetition of the original list.  It is the identity
on infinite lists. -}

cycle' :: [a] -> [a]
cycle' [] = error "Prelude.cycle: empty list"
cycle' xs = xs ++# cycle' xs
-- cycle xs         =  xs' where xs' = xs ++ xs'

{- take n, applied to a list xs, returns the prefix of xs of length n,
or xs itself if n > length xs.  drop n xs returns the suffix of xs
after the first n elements, or [] if n > length xs.  splitAt n xs
is equivalent to (take n xs, drop n xs). -}

take' :: Int -> [a] -> [a]
take' n _ | n <= 0 = []
take' _ [] = []
take' n (x : xs) = x : take' (n - 1) xs

drop' :: Int -> [a] -> [a]
drop' n xs | n <= 0 = xs
drop' _ [] = []
drop' n (_ : xs) = drop' (n - 1) xs

splitAt' :: Int -> [a] -> ([a], [a])
splitAt' n xs = (take' n xs, drop' n xs)

{- takeWhile, applied to a predicate p and a list xs, returns the longest
prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs
returns the remaining suffix.  span p xs is equivalent to
(takeWhile p xs, dropWhile p xs), while break p uses the negation of p. -}

takeWhile' :: (a -> Bool) -> [a] -> [a]
takeWhile' p [] = []
takeWhile' p (x : xs)
            | p x = x : takeWhile' p xs
            | otherwise' = []

dropWhile' :: (a -> Bool) -> [a] -> [a]
dropWhile' p [] = []
dropWhile' p (x : xs)
            | p x = dropWhile' p xs
            | otherwise' = x : xs

span', break' :: (a -> Bool) -> [a] -> ([a], [a])
span' p [] = ([], [])
span' p (x : xs)
            | p x = let yz = span' p xs
                 in (x : (fst yz), snd yz)
            | otherwise' = ([], x : xs)
{- | p x       =  (x:ys,zs)
where (ys,zs) = span p xs -}

break' p = span' (not . p)

{- lines breaks a string up into a list of strings at newline characters.
The resulting strings do not contain newlines.  Similary, words
breaks a string up into a list of words, which were delimited by
white space.  unlines and unwords are the inverse operations.
unlines joins lines with terminating newlines, and unwords joins
words with separating spaces. -}

{- isSpace' :: Char -> Bool
isSpace' c =  elem' c " \t\n\r\f\v\xA0" -}

lines' :: String -> [String]
lines' s = if s == "" then []
           else let ls = break' (== '\n') s
                    l = fst ls
                    s' = snd ls
                  in l : case s' of
                                [] -> []
                                (_ : s'') -> lines' s''

{-
words'            :: String -> [String]
words' s          =  let s' = dropWhile' isSpace' s
                     in if s' == "" then []
                        else let ws = break' isSpace' s'
                             in (fst ws) : words' (snd ws)
-}

{- unlines'          :: [String] -> String
unlines'          =  concatMap' (++# "\n") -}

{-
unwords'          :: [String] -> String
unwords' []       =  ""
unwords' ws       =  foldr1' (\w s -> w ++# (' ':s)) ws
-}

-- reverse xs returns the elements of xs in reverse order.  xs must be finite.

reverse' :: [a] -> [a]
reverse' = foldl' (flip (:)) []

{- and returns the conjunction of a Boolean list.  For the result to be
True, the list must be finite; False, however, results from a False
value at a finite index of a finite or infinite list.  or is the
disjunctive dual of and. -}

and', or' :: [Bool] -> Bool
and' = foldr' (&&) True
or' = foldr' (||) False

{- Applied to a predicate and a list, any determines if any element
of the list satisfies the predicate.  Similarly, for all. -}

any', all' :: (a -> Bool) -> [a] -> Bool
any' p = or' . map p
all' p = and' . map p

{- elem is the list membership predicate, usually written in infix form,
e.g., x `elem` xs.  notElem is the negation. -}

elem', notElem' :: (Eq a) => a -> [a] -> Bool
elem' x = any' (== x)
notElem' x = all' (/= x)

-- lookup key assocs looks up a key in an association list.

lookup' :: (Eq a) => a -> [(a, b)] -> Maybe b
lookup' key [] = Nothing
lookup' key (xy : xys)
    | key == fst xy = Just (snd xy)
    | otherwise' = lookup' key xys

-- sum and product compute the sum or product of a finite list of numbers.

sum', product' :: (Num a) => [a] -> a
sum' = foldl' (+) 0
product' = foldl' (*) 1

{- maximum and minimum return the maximum or minimum value from a list,
which must be non-empty, finite, and of an ordered type. -}

{-
maximum', minimum' :: (Ord a) => [a] -> a
maximum' []       =  error "Prelude.maximum: empty list"
maximum' xs       =  foldl1' max xs

minimum' []       =  error "Prelude.minimum: empty list"
minimum' xs       =  foldl1' min xs
-}

{- zip takes two lists and returns a list of corresponding pairs.  If one
input list is short, excess elements of the longer list are discarded.
zip3 takes three lists and returns a list of triples.  Zips for larger
tuples are in the List library -}

zip' :: [a] -> [b] -> [(a, b)]
zip' = zipWith' (,)

{- The zipWith family generalises the zip family by zipping with the
function given as the first argument, instead of a tupling function.
For example, zipWith (+) is applied to two lists to produce the list
of corresponding sums. -}

zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' z (a : as) (b : bs)
                 = z a b : zipWith' z as bs
zipWith' _ _ _ = []

-- unzip transforms a list of pairs into a pair of lists.
unzip' :: [(a, b)] -> ([a], [b])
unzip' = foldr' (\ x xs -> ((fst x) :
                               (fst xs), (snd x) : (snd xs))) ([], [])
