mipt_pl_comparsion/arithmetic/Main.hs

module Main where

import Data.Char
import qualified Data.Map as M

data Token = Number Double | ParenOpen | ParenClose | AddOp | MulOp  | DivOp | SubOp deriving (Show, Eq)

isOp:: Token -> Bool
isOp AddOp = True
isOp MulOp = True
isOp DivOp = True
isOp SubOp = True
isOp _ = False

scanNumber:: String -> (Double, String)
scanNumber xs = (num, str) where 
        (n, str) = span isNumber xs
        num = read n :: Double

opmap:: M.Map Char Token
opmap = M.fromList [ ('+', AddOp), ('*', MulOp), ('/', DivOp), ('(', ParenOpen), ('-', SubOp), (')', ParenClose)]

tokenize:: String -> [Maybe Token]
tokenize s = loop s [] where
    loop str tokens
        | null str = tokens
        | isNumber $ head str = let
                    (num, str') = scanNumber str
                    tokens' = tokens ++ [Just (Number num)]
                in loop str' tokens'
        -- Skip whitespaces
        | (\c -> c == ' ') $ head str = loop (tail str) tokens
        -- Otherwise lookup for op
        | otherwise = loop (tail str) (tokens ++ [M.lookup (head str) opmap])

opPriority :: Token -> Int
opPriority AddOp = 0
opPriority SubOp = 0
opPriority MulOp = 1
opPriority DivOp = 1
opPriority ParenOpen = 2
opPriority ParenClose = 2
opPriority (Number _) = 3

-- Shunting yard algo
transform:: [Maybe Token] -> [Token]
-- tokens - stack - output
transform ts = transform' ts [] [] where
    transform' [] [] out = out
    transform' [] st out =
        if head st == ParenOpen 
            then error "Mismatched parentheses" 
            else transform' [] (tail st) (out ++ [head st])
    transform' (t:ts) st out = case t of
        Nothing -> error "Illegal tokens"
        Just (Number n) -> transform' ts st (out ++ [Number n])
        Just ParenOpen -> transform' ts (ParenOpen:st) out
        Just ParenClose -> transform' ts st0 out0 where
            st0 = tail $ dropWhile (/= ParenOpen) st
            out0 = out ++ takeWhile (/= ParenOpen) st
        Just o1 -> transform' ts st1 out1 where
            cond o2 = isOp o2 && (opPriority o1 <= opPriority o2)
            spl = span cond st
            st1 = o1 : snd spl
            out1 = out ++ fst spl

eval :: [Token] -> Token
eval ts = head $ eval' [] ts where
    eval' :: [Token] -> [Token] -> [Token]
    eval' st (t:ts) = let 
        numFromToken (Number n) = n
        fstNum = numFromToken . head
        sndNum = numFromToken . head . tail
        rem = tail . tail
        in case t of
            Number n -> eval' (t : st) ts
            AddOp -> eval' ((Number (sndNum st + fstNum st)) : (rem st)) ts
            MulOp -> eval' ((Number (sndNum st * fstNum st)) : (rem st)) ts
            DivOp -> eval' ((Number (sndNum st / fstNum st)) : (rem st)) ts
            SubOp -> eval' ((Number (sndNum st - fstNum st)) : (rem st)) ts
    eval' st [] = st

main = do
    s <- getLine
    let Number res = eval $ transform $ tokenize s
    print res