AFSM-0.1.3.0: examples/RPN.hs

-----------------------------------------------------------------------------
-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,
-- License     :  MIT License
--
-- Maintainer  :  hanzh.xu@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
-- A simple calculator
-----------------------------------------------------------------------------

-- {-# LANGUAGE Arrows #-}

module Main where

import Control.AFSM
import Data.Maybe
-- import Data.Map (fromList, (!))


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

instance Show Op where
  show Add = "+"
  show Sub = "-"
  show Mul = "*"
  show Div = "/"


data Token = Num Int | Op Op | L | R | End
  deriving (Eq)

instance Show Token where
  show (Num x) = show x
  show (Op op) = show op
  show L = "("
  show R = ")"
  show End = ""

-- 3 * (2 - 3) + (4 - 2 * 3)
test1 = [Num 3, Op Mul, L, Num 2, Op Sub, Num 3, R, Op Add, L, Num 4, Op Sub, Num 2, Op Mul, Num 3, R, End]

-- 3 + 4 * 2 / (1 - 5) * 2 + 3
test2 = [Num 3, Op Add, Num 4, Op Mul, Num 2, Op Div, L, Num 1, Op Sub, Num 5, R, Op Mul, Num 2, Op Add, Num 3, End]


-- State machines

trans0 :: [Token] -> Token -> ([Token], [Token])
trans0 xs End = ([End], xs)
trans0 xs (Num x) = (xs, [(Num x)])
trans0 xs L = (L:xs, [])
trans0 xs R = let (x0, x1) = span (L /= ) xs in (tail $ x1, x0)
trans0 xs op =
  (op:x1, x0)
  where
    f0 = (\x -> x == (Op Mul) || x == (Op Div))
    (x0, x1) = span f0 xs


-- the SM converting infix to postfix
--
--   Token /---------\ [Token]
--  >----->| in2post |>------->
--         \---------/
--
in2post :: SM [Token] Token [Token]
in2post = simpleSM trans0 [End]

post1 = concat $ getRet in2post test1
post2 = concat $ getRet in2post test2

f :: Op -> Int -> Int -> Int
f Add x y = x + y
f Sub x y = x - y
f Mul x y = x * y
f Div x y = quot x y

trans1 :: [Int] -> Token -> ([Int], Maybe Int)
trans1 xs End = if (null xs) then (xs, Just 0) else ([], Just $ head xs)
trans1 xs (Num x) = (x:xs, Nothing)
trans1 (x:y:xs) (Op o) = ((f o y x):xs, Nothing)

-- the SM evaluating postfix expression
--
--   Token /-----------\ Maybe Int
--  >----->| post2ret' |>--------->
--         \-----------/
--
post2ret' :: SM [Int] Token (Maybe Int)
post2ret' = simpleSM trans1 []


--
--   [Token] /----------\ [Maybe Int]
--  >------->| post2ret |>----------->
--           \----------/
--
post2ret :: SM [Int] [Token] [Maybe Int]
post2ret = execSM post2ret'


-- an example to use Arrow notation
--   the SM composed of in2post and post2ret
--
--         /----------------------------\
--   Token |          [Token]           | [Maybe Int]
--  >----->| in2post >-------> post2ret |>----------->
--         |                            |
--         \----------------------------/
--                     in2ret
--
in2ret :: SM ([Token], [Int]) Token [Maybe Int]
in2ret = in2post >>>> post2ret
{-
hg = hideStorage

in2ret :: SMH Token [Maybe Int]
in2ret = hg $ proc x -> do
   y <- (hg in2post) -< x
   (hg post2ret) -< y
-}
-- Parsing and evaluating

getRet :: SM s a b -> [a] -> [b]
getRet sm xs = snd $ exec sm xs

calc :: [Token] -> [Int]
calc xs = catMaybes $ concat $ getRet in2ret xs

isNum :: Char -> Bool
isNum x = elem x "0123456789"

-- parseOp x = (fromList $ zip "()+-*/" [L, R, Op Add, Op Sub, Op Mul, Op Div])!x
parseOp :: Char -> Token
parseOp '(' = L
parseOp ')' = R
parseOp '+' = Op Add
parseOp '-' = Op Sub
parseOp '*' = Op Mul
parseOp '/' = Op Div

parseStr :: String -> [Token]
parseStr [] = [End]
parseStr (x:xs) =
  if elem x ",\n" then End : (parseStr xs)
  else if x == ' ' then parseStr xs
  else if isNum x then
    let (ys, zs) = span isNum xs in (Num $ read (x:ys)):(parseStr zs)
  else if elem x "()+-*/" then
    (parseOp x):(parseStr xs)
  else
    parseStr xs

main = do
  getContents >>= (mapM_ putStrLn).(map show).(calc.parseStr)

-- input samples
-- 3 * (2 - 3) + (4 - 2 * 3), 3 + 4 * 2 / (1 - 5) * 2 + 3