//
//
// An evaluator for untyped lambda-calculus
//
//

datatype term =
  | TMvar of string
  | TMlam of (string(*name*), term(*body*))
  | TMapp of (term(*fun*), term(*arg*))
  | TMbool of bool
  | TMint of int
  | TMopr of (string(*name*), termlst)
  | TMif of (term(*cond*), term(*then*), term(*else*))
  | TMfix of (string(*fun*), string (*arg*), term(*body*))

where termlst = list0 term

(* ****** ****** *)

extern fun print_term (t: term): void
overload print with print_term

implement print_term (t0) = begin case+ t0 of
  | TMvar x => begin
      print "TMvar("; print x; print ")"
    end
  | TMlam (x, t) => begin
      print "TMlam("; print x; print ", "; print t; print ")"
    end
  | TMapp (t1, t2) => begin
      print "TMapp("; print t1; print ", "; print t2; print ")"
    end
  | _ => begin
      print "print_term: not implemented yet!"; print_newline (); exit (1)
    end
end // end of [print_term]

(* ****** ****** *)

datatype value =
  | VALbool of bool
  | VALint of int
  | VALclo of (string(*name*), term(*body*), env_t(*environment*))
  | VALfix of (string(*fun*), string(*arg*), term(*body*), env_t(*environment*))

where env_t = list0 '(string(*name*), value)

(* ****** ****** *)

extern fun print_value (v: value): void
overload print with print_value

implement print_value (v) = begin case+ v of
  | VALbool b => begin
      if b then print "VALbool(true)" else print "VALbool(false)"
    end // end of [VALbool]
  | VALint i => (print "VALint("; print i; print ")")
  | VALclo _ => print "VALclo(...)"
  | VALfix _ => print "VALfix(...)"
end // end of [print_value]

//

#define :: list0_cons; #define cons list0_cons; #define nil list0_nil

//

extern fun eval0 (prog: term): value(*answer*)
extern fun eval (env: env_t, t: term): value(*answer*)
extern fun eval_var (env: env_t, x: string): value
extern fun eval_opr (opr: string, vs: list0 value): value

implement eval0 (prog) = eval (nil (), prog)

implement eval_var (env, x0) = begin case+ env of
  | xv :: env_rest =>
      if (xv.0 = x0) then xv.1 else eval_var (env_rest, x0)
  | nil () => let
      val () = prerrf ("Fatal Error: unbound variable: %s", @(x0))
    in
      exit {value} (1) // exit: {a:viewt@ype} () -> a
    end // end of [nil]
end // end of [eval_var]

implement eval_opr (opr, vs) = begin case+ opr of 
  | ">" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 > i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of [">"]
  | ">=" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 >= i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of [">="]
  | "<" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 < i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["<"]
  | "<=" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 <= i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["<="]
  | "=" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 = i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["="]
  | "<>" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALbool (i1 <> i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["<>"]
  | "+" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALint (i1 + i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["+"]
  | "-" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALint (i1 - i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["-"]
  | "*" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALint (i1 * i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["*"]
  | "/" => begin case+ vs of
    | VALint i1 :: VALint i2 :: nil => VALint (i1 / i2)
    | _ => begin
        prerrf ("eval_opr: [%s]: Type Error\n", @(opr)); exit (1)
      end
    end // end of ["/"]
  | _ => begin
      prerrf ("eval_opr: [%s]: not supported yet!\n", @(opr)); exit (1)
    end // end of [_]
end // end of [eval_opr]
  
implement eval (env, t0) = begin case+ t0 of
  | TMbool i => VALbool i
  | TMint i => VALint i
  | TMvar x => eval_var (env, x)
  | TMlam (x, t) => VALclo (x, t, env)
  | TMapp (t_fun, t_arg) => let
      val v_fun = eval (env, t_fun)
      val v_arg = eval (env, t_arg)
    in
      case+ v_fun of
      | VALclo (x, t_body, env1) => let
          val env_new = '(x, v_arg) :: env1
        in
          eval (env_new, t_body)
        end
      | VALfix (f, x, t_body, env1) => let
          val env_new = '(x, v_arg) :: '(f, v_fun) :: env1
        in
          eval (env_new, t_body)
        end
      | _ => begin
          prerr ("Type Error"); prerr_newline (); exit (1)
        end
    end // end of [TMapp]
  | TMif (t_cond, t_then, t_else) => let
      val v_cond = eval (env, t_cond)
    in
      case+ v_cond of
      | VALbool b => begin
          if b then eval (env, t_then) else eval (env, t_else)
        end
      | _ => begin
          prerr ("Type Error"); prerr_newline (); exit (1)
        end
    end // end of [TMif]
  | TMopr (opr, ts) => let
      val vs = eval_list (env, ts) where {
        fun eval_list (env: env_t, ts: list0 term): list0 value =
          case+ ts of
          | t :: ts => cons (eval (env, t), eval_list (env, ts))
          | nil () => nil ()
      } // end of [where]
    in
      eval_opr (opr, vs)
    end // end of [TMopr]
  | TMfix (f, x, t) => VALfix (f, x, t, env)
(*
  | _ => begin
      prerr "eval: not implemented yet"; prerr_newline (); exit {value} (1)
    end  
*)
end // end of [eval]

//

val t_0 = TMint 0 and t_1 = TMint 1 and t_2 = TMint 2
val tt = TMbool (true) and ff = TMbool (false)

var f_var = TMvar "f"
val m_var = TMvar "m"
val n_var = TMvar "n"
val x_var = TMvar "x"
val y_var = TMvar "y"
val z_var = TMvar "z"
val s_var = TMvar ("s")

val t_K = TMlam ("x", TMlam ("y", x_var))
val t_S = TMlam ("x", TMlam ("y", TMlam ("z", TMapp (TMapp (x_var, z_var), TMapp (y_var, z_var)))))

val t_SKK = TMapp (TMapp (t_S, t_K), t_K) // SKK => I = \lam x. x

fn numeral_make (n: int): term = let
  fun loop (n: int, t: term): term =
    if n > 0 then loop (n-1, TMapp (s_var, t)) else t
in
  TMlam ("s", TMlam ("z", loop (n, z_var)))
end // end of [numeral_make]

val t_succ = TMlam ("x", TMopr ("+", cons (x_var, cons (t_1, nil()))))

(* ****** ****** *)

val t_add = TMlam ("m", TMlam ("n", TMlam ("s", TMlam ("z", TMapp (TMapp (m_var, s_var), TMapp (TMapp (n_var, s_var), z_var))))))

val t_mul = TMlam ("m", TMlam ("n", TMlam ("s", TMlam ("z", TMapp (TMapp (m_var, TMapp (n_var, s_var)), z_var)))))

// val t_pow = ???

(* ****** ****** *)

val t_fact = TMfix ("f", "x", TMif (TMopr ("=", x_var :: TMint 0 :: nil), TMint 1, TMopr ("*", x_var :: TMapp (f_var, TMopr ("-", x_var :: TMint 1 :: nil)) :: nil)))

(* ****** ****** *)

implement main () = let
  val n10 = numeral_make (10)
  val t10 = TMapp (TMapp (n10, t_succ), t_0)
  val v10 = eval0 (t10)
  val () = (print "v10 = "; print v10; print_newline ())
  val n20 = TMapp (TMapp (t_add, n10), n10)
  val t20 = TMapp (TMapp (n20, t_succ), t_0)
  val v20 = eval0 (t20)
  val () = (print "v20 = "; print v20; print_newline ())
  val n100 = TMapp (TMapp (t_mul, n10), n10)
  val t100 = TMapp (TMapp (n100, t_succ), t_0)
  val v100 = eval0 (t100)
  val () = (print "v100 = "; print v100; print_newline ())
  val t_fact10 = TMapp (t_fact, TMint 10)
  val v_fact10 = eval0 (t_fact10)
  val () = (print "v_fact10 = "; print v_fact10; print_newline ())
in
  // empty
end // end of [main]

(* ****** ****** *)

(* end of [utlc_eval-2008-09-18.dats] *)