ALP Práctica 6

-- EJERCICIO 1
newtype Id a = Id a

instance Monad Id where
    return x = Id x
    (Id x) >>= f = f x

{-
1- return x >>= f = Id x >>= f = f x
2- (Id x) >>= return = return x = Id x
3- ((Id x) >>= f) >>= g = f x >>= g = (\x -> f x >>= g) x = (Id x) >>= (\x -> f x >>= g)
-}

newtype Maybe a = Nothing | Just a

instance Monad Maybe where
    return = Just
    Nothing >>= f = Nothing
    (Just x) >>= f = f x

{-
1- return x >>= f = Just x >>= f = f x
2- Nothing >>= return = Nothing
   (Just x) >>= return = return x = Just x
3- (Nothing >>= f) >>= g = Nothing >>= g = Nothing = Nothing >>= (\x -> f x >>= g)
   ((Just x) >>= f) >>= g = (f x) >>= g = (\x -> f x >>= g) x = (Just x) >>= (\x -> f x >>= g)
-}


-- EJERCICIO 2
instance Monad [] where
    return x = [x]
    [] >>= f = []
    (x:xs) >>= f = (f x) ++ (xs >>= f)

{-
LEMA: (xs ++ ys) >>= f = xs >>= f ++ ys >>= g
Por inducción en xs:
   ([] ++ ys) >>= f =
   ys >>= f =
   [] ++ ys >>= f =
   [] >>= f ++ ys >>= f
   ((x:xs) ++ ys) >>= f =
   (x : (xs ++ ys)) >>= f =
   (f x) ++ (xs ++ ys) >>= f =
   (f x) ++ xs >>= f ++ ys >>= f =
   ((f x) ++ xs >>= f) ++ ys >>= f =
   (x:xs) >>= f ++ ys >>= f
DEMOSTRACION:
1- return x >>= f = [x] >>= f = (x:[]) >>= f = (f x) ++ ([] >>= f) = (f x) ++ [] = f x
2- [] >>= return = []
   (x:xs) >>= return = (return x) ++ (xs >>= return) = [x] ++ (xs >>= return) = [x] ++ xs = x:xs
3- ([] >>= f) >>= g = [] >>= g = [] = [] >>= (\x -> f x >>= g)
   ((x:xs) >>= f) >>= g = ((f x) ++ (xs >>= f)) >>= g =
   (f x) >>= g ++ (xs >>= f) >>= g =
   (\x f x >>= g) x ++ (xs >>= (\x -> f x >>= g)) =
   (x:xs) >>= (\x f x >>= g)
-}


-- EJERCICIO 3
-- (La demostración está copiada del TP 4 y no tengo ganas de cambiarla para que corresponda al ejercicio)
newtype State a = State {runState :: Env -> (a, Env)}

instance Monad State where
    return x = State (\s -> (x, s))
    m >>= f = State (\s -> let (v, s') = runState m s
                           in runState (f v) s')

-- Monad 1
return y >>= f =
-- {Definicion de return}
State (\s -> (y, s)) >>= f =
-- {Definicion de >>=}
State (\s -> let (v, s') = runState (State (\s -> (y, s))) s
              in runState (f v) s') =
-- {Definicion de runState}
State (\s -> let (v, s') = (\s -> (y, s)) s
              in runState (f v) s') =
-- {Aplicacion de funcion anonima}
State (\s -> let (v, s') = (y, s)
              in runState (f v) s') =
-- {Sustitucion de let}
State (\s -> runState (f y) s) =
-- {Eta-reduccion}
State (runState (f y)) =
-- {Sea x = State z. Luego, State (runState x) = State z = x}
-- {Entonces, la composicion de State y runState es la identidad}
f y

-- Monad 2
m >>= return =
-- {Definicion de >>=}
State (\s -> let (v, s') = runState m s
              in runstate (return v) s') =
-- {Definicion de return}
State (\s -> let (v, s') = runState m s
              in runstate (State (\s -> (v, s))) s') =
-- {Definicion de runState}
State (\s -> let (v, s') = runState m s
              in (\s -> (v, s)) s') =
-- {Aplicacion de funcion anonima}
State (\s -> let (v, s') = runState m s
              in (v, s')) =
-- {Sustitucion de let}
State (\s -> runState m s) =
--{Eta-reduccion}
State (runState m) =
-- {La composicion de State y runState es la identidad}
m

-- Monad 3
(m >>= f) >>= g =
-- {Definicion de >>=}
(State (\s -> let (v, s') = runState m s
               in runState (f v) s')) >>= g =
-- {Definicion de >>=}
State (\s -> let (v, s') = runState (State (\s -> let (v, s') = runState m s
                                                   in runState (f v) s')) s
              in runState (g v) s') =
-- {Definicion de runState}
State (\s -> let (v, s') = (\s -> let (v, s') = runState m s
                                   in runState (f v) s')) s
              in runState (g v) s') =
-- {Aplicacion de funcion anonima}
State (\s -> let (v, s') = (let (v, s') = runState m s
                             in runState (f v) s')
              in runState (g v) s') =
-- {Se reescribe el let de la siguiente forma:
-- let a = (let b = c in f(b)) in g(a)
-- let b = c
--     a = f(b)
--  in g(a)}
State (\s -> let (v, s')  = runState m s
                 (w, s'') = runState (f v) s'
             in runState (g w) s'')


m >>= (\x -> f x >>= g) =
-- {Definicion de >>=}
State (\s -> let (v, s') = runState m s
             in runState ((\x -> f x >>= g) v) s') =
-- {Aplicacion de funcion anonima}
State (\s -> let (v, s') = runState m s
             in runState (f v >>= g) s') =
-- {Definicion de >>=}
State (\s -> let (v, s') = runState m s
              in runState (State (\s -> let (v, s') = runState (f v) s
                                         in runState (g v) s')) s') =
-- {Definicion de runState}
State (\s -> let (v, s') = runState m s
              in (\s -> let (v, s') = runState (f v) s
                         in runState (g v) s') s') =
-- {Aplicacion de funcion anonima}
State (\s -> let (v, s') = runState m s
              in (let (v, s') = runState (f v) s'
                   in runState (g v) s')) =
-- {Se reescribe el let de la siguiente forma:
-- let a = b in (let c = f(a) in g(c))
-- let a = b
--     c = f(a)
--  in g(c)}
State (\s -> let (v, s')  = runState m s
                 (w, s'') = runState (f v) s'
             in runState (g w) s'')

-- {Ambos terminos son iguales a una misma expresion}
-- {Por transitividad, (m >>= f) >>= g = m >>= (\x -> f x >>= g)}

set :: s -> State s ()
set x = St (\s -> ((), x))

get :: State s s
get = St (\s -> (s, s))


-- EJERCICIO 4
data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Show

instance Functor Tree where
    fmap f (Leaf a) = Leaf (f a)
    fmap f (Branch l r) = Branch (fmap f l) (fmap f r)

numTree :: Tree a -> Tree Int
numTree t = fst (mapTreeNro update t 0)
            where update a n = (n, n + 1)

mapTreeNro :: (a -> Int -> (b, Int)) -> Tree a -> Int -> (Tree b, Int)
mapTreeNro update (Leaf x) n = let (actual, next) = update x n
                                in (Leaf actual, next)
mapTreeNro update (Branch l r) n = let (ml, next)  = mapTreeNro update l n
                                       (mr, next2) = mapTreeNro update r next
                                    in (Branch ml mr, next2)

mapTreeSt :: (a -> s -> (b, s)) -> Tree a -> s -> (Tree b, s)
mapTreeSt update (Leaf x) s = let (actual, next) = update x s
                               in (Leaf actual, next)
mapTreeSt update (Branch l r) s = let (ml, next)  = mapTreeSt update l s
                                      (mr, next2) = mapTreeSt update r next
                                   in (Branch ml mr, next2)

newtype State s a = St {runState :: s -> (a, s)}

instance Monad (State s) where
    return x = St (\s -> (x, s))
    (St h) >>= f = St (\s -> let (x, s') = h s
                              in runState (f x) s')

mapTreeM :: (a -> State s b) -> Tree a -> State s (Tree b)
mapTreeM update (Leaf x) = do y <- update x
                              return (Leaf y)
mapTreeM update (Branch l r) = do ml <- mapTreeM update l
                                  mr <- mapTreeM update r
                                  return (Branch ml mr)


-- EJERCICIO 5
data MyString = Empty | Cons Char MyString

instance Monoid MyString where
    mempty = Empty
    mappend Empty ys = ys
    mappend (Cons c xs) ys = Cons c (mappend xs ys)

{-
1- mappend mempty xs = mappend Empty xs = xs
2- mappend mempty mempty = mempty
   mappend (Cons c xs) mempty = Cons c (mappend xs mempty) = Cons c xs
3- mappend (mappend xs ys) zs
   mappend xs (mappend ys zs)
-}

newtype Output w a = Out (a, w)


instance Monad (Output w) where
    return x = Out (x, mempty)
    Out (a, mempty) >>= f = f a
    Out (a, w) = let Out (b, w2) = f a
                  in Out (b, w)

{-
1- return x >>= f = Out (x, mempty) >>= f = f x
2- Out (a, mempty) >>= return = return a = Out (a, mempty)
   Out (a, w) >>= return = let Out (b, w2) = return a in Out (b, w) =
 = let Out (b, w2) = Out (a, mempty) in Out (b, w) = Out (a, w)
3- (Out (a, mempty) >>= f) >>= g =
 = (f a) >>= g = (\x -> f x >>= g) a = Out (a, mempty) >>= (\x -> f x >>= g)

   (Out (a, w) >>= f) >>= g =
 = (let Out (b, w2) = f a in Out (b, w)) >>= g = **Sea Out (b, w2) = f a**
 = Out (b, w) >>= g =
 = let Out (b, w2) = g b in Out (b, w) =
 = let Out (b, w2) = f a
       Out (c, w3) = g b
    in Out (c, w)

   Out (a, w) >>= (\x -> f x >>= g) =
 = let Out (b, w2) = (\x -> fx >>= g) a in Out (b, w) =
 = let Out (b, w2) = (f a >>= g) in Out (b, w) = **Sea Out (b, w2) = f a**
 = let Out (b, w2) = (let Out (c, w2) = g b in Out (c, w)) in Out (b, w) =
 = let Out (b, w2) = f a
       Out (c, w3) = g b
    in Out (c, w)
-}


instance Monad (Output w) where
    return x = Out (x, mempty)
    Out (a, w) = let Out (b, w2) = f a
                  in Out (b, mappend w2 w)

{-
1- return x >>= f =
 = Out (x, mempty) >>= f =
 = let Out (b, w2) = f a
    in Out (b, mappend w2 mempty) =
 = let Out (b, w2) = f a
    in Out (b, w2) =
 = f a
2- Out (a, w) >>= return =
 = let Out (b, w2) = return a
    in Out (b, mappend w2 w) =
 = let Out (b, w2) = Out (a, mempty)
    in Out (b, mappend w2 w) =
 = let Out (b, w2) = Out (a, mempty)
    in Out (a, mappend mempty w) =
 = Out (a, w)
3- (Out (a, w) >>= f) >>= g =
 = (let Out (b, w2) = f a in Out (b, mappend w2 w)) >>= g =
 = (let Out (b, w2) = f a in Out (b, mappend w2 w) >>= g) =
 = (let Out (b, w2) = f a in (let Out (c, w3) = g b
                               in Out (c, mappend w3 (mappend w2 w))

   Out (a, w) >>= (\x -> f x >>= g) =
 = let Out (b, w2) = (\x -> f x >>= g) a in Out (b, mappend w2 w) =
 = let Out (b, w2) = (f a >>= g) in Out (b, mappend w2 w) =
 = let Out (b, w2) = (let Out (b, w2) = f a in Out (b, w2) >>= g) in Out (b, mappend w2 w) =
 = let Out (b, w2) = (let Out (b, w2) = f a in (let Out (c, w3) = g b
                                                 in Out (c, mappend w3 w2))) in Out (b, mappend w2 w) =
 = let Out (b, w2) = f a
       Out (c, w3) = g b
    in Out (c, mappend (mappend w3 w2) w) =
 = let Out (b, w2) = f a
       Out (c, w3) = g b
    in Out (c, mappend w3 (mappend w2 w))
-}



-- EJERCICIO 6
(>>)  :: M a -> M b -> M b
(>>) = \a b -> (>>=) a (\a -> b)

-- (>>=) no puede definirse en términos de (>>) pues cuando se hace un paso de secuenciación, se pierde el resultado de la primera computación para poder usarlo en la segunda.


-- EJERCICIO 7
sequence1 :: Monad m => [m a] -> m [a]
sequence1 [] = return []
sequence1 (mx:mxs) = (sequence1 mxs) >>= \xs -> mx >>= \x -> return (x : xs)

liftM :: Monad m => (a -> b) -> m a -> m b
liftM f ma = ma >>= \a -> return (f a)

liftM2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
liftM2 f ma mb = ma >>= \a -> mb >>= \b -> return (f a b)

sequence2 :: Monad m => [m a] -> m [a]
sequence2 mxs = foldr (liftM2 (:)) (return []) mxs


-- EJERCICIO 8
data Error er a = Raise er | Return a deriving Show

instance Monad (Error er) where
    return a = Return a
    Raise er >>= f = Raise er
    Return a >>= f = f a

{-
1- return x >>= f = Return x >>= f = f x
2- Raise er >>= return = Raise er
   Return x >>= return = return x = Return x
3- (Raise er >>= f) >>= g = Raise er >>= g = Raise er = Raise er >>= (\x -> f x >>= g)
   ((Return a) >>= f) >>= g = f a >>= g = (\x -> f x >>= g) a = Return a >>= (\x -> f x >>= g)
-}

headEr :: [a] -> Error String a
headEr [] = Raise "No existe head de []"
headEr (x:xs) = Return x

tailEr :: [a] -> Error String [a]
tailEr [] = Raise "No existe tail de []"
tailEr (x:xs) = Return xs

pushEr :: a -> [a] -> Error String [a]
pushEr a xs = Return (a:xs)

popEr :: [a] -> Error String [a]
popEr = tailEr


-- EJERCICIO 9
import Control.Applicative (Applicative(..))
import Control.Monad       (liftM, ap)

data Error er a = Raise er | Return a deriving Show

data T = Con Int | Div T T

newtype M s e a = M {runM :: s -> Error e (a, s)}

-- Para calmar al GHC
instance Functor (Error er) where
    fmap = liftM

instance Applicative (Error er) where
    pure   = return
    (<*>)  = ap
--

instance Monad (Error er) where
    return a = Return a
    Raise er >>= f = Raise er
    Return a >>= f = f a


-- Para calmar al GHC
instance Functor (M s e) where
    fmap = liftM

instance Applicative (M s e) where
    pure   = return
    (<*>)  = ap
--

instance Monad (M s e) where
    return x = M (\s -> Return (x, s))
    (M h) >>= f = M (\s -> case h s of
                                Raise er -> Raise er
                                Return (a, s2) -> runM (f a) s2)

raise :: String -> M Int String Int
raise xs = M (\s -> Raise xs)

modify :: (Int -> Int) -> M Int String ()
modify f = M (\s -> Return ((), f s))


eval :: T -> M Int String Int
eval (Con n) = return n
eval (Div t1 t2) = do v1 <- eval t1
                      v2 <- eval t2
                      if v2 == 0 then raise "Error: Division por cero"
                                 else do modify (+1)
                                         return (div v1 v2)

doEval :: T -> Error String (Int, Int)
doEval t = runM (eval t) 0


eval2 :: T -> Error String (Int, Int)
eval2 (Con n) = Return (n, 0)
eval2 (Div t1 t2) = case eval2 t1 of
                         Raise er -> Raise er
                         Return (v1, s1) -> case eval2 t2 of
                                                 Raise er -> Raise er
                                                 Return (v2, s2) -> if v2 == 0 then Raise "Error: Division por cero"
                                                                               else Return ((div v1 v2), s1 + s2 + 1)


-- EJERCICIO 10
data Cont r a = Cont ((a -> r) -> r)

instance Monad (Cont r) where
    return x = Cont (\f -> f x)
    (Cont f) >>= g = Cont (\h -> f (\a -> let (Cont j) = g a
                                           in j h))

{-
1- return x >>= f
 = Cont (\f -> f x) >>= f =
 = Cont (\h -> (\f -> f x) (\a -> let (Cont j) = f a
                                   in j h)) =
 = Cont (\h -> (\a -> let (Cont j) = f a
                       in j h) x) =
 = Cont (\h -> let (Cont j) = f x
                in j h) =
 = Cont (let (Cont j) = f x in j) =
 = let (Cont j) = f x in Cont j =
 = f x

2- (Cont z) >>= return =
 = Cont (\h -> z (\a -> let (Cont j) = return a
                         in j h)) =
 = Cont (\h -> z (\a -> let (Cont j) = Cont (\f -> f a)
                         in j h)) =
 = Cont (\h -> z (\a -> (\f -> f a) h)) =
 = Cont (\h -> z (\a -> h a)) =
 = Cont (\h -> z h) =
 = Cont z

3- ((Cont z) >>= f) >>= g =
 = Cont (\h -> z (\a -> let (Cont j) = f a
                         in j h)) >>= g =
 = Cont (\h -> (\h -> z (\a -> let (Cont j) = f a
                                in j h)) (\a -> let (Cont j) = g a
                                                 in j h)) =
 = Cont (\h -> z (\a -> let (Cont j) = f a
                         in j (\a -> let (Cont j) = g a
                                      in j h))) =
...

   (Cont z) >>= (\x -> f x >>= g) =
 = Cont (\h -> z (\a -> let (Cont j) = (\x -> f x >>= g) a
                         in j h)) =
 = Cont (\h -> z (\a -> let (Cont j) = f a >>= g
                         in j h)) =
 = Cont (\h -> z (\a -> let (Cont j) = (let (Cont y) = f a in (Cont y) >>= g)
                         in j h)) =
 = Cont (\h -> z (\a -> let (Cont j) = (let (Cont y) = f a in Cont (\h -> y (\a -> let (Cont j) = g a
                                                                                    in j h))
                         in j h)) =
...

-}