---   ParserFunction
---   by Enzo Haussecker

---   The centerpiece of this module is a function called: expressionToDouble, 
---   which parses an expression (in the form of a string) and returns a Double.

---   You must declare all variables in the expression! 

---   Examples are as fallows.

---   > expressionToDouble "5 - 2" []
---   3.0


---   > expressionToDouble "x^2 + y" [('x',2),('y',3)]
---   7.0

---   > expressionToDouble "cos(x)" [('x',pi)]
---   -1.0

module Text.ParserCombinators.Parsec.ParserFunction
    (expressionToDouble) where

import Text.ParserCombinators.Parsec.Expr 
import Text.ParserCombinators.Parsec
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.List (isInfixOf)
import Data.Char (toLower)

data Expr = Num Double    | Var Char      | Sub Expr Expr
          | Div Expr Expr | Pow Expr Expr | Log Expr
          | Abs Expr      | Sqrt Expr     | Cbrt Expr
          | ArcSinh Expr  | ArcCosh Expr  | ArcTanh Expr
          | ArcSin Expr   | ArcCos Expr   | ArcTan Expr
          | Sinh Expr     | Cosh Expr     | Tanh Expr
          | Sin Expr      | Cos Expr      | Tan Expr
          | ArcSech Expr  | ArcCsch Expr  | ArcCoth Expr
          | ArcSec Expr   | ArcCsc Expr   | ArcCot Expr
          | Sech Expr     | Csch Expr     | Coth Expr
          | Sec Expr      | Csc Expr      | Cot Expr
          | Mul Expr Expr | Add Expr Expr | Exp Expr deriving (Show, Eq, Ord)

expressionToDouble :: String -> [(Char,Double)] -> Double
expressionToDouble s m = eval (M.fromAscList $ caseMap m) (fromMaybe failing $ stringToExpr s)
    where 
        caseMap x = fmap (\ (a, b) -> ([toLower a], b)) x
        failing   = error "Parser error in expression"

stringToExpr :: String -> Maybe Expr
stringToExpr xs = if any (==True) (symbols failingSymbols xs)
                  then Nothing
                  else either (const Nothing) (Just) (parse buildExpr "" handleString)
    where
        handleString   = "(" ++ (map toLower $ filter (/=' ') xs) ++ ")"
        symbols [] y   = []
        symbols x  y   = [isInfixOf (head x) y] ++ (symbols (drop 1 x) y)
        failingSymbols = ["^^","^*","^/","^+","^-","*^","**","*/","*+","*-",
                          "/^","/*","//","/+","/-","+^","+*","+/","++","+-",
                          "-^","-*","-/","-+","--"]

buildExpr :: Parser Expr
buildExpr = buildExpressionParser expressionTable factor

expressionTable :: [[Operator Char st Expr]]
expressionTable =  [[pr "arcsinh" ArcSinh, pr "arcsin" ArcSin, pr "sinh" Sinh, pr "sin" Sin],
                    [pr "arccosh" ArcCosh, pr "arccos" ArcCos, pr "cosh" Cosh, pr "cos" Cos],
                    [pr "arctanh" ArcTanh, pr "arctan" ArcTan, pr "tanh" Tanh, pr "tan" Tan],
                    [pr "arcsech" ArcSech, pr "arcsec" ArcSec, pr "sech" Sech, pr "sec" Sec],
                    [pr "arccsch" ArcCsch, pr "arccsc" ArcCsc, pr "csch" Csch, pr "csc" Csc],
                    [pr "arccoth" ArcCoth, pr "arccot" ArcCot, pr "coth" Coth, pr "cot" Cot],
                    [pr "log" Log, pr "abs" Abs,pr "exp" Exp,pr "e^" Exp],
                    [pr "sqrt" Sqrt, pr "cbrt" Cbrt],
                    [op "^" Pow AssocLeft],
                    [op "*" Mul AssocLeft, op "/" Div AssocLeft],
                    [op "+" Add AssocLeft, op "-" Sub AssocLeft]]
    where
        op s f assoc = Infix  (do{ string s; return f}) assoc
        pr s f       = Prefix (try (string s) >> return f)

factor :: Parser Expr
factor = do
    char '('
    e <- buildExpr
    char ')'
    return e
    <|> variables

variables :: Parser Expr
variables = do
    ds <- letter
    return $ Var ds
    <|> number

number :: Parser Expr
number = do
    br  <- many digit
    let d :: Double
        d = fromInteger (foldl ((. ch2num) . (+) . (*10)) 0 br)
    option (Num (d)) (try (do
        char '.'
        ar <- many1 digit
        return $ (Num (d + foldr (fd) 0 ar)) ))
        where
            fd a b = (fromInteger (ch2num a) + b) / 10
            fe = toInteger . fromEnum
            ch2num = (subtract $ fe '0') . fe

eval :: M.Map String Double -> Expr -> Double
eval m expr =
    case expr of 
        (Num d)           -> d
        (Var c)         -> fromMaybe (failing c) (M.lookup [c] m)
        (Add expr1 expr2) -> (eval m expr1) +  (eval m expr2)
        (Sub expr1 expr2) -> (eval m expr1) -  (eval m expr2)
        (Mul expr1 expr2) -> (eval m expr1) *  (eval m expr2)
        (Div expr1 expr2) -> (eval m expr1) /  (eval m expr2)
        (Pow expr1 expr2) -> (eval m expr1) ** (eval m expr2)
        (Exp expr1)       -> exp (eval m expr1)
        (Sqrt expr1)      -> (eval m expr1) ** (0.5)
        (Cbrt expr1)      -> (eval m expr1) ** (1/3)
        (Log expr1)       -> log (eval m expr1)
        (Abs expr1)       -> abs (eval m expr1)
        (Sin expr1)       -> sin (eval m expr1) 
        (Cos expr1)       -> cos (eval m expr1)
        (Tan expr1)       -> tan (eval m expr1)
        (Sec expr1)       -> 1/sin (eval m expr1) 
        (Csc expr1)       -> 1/cos (eval m expr1)
        (Cot expr1)       -> 1/tan (eval m expr1)
        (Sinh expr1)      -> sinh (eval m expr1) 
        (Cosh expr1)      -> cosh (eval m expr1)
        (Tanh expr1)      -> tanh (eval m expr1)
        (Sech expr1)      -> 1/sinh (eval m expr1) 
        (Csch expr1)      -> 1/cosh (eval m expr1)
        (Coth expr1)      -> 1/tanh (eval m expr1)
        (ArcSin expr1)    -> asin (eval m expr1) 
        (ArcCos expr1)    -> acos (eval m expr1)
        (ArcTan expr1)    -> atan (eval m expr1)
        (ArcSec expr1)    -> 1/asin (eval m expr1) 
        (ArcCsc expr1)    -> 1/acos (eval m expr1)
        (ArcCot expr1)    -> 1/atan (eval m expr1)
        (ArcSinh expr1)   -> asinh (eval m expr1) 
        (ArcCosh expr1)   -> acosh (eval m expr1)
        (ArcTanh expr1)   -> atanh (eval m expr1)
        (ArcSech expr1)   -> 1/asinh (eval m expr1) 
        (ArcCsch expr1)   -> 1/acosh (eval m expr1)
        (ArcCoth expr1)   -> 1/atanh (eval m expr1)
    where
        failing x = error $ "M.lookup error in value for variable `" ++ [x] ++ "'"