ShuntingYard

ShuntingYard.hs

{-# LANGUAGE LambdaCase #-}

import           Data.Char                      ( isDigit
                                                , isSpace
                                                )

data Op = Add | Sub | Mul | Div deriving (Eq, Show)

data Item a
  = Value a
  | BinOp Op
  | LeftBr
  | RightBr
  deriving Eq

instance Show a => Show (Item a) where
  show = \case
    (Value a ) -> show a
    (BinOp op) -> show op
    LeftBr     -> "("
    RightBr    -> ")"

parseBinOp :: String -> Item a
parseBinOp = BinOp . \case
  "-" -> Sub
  "+" -> Add
  "*" -> Mul
  "/" -> Div

prec :: Op -> Int
prec = \case
  Add -> 1
  Sub -> 1
  Mul -> 2
  Div -> 2

tokenize :: String -> [Item Float]
tokenize [] = []
tokenize str@(x : xs) | isSpace x       = tokenize xs
                      | x `elem` "*+/-" = parseBinOp [x] : tokenize xs
                      | x == '('        = LeftBr : tokenize xs
                      | x == ')'        = RightBr : tokenize xs
                      | otherwise = Value (read floatLit) : tokenize remaining
 where
  (floatLit, remaining) = span f' str
  f' c = isDigit c || c == '.'

shuntingYard :: (Eq a, Show a) => [Item a] -> [Item a]
shuntingYard []    = []
shuntingYard items = reverse $ reverse remainingStack ++ queue
 where
  (remainingStack, queue) = foldl foldFn ([], []) items
  foldFn (stack, queue) item = case item of
    Value n -> (stack, item : queue)
    BinOp op ->
      let (ops, newstack) = span (popPredicate op) stack
      in  (item : newstack, reverse ops ++ queue)
    LeftBr -> (item : stack, queue)
    RightBr ->
      let (ops, _ : newStack) = span (/= LeftBr) stack
      in  (newStack, reverse ops ++ queue)
  popPredicate op = \case
    BinOp op' -> prec op' >= prec op
    LeftBr    -> False
    _         -> True

runRPN :: (Fractional a, Num a) => [Item a] -> a
runRPN arr = val . head $ foldl f' [] arr
 where
  f' stack item = case item of
    BinOp op -> Value (binOp op x y) : restStack
    _        -> item : stack
    where (Value x : Value y : restStack) = stack
  val (Value n) = n
  binOp = flip . \case
    Add -> (+)
    Sub -> (-)
    Mul -> (*)
    Div -> (/)