(*
 *
 * BU CAS CS 520, F2002
 * Assignment 3
 *
 *)

(* The code is written Hongwei Xi on Oct 10, 2002 *)

signature EVALUATOR =
    sig
	datatype utm = (* for untyped term via deBruijn indices *)
	    UtmBool of bool
	  | UtmInt of int
	  | UtmStr of string
	  | UtmVar of int
	  | UtmIf of utm * utm * utm
	  | UtmOp of string * utm list
	  | UtmLam of utm
	  | UtmApp of utm * utm
	  | UtmLet of utm * utm
	  | UtmLetrec of utm * utm
	  | UtmTup of utm list
	  | UtmPro of utm * int
	  | UtmFix of utm

	val erase: Parser.ttm -> utm
	val evaluate: utm -> utm
    end

structure Evaluator :> EVALUATOR =
    struct
	datatype utm =
	    UtmBool of bool
	  | UtmInt of int
	  | UtmStr of string
	  | UtmVar of int
	  | UtmIf of utm * utm * utm
	  | UtmOp of string * utm list
	  | UtmLam of utm
	  | UtmApp of utm * utm
	  | UtmLet of utm * utm
	  | UtmLetrec of utm * utm
	  | UtmTup of utm list
	  | UtmPro of utm * int
	  | UtmFix of utm

	structure P = Parser

	exception UnboundVariable

	fun unboundVariable (x: string) =
	    (print ("unbound variable: " ^ x ^ "\n");
	     raise UnboundVariable)

	fun erase (t: P.ttm): utm =
	    let
		fun auxVar (x: string, n: int, env: string list): int =
		    case env of
			[] => unboundVariable (x)
		      | x' :: env' =>
			    if x = x' then n else auxVar (x, n+1, env')

		fun aux (t: P.ttm, env: string list): utm =
		    case t of
			P.TtmBool b => UtmBool b
		      | P.TtmInt i => UtmInt i
		      | P.TtmStr s => UtmStr s
		      | P.TtmVar x => UtmVar (auxVar (x, 0, env))
		      | P.TtmIf (t1, t2, t3) =>
			    UtmIf (aux (t1, env), aux (t2, env), aux (t3, env))
		      | P.TtmOp (opname, ts) =>
			    UtmOp (opname, auxlist (ts, env))
		      | P.TtmLam (x, _, t) => UtmLam (aux (t, x :: env))
		      | P.TtmApp (t1, t2) =>
			    UtmApp (aux (t1, env), aux (t2, env))
		      | P.TtmLet (x, t1, t2) =>
			    UtmLet (aux (t1, env), aux (t2, x :: env))
		      | P.TtmLetrec (x, _, t1, t2) =>
			    UtmLetrec (aux (t1, x :: env), aux (t2, x :: env))
		      | P.TtmTup (ts) => UtmTup (auxlist (ts, env))
		      | P.TtmPro (t, n) => UtmPro (aux (t, env), n)
		      | P.TtmFix (t) => UtmFix (aux (t, env))
		      | P.TtmAsc (t, _) => aux (t, env)

		and auxlist (ts: P.ttm list, env: string list): utm list =
		    List.map (fn t => aux (t, env)) ts
	    in
		aux (t, [])
	    end

	fun subst (t1: utm, n: int, t2: utm): utm =
	    case t2 of
		UtmBool b => UtmBool b
	      | UtmInt i => UtmInt i
	      | UtmStr s => UtmStr s
	      | UtmVar n' =>
		    if n < n' then UtmVar (n'-1)
		    else if n > n' then t2 else t1
	      | UtmIf (t21, t22, t23) =>
		    UtmIf (subst (t1, n, t21),
			   subst (t1, n, t22),
			   subst (t1, n, t23))
	      | UtmOp (opname, t2s) =>
		    UtmOp (opname, substList (t1, n, t2s))
	      | UtmLam (t2) => UtmLam (subst (t1, n+1, t2))
	      | UtmApp (t21, t22) =>
		    UtmApp (subst (t1, n, t21), subst (t1, n, t22))
	      | UtmLet (t21, t22) =>
		    UtmLet (subst (t1, n, t21), subst (t1, n+1, t22))
	      | UtmLetrec (t21, t22) =>
		    UtmLetrec (subst (t1, n+1, t21), subst (t1, n+1, t22))
	      | UtmTup (t2s) => UtmTup (substList (t1, n, t2s))
	      | UtmPro (t2, i) => UtmPro (subst (t1, n, t2), i)
	      | UtmFix (t2) => UtmFix (subst (t1, n, t2))	

	and substList (t1: utm, n: int, t2s: utm list): utm list =
	    List.map (fn t2 => subst (t1, n, t2)) t2s

	exception Stuck

	fun isStuck (msg: string) = (print msg; raise Stuck)

	fun isValue (UtmBool _) = true
	  | isValue (UtmInt _) = true
	  | isValue (UtmStr _) = true
	  | isValue (UtmVar _) = true
	  | isValue (UtmLam _) = true
	  | isValue (UtmTup ts) = isValueList ts
	  | isValue _ = false

	and isValueList [] = true
	  | isValueList (t :: ts) = isValue t andalso isValueList ts

	fun evaluate (t as UtmBool _) = t
	  | evaluate (t as UtmInt _) = t
	  | evaluate (t as UtmStr _) = t
	  | evaluate (t as UtmVar _) = isStuck ("unbound variable")
	  | evaluate (UtmIf (t1, t2, t3)) =
	    let
		val v1 = evaluate t1
	    in
		case v1 of
		    UtmBool b => if b then evaluate t2 else evaluate t3
		  | _ => isStuck ("If: not a boolean")
	    end
	  | evaluate (UtmOp (opname, ts)) =
	    evaluateOp (opname, evaluateList ts)
	  | evaluate (t as UtmLam _) = t
	  | evaluate (UtmApp (t1, t2)) =
	    let
		val v1 = evaluate t1
		val v2 = evaluate t2
	    in
		case v1 of
		    UtmLam (t11) => evaluate (subst (v2, 0, t11))
		  | _ => isStuck ("App: not a lambda")
	    end
	  | evaluate (UtmLet (t1, t2)) =
	    let
		val v1 = evaluate t1
	    in
		evaluate (subst (v1, 0, t2))
	    end
	  | evaluate (UtmLetrec (t1, t2)) =
	    evaluate (subst (UtmFix (UtmLam (t1)), 0, t2))
	  | evaluate (UtmTup (ts)) = UtmTup (evaluateList ts)
	  | evaluate (UtmPro (t, i)) =
	    let
		val v = evaluate t
	    in
		case v of
		    UtmTup (vs) => List.nth (vs, i-1)
		  | _ => isStuck ("Pro: not a tuple")
	    end
	  | evaluate (UtmFix (t1)) =
	    let
		val v1 = evaluate t1
	    in
		case v1 of
		    UtmLam (t11) => evaluate (subst (UtmFix (v1), 0, t11))
		  | _ => isStuck ("Fix: not a function")
	    end

	and evaluateList (ts) = List.map evaluate ts

	and evaluateOp ("+", [UtmInt i, UtmInt j]) = UtmInt (i+j)
	  | evaluateOp ("-", [UtmInt i, UtmInt j]) = UtmInt (i-j)
	  | evaluateOp ("*", [UtmInt i, UtmInt j]) = UtmInt (i*j)
	  | evaluateOp ("/", [UtmInt i, UtmInt j]) = UtmInt (i div j)
	  | evaluateOp (">", [UtmInt i, UtmInt j]) = UtmBool (i>j)
	  | evaluateOp (">=", [UtmInt i, UtmInt j]) = UtmBool (i>=j)
	  | evaluateOp ("<", [UtmInt i, UtmInt j]) = UtmBool (i<j)
	  | evaluateOp ("<=", [UtmInt i, UtmInt j]) = UtmBool (i<=j)
	  | evaluateOp ("=", [UtmInt i, UtmInt j]) = UtmBool (i=j)
	  | evaluateOp ("<>", [UtmInt i, UtmInt j]) = UtmBool (i<>j)
	  | evaluateOp ("print", [UtmStr s]) = (print s; UtmTup [])
	  | evaluateOp (opname, _) = isStuck ("Op: " ^ opname)
    end