1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
| module Numeric.MiniCalc (parseAndEvaluate, parseAndEvaluateWith, parseMaths, evaluate, expr, Expr(..), defaultFunctions) where
import qualified Data.Map.Strict as M
import Text.Parsec
import Text.Parsec.Expr
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef)
type Env a = M.Map String a
data Expr a =
Num a
| Var String
| Unary (a -> a) (Expr a)
| Binary (a -> a -> a) (Expr a) (Expr a)
| Function String (Expr a)
expr funcs = exprs
where exprs = buildExpressionParser (map function funcs : table) term
<?> "expression"
term = parens exprs
<|> Num <$> number
<|> Var <$> identifier
<?> "simple expression"
table = [ [binary "^" (**) AssocRight]
, [prefix "-" negate, prefix "+" id ]
, [binary "*" (*) AssocLeft, binary "/" (/) AssocLeft ]
, [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ]
]
binary name fun assoc = Infix (do{ reservedOp name; return (Binary fun) }) assoc
prefix name fun = Prefix (do{ reservedOp name; return (Unary fun) })
postfix name fun = Postfix (do{ reservedOp name; return (Unary fun) })
function name = Prefix (do{ reservedOp name; return (Function name) })
lexer = P.makeTokenParser haskellDef
parens = P.parens lexer
identifier = P.identifier lexer
number = either fromInteger id <$> P.naturalOrFloat lexer
reservedOp = P.reservedOp lexer
evaluate :: Env (a->a) -> Env a -> Expr a -> a
evaluate _ _ (Num n) = n
evaluate _ env (Var s) = M.findWithDefault (error $ "Cannot find " ++ s ++ " in the environment") s env
evaluate funcs env (Unary f e) = f (evaluate funcs env e)
evaluate funcs env (Binary f e1 e2) = f (evaluate funcs env e1) (evaluate funcs env e2)
evaluate funcs env (Function name e) = let func = M.findWithDefault (error $ "Cannot find " ++ name ++ " in the functions") name funcs
in func (evaluate funcs env e)
parseMaths :: [String] -> String -> Either ParseError (Expr Double)
parseMaths funcs s = parse (expr funcs) "Maths Expression" s
parseAndEvaluateWith :: [(String, Double->Double)] -> [(String, Double)] -> String -> Double
parseAndEvaluateWith funcs env s = case parseMaths (map fst funcs) s of
Left err -> error $ show err
Right e -> evaluate (M.fromList funcs) (M.fromList env) e
parseAndEvaluate :: String -> Double
parseAndEvaluate = parseAndEvaluateWith defaultFunctions []
defaultFunctions = [("cos", cos), ("sin", sin), ("tan", tan)
,("exp", exp), ("log", log)
,("abs", abs), ("sqrt", sqrt)] |
Partager