arithmetic

arithmetic/Main.hs

@@ -0,0 +1,86 @@
+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' [] [] q = q
+    transform' [] s q =
+        if head s == ParenOpen 
+            then error "Mismatched parentheses" 
+            else transform' [] (tail s) (q ++ [head s])
+    transform' (x:xs) s q = case x of
+        Nothing -> error "Illegal tokens"
+        (Just (Number n)) -> transform' xs s (q ++ [Number n])
+        (Just ParenOpen) -> transform' xs (ParenOpen:s) q
+        (Just ParenClose) -> transform' xs s0 q0 where
+            s0 = tail $ dropWhile (/= ParenOpen) s
+            q0 = q ++ takeWhile (/= ParenOpen) s
+        (Just o1) -> transform' xs s1 q1 where
+            cond o2 = isOp o2 && (opPriority o1 < opPriority o2)
+            spl = span cond s
+            s1 = o1 : snd spl
+            q1 = q ++ 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 (fstNum st + sndNum st)) : (rem st)) ts
+            MulOp -> eval' ((Number (fstNum st * sndNum 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