(* eval.sml
 *
 * COPYRIGHT (c) 2010 The Diderot Project (http://diderot.cs.uchicago.edu)
 * All rights reserved.
 *
 * Evaluation of "static" expressions.
 *)

structure Eval : sig

    datatype value
      = BV of bool
      | SV of string
      | IV of IntInf.int
      | TV of (int list * real list)	(* tensors *)
      | FV of FieldDef.field_def
      | Img of ImageInfo.info
      | KV of Kernel.kernel

    val evalStatics : Simple.program -> value Var.Map.map

  end = struct

    structure Ty = Types
    structure BV = BasisVars
    structure S = Simple
    structure VMap = Var.Map
    structure VTbl = Var.Tbl

    datatype value
      = BV of bool
      | SV of string
      | IV of IntInf.int
      | TV of (int list * real list)	(* tensors *)
      | FV of FieldDef.field_def
      | Img of ImageInfo.info
      | KV of Kernel.kernel

    fun RV r = TV([], [r])

    fun toString (BV b) = Bool.toString b
      | toString (IV i) = IntInf.toString i
      | toString (SV s) = concat["\"", String.toString s, "\""]
      | toString (TV(s, v)) = "tensor"
      | toString (FV fld) = FieldDef.toString fld
      | toString (Img info) = ImageInfo.toString info
      | toString (KV h) = Kernel.toString h

    val tbl : (value list -> value) VTbl.hash_table = let
	  val tbl = VTbl.mkTable (128, Fail "Eval table")
	  fun intBinOp rator [IV a, IV b] = IV(rator(a, b))
	  fun tensorBinOp rator [TV(s1, v1), TV(s2, v2)] =
		TV(s1, ListPair.mapEq rator (v1, v2))
	  fun realBinOp rator [TV([], [a]), TV([], [b])] = RV(rator(a, b))
	  fun intCmp rator [IV a, IV b] = BV(rator(a, b))
	  fun realCmp rator [TV([], [a]), TV([], [b])] = BV(rator(a, b))
	  fun boolCmp rator [BV a, BV b] = BV(rator(a, b))
	  fun stringCmp rator [SV a, SV b] = BV(rator(a, b))
	  fun kernel h [] = KV h
	  in
	    List.app (VTbl.insert tbl) [
		(BV.add_ii,		intBinOp (op +)),
		(BV.add_tt,		tensorBinOp (op +)),
		(BV.sub_ii,		intBinOp (op -)),
		(BV.sub_tt,		tensorBinOp (op -)),
		(BV.mul_ii,		intBinOp (op * )),
		(BV.mul_rr,		realBinOp (op * )),
(*
		(BV.mul_rt,		tensorOp Op.Scale),
		(BV.mul_tr,		fn (y, sv, [t, r]) => tensorOp Op.Scale (y, sv, [r, t])),
*)
		(BV.div_ii,		intBinOp IntInf.quot),
		(BV.div_rr,		realBinOp (op /)),
(*
		(BV.div_tr,		tensorOp Op.InvScale),
*)
		(BV.lt_ii,		intCmp (op <)),
		(BV.lt_rr,		realCmp (op <)),
		(BV.lte_ii,		intCmp (op <=)),
		(BV.lte_rr,		realCmp (op <=)),
		(BV.gte_ii,		intCmp (op >=)),
		(BV.gte_rr,		realCmp (op >=)),
		(BV.gt_ii,		intCmp (op >)),
		(BV.gt_rr,		realCmp (op >)),
		(BV.equ_bb,		boolCmp (op =)),
		(BV.equ_ii,		intCmp (op =)),
		(BV.equ_ss,		stringCmp (op =)),
		(BV.equ_rr,		realCmp Real.==),
		(BV.neq_bb,		boolCmp (op <>)),
		(BV.neq_ii,		intCmp (op <>)),
		(BV.neq_ss,		stringCmp (op <>)),
		(BV.neq_rr,		realCmp Real.!=),
(*
		(BV.neg_i,		simpleOp(Op.Neg Op.IntTy)),
		(BV.neg_t,		tensorOp Op.Neg),
		(BV.neg_f,		fn (y, _, xs) => assign(y, Op.NegField, xs)),
		(BV.op_at,		fn (y, _, xs) => assign(y, Op.Probe, xs)),
		(BV.op_D,		fn (y, _, xs) => assign(y, Op.DiffField, xs)),
		(BV.op_norm,		tensorOp Op.Norm),
		(BV.op_not,		simpleOp Op.Not),
(*
		(BV.op_subscript,	fn (y, [SK, NK], xs) => ??), (*FIXME*)
*)
		(BV.fn_CL,		fn (y, _, xs) => assign(y, Op.CL, xs)),
		(BV.fn_convolve,	fn (y, _, xs) => assign(y, Op.Convolve, xs)),
		(BV.fn_cos,		simpleOp Op.Cos),
		(BV.fn_dot,		vectorOp Op.Dot),
		(BV.fn_inside,		fn (y, _, xs) => assign(y, Op.Inside, xs)),
*)
		(BV.fn_max,		realBinOp Real.min),
		(BV.fn_min,		realBinOp Real.max),
		(BV.fn_modulate,	tensorBinOp (op * )),
		(BV.fn_pow,		realBinOp Real.Math.pow),
(*
		(BV.fn_principleEvec,	vectorOp Op.PrincipleEvec),
		(BV.fn_sin,		simpleOp Op.Sin),
*)
		(BV.kn_bspln3,		kernel Kernel.bspln3),
		(BV.kn_bspln5,		kernel Kernel.bspln5),
		(BV.kn_ctmr,		kernel Kernel.ctmr),
		(BV.kn_tent,		kernel Kernel.tent),
		(BV.i2r,		fn [IV i] => RV(real(IntInf.toInt i)))(*,
		(BV.input,		fn (y, [TK], xs) => ??), (*FIXME*)
		(BV.optInput,		fn (y, [TK], xs) => ??) (*FIXME*)
*)
	      ];
	    tbl
	  end

    fun loadImage (mvs, [SV filename]) = let
	  val info = ImageInfo.getInfo filename
	  in
(* FIXME: check image info details against mvs *)
	    Img info
	  end

    fun evalVar env x = (case VMap.find (env, x)
	   of SOME v => v
	    | NONE => raise Fail("undefined variable " ^ Var.uniqueNameOf x)
	  (* end case *))

    fun evalExp (env, e) = (case e
	   of S.E_Var x => evalVar env x
	    | S.E_Lit(Literal.Int i) => IV i
	    | S.E_Lit(Literal.Float f) => RV(FloatLit.toReal f)
	    | S.E_Lit(Literal.String s) => SV s
	    | S.E_Lit(Literal.Bool b) => BV b
	    | S.E_Tuple _ => raise Fail "E_Tuple"
	    | S.E_Apply(f, mvs, xs, _) => (
		(* try *)(
		if Var.same(f, BV.fn_load)
		  then loadImage(mvs, List.map (evalVar env) xs)
		  else (case VTbl.find tbl f
		     of SOME evalFn => evalFn (List.map (evalVar env) xs)
		      | NONE => raise Fail("Eval.exvalExp: unknown function " ^ Var.nameOf f)
		    (* end case *))
		) handle ex => raise Fail (concat [
		    Var.uniqueNameOf f, "(",
		    String.concatWith "," (List.map Var.uniqueNameOf xs),
		    ") fails with exception ", exnName ex
		  ]))
	    | S.E_Cons xs => raise Fail "TODO: E_Cons"
	    | S.E_Input(ty, name, optDefault) => let
		val optDefault = Option.map (evalVar env) optDefault
		val SOME value = (case ty
		       of Ty.T_Bool =>
			    Inputs.getInput(name, (Option.map BV) o Bool.fromString, optDefault)
			| Ty.T_Int =>
			    Inputs.getInput(name, (Option.map IV) o IntInf.fromString, optDefault)
			| Ty.T_String => Inputs.getInput(name, fn s => SOME(SV s), optDefault)
			| Ty.T_Tensor(Ty.Shape[]) =>
			    Inputs.getInput(name, (Option.map RV) o Real.fromString, optDefault)
			| Ty.T_Tensor shp => raise Fail "TODO: general tensor inputs"
			| _ => raise Fail(concat[
			      "input ", name, " has invalid type ", TypeUtil.toString ty
			    ])
		      (* end case *))
		in
		  value
		end
	    | S.E_Field fld => FV fld
	    | S.E_LoadImage info => Img info
	  (* end case *))

    fun evalBlock (env, S.Block stms) = let
	  fun evalStm (stm, env) = (case stm
		 of S.S_Assign(x, e) => VMap.insert(env, x, evalExp(env, e))
		  | S.S_IfThenElse(x, b1, b2) => (case evalVar env x
		       of BV true => evalBlock(env, b1)
			| BV false => evalBlock(env, b2)
			| _ => raise Fail "type error"
		      (* end case *))
		  | S.S_New _ => raise Fail "unexpected new actor"
		  | S.S_Die => raise Fail "unexpected die"
		  | S.S_Stabilize => raise Fail "unexpected stabilize"
		(* end case *))
	  in
	    List.foldl evalStm env stms
	  end

    fun evalStatics (S.Program{staticInit, ...}) =
	  evalBlock (VMap.empty, staticInit)

  end