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)
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 :: 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 :: 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 :: 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] ++ "'"