5outh

{-# LANGUAGE NoMonomorphismRestriction #-}

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Token hiding (parens)
import Text.ParserCombinators.Parsec.Expr
import Control.Applicative hiding ((<|>))
import Control.Monad
import Prelude hiding (not)

data Expr = Not Expr | And Expr Expr | Or Expr Expr | Var Char | SubExpr Expr deriving Eq

5outh

ddx :: (Floating a, Eq a) => Expr a -> Expr a
ddx = fullSimplify . derivative  

ddxs :: (Floating a, Eq a) => Expr a -> [Expr a]
ddxs = iterate ddx

nthDerivative :: (Floating a, Eq a) => Int -> Expr a -> Expr a
nthDerivative n = foldr1 (.) (replicate n ddx)

5outh

taylor :: (Floating a, Eq a) => Expr a -> [Expr a]
taylor expr = fmap fullSimplify (fmap series exprs)
  where indices = fmap fromIntegral [1..]
        derivs  = fmap (changeVars 'a') (ddxs expr)
          where changeVars c = mapVar (\_ -> Var c)
        facts   = fmap Const $ scanl1 (*) indices
        exprs   = zip (zipWith (:/:) derivs facts) indices -- f^(n)(a)/n!
        series (expr, n) = 
          expr :*: ((Var 'x' :+: (negate' $ Var 'a')) :^: Const n) -- f^(n)(a)/n! * (x - a)^n

5outh

evalExpr :: (Num a, Floating a) => Char -> a -> Expr a -> a
evalExpr c x = evalExpr' . plugIn c x 

evalExpr' :: (Num a, Floating a) => Expr a -> a
evalExpr' (Const a) = a
evalExpr' (Var   c) = error $ "Variables ("
                              ++ [c] ++ 
                              ") still exist in formula. Try plugging in a value!"
evalExpr' (a :+: b) = (evalExpr' a) + (evalExpr' b)
evalExpr' (a :*: b) = (evalExpr' a) * (evalExpr' b)

5outh

mapVar :: (Char -> Expr a) => Expr a -> Expr a
mapVar f (Var d)   = f d
mapVar _ (Const a) = Const a
mapVar f (a :+: b) = (mapVar f a) :+: (mapVar f b)
mapVar f (a :*: b) = (mapVar f a) :*: (mapVar f b)
mapVar f (a :^: b) = (mapVar f a) :^: (mapVar f b)
mapVar f (a :/: b) = (mapVar f a) :/: (mapVar f b)

plugIn :: Char -> a -> Expr a -> Expr a
plugIn c val = mapVar (\x -> if x == c then Const val else Var x)

5outh

negate' :: (Num a) => Expr a -> Expr a
negate' (Var c)    = (Const (-1)) :*: (Var c)
negate' (Const a)  = Const (-a)
negate' (a :+: b)  = (negate' a) :+: (negate' b)
negate' (a :*: b)  = (negate' a) :*: b
negate' (a :^: b)  = Const (-1) :*: a :^: b
negate' (a :/: b)  = (negate' a) :/: b

5outh

derivative :: (Num a) => Expr a -> Expr a
derivative (Var c)           = Const 1
derivative (Const x)         = Const 0
--product rule (ab' + a'b)
derivative (a :*: b)         = (a :*: (derivative b)) :+:  (b :*: (derivative a)) -- product rule
 --power rule (xa^(x-1) * a')
derivative (a :^: (Const x)) = ((Const x) :*: (a :^: (Const $ x-1))) :*: (derivative a)
derivative (a :+: b)         = (derivative a) :+: (derivative b)
 -- quotient rule ( (a'b - b'a) / b^2 )
derivative (a :/: b)         = ((derivative a :*: b) :+: (negate' (derivative b :*: a))) 

5outh

infixl 4 :+:
infixl 5 :*:, :/:
infixr 6 :^:

data Expr a = Var Char
             | Const a 
             | (Expr a) :+: (Expr a) 
             | (Expr a) :*: (Expr a)
             | (Expr a) :^: (Expr a)
             | (Expr a) :/: (Expr a)

5outh

simplify :: (Num a, Eq a, Floating a) => Expr a -> Expr a
simplify (Const a :+: Const b) = Const (a + b)
simplify (a       :+: Const 0) = simplify a
simplify (Const 0 :+: a      ) = simplify a

simplify (Const a :*: Const b) = Const (a*b)
simplify (a :*: Const 1)         = simplify a
simplify (Const 1 :*: a)         = simplify a
simplify (a :*: Const 0)         = Const 0
simplify (Const 0 :*: a)         = Const 0

5outh

minimumDist = trip =>> shortest