module Class130723 where

import Prelude hiding (sequence)
import Data.Map (findWithDefault, fromList, Map)
import Control.Applicative
import Data.Functor.Compose
import Control.Applicative.Backwards

-- adapted from "Applicative programming with effects"
-- by CONOR MCBRIDE and ROSS PATERSON

-- IO
sequence :: [IO a] -> IO [a]
sequence [] = return []
sequence (c : cs) = do
    x  <- c
    xs <- sequence cs
    return $ x : xs

-- Test
sequenceTest :: IO [String]
sequenceTest = sequence $ replicate 3 getLine

-- Alternatively, using the fact that every monad is declared 
-- to be an instance of Applicative, using (<*>) :: m (a -> b) -> m a -> m b  
sequence' :: [IO a] -> IO [a]
sequence' [] = pure []
sequence' (c : cs) = pure (:) <*> c <*> sequence' cs

-- Transposing matrices
transpose :: [[a]] -> [[a]]
transpose [] = repeat []
transpose (xs : xss) = zipWith (:) xs (transpose xss)

transposeTest1 = transpose $ [[1,2],[3,4]]

transposeTest2 = transpose $ [[1],[3,4]]

-- Applicative functor version
transpose' :: ZipList [a] -> ZipList [a]
transpose' (ZipList []) = pure $ []
transpose' (ZipList (xs : xss)) = pure (:) <*> (ZipList xs) <*> transpose' (ZipList xss)

-- This is, quite remarkably, an applicative functor, not agreeing 
-- with any monad structure on lists (!) because return x == [x] /= repeat x == pure x

-- Evaluating expressions 

data Exp v = Var v | Val Int | Add (Exp v) (Exp v)
type Env v = Map v Int

fetch :: (Ord v) => v -> Env v -> Int
fetch = findWithDefault (-1)

eval :: (Ord v) => Exp v -> Env v -> Int
eval (Var x) g = fetch x g
eval (Val i) g = i
eval (Add p q) g = eval p g + eval q g

evalTest = eval (Add (Var "x") (Var "y")) $ fromList [("x", 2), ("y", 2)]

-- K combinator
kComb :: a -> Env v -> a
kComb x g = x

-- S combinator
sComb :: (Env v -> a -> b) -> (Env v -> a) -> Env v -> b
sComb x y g = (x g) (y g)

data EnvApp v a = EnvApp (Env v -> a)

instance Functor (EnvApp v) where
    fmap f (EnvApp m) = EnvApp (f . m)

instance Applicative (EnvApp v) where
    pure = EnvApp . kComb

    (EnvApp f) <*> (EnvApp m) = EnvApp $ sComb f m 

-- Applicative functor version
eval' :: (Ord v) => Exp v -> EnvApp v Int
eval' (Var x) = EnvApp $ fetch x
eval' (Val i) = pure i
eval' (Add p q) = pure (+) <*> eval' p <*> eval' q

-- One big advantage over monads is that applicative functors are composable!
-- Example: matrix addition

testComp :: ZipList (ZipList Integer)
testComp = getCompose $ pure (+) <*> Compose (ZipList [ZipList [1,2],ZipList [3,4]]) 
 <*> Compose (ZipList [ZipList [3,2],ZipList [2,1]])

-- Applicative functors are equivalent to strong lax monoidal functors.
-- This is essentially why.
mrg :: (Applicative f) => f a -> f b -> f (a, b)
mrg p q = pure (curry id) <*> p <*> q 

-- Every applicative functor comes with a certain evaluation order
testMrg1 = [1,2] `mrg` [3,4] -- == [(x,y) | x <- [1,2], y <- [3,4]] == [(1,3),(1,4),(2,3),(2,4)]

-- Dualizing the order yields a different applicative functor,
-- unless the original functor is "commutative", 
testMrg2 = forwards $ Backwards [1,2] `mrg` Backwards [3,4] --  == [(x,y) | y <- [3,4], x <- [1,2]] == [(1,3),(2,3),(1,4),(2,4)]

-- (*>) is simply the second projection, composed with `mrg`
-- ([1,2] *> [3,4]) == (map snd $  mrg [1,2] [3,4])

-- (<*) is the first
-- ([1,2] <* [3,4]) == (map fst $  mrg [1,2] [3,4])