evaluate math expr

1 files changed, 129 insertions, 0 deletions

diff --git a/2-kyu/evaluate-mathematical-expression.hs b/2-kyu/evaluate-mathematical-expression.hs
new file mode 100644
index 0000000..e583ba0
--- /dev/null
+++ b/2-kyu/evaluate-mathematical-expression.hs
@@ -0,0 +1,129 @@
+-- https://www.codewars.com/kata/52a78825cdfc2cfc87000005
+module EvaluateMathematicalExpression (calc) where
+
+import Data.Char (isDigit, isSpace)
+
+newtype Parser a = Parser { runParser :: String -> Maybe (a, String) }
+
+instance Functor Parser where
+  fmap f p = Parser $ \s -> case runParser p s of
+    Nothing -> Nothing
+    Just (r, xs) -> Just (f r, xs)
+
+instance Applicative Parser where
+  pure x = Parser $ \s -> Just (x, s)
+  mf <*> ma = do
+    f <- mf
+    f <$> ma
+
+instance Monad Parser where
+  p >>= f = Parser $ \s -> case runParser p s of
+    Nothing -> Nothing
+    Just (x, rs) -> (runParser $ f x) rs
+
+instance Semigroup (Parser a) where
+  p1 <> p2 = Parser $
+    \s -> case runParser p1 s of 
+            Just a -> Just a
+            Nothing -> runParser p2 s
+
+instance Monoid (Parser a) where
+  mempty = Parser $ const Nothing
+
+satisfy :: (Char -> Bool) -> Parser Char
+satisfy cond = Parser fn where
+  fn [] = Nothing
+  fn (x:xs) = if cond x then Just (x, xs) else Nothing
+
+item :: Char -> Parser Char
+item c = satisfy (==c)
+
+one :: Parser Char -> Parser String
+one pc = do
+ ret <- pc
+ return [ret]
+
+optional p = p <> pure []
+
+many p = optional $ some p
+
+some p = (:) <$> p <*> many p
+
+digit = satisfy isDigit
+
+skipSpace = do
+  let isSpace x = x == ' ' || x == '\t' || x == '\n'
+  many (satisfy isSpace)
+  return ()
+
+token p = do
+  skipSpace
+  r <- p
+  skipSpace
+  pure r
+
+number :: Parser Double
+number = token impl where
+  impl =
+    let 
+      intPart = (++) <$> optional (one $ item '-') <*> some digit
+      dotPart = (++) <$> one (item '.') <*> some digit
+    in do 
+      numStr <- (++) <$> intPart <*> optional dotPart
+      pure $ read numStr
+
+charToOp '+' = (+)
+charToOp '-' = (-)
+charToOp '*' = (*)
+charToOp '/' = (/)
+
+op1 = token impl where
+  impl = do
+   c <- item '+' <> item '-'
+   pure $ charToOp c
+
+op2 = token impl where
+  impl = do
+   c <- item '/' <> item '*'
+   pure $ charToOp c
+
+leftBracket = token $ one $ item '('
+rightBracket = token $ one $ item ')'
+
+expr = do
+  lhs <- term
+  exprs <- many $ do
+    op <- op1
+    t <- term
+    pure (`op` t)
+  pure $ foldl (flip ($)) lhs exprs
+
+negSign = do
+  x <- many $ item '-'
+  return $ if even $ length x then id else negate
+
+term = do
+  lhs <- signedFactor
+  terms <- many $ do
+    op <- op2
+    f <- signedFactor
+    pure (`op` f)
+  pure $ foldl (flip ($)) lhs terms
+
+signedFactor = token $ do
+  s <- negSign
+  s <$> factor
+
+factor = number <> bracketExpr where
+  bracketExpr = do
+    leftBracket
+    e <- expr
+    rightBracket
+    pure e
+
+calc :: String -> Double
+calc s =
+  case runParser expr s of
+    Just (x, _) -> x
+    Nothing -> 0
+