|| Miranda Project - Symbolic Differentiation 
||           (Solution as suggested by hints)

|| type definitions

|| define string as a synomym for list of character
string == [char]

arith ::= Add | Sub | Mult

token ::= VarToken [char] | ConstToken num | ArithToken arith 
                          | RightParen | LeftParen

expr ::= Binop arith expr expr | Const num | Var [char]

to_digit :: char -> num
to_digit ch = (code ch) - (code '0'), digit ch

tokens :: string -> [token]
tokens [] = []
tokens (' ':rest) = tokens rest
tokens ('*':rest) = ArithToken Mult : tokens rest
tokens ('-':rest) = ArithToken Sub: tokens rest
tokens ('+':rest) = ArithToken Add: tokens rest
tokens ('(':rest) = LeftParen : tokens rest
tokens (')':rest) = RightParen : tokens rest
tokens (ch:rest)  = tokens_var [ch] rest, letter ch
                  = tokens_const (to_digit ch) rest, digit ch


tokens_var var [] 
        = [(VarToken var)]
tokens_var var (ch:rest) 
        = tokens_var (var ++ [ch]) rest, if letter ch
        = (VarToken var) : (tokens (ch:rest)), otherwise

tokens_const c [] 
        = [(ConstToken c)]
tokens_const c (ch:rest) 
        = tokens_const ((c * 10) + (to_digit ch)) rest, if digit ch
        = (ConstToken c) : (tokens (ch:rest)), otherwise 


parse :: [token] -> (expr,[token])

parse (VarToken str : ts) = (Var str , ts)

parse (ConstToken str : ts) = (Const str , ts)

parse (LeftParen : ArithToken arith : ts) 
        = (Binop arith arg1 arg2 , rest)
          where (arg1,t1) = parse ts
                (arg2, RightParen : rest) = parse t1

parse ts = error ("syntax error -- tokens = " ++ show ts)

binop_to_string Add  = "+"
binop_to_string Mult = "*"
binop_to_string Sub  = "-"

const_to_string c = shownum c
var_to_string var = var

expr_to_string :: expr -> string
expr_to_string (Binop a e1 e2) = "(" ++ (binop_to_string a) ++
                                 " " ++ (expr_to_string e1) ++
                                 " " ++ (expr_to_string e2) ++ ")"
expr_to_string (Const c)       = (const_to_string c)
expr_to_string (Var var)       = (var_to_string var)

simplify :: expr -> expr
simplify (Binop a e1 e2) 
        = simplify_help (Binop a (simplify e1) (simplify e2))
          where 
          simplify_help (Binop a (Const c1) (Const c2))
                = Const (do_binop a c1 c2)
                  where 
                  do_binop Add c1 c2 = c1+c2
                  do_binop Sub c1 c2 = c1-c2
                  do_binop Mult c1 c2 = c1*c2
          simplify_help (Binop Add (Const 0) e)
                = e
          simplify_help (Binop Add e (Const 0))
                = e
          simplify_help (Binop Mult (Const 1) e)
                = e
          simplify_help (Binop Mult e (Const 1))
                = e
          simplify_help (Binop Mult (Const 0) e)
                = Const 0
          simplify_help (Binop Mult e (Const 0))
                = Const 0
          simplify_help default
                = default
simplify default 
        = default

expr_deriv (Binop a e1 e2) v 
        = (Binop a (expr_deriv e1 v) (expr_deriv e2 v)), 
	                              a = Add \/ a = Sub
        = (Binop Add 
                (Binop Mult e1 (expr_deriv e2 v)) 
                (Binop Mult (expr_deriv e1 v) e2)
          ), otherwise
expr_deriv (Var var) v
        = Const 0, var ~= v
        = Const 1, otherwise
expr_deriv (Const c) v
        = Const 0
 
deriv :: string -> string -> string
deriv str v = deriv_checker result remnant
              where 
	      (expr,remnant) = parse (tokens str)
              result = expr_to_string 
                           (simplify (expr_deriv expr v))

|| make sure there isn't anything left over in parse
deriv_checker :: string -> [token] -> string
deriv_checker result remnant
        = result, if remnant = []
        = error ("bad parse -- remaining tokens: " 
                ++ show remnant), otherwise


showderiv str v = "derivative of: " ++ str ++ " wrt: "
                    ++ v ++ " = " ++ deriv str v

t1 = showderiv "(+ x 3)" "x"
t2 = showderiv "x" "x"
t3 = showderiv "3" "x"
t4 = showderiv "(* x y)"  "x"
t5 = showderiv "(+ (* x 3) (* x 2))"  "x"
t6 = showderiv "(* (* x y) (+ x 3))"  "x"  

t7 = showderiv "(- x 3)" "x"
t8 = showderiv "(- x y)" "y"

||
|| the end
||

