CyberZX

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)