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))) ([],[])