ch12_00_sandbox.hs

module Chapter_12_Sandbox where

import Data.Char

inc :: [Int] -> [Int]
inc []     = []
inc (n:ns) = n+1 : inc ns

sqr :: [Int] -> [Int]
sqr []     = []
sqr (n:ns) = n^2 : sqr ns

inc' :: [Int] -> [Int]
inc' = map (+1)

sqr' :: [Int] -> [Int]
sqr' = map (^2)

--class Functor f where
--    fmap :: (a -> b) -> f a -> f b    

--instance Functor [] where
--    fmap = map

data Tree a = Leaf a | Node (Tree a) (Tree a)
              deriving Show

instance Functor Tree where
    fmap g (Leaf x)   = Leaf (g x)
    fmap g (Node l r) = Node (fmap g l) (fmap g r)


t1 = Node (Node (Leaf "abc") (Leaf "def")) (Leaf "hij")

inc'' :: Functor f => f Int -> f Int 
inc'' = fmap (+1)

-- 12.2 Applicatives

ap1 = pure (+1) <*> Just 3
ap2 = pure (map (+2)) <*> (Just [1,2,3,4])
ap3 = pure (zip) <*> (Just [1..]) <*> (Just ['a', 'b', 'c', 'd'])

prods :: [Int] -> [Int] -> [Int]
prods xs ys = [x * y | x <- xs, y <- ys]

prods' :: [Int] -> [Int] -> [Int]
prods' xs ys = pure (*) <*> xs <*> ys

getChars :: Int -> IO String
getChars 0 = return []
getChars n = pure (:) <*> getChar <*> getChars (n-1)

getChars' :: Int -> IO String
getChars' n = sequenceA (replicate n getChar)

-- 12.3 Monads

data Expr = Val Int | Div Expr Expr

eval :: Expr -> Int
eval (Val n)   = n
eval (Div x y) = eval x `div` eval y

safediv :: Int -> Int -> Maybe Int
safediv _ 0 = Nothing
safediv x y = Just (x `div` y)

eval' :: Expr -> Maybe Int
eval' (Val n)   = Just n
eval' (Div x y) = case eval' x of
                    Nothing -> Nothing
                    Just n -> case eval' y of
                                Nothing -> Nothing
                                Just m -> n `safediv` m

-- Implementing eval in applicative style
--(>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b
--mx >>= f = case mx of
--             Nothing -> Nothing
--             Just x  -> f x

eval'' :: Expr -> Maybe Int
eval'' (Val n)   = Just n
eval'' (Div x y) = eval'' x >>= \n -> eval'' y >>= \m -> n `safediv` m

eval''' ::Expr -> Maybe Int
eval''' (Val n)   = Just n
eval''' (Div x y) = do n <- eval''' x
                       m <- eval''' y
                       n `safediv` m

--instance Monad [] where
--    -- (>>=) :: [a] -> (a -> [b]) -> [b]
--    xs >>= f = [f x | x <- xs]

pairs :: [a] -> [b] -> [(a,b)]
pairs xs ys = do x <- xs
                 y <- ys
                 return (x,y)

-- The state monad

type State = Int

newtype ST a = S (State -> (a, State))

app :: ST a -> State -> (a, State)
app (S st) x = st x

instance Functor ST where
    -- fmap :: (a -> b) -> ST a -> ST b
    fmap g st = S (\s -> let (x, s') = app st s in (g x, s'))

instance Applicative ST where
    -- pure :: a -> ST a
    pure x = S (\s -> (x,s))

    -- (<*>) :: ST (a -> b) -> ST a -> ST b
    stf <*> stx = S (\s -> let (f, s')  = app stf s
                               (x, s'') = app stx s' in (f x, s''))

instance Monad ST where
    -- (>>=) :: ST a -> (a -> ST b) -> ST b
    st >>= f = S (\s -> let (x, s') = app st s in app (f x) s')

-- Relabelling trees

tree :: Tree Char
tree = Node (Node (Leaf 'a') (Leaf 'b')) (Leaf 'c')

-- Recursive label function
rlabel :: Tree a -> Int -> (Tree Int, Int)
rlabel (Leaf _) n   = (Leaf n, n+1)
rlabel (Node l r) n = (Node l' r', n'')
                      where
                        (l', n') = rlabel l n
                        (r', n'') = rlabel r n'

fresh :: ST Int
fresh = S (\n -> (n, n+1))

-- Applicative version of rlabel
alabel :: Tree a -> ST (Tree Int)
alabel (Leaf _)   = Leaf <$> fresh
alabel (Node l r) = Node <$> alabel l <*> alabel r

-- Monadic version of rlabel
mlabel :: Tree a -> ST (Tree Int)
mlabel (Leaf _)   = do n <- fresh
                       return (Leaf n)
mlabel (Node l r) = do l' <- mlabel l
                       r' <- mlabel r
                       return (Node l' r')


mapM' :: Monad m => (a -> m b) -> [a] -> m [b]
mapM' f []     = return []
mapM' f (x:xs) = do y  <- f x
                    ys <- mapM f xs
                    return (y:ys)


conv :: Char -> Maybe Int
conv c | isDigit c = Just (digitToInt c)
       | otherwise = Nothing


filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
filterM p []     = return []
filterM p (x:xs) = do b  <- p x
                      ys <- filterM p xs
                      return (if b then x:ys else ys)


join :: Monad m => m (m a) -> m a
join mmx = do mx <- mmx
              x  <- mx
              return x


-- Ex. 1: Define an instance of the have data in their nodes.
data Tree' a = Leaf' | Node' (Tree' a) a (Tree' a)
               deriving Show

instance Functor Tree' where
    -- fmap :: (a -> b) -> Tree a -> Tree b
    fmap g Leaf'         = Leaf'
    fmap g (Node' l x r) = Node' (fmap g l) (g x) (fmap g r)

-- Ex. 2: Complete the following instance declaration to make the partially-applied function
--        type (a ->) into a functor:
--        instance Functor ((->) a) where
--        ...
--        Hint: first write down the type of fmap , and then think if you already know a library
--        function that has this type.  

--instance Functor ((->) a) where
--    -- fmap :: (b -> c) -> (a -> b) -> (a -> c)
--    fmap = (.)


-- Ex. 3: Define an instance of the Applicative class for the type (a ->) . If you are familiar
--        with combinatory logic, you might recognise pure and <*> for this type as being the
--        well-known K and S combinators.

--instance Applicative ((->) a) where
--    -- pure :: a -> (b -> a)
--    pure = const
--    -- (<*>) :: (a -> b -> c) -> (a -> b) -> (a -> c)
--    g <*> f = \x -> g x (f x)


-- Ex. 4: There may be more than one way to make a parameterised type into an applicative
--        functor. For example, the library Control.Applicative provides an alternative
--        ‘zippy’ instance for lists, in which the function pure makes an infinite list of copies
--        of its argument, and the operator <*> applies each argument function to the
--        corresponding argument value at the same position. Complete the following
--        declarations that implement this idea

newtype ZipList a = Z [a] deriving Show

instance Functor ZipList where
    -- fmap :: (a -> b) -> ZipList a -> ZipList b
    fmap g (Z xs) = Z (fmap g xs)

instance Applicative ZipList where
    -- pure :: a -> ZipList a
    pure x = Z (repeat x) 
    -- (<*>) :: ZipList (a -> b) -> ZipList a -> ZipList b
    (Z gs) <*> (Z xs) = Z [g x | (g,x) <- zip gs xs]


-- Ex. 7: Given the following type of expressions
--        data Expr a = Var a | Val Int | Add (Expr a) (Expr a)
--        deriving Show
--        that contain variables of some type a , show how to make this type into instances of
--        the Functor , Applicative and Monad classes. With the aid of an example, explainwhat the >>= operator for this type does.

data Expr' a = Var' a | Val' Int | Add' (Expr' a) (Expr' a)
               deriving Show

instance Functor Expr' where
    fmap g (Var' x)   = Var' (g x)
    fmap g (Add' a b) = Add' (fmap g a) (fmap g b)