{-
  * Copyright (c): Uwe Schmidt, FH Wedel
  *
  * You may study, modify and distribute this source code
  * FOR NON-COMMERCIAL PURPOSES ONLY.
  * This copyright message has to remain unchanged.
  *
  * Note that this document is provided 'as is',
  * WITHOUT WARRANTY of any kind either expressed or implied.
-}

module Expr1 where
import ShowTree

data Expr a = Const a
            | Bin Op2 (Expr a) (Expr a)
            | Un  Op1 (Expr a)
            deriving (Show)

data Op2 = Add | Sub | Mul | Div
         deriving (Show)

data Op1 = Plus | Minus | Abs
         deriving (Show)

-- --------------------
--
-- functor instance for Expr

mapExpr :: (a -> b) -> Expr a -> Expr b
mapExpr f (Const n)      = Const (f n)
mapExpr f (Bin op e1 e2) = Bin op (mapExpr f e1) (mapExpr f e2)
mapExpr f (Un  op e1)    = Un  op (mapExpr f e1)

instance Functor Expr where
  fmap = mapExpr

-- --------------------
--
-- the general evaluator

eval :: (Op2 -> (a -> a -> a)) ->
        (Op1 -> (a -> a)) ->
        Expr a -> a
eval apply2 apply1 e = eval' e
  where
    eval' (Const n)      = n
    eval' (Bin op e1 e2) = apply2 op (eval' e1) (eval' e2)
    eval' (Un  op e1)    = apply1 op (eval' e1)

-- --------------------
--
-- integer arithmetic

apply2i :: Integral a => Op2 -> (a -> a -> a)
apply2i Add = (+)
apply2i Sub = (-)
apply2i Mul = (*)
apply2i Div = div

-- --------------------
--
-- fractional arithmetic

apply2r :: Fractional a => Op2 -> (a -> a -> a)
apply2r Add = (+)
apply2r Sub = (-)
apply2r Mul = (*)
apply2r Div = (/)

-- --------------------
--
-- common arithmetic

apply1 :: Num a => Op1 -> (a -> a)
apply1 Plus  = id
apply1 Minus = \ x -> 0 - x
apply1 Abs   = abs

-- --------------------
--
-- two different evaluators

evali :: Expr Integer -> Integer
evali = eval apply2i apply1

evalr :: Expr Double -> Double
evalr = eval apply2r apply1

-- ----------------------------------------
--
-- example expr

e1 :: Num a => Expr a
e1 = Bin Mul (Un Abs (Bin Sub (Const 1)
                              (Const 8)
                     )
             )
             (Bin Div (Const 13)
                      (Const 2)
             )

v1 :: Integer
v1 = evali e1

v2 :: Double
v2 = evalr e1

-- ----------------------------------------

e1' :: Expr String
e1' = fmap show e1

apply2s :: Op2 -> (String -> String -> String)
apply2s Add = binToString "+"
apply2s Sub = binToString "-"
apply2s Mul = binToString "*"
apply2s Div = binToString "/"

binToString op s1 s2 =
  "(" ++ s1 ++ " " ++ op ++ " " ++ s2 ++ ")"

apply1s :: Op1 -> (String -> String)
apply1s Plus  = unToString "+"
apply1s Minus = unToString "-"
apply1s Abs   = unToString "abs"

unToString op s1 =
      "(" ++ op ++ " " ++ s1 ++ ")"

evals :: Expr String -> String
evals = eval apply2s apply1s

exprToString :: Show a => Expr a -> String
exprToString = evals . fmap show

-- ----------------------------------------
--
-- test output

showExpr :: Show a => Expr a -> String
showExpr = formatStringNTree . toNTree
  where
    toNTree (Const n)       = NTree (show n) []
    toNTree (Bin op2 e1 e2) = NTree (show op2) [toNTree e1, toNTree e2]
    toNTree (Un  op1 e1)    = NTree (show op1) [toNTree e1]

printExpr :: Show a => Expr a -> IO ()
printExpr = putStrLn . showExpr

-- ----------------------------------------