Sync

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

@@ -0,0 +1,31 @@
+import Text.Printf
+
+prec "^" = 4
+prec "*" = 3
+prec "/" = 3
+prec "+" = 2
+prec "-" = 2
+
+leftAssoc "^" = False
+leftAssoc _ = True
+
+isOp t = t `elem` (map (:[]) "-+/*^")
+
+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)
+                       | True     = (t:out, st, t)
+          where testOp x = isOp x && (leftAssoc t && prec t == prec x
+                                      || prec t < prec x)
+
+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,97 @@
+{-# LANGUAGE LambdaCase #-}
+import Control.Applicative
+import Control.Lens
+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. `process` is effectively foldM_ with the base case to
+--format the output string
+toRPN :: [InToken] -> Either String [OutToken]
+toRPN xs = evalStateT (process (return ()) xs) ([],[])
+    where process st [] = st >> get >>= \(a,b) -> (reverse a++) <$>
+                                                    (mapM toOut b)
+          process st (x:xs) = process (st >> processToken x) xs
+          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

Task/Parsing-Shunting-yard-algorithm/Racket/parsing-shunting-yard-algorithm.rkt

@@ -0,0 +1,44 @@
+#lang racket
+;print column of width w
+(define (display-col w s)
+  (let* ([n-spaces (- w (string-length s))]
+         [spaces (make-string n-spaces #\space)])
+    (display (string-append s spaces))))
+;print columns given widths (idea borrowed from PicoLisp)
+(define (tab ws . ss) (for-each display-col ws ss) (newline))
+
+(define input "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3")
+
+(define (paren? s) (or (string=? s "(") (string=? s ")")))
+(define-values (prec lasso? rasso? op?)
+  (let ([table '(["^" 4 r]
+                 ["*" 3 l]
+                 ["/" 3 l]
+                 ["+" 2 l]
+                 ["-" 2 l])])
+    (define (asso x) (caddr (assoc x table)))
+    (values (λ (x) (cadr (assoc x table)))
+            (λ (x) (symbol=? (asso x) 'l))
+            (λ (x) (symbol=? (asso x) 'r))
+            (λ (x) (member x (map car table))))))
+
+(define (shunt s)
+  (define widths (list 8 (string-length input) (string-length input) 20))
+  (tab widths "TOKEN" "OUT" "STACK" "ACTION")
+  (let shunt ([out '()] [ops '()] [in (string-split s)] [action ""])
+    (match in
+      ['() (if (memf paren? ops)
+               (error "unmatched parens")
+               (reverse (append (reverse ops) out)))]
+      [(cons x in)
+       (tab widths x (string-join (reverse out) " ") (string-append* ops) action)
+       (match x
+         [(? string->number n) (shunt (cons n out) ops in (format "out ~a" n))]
+         ["(" (shunt out (cons "(" ops) in "push (")]
+         [")" (let-values ([(l r) (splitf-at ops (λ (y) (not (string=? y "("))))])
+                (match r
+                  ['() (error "unmatched parens")]
+                  [(cons _ r) (shunt (append (reverse l) out) r in "clear til )")]))]
+         [else (let-values ([(l r) (splitf-at ops (λ (y) (and (op? y)
+                                                              ((if (lasso? x) <= <) (prec x) (prec y)))))])
+                 (shunt (append (reverse l) out) (cons x r) in (format "out ~a, push ~a" l x)))])])))