Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- module Calculator where
- import Data.Char
- ------------------------------------------------------------
- -- lexical analyzer
- ------------------------------------------------------------
- data Token = Number Double |
- UnaryFunction (String, Double->Double) |
- BinaryFunction (String, Double->Double->Double) |
- Comma | Plus | Minus | Mul | Div | Circum | LParen | RParen
- type Tokens = [Token]
- unaryFunctionsList = [("ln",log), ("exp", exp), ("sin", sin), ("cos", cos), ("inc", (+) 1), ("dec", \x->x-1)]
- binaryFunctionsList= [("pow", (**)), ("add", (+)), ("sub",(-)), ("mul", (*)), ("div",(/)), ("log", \x y->log x / log y)]
- constantsList = [("pi", pi), ("e", exp 1)]
- instance Show Token where
- showsPrec d (Number f) = showsPrec d f
- showsPrec _ (UnaryFunction (n, _) ) = showString n
- showsPrec _ (BinaryFunction (n, _) ) = showString n
- showsPrec _ Comma = showString ","
- showsPrec _ Plus = showString "+"
- showsPrec _ Minus = showString "-"
- showsPrec _ Mul = showString "*"
- showsPrec _ Circum = showString "^"
- showsPrec _ Div = showString "/"
- showsPrec _ LParen = showString "("
- showsPrec _ RParen = showString ")"
- 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 :: String -> [(String, a)] -> Maybe ((String, a), String)
- findTableElement s table = let sl = map (\x -> (x, checkStr (fst x) s)) table
- found = filter (fst.snd) sl
- in case found of
- [] -> Nothing
- otherwise -> Just((fst.head) found, (snd.snd.head) found)
- 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 [(Circum, 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 case findTableElement s unaryFunctionsList of
- Just (f, sf) -> [(UnaryFunction f, sf)]
- Nothing -> case findTableElement s binaryFunctionsList of
- Just (f, sf) -> [(BinaryFunction f, sf)]
- Nothing -> case findTableElement s constantsList of
- Just((_,c), sc) -> [(Number c, sc)]
- Nothing -> []
- where fr = (readsPrec 0 s ::[(Double, 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: strange token " ++ s) else
- (fst.head) tok : lexicalScan ((snd.head) tok)
- showTokens :: Tokens -> String
- showTokens [] = []
- showTokens (x:xs) = show x ++ showTokens xs
- ------------------------------------------------------------
- -- syntax parser
- {--
- epxression grammar
- expr -> expr + term |
- expr - term |
- term
- term -> term * factor |
- term / factor |
- factor
- factor -> -factor | (expr) | func | number
- func -> func_name (params)
- params -> params, expr |
- expr
- eliminate left recursion for expr and term
- expr -> term e_rest
- e_rest -> +term e_rest |
- -term e_rest |
- eps
- term -> factor t_rest
- t_rest -> *factor t_rest |
- /factor t_rest |
- eps
- --}
- ------------------------------------------------------------
- type ExprParser = Tokens -> Maybe (Double, Tokens)
- type RestParser = Tokens -> Maybe (Double->Double, Tokens)
- infixl 4 >|
- (>|) :: ExprParser -> ExprParser -> ExprParser
- (p1 >| p2) s = case p1 s of
- Nothing -> p2 s
- _ -> p1 s
- infixl 5 >>>
- (>>>) :: ExprParser -> RestParser -> ExprParser
- (p1 >>> p2) s = case p1 s of
- Nothing -> Nothing
- Just(v, t) -> case p2 t of
- Nothing -> Nothing
- Just (f, tr) -> Just (f v, tr)
- parse_error :: String -> Tokens -> a
- parse_error msg toks = error (msg ++ ": `" ++ showTokens toks ++ "'")
- expr :: ExprParser
- parentheses :: ExprParser
- number :: ExprParser
- t_rest :: RestParser
- e_rest :: RestParser
- minus_factor :: ExprParser
- factor :: ExprParser
- term :: ExprParser
- unary_func :: ExprParser
- binary_func :: ExprParser
- ------------------------------------------------------------
- expr s = (term >>> e_rest) s
- ------------------------------------------------------------
- term s = (factor >>> t_rest) s
- ------------------------------------------------------------
- restf toks f2 t rest = case t toks of
- Just(val, rtoks) -> Just((\x-> f (f2 x val) ), rtoks2)
- where Just (f, rtoks2) = rest rtoks
- Nothing -> parse_error "Syntax error, bad term" toks
- e_rest (Plus:toks) = restf toks (+) term e_rest
- e_rest (Minus:toks) = restf toks (-) term e_rest
- e_rest s = Just(\x->x, s) --eps
- t_rest (Mul:toks) = restf toks (*) factor t_rest
- t_rest (Div:toks) = restf toks (/) factor t_rest
- t_rest (Circum:toks)= restf toks (**) factor t_rest
- t_rest s = Just(\x->x, s)
- ------------------------------------------------------------
- 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, _) -> parse_error "Parentheses syntax error" toks
- Nothing -> parse_error "Syntax error" toks
- parentheses _ = Nothing
- ------------------------------------------------------------
- minus_factor (Minus:toks) = case factor toks of
- Just (val, rtok) -> Just(-1*val, rtok)
- otherwise -> Nothing
- minus_factor _ = Nothing
- ------------------------------------------------------------
- factor [] = Nothing
- factor s = (minus_factor >| parentheses >| unary_func >| binary_func >| number) s
- ------------------------------------------------------------
- unary_func s@((UnaryFunction (_,f)):LParen:toks) = case expr toks of
- Just (val, RParen:rtoks) -> Just (f val, rtoks)
- Just (_, _) -> parse_error "Function call syntax error, maybe forgot ')'?" s
- otherwise -> parse_error "Function call syntax error, bad parameter" s
- unary_func s@((UnaryFunction _):toks) = parse_error "Function call syntax error, maybe forgot '('? " s
- unary_func _ = Nothing
- ------------------------------------------------------------
- binary_func s@((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 (_, _) -> parse_error "Function call syntax error, maybe forgot ')'?" s
- otherwise -> parse_error "Function call syntax error, bad parameter" s
- Just (_, rtoks) -> parse_error "Function call syntax error, missing parameter" s
- otherwise -> parse_error "Function call syntax error, bad value" s
- binary_func s@((BinaryFunction _):toks) = parse_error "Function call syntax error, maybe forgot '('?" s
- binary_func _ = Nothing
- calc :: String -> Maybe(Double)
- calc s = case (expr.lexicalScan) s of
- Just (v, _) -> Just (v)
- Nothing -> parse_error "Syntax error" (lexicalScan s)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement