module Calculator where import Data.Char -- epxression grammar -- -- expression ::= | | -- addsub_expr ::= + | - -- muldiv_expr ::= * | / -- term2 ::= | -- term ::= - | () | unary_func | binary_func | | const -- unary_func ::= (ln | exp | sin | cos | ...) () -- binary_func ::= (pow| add | sub | mul | div | ...) (, ) -- 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