Need help fixing issues in my Haskell code for the Shunting Yard algorithm

#1

I’m learning the Haskell and I am trying to implement the very basic Shunting Yard algorithm to read the very basic mathematical expression. For example as like A+B-C*D.

Here is my current algorithm:

push :: Char -> [Char] -> [Char]
push x [] = [x]
push x xs = reverse (x:(reverse xs))

pop :: [Char] -> [Char]
pop [] = []
pop (x:xs) = xs

peek :: [Char] -> Char
peek (x:_) = x

isEmpty :: [Char] -> Bool
isEmpty [] = True
isEmpty _  = False

isParenthesis :: Char -> Bool
isParenthesis chr = elem chr "()"
isOperand :: Char -> Bool
isOperand chr = elem chr ['A'..'Z'] || elem chr ['a'..'z']
isOperator :: Char -> Bool
isOperator chr = elem chr "+-*/^"

infixToPostfix :: [Char] -> [Char]
infixToPostfix expr = helper expr [] []
  where
    helper :: [Char] -> [Char] -> [Char] -> [Char]
    helper [] operand operator = operand ++ operator
    helper (x:xs) operand operator
      | isParenthesis x = helper xs operand operator
      | isOperand x = helper xs (push x operand) operator
      | isOperator x && isEmpty operator = helper xs operand (x:operator)
      | isOperator x && not (isEmpty operator) =
          if set (peek operator) >= set x
          then helper xs (push (peek operator) operand) (x:pop operator)
          else helper xs operand (x:operator)
      | otherwise = helper xs operand operator
    set :: Char -> Int
    set chr = case chr of
      '+' -> 1
      '-' -> 1
      '*' -> 2
      '/' -> 2
      '^' -> 3
      _   -> 0

main :: IO ()
main = do
 let expr = "A+B-C*D+E/F^G"
 print $ infixToPostfix expr

When I try to convert the expression A+B-C*D+E/F^G to postfix notation, the program give the output as like AB+CD*EFG^/+-. But the actual correct output is AB+CD*-EFG^/+. What is wrong with my algorithm?

#2

Take a look at your isOperator x && not (isEmpty operator) case. What happens if there are two operators on the operator stack, both of which are higher precedence than the current operator?

#3

I modified my code as follow and it well produce the correct output.

push :: Char -> [Char] -> [Char]
push x [] = [x]
push x xs = reverse (x:(reverse xs))

pop :: [Char] -> [Char]
pop [] = []
pop (x:xs) = xs

peek :: [Char] -> Char
peek (x:_) = x

isEmpty :: [Char] -> Bool
isEmpty [] = True
isEmpty _  = False

delimit :: [Char] -> Bool
delimit [] = True
delimit copy = matching copy []
 where
 matching :: [Char] -> [Char] -> Bool
 matching [] ret = isEmpty ret
 matching (x:xs) ret
  | elem x "(" = matching xs (push x ret)
  | elem x ")" = matching xs (pop ret)
  | otherwise = matching xs ret

isParenthesis :: Char -> Bool
isParenthesis chr = elem chr "()"
isOperand :: Char -> Bool
isOperand chr = elem chr ['A'..'Z'] || elem chr ['a'..'z']
isOperator :: Char -> Bool
isOperator chr = elem chr "+-*/^"

infixToPostfix :: [Char] -> [Char]
infixToPostfix expr = helper expr [] []
  where
    helper :: [Char] -> [Char] -> [Char] -> [Char]
    helper [] operand operator = operand ++ operator
    helper copy@(x:xs) operand operator
      | delimit copy == False = error "Delimiter not matched."
      | isParenthesis x = helper xs operand operator
      | isOperand x = helper xs (push x operand) operator
      | isOperator x && isEmpty operator = helper xs operand (x:operator)
      | isOperator x && not (isEmpty operator) =
          if precedence x == precedence (peek operator)
          then helper xs (push (peek operator) operand) (x:pop operator)
          else if precedence x < precedence (peek operator)
          then extractAll xs operand operator x
          else if precedence x > precedence (peek operator)
          then helper xs operand (x:operator)
          else helper xs operand operator
      | otherwise = helper xs operand operator
    precedence :: Char -> Int
    precedence chr = case chr of
      '+' -> 1
      '-' -> 1
      '*' -> 2
      '/' -> 2
      '^' -> 3
      _   -> 0
    extractAll :: [Char] -> [Char] -> [Char] -> Char -> [Char]
    extractAll xs operand operator x = extractAll' xs operand operator x (length operator)
      where
        extractAll' :: [Char] -> [Char] -> [Char] -> Char -> Int -> [Char]
        extractAll' xs operand [] x 0 = helper xs operand [x]
        extractAll' xs operand (y:ys) x len = extractAll' xs (push y operand) ys x (len-1)

main :: IO ()
main = do
 let expr0 = "A+B-C*D+E/F*E+G/A"
     expr1 = "A^B^C*D+E-F/E^G^A+C-D"
     expr2 = "A*B+C-D+A^B^C-D/A"
 print $ infixToPostfix expr0
 print $ infixToPostfix expr1
 print $ infixToPostfix expr2