---   ParserFunction
---   by Enzo Haussecker

---   ParserFunction provides utilities for parsing and evaluating mathematical expressions. 
---   The central parsing function in this package is stringToExpr, which parses an expression 
---   (as a string) and returns an expression tree of type Expr (or nothing if the string is malformed). 

---   Examples of stringToExpr are as fallows.

---   > stringToExpr "cos(x^2)+4*(1+y)"
---   Just (Add (Cos (Pow (Var 'x') (Num 2.0))) (Mul (Num 4.0) (Add (Num 1.0) (Var 'y'))))

---   Expressions can be evaluated using the function evaluateExpression. Example: 

---   Examples of evaluateExpression are as fallows.

---   > evaluateExpression "5 - 2" []
---   3.0
---   > evaluateExpression "x^2 + y" [('x',2),('y',3)]
---   7.0
---   > evaluateExpression "cos(x)" [('x',pi)]
---   -1.0

module Text.ParserCombinators.Parsec.ParserFunction
    (Expr,evaluateExpression,stringToExpr,buildExpr,expressionTable,factor,variables,number,evaluate) 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)

-- |The Expr data type provides a basis for ordering mathematical operations.
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)

-- |@evaluateExpression@ evaluates a mathematical expression s using the variable map m. 
evaluateExpression :: String -> [(Char,Double)] -> Double
evaluateExpression s m = evaluate (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@ parses an expression and returns an expression tree of type Expr.
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

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