Initial data commit

Task/Parsing-Shunting-yard-algorithm/Haskell/parsing-shunting-yard-algorithm-1.hs

@@ -0,0 +1,59 @@
+import Text.Printf
+
+prec :: String -> Int
+prec "^" = 4
+prec "*" = 3
+prec "/" = 3
+prec "+" = 2
+prec "-" = 2
+
+leftAssoc :: String -> Bool
+leftAssoc "^" = False
+leftAssoc _ = True
+
+isOp :: String -> Bool
+isOp [t] = t `elem` "-+/*^"
+isOp _ = False
+
+simSYA :: [String] -> [([String], [String], String)]
+simSYA xs = final <> [lastStep]
+  where
+    final = scanl f ([], [], "") xs
+    lastStep =
+      ( \(x, y, _) ->
+          (reverse y <> x, [], "")
+      )
+        $ last final
+    f (out, st, _) t
+      | isOp t =
+        ( reverse (takeWhile testOp st) <> out,
+          (t :) (dropWhile testOp st),
+          t
+        )
+      | t == "(" = (out, "(" : st, t)
+      | t == ")" =
+        ( reverse (takeWhile (/= "(") st) <> out,
+          tail $ dropWhile (/= "(") st,
+          t
+        )
+      | otherwise = (t : out, st, t)
+      where
+        testOp x =
+          isOp x
+            && ( leftAssoc t && prec t == prec x
+                   || prec t < prec x
+               )
+
+main :: IO ()
+main = do
+  a <- getLine
+  printf "%30s%20s%7s" "Output" "Stack" "Token"
+  mapM_
+    ( \(x, y, z) ->
+        printf
+          "%30s%20s%7s\n"
+          (unwords $ reverse x)
+          (unwords y)
+          z
+    )
+    $ simSYA $ words a

Task/Parsing-Shunting-yard-algorithm/Haskell/parsing-shunting-yard-algorithm-2.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE LambdaCase #-}
+import Control.Applicative
+import Control.Lens
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.State
+import System.Console.Readline
+
+data InToken = InOp Op | InVal Int | LParen | RParen deriving (Show)
+data OutToken = OutOp Op | OutVal Int
+data StackElem = StOp Op | Paren deriving (Show)
+data Op = Pow | Mul | Div | Add | Sub deriving (Show)
+data Assoc = L | R deriving (Eq)
+
+type Env = ([OutToken], [StackElem])
+type RPNComp = StateT Env (Either String)
+
+instance Show OutToken where
+    show (OutOp x) = snd $ opInfo x
+    show (OutVal v) = show v
+
+opInfo = \case
+    Pow -> (4, "^")
+    Mul -> (3, "*")
+    Div -> (3, "/")
+    Add -> (2, "+")
+    Sub -> (2, "-")
+
+prec = fst . opInfo
+leftAssoc Pow = False
+leftAssoc _   = True
+
+--Stateful actions
+processToken :: InToken -> RPNComp ()
+processToken = \case
+    (InVal z) -> pushVal z
+    (InOp op) -> pushOp op
+    LParen    -> pushParen
+    RParen    -> pushTillParen
+
+pushTillParen :: RPNComp ()
+pushTillParen = use _2 >>= \case
+    []     -> throwError "Unmatched right parenthesis"
+    (s:st) -> case s of
+         StOp o -> _1 %= (OutOp o:) >> _2 %= tail >> pushTillParen
+         Paren  -> _2 %= tail
+
+pushOp :: Op -> RPNComp ()
+pushOp o = use _2 >>= \case
+    [] -> _2 .= [StOp o]
+    (s:st) -> case s of
+        (StOp o2) -> if leftAssoc o && prec o == prec o2
+                     || prec o < prec o2
+                     then _1 %= (OutOp o2:) >> _2 %= tail >> pushOp o
+                     else _2 %= (StOp o:)
+        Paren     -> _2 %= (StOp o:)
+
+pushVal :: Int -> RPNComp ()
+pushVal n = _1 %= (OutVal n:)
+
+pushParen :: RPNComp ()
+pushParen = _2 %= (Paren:)
+
+--Run StateT
+toRPN :: [InToken] -> Either String [OutToken]
+toRPN xs = evalStateT process ([],[])
+    where process = mapM_ processToken xs
+                      >> get >>= \(a,b) -> (reverse a++) <$> (mapM toOut b)
+          toOut :: StackElem -> RPNComp OutToken
+          toOut (StOp o) = return $ OutOp o
+          toOut Paren    = throwError "Unmatched left parenthesis"
+
+--Parsing
+readTokens :: String -> Either String [InToken]
+readTokens = mapM f . words
+    where f = let g = return . InOp in \case {
+            "^" -> g Pow; "*" -> g Mul; "/" -> g Div;
+            "+" -> g Add; "-" -> g Sub; "(" -> return LParen;
+            ")" -> return RParen;
+            a   -> case reads a of
+                [] -> throwError $ "Invalid token `" ++ a ++ "`"
+                [(_,x:[])] -> throwError $ "Invalid token `" ++ a ++ "`"
+                [(v,[])]    -> return $ InVal v }
+
+--Showing
+showOutput (Left msg) = msg
+showOutput (Right xs) = unwords $ map show xs
+
+main = do
+    a <- readline "Enter expression: "
+    case a of
+        Nothing -> putStrLn "Please enter a line" >> main
+        Just "exit" -> return ()
+        Just l      -> addHistory l >> case readTokens l of
+            Left msg -> putStrLn msg >> main
+            Right ts -> putStrLn (showOutput (toRPN ts)) >> main