Brian: Created page with " {- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List. This implementation is not error-tolerant; an exception w..."

2012-07-31T19:01:36Z

Created page with "<syntaxhighlight lang="haskell"> {- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List. This implementation is not error-tolerant; an exception w..."

New page

<syntaxhighlight lang="haskell">
{- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List.
This implementation is not error-tolerant; an exception will occur on any incorrect input.
Note: Unary + and - have precedence higher than * and / but lower than ^. -}
data (Num a) => Token a =
Plus | Minus |
Add | Subtract | Multiply | Divide | Exp |
LeftParen | RightParen |
Operand a

isLeftParen LeftParen = True; isLeftParen _ = False

instance (Num a) => Show (Token a) where {
show Plus = "+"; show Minus = "-";
show Add = "+"; show Subtract = "-"; show Multiply = "*"; show Divide = "/"; show Exp = "^";
show LeftParen = "("; show RightParen = ")";
show (Operand x) = show x
}

prec Add = 1; prec Subtract = 1;
prec Multiply = 2; prec Divide = 2;
prec Plus = 3; prec Minus = 3;
prec Exp = 4;
prec _ = 0

tokenize s = reverse $ f s [] where
f [] l = l
f ('(':s') l = f s' (LeftParen:l)
f (')':s') l = f s' (RightParen:l)
f ('/':s') l = f s' (Divide:l)
f ('^':s') l = f s' (Exp:l)
f ('+':s') l = f s' (op:l) where
op = if null l || precedesUnary (head l) then Plus else Add
f ('-':s') l = f s' (op:l) where
op = if null l || precedesUnary (head l) then Minus else Subtract
f ('*':s') l = if "*" `isPrefixOf` s' then f (tail s') (Exp:l) else f s' (Multiply:l)
f s@(c:s') l
| isSpace c = f (dropWhile isSpace s) l
| otherwise =
let (number, rest) = break (\x -> not (isDigit x || x == '.')) s
in f rest ((Operand (read number)):l)
precedesUnary LeftParen = True
precedesUnary RightParen = False
precedesUnary (Operand _) = False
precedesUnary _ = True

data (Num a) => AST a =
Leaf (Token a) |
Unary (Token a) (AST a) |
Binary (Token a) (AST a) (AST a)

instance (Num a) => Show (AST a) where
show (Leaf t) = show t
show (Unary t a) = "(" ++ show t ++ " " ++ show a ++ ")"
show (Binary t a1 a2) = "(" ++ show t ++ " " ++ show a1 ++ " " ++ show a2 ++ ")"

shuntingYard l = f ([LeftParen] ++ l ++ [RightParen]) [] [] where
f [] st os = head os
f (Operand x : ts) st os = f ts st (Leaf (Operand x) : os)
f (LeftParen:ts) st os = f ts (LeftParen:st) os
f (RightParen:ts) st os = f ts (tail after) (helper before os) where
(before, after) = break isLeftParen st
f (Exp:ts) st os = f ts (Exp:st) os
f (Plus:ts) st os = f ts (Plus:st) os
f (Minus:ts) st os = f ts (Minus:st) os
f (op:ts) st os = f ts (op:after) (helper before os) where
(before, after) = break ((>) (prec op) . prec) st
helper [] os = os
helper (Plus:st') (o:os) = helper st' (Unary Plus o : os)
helper (Minus: st') (o:os) = helper st' (Unary Minus o : os)
helper (o':st') (o2:o1:os) = helper st' (Binary o' o1 o2 : os)
</syntaxhighlight>

Shunting yard algorithm/foo.hs - Revision history

Brian: Created page with " {- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List. This implementation is not error-tolerant; an exception w..."