SHARE
TWEET

CyberZX

a guest Nov 3rd, 2007 77 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module Calculator where
  2. import Data.Char
  3.  
  4. ------------------------------------------------------------
  5. -- lexical analyzer
  6. ------------------------------------------------------------
  7. data Token = Number Double |
  8.              UnaryFunction (String, Double->Double) |
  9.              BinaryFunction (String, Double->Double->Double) |
  10.              Comma | Plus | Minus | Mul | Div | Circum | LParen | RParen
  11.              
  12. type Tokens = [Token]
  13.  
  14. unaryFunctionsList = [("ln",log), ("exp", exp), ("sin", sin), ("cos", cos), ("inc", (+) 1), ("dec", \x->x-1)]
  15. binaryFunctionsList= [("pow", (**)), ("add", (+)), ("sub",(-)), ("mul", (*)), ("div",(/)), ("log", \x y->log x / log y)]
  16. constantsList      = [("pi", pi), ("e", exp 1)]
  17.              
  18.  
  19. instance Show Token where
  20.     showsPrec d (Number f) = showsPrec d f
  21.     showsPrec _ (UnaryFunction (n, _) )  = showString n
  22.     showsPrec _ (BinaryFunction (n, _) ) = showString n
  23.     showsPrec _ Comma   = showString ","
  24.     showsPrec _ Plus    = showString "+"
  25.     showsPrec _ Minus   = showString "-"
  26.     showsPrec _ Mul     = showString "*"
  27.     showsPrec _ Circum  = showString "^"    
  28.     showsPrec _ Div     = showString "/"
  29.     showsPrec _ LParen  = showString "("
  30.     showsPrec _ RParen  = showString ")"
  31.        
  32. dropWS :: String->String
  33. dropWS [] = []
  34. dropWS s@(x:xs)
  35.     | isSpace x = dropWS xs
  36.     | otherwise = s
  37.    
  38. checkStr :: String -> String -> (Bool, String)
  39. checkStr [] s2 = (True, s2)
  40. checkStr s1 [] = (False, [])
  41. checkStr s1 s2 = if (head(s1) == head(s2) ) then checkStr (tail s1) (tail s2)
  42.                         else (False, s2)
  43.                            
  44. findTableElement :: String -> [(String, a)] -> Maybe ((String, a), String)
  45. findTableElement s table = let sl = map (\x -> (x, checkStr (fst x) s)) table
  46.                                found = filter (fst.snd) sl
  47.                                        in case found of
  48.                                         [] -> Nothing
  49.                                         otherwise -> Just((fst.head) found, (snd.snd.head) found)
  50.                                                                                          
  51.        
  52. readToken :: String -> [(Token, String)]
  53. readToken [] = []
  54. readToken s@(x:xs) =  if (x == ',') then [(Comma, xs)]
  55.                         else if (x == '+') then [(Plus, xs)]
  56.                         else if (x == '-') then [(Minus, xs)]
  57.                         else if (x == '*') then [(Mul, xs)]
  58.                         else if (x == '/') then [(Div, xs)]
  59.                         else if (x == '^') then [(Circum, xs)]
  60.                         else if (x == '(') then [(LParen, xs)]
  61.                         else if (x == ')') then [(RParen, xs)]
  62.                         else if not (null fr) then [(Number ((fst.head) fr), (snd.head) fr)]
  63.                         else case findTableElement s unaryFunctionsList of
  64.                                 Just (f, sf) -> [(UnaryFunction f, sf)]
  65.                                 Nothing -> case findTableElement s binaryFunctionsList of
  66.                                             Just (f, sf) -> [(BinaryFunction f, sf)]
  67.                                             Nothing -> case findTableElement s constantsList of
  68.                                                         Just((_,c), sc) -> [(Number c, sc)]
  69.                                                         Nothing -> []
  70.                         where  fr = (readsPrec 0 s ::[(Double, String)])
  71.    
  72. instance Read Token where
  73.     readsPrec d s = readToken (dropWS s)
  74.                
  75. lexicalScan :: String -> Tokens
  76. lexicalScan [] = []
  77. lexicalScan s  = let tok = readsPrec 0 s
  78.                  in if null tok then error ("Parse error: strange token " ++ s) else
  79.                      (fst.head) tok : lexicalScan ((snd.head) tok)
  80.                      
  81. showTokens :: Tokens -> String
  82. showTokens [] = []
  83. showTokens (x:xs) = show x ++ showTokens xs                    
  84.  
  85. ------------------------------------------------------------        
  86. -- syntax parser
  87. {--
  88.  
  89. epxression grammar
  90.  
  91. expr -> expr + term |
  92.         expr - term |
  93.         term
  94.  
  95. term -> term * factor |
  96.         term / factor |
  97.         factor
  98.  
  99. factor -> -factor | (expr) | func | number
  100.  
  101. func -> func_name (params)
  102. params -> params, expr |
  103.           expr
  104.  
  105.  
  106. eliminate left recursion for expr and term
  107.  
  108. expr   ->  term e_rest
  109. e_rest -> +term e_rest |
  110.           -term e_rest |
  111.            eps
  112.          
  113. term   ->  factor t_rest
  114. t_rest -> *factor t_rest |
  115.           /factor t_rest |
  116.            eps        
  117.  
  118. --}
  119.  
  120. ------------------------------------------------------------
  121. type ExprParser = Tokens -> Maybe (Double, Tokens)
  122. type RestParser = Tokens -> Maybe (Double->Double, Tokens)
  123.  
  124. infixl 4 >|
  125. (>|) :: ExprParser -> ExprParser -> ExprParser
  126. (p1 >| p2) s = case p1 s of
  127.                 Nothing -> p2 s
  128.                 _ -> p1 s
  129.                
  130. infixl 5 >>>
  131. (>>>) :: ExprParser -> RestParser -> ExprParser
  132. (p1 >>> p2) s = case p1 s of
  133.                 Nothing -> Nothing
  134.                 Just(v, t) -> case p2 t of
  135.                                 Nothing -> Nothing
  136.                                 Just (f, tr) -> Just (f v, tr)
  137.                                      
  138. parse_error :: String -> Tokens -> a                                    
  139. parse_error msg toks = error (msg ++ ": `" ++ showTokens toks ++ "'")
  140.  
  141. expr            :: ExprParser
  142. parentheses     :: ExprParser
  143. number          :: ExprParser
  144. t_rest          :: RestParser
  145. e_rest          :: RestParser
  146. minus_factor    :: ExprParser
  147. factor          :: ExprParser
  148. term            :: ExprParser
  149. unary_func      :: ExprParser
  150. binary_func     :: ExprParser
  151.  
  152. ------------------------------------------------------------
  153. expr s = (term >>> e_rest) s
  154.  
  155. ------------------------------------------------------------
  156. term s = (factor >>> t_rest) s
  157.  
  158. ------------------------------------------------------------
  159. restf toks f2 t rest = case t toks of
  160.                        Just(val, rtoks) -> Just((\x-> f (f2 x val) ), rtoks2)
  161.                                            where Just (f, rtoks2) = rest rtoks
  162.                        Nothing -> parse_error "Syntax error, bad term" toks
  163.  
  164. e_rest (Plus:toks)  = restf toks (+) term e_rest                  
  165. e_rest (Minus:toks) = restf toks (-) term e_rest
  166. e_rest s = Just(\x->x, s) --eps
  167.  
  168. t_rest (Mul:toks)   = restf toks (*) factor t_rest
  169. t_rest (Div:toks)   = restf toks (/) factor t_rest
  170. t_rest (Circum:toks)= restf toks (**) factor t_rest
  171. t_rest s = Just(\x->x, s)
  172.                                  
  173.  
  174. ------------------------------------------------------------
  175. number ((Number f):toks) = Just (f, toks)
  176. number _ = Nothing
  177.  
  178. ------------------------------------------------------------
  179. parentheses (LParen:toks) = case expr toks of
  180.                             Just (val, RParen:rtok) -> Just (val, rtok)
  181.                             Just (val, _) -> parse_error "Parentheses syntax error" toks
  182.                             Nothing -> parse_error "Syntax error" toks
  183. parentheses _ = Nothing
  184.  
  185. ------------------------------------------------------------
  186. minus_factor (Minus:toks) = case factor toks of
  187.                             Just (val, rtok) -> Just(-1*val, rtok)
  188.                             otherwise -> Nothing
  189. minus_factor _ = Nothing
  190.  
  191. ------------------------------------------------------------
  192. factor [] = Nothing
  193. factor s = (minus_factor >| parentheses >| unary_func >| binary_func >| number) s
  194.  
  195. ------------------------------------------------------------
  196. unary_func s@((UnaryFunction (_,f)):LParen:toks) = case expr toks of
  197.                                                 Just (val, RParen:rtoks) -> Just (f val, rtoks)
  198.                                                 Just (_, _) -> parse_error "Function call syntax error, maybe forgot ')'?" s
  199.                                                 otherwise -> parse_error "Function call syntax error, bad parameter" s
  200. unary_func s@((UnaryFunction _):toks) = parse_error "Function call syntax error, maybe forgot '('? " s
  201. unary_func _ = Nothing
  202.  
  203. ------------------------------------------------------------
  204. binary_func s@((BinaryFunction (_,f)):LParen:toks) =  case expr toks of
  205.                                                     Just (op1, Comma:rtoks) -> case expr rtoks of
  206.                                                                                 Just (op2, RParen:rtoks_next) -> Just (f op1 op2, rtoks_next)
  207.                                                                                 Just (_, _) -> parse_error "Function call syntax error, maybe forgot ')'?" s
  208.                                                                                 otherwise -> parse_error "Function call syntax error, bad parameter" s
  209.                                                     Just (_, rtoks) -> parse_error "Function call syntax error, missing parameter" s
  210.                                                     otherwise -> parse_error "Function call syntax error, bad value" s
  211.  
  212. binary_func s@((BinaryFunction _):toks) = parse_error "Function call syntax error, maybe forgot '('?" s
  213. binary_func _ = Nothing
  214.  
  215. calc :: String -> Maybe(Double)
  216. calc s = case (expr.lexicalScan) s of
  217.             Just (v, _) -> Just (v)
  218.             Nothing -> parse_error "Syntax error" (lexicalScan s)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top