-- Lab2

--------------------------------------------------------------------------------
-- H2(h,Op,op) =∀x.∀y.h(Op x  y)op(h x) (h y)

-- 1.
-- The evaluation of the second derivative is given by: eval'' = eval' . derive = eval . derive . derive

-- (a) Show that eval'' is not a homomorphism from FunExp to FunSem = R -> R.

{-

eval'' :: FunExp -> FunSem
eval'' = eval' . derive == eval . derive . derive

-}

{-# LANGUAGE FlexibleInstances #-}
-- Allows instance declarations to take synonym types as argument
-- (Tri a) instead of (a,a,a)
-------------------------------------------------------------------------------
-- Test FunExps

fe1 = Const 5                                                        -- 5
fe2 = Id :+: (Id :*: Const 3) :+: Const 7                            -- x + 3x + 7 = 4x + 7
fe3 = (Id :*: Id :*: Id) :+: (Const 3 :*: Id :*: Id) :+: Id :+: Const 12 -- x^3 + 3x^2 + x + 12
fe4 = Id :*: Id :*: Id :*: Id                                        -- x^4

-------------------------------------------------------------------------------
-- Types

type Tri a      = (a, a, a)
type TriFun a   = Tri (a -> a)  -- ((a -> a), (a -> a), (a -> a))
type FunTri a   = a -> Tri a    -- a -> (a, a, a)

-------------------------------------------------------------------------------
-- Data

data FunExp = Const Rational
            | Id
            | FunExp :+: FunExp
            | FunExp :*: FunExp
            | Exp FunExp
            deriving (Eq, Show)

-------------------------------------------------------------------------------
-- Instance declarations

instance Num a => Num (Tri a) where
    (+)     = plusT
    (*)     = mulT
    (-)     = minT
    negate  = negateT
    abs     = absT
    signum  = signumT
    fromInteger = undefined

instance Fractional a => Fractional (Tri a) where
    (/)     = divT
    recip   = recipT
    fromRational = fromRationalT

instance Floating a => Floating (Tri a) where
    pi      = undefined
    exp     = expT
    log     = undefined
    sqrt    = undefined
    (**)    = undefined
    logBase = undefined
    sin     = sinT
    cos     = cosT
    tan     = undefined
    asin    = undefined
    acos    = undefined
    atan    = undefined
    sinh    = undefined
    cosh    = undefined
    tanh    = undefined
    asinh   = undefined
    acosh   = undefined
    atanh   = undefined


-------------------------------------------------------------------------------
--  Num Instances


plusT :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)
plusT (x, x', x'') (y, y', y'') = (x + y, x' + y', x'' + y'')

mulT :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)
mulT (x, x', x'') (y, y', y'') = (  x * y,
                                    (x * y') + (x' * y),
                                    (x'' * y) + (x' * y') + (x' * y') + (x * y'')
                                 )

minT :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)
minT (x, x', x'') (y, y', y'') = (x - y, x' - y', x'' - y'')

negateT :: Num a => (a,a,a) -> (a,a,a)
negateT (x, x', x'') = (negate x, negate x', negate x'')

absT :: Num a => (a,a,a) -> (a,a,a)
absT (x, x', x'') = (abs x, abs x', abs x'')

signumT :: Num a => (a,a,a) -> (a,a,a)
signumT (x, x', x'') = (signum x, signum x', signum x'')

-------------------------------------------------------------------------------
--  Fractional Instances

divT :: Fractional a => (a,a,a) -> (a,a,a) -> (a,a,a)
divT (x, x', x'') (y, y', y'') = (  (x / y),
                                    (x'*y - x*y') / (y*y),
                                    (x''*y*y - 2*y*y'*x' - y''*y*x + 2*y'*y'*x) / (y*y*y))

recipT :: Fractional a => (a,a,a) -> (a,a,a)
recipT (x, x', x'') = (recip x, recip x', recip x'')

fromRationalT :: Fractional a => Rational -> Tri a
fromRationalT x = (fromRational x, 0, 0)

-------------------------------------------------------------------------------
--  Floating Instances

expT :: Floating a => (a,a,a) -> (a,a,a)
expT (x, x', x'') = (exp x, exp x', exp x'')

sinT :: Floating a => (a,a,a) -> (a,a,a)
sinT (x, x', x'') = (sin x, x' * cos x, (x'' * cos x) + (x' * x' * (- sin x))  )

cosT :: Floating a => (a,a,a) -> (a,a,a)
cosT (x, x', x'') = (cos x, x' * (- sin x), - ((x'' * sin x) + (x'*x'*cos x) ))

-------------------------------------------------------------------------------
-- derive FunExp

derive :: FunExp -> FunExp
derive (Const c)    = Const 0
derive Id           = Const 1
derive (x :+: y)    = derive x :+: derive y
derive (x :*: y)    = (derive x :*: y) :+: (derive y :*: x)
derive (Exp   x)    = derive x :*: Exp x


simplify :: FunExp -> FunExp
simplify x =    if ((simplify' x) /= x)
                then simplify (simplify' x)
                else x

simplify' :: FunExp -> FunExp
simplify' (Const x)              = Const x
simplify' (Id)                   = Id
simplify' (Exp x)                = Exp (simplify' x)

simplify' (Const 0 :+: x)        = simplify' x
simplify' (x :+: Const 0)        = simplify' x
simplify' (Const x :+: Const y)  = Const (x + y)
simplify' (Id :+: Id)            = (Const 2 :*: Id)
simplify' (Id :+: Const x)       = (Id :+: Const x)
simplify' (Const x :+: Id)       = (Id :+: Const x)


simplify' (Const 0 :*: _)        = Const 0
simplify' (_ :*: Const 0)        = Const 0
simplify' (Const 1 :*: x)        = simplify' x
simplify' (x :*: Const 1)        = simplify' x
simplify' (Const x :*: Const y)  = Const (x * y)
simplify' (Id :*: Id)            = Id :*: Id
simplify' (Const x :*: Id)       = Const x :*: Id

simplify' (x :*: (y :+: z))      = simplify' (simplify' (x :*: y)) :+: (simplify' (x :*: z))
simplify' ((x :+: y) :*: z)      = simplify' (simplify' (x :*: z)) :+: (simplify' (y :*: z))
simplify' (Id :*: Const x)       = Const x :*: Id

simplify' (x :*: y)              = (simplify' x :*: simplify' y)
simplify' (x :+: y)              = if (simplify' x == simplify' y)
                                    then (Const 2 :*: simplify' x)
                                    else (simplify' x :+: simplify' y)

show' :: FunExp -> String
show' (Const x) = "(" ++ show x ++ ")"
show' (Id)      = "x"
show' (Exp f)   = "e^" ++ "(" ++ show' f ++ ")"
show' (x :+: y) = (show' x) ++ " + " ++ (show' y)
show' (x :*: y) = (show' x) ++ " * " ++ (show' y)

d :: FunExp -> FunExp
d = simplify . derive

sh :: FunExp -> String
sh = show' . d
-------------------------------------------------------------------------------
-- EvalDD

evalDD :: (Floating a, Num a) => FunExp -> FunTri a  -- FunExp -> (a -> (a,a,a))
evalDD (Const c)    = \x -> fromRationalT c
evalDD Id           = \x -> (x, 1, 0)
evalDD (a :+: b)    = (evalDD (a + b))
evalDD (a :*: b)    = undefined
evalDD (Exp   a)    = undefined