rendered paste bodymodule Calculator where
import Data.Char
-- epxression grammar
--
-- expression ::= <addsub_expr> | <muldiv_expr> | <term>
-- addsub_expr ::= <expression> + <term2> | <expression> - <term2>
-- muldiv_expr ::= <term> * <term2> | <term> / <term2>
-- term2 ::= <muldiv_expr> | <term>
-- term ::= -<term> | (<expression>) | unary_func | binary_func | <number> | const
-- unary_func ::= (ln | exp | sin | cos | ...) (<expression>)
-- binary_func ::= (pow| add | sub | mul | div | ...) (<expression>, <expression>)
-- const :: = pi | e | ...
-- lexical analyzer
data Token = Number Float |
UnaryFunction (Float->Float) |
BinaryFunction (Float->Float->Float) |
Comma | Plus | Minus | Mul | Div | LParen | RParen
type Tokens = [Token]
unaryFunctionsList = [("ln",log), ("exp", exp), ("sin", sin), ("cos", cos), ("inc", (+) 1)]
binaryFunctionsList= [("pow", (**)), ("add", (+)), ("sub",(-)), ("mul", (*)), ("div",(/))]
constantsList = [("pi", pi), ("e", exp 1)]
instance Show Token where
showsPrec d (Number f) = showString "[Number, ". showsPrec d f . showString "]"
showsPrec d (UnaryFunction f) = showString "[UnaryFunction]"
showsPrec d (BinaryFunction f) = showString "[BinaryFunction]"
showsPrec d Comma = showString "[Comma]"
showsPrec d Plus = showString "[Plus]"
showsPrec d Minus = showString "[Minus]"
showsPrec d Mul = showString "[Mul]"
showsPrec d Div = showString "[Div]"
showsPrec d LParen = showString "[LParen]"
showsPrec d RParen = showString "[RParen]"
dropWS :: String->String
dropWS [] = []
dropWS s@(x:xs)
| isSpace x = dropWS xs
| otherwise = s
checkStr :: String -> String -> (Bool, String)
checkStr [] s2 = (True, s2)
checkStr s1 [] = (False, [])
checkStr s1 s2 = if (head(s1) == head(s2) ) then checkStr (tail s1) (tail s2)
else (False, s2)
findTableElement s table df = let sl = map (\x -> (x, checkStr (fst x) s)) table
found = filter (fst.snd) sl
in case found of
[] -> (df, [], False)
otherwise -> ((snd.fst.head) found, (snd.snd.head) found, True)
readToken :: String -> [(Token, String)]
readToken [] = []
readToken s@(x:xs) = if (x == ',') then [(Comma, xs)]
else if (x == '+') then [(Plus, xs)]
else if (x == '-') then [(Minus, xs)]
else if (x == '*') then [(Mul, xs)]
else if (x == '/') then [(Div, xs)]
else if (x == '(') then [(LParen, xs)]
else if (x == ')') then [(RParen, xs)]
else if not (null fr) then [(Number ((fst.head) fr), (snd.head) fr)]
else let (f1, s1, r1) = findTableElement s unaryFunctionsList (\_->0)
(f2, s2, r2) = findTableElement s binaryFunctionsList(\_ _->0)
(c, s3, r3) = findTableElement s constantsList 0.0
in if r1 then [(UnaryFunction f1, s1)] else
if r2 then [(BinaryFunction f2, s2)] else
if r3 then [(Number c, s3)] else
[]
where fr = (readsPrec 0 s ::[(Float, String)])
instance Read Token where
readsPrec d s = readToken (dropWS s)
lexicalScan :: String -> Tokens
lexicalScan [] = []
lexicalScan s = let tok = readsPrec 0 s
in if null tok then error ("Parse error: unknown token at " ++ s) else
(fst.head) tok : lexicalScan ((snd.head) tok)
-- syntax parser
type ExprParser = Tokens -> Maybe (Float, Tokens)
infixr 4 >|
(>|) :: ExprParser -> ExprParser -> ExprParser
(p1 >| p2) s = case p1 s of
Nothing -> p2 s
_ -> p1 s
expr :: ExprParser
parentheses :: ExprParser
number :: ExprParser
muldiv_expr :: ExprParser
addsub_expr :: ExprParser
minus_term :: ExprParser
term :: ExprParser
term2 :: ExprParser
unary_func :: ExprParser
binary_func :: ExprParser
------------------------------------------------------------
expr s = (addsub_expr >| muldiv_expr >| term) s
------------------------------------------------------------
unary_func ((UnaryFunction f):LParen:toks) = case expr toks of
Just (val, RParen:rtoks) -> Just (f val, rtoks)
Just (_, _) -> error ("Function call syntax error, maybe forgot ')'?")
otherwise -> error ("Function call syntax error, bad value")
unary_func ((UnaryFunction f):toks) = error ("Function call syntax error, maybe forgot '('?")
unary_func _ = Nothing
------------------------------------------------------------
binary_func ((BinaryFunction f):LParen:toks) = case expr toks of
Just (op1, Comma:rtoks) -> case expr rtoks of
Just (op2, RParen:rtoks_next) -> Just (f op1 op2, rtoks_next)
Just (_, _) -> error ("Function call syntax error, maybe forgot ')'?")
otherwise -> error ("Function call syntax error, bad value")
Just (_, rtoks) -> error ("Function call syntax error, need second operand")
otherwise -> error ("Function call syntax error, bad value")
binary_func ((BinaryFunction f):toks) = error ("Function call syntax error, maybe forgot '('?")
binary_func _ = Nothing
------------------------------------------------------------
addsub_expr toks = case term2 toks of
Just(val1, sign:rtok) -> case sign of
Plus -> eval((+))
Minus-> eval((-))
otherwise -> Nothing
where eval f = case expr rtok of
Just(val2, rtok2) -> Just(f val1 val2, rtok2)
Nothing -> error ("Expression syntax error: " ++ show rtok)
otherwise -> Nothing
------------------------------------------------------------
muldiv_expr toks = case term toks of
Just(val1, sign:rtok) -> case sign of
Mul -> eval((*))
Div-> eval((/))
otherwise -> Nothing
where eval f = case term2 rtok of
Just(val2, rtok2) -> Just(f val1 val2, rtok2)
Nothing -> error ("Expression syntax error: " ++ show rtok)
otherwise -> Nothing
------------------------------------------------------------
number ((Number f):toks) = Just (f, toks)
number _ = Nothing
------------------------------------------------------------
parentheses (LParen:toks) = case expr toks of
Just (val, RParen:rtok) -> Just (val, rtok)
Just (val, _) -> error ("Parentheses syntax error" ++ show toks)
Nothing -> error ("Syntax error" ++ show toks)
parentheses _ = Nothing
------------------------------------------------------------
minus_term (Minus:toks) = case term toks of
Just (val, rtok) -> Just(-1*val, rtok)
otherwise -> Nothing
minus_term _ = Nothing
------------------------------------------------------------
term [] = Nothing
term s = (minus_term >| parentheses >| unary_func >| number) s
------------------------------------------------------------
term2 s = (muldiv_expr >| term) s
calc = expr.lexicalScan