Skip to content

Instantly share code, notes, and snippets.

@evansb
Created June 6, 2014 14:22
Show Gist options
  • Save evansb/571d783bc5653d3b4fb7 to your computer and use it in GitHub Desktop.
Save evansb/571d783bc5653d3b4fb7 to your computer and use it in GitHub Desktop.
Shunting Yard Algorithm in Haskell
module Main where
import Data.Char
import Data.Map
-- Shunting - Yard algorithm for Reverse Polish Notation
data Token = Number Int | 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
isWhiteSpace:: Char -> Bool
isWhiteSpace '\n' = True
isWhiteSpace '\r' = True
isWhiteSpace '\0' = True
isWhiteSpace _ = False
scanNumber:: String -> (Int, String)
scanNumber xs = (num, str) where
(n, str) = span isNumber xs
num = read n :: Int
opmap:: Map Char Token
opmap = fromList [ ('+', AddOp), ('*', MulOp), ('/', DivOp), ('(', ParenOpen),
('-', SubOp), (')', ParenClose)]
tokenize:: String -> [Maybe Token]
tokenize s = loop s [] where
loop str tokens
| Prelude.null str = tokens
| isNumber $ head str = let
(num, str') = scanNumber str
tokens' = tokens ++ [Just (Number num)]
in loop str' tokens'
| isWhiteSpace $ head str = loop (tail str) tokens
| otherwise = loop (tail str) (tokens ++ [Data.Map.lookup (head str) opmap])
prec:: Token -> Int
prec AddOp = 0
prec SubOp = 0
prec MulOp = 1
prec DivOp = 1
prec ParenOpen = 2
prec ParenClose = 2
prec (Number _) = 3
transform:: [Maybe Token] -> [Token]
transform ts = transform' ts [] [] where
-- No more tokens
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 && (prec o1 < prec o2)
spl = span cond s
s1 = o1 : snd spl
q1 = q ++ fst spl
toString:: [Token] -> String
toString = concatMap toStringOne where
toStringOne (Number n) = show n
toStringOne AddOp = "+"
toStringOne MulOp = "*"
toStringOne DivOp = "/"
toStringOne SubOp = "-"
toStringOne ParenOpen = "("
toStringOne ParenClose = ")"
convert:: String -> String
convert = toString . transform . tokenize
@reverofevil
Copy link

reverofevil commented May 10, 2023

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment