module Logger where

import           Control.Arrow
import           Data.Function

{-

f n = (n * f (n - 1), "recursion")
f 0 = (1, "start")

type of f is not correct!
f :: Int -> (Int, String)
f :: Int -> Int

\n ->
f n = (m, s)
g m = (k, s2)
return (k, s ++ s2)


-- f x y = 3 * (x + y)
-- f = (.(* 3)) . (+)

-- f1 x y z = z + 3 * (x + y)
-- f1 = (+) . (.(* 3)) . (+)

-- let s4= (((+).).) . ((+).) . (+)

-}
newtype Cont r a = Cont
    { unC :: (a -> r) -> r
    }

bindC :: ((a -> r) -> r) -> (a -> (b -> r) -> r) -> (b -> r) -> r
bindC a f = \x -> a $ (($x) . f)

applyC :: (((a -> b) -> r) -> r) -> ((a -> r) -> r) -> (b -> r) -> r
applyC f c = f . (.) c . (.) -- (\beta -> c (rho . beta))

instance Functor (Cont r)
    --fmap :: (a -> b) -> Cont r a -> Cont r b
                                               where
    fmap f (Cont c) = Cont (\b_r -> c $ b_r . f) -- Cont $ c.(.f)

instance Applicative (Cont r) where
    pure = Cont . (flip ($))
    (Cont f) <*> (Cont c) = Cont $ \bToR -> f (\aToB -> c (bToR . aToB))

instance Monad (Cont r) where
    return a = Cont $ \f -> f a
    (Cont c) >>= f = Cont $ \g -> c (\a -> unC (f a) g)

newtype St a val = St
    { unSt :: a -> (val, a)
    }

type State = St String

bind2 :: St x a -> (a -> St x b) -> St x b
f `bind2` g =
    St $ \a ->
        case unSt f a of
            (a', str) ->
                case unSt (g a') str of
                    (a'', str') -> (a'', str')

ret :: v -> St a v
ret v = St (\a -> (v, a))

set :: s -> St s s
set s = St (\_ -> (s, s))

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

instance Functor (St a) where
    fmap f (St s) =
        St
            (\a ->
                 case s a of
                     (v, a') -> (f v, a'))

instance Applicative (St a) where
    (St f) <*> (St s) =
        St
            (\a ->
                 case f a of
                     (fun, _) ->
                         case s a of
                             (v, a'') -> (fun v, a''))
    pure v = St (\a -> (v, a))

instance Monad (St a) where
    (>>=) = bind2
    return = ret

newtype RSt s a = RSt
    { unRSt :: s -> (s, a)
    }

modifyR :: (s -> s) -> RSt s ()
modifyR f = RSt (\s -> (f s, ()))

setR :: s -> RSt s ()
setR s = RSt (\_ -> (s, ()))

getR :: RSt s s
getR = RSt (\s -> (s, s))

instance Functor (RSt s) where
    fmap f (RSt x) =
        RSt $ \s ->
            case x s of
                (s', a) -> (s', f a)

instance Applicative (RSt s) where
    pure a = RSt $ \s -> (s, a)
    (RSt f) <*> (RSt s) =
        RSt
            (\a ->
                 case f a of
                     (_, fun) ->
                         case s a of
                             (a'', v) -> (a'', fun v))

instance Monad (RSt s) where
    (RSt x) >>= f =
        RSt $ \s ->
            let (state2, res1) = x state1
                (state1, res2) = unRSt (f res1) s
             in (state2, res2)

{-
    return x >>= f = f x
    a >>= return = a
    (a >>= f) >>= g = a >>= \ x -> f x >>= g
return :: a -> State a
return x = St $ \a -> (x, a)
-}
newtype R e a = R
    { unR :: e -> a
    }

instance Functor (R e) where
    fmap f (R a) = R $ f . a

instance Applicative (R e) where
    pure x = R $ const x
    (R f) <*> (R x) = R $ \e -> f e (x e)

instance Monad (R e) where
    return x = R $ const x
    -- bind :: (e -> a) -> (a -> e -> b) -> e -> b
    (R x) >>= f = R (\e -> unR (f (x e)) e)

newtype A a v = A
    { unA :: (a, v)
    }

instance Functor (A a) where
    fmap f (A (a, v)) = A (a, f v)

instance Monoid a => Applicative (A a) where
    pure v = A (mempty, v)
    (A (a, f)) <*> (A (a', v')) = A (a <> a', f v')

instance Monoid a => Monad (A a) where
    A (u, v) >>= k =
        case k v of
            A (v1, b) -> A (u <> v1, b)

-- fix f = let x = f x in x
f n k =
    if n == 0
        then 1
        else n * f (n - 1) (k - 1)

fix' (f) =
    let x = f x
     in f (f x)
{-
f 3 == \k -> 3 * f 2 (k - 1)




* @'return' a '>>=' k  =  k a@
* @m '>>=' 'return'  =  m@
* @m '>>=' (\\x -> k x '>>=' h)  =  (m '>>=' k) '>>=' h@
-}
-- [/identity/]
--
--      @'pure' 'id' '<*>' v = v@
--
-- [/composition/]
--
--      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
--
-- [/homomorphism/]
--
--      @'pure' f '<*>' 'pure' x = 'pure' (f x)@
--
-- [/interchange/]
--
--      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@