type ('a,'b) map = ('a * 'b) list

let empty = []

(*=====================================================*)
(*     LOOKUP                                          *)
(*=====================================================*)

(* symbol -> (symbol * 'a) list -> 'a *)

let rec lookup k' x =
  match x with 
    ((k,v)::l) -> if k=k' then Some v else lookup k' l
  | _          -> None


(*=====================================================*)
(*     ZIP                                             *)
(*=====================================================*)

(* ('a list * 'b list) -> ('a * 'b) list *)

let rec zip (a,b) =
  match (a,b) with
    (x::xs, y::ys) -> (x,y) :: zip (xs,ys)
  | _              -> []


(*=====================================================*)
(*     Types for Variable,                             *)
(*               Class Names                           *)
(*               Method Names                          *)
(*               Field Names                           *)
(*               Expressions                           *)
(*=====================================================*)



type var       = string  (* including "this" *)
type className = string
type methName  = string
type fieldName = string

type exp = 
    Var of var 
  | Inv of exp * methName * exp list 
  | Sel of exp * fieldName
  | New of className * exp list

(*======================================================*)
(* Method Definitions: Variable List X Expression       *)
(* Class Declarations: 
(* Class Name X List of Field Names X List of Method Definitions*)
(* Class Talbes: List of Class Names X Class Declarations*)
(* Program: Class Table X Expression                    *)
(*======================================================*)

type methDef    = var list * exp
type classDecl  = className * fieldName list * (methName, methDef) map
type classTable = (className, classDecl) map
type program    = classTable * exp

(*=======================================================*)
(* Values are Objects                                    *)
(*=======================================================*)

type value = Obj of className * value list


(*=======================================================*)
(* Root of the Class Heirarchy                           *)
(* class myObject { }                                    *)
(*=======================================================*)

let myObject = ("",[],empty)

(*=======================================================*)
(* Class Thunk to Memoize Values                         *)
(* class thunk ext myObject                              *)
(*   { myObject val; myObject get () { this.val } }      *)
(*=======================================================*)


let thunk = ("myObject",
	     ["val"],
	     [("get", ([], Sel (Var "this", "val")))])

(*=======================================================*)
(* Boolean Class, True, False Classes                    *)
(* class bool ext myObject                               *)
(*   { myObject if (thunk x, thunk y) { this.if(x,y) } } *)
(* class true ext bool                                   *)
(*        { myObject if (thunk x, thunk y) { x.get() } } *)
(* class myFalse ext bool                                *)
(*        { myObject if (thunk x, thunk y) { y.get() } } *)
(*=======================================================*)


let bool = ("myObject",
	    [],
	    [("if", (["x";"y"], Inv (Var "this", "if", [Var "x";Var "y"])))])

let myTrue = ("bool",
	      [],
	      [("if", (["x";"y"], Inv (Var "x", "get", [])))])

let myFalse = ("bool",
	       [],
	       [("if", (["x";"y"], Inv (Var "y", "get", [])))])


(*=======================================================*)
(*    Exception Types                                    *)
(*=======================================================*)

exception EvalError of string

(*=======================================================*)
(*    Method Lookup                                      *)
(*                                                       *)
(* class table -> method name -> class name -> methodDef *)
(*=======================================================*)

let rec lookupMeth table methodname classname =
  match lookup classname table with
  |  None -> raise(EvalError("Error: class not found: "^classname))
  | Some (super,_,meths) -> 
        match lookup methodname meths with
        |  Some x -> x
	| None   -> lookupMeth table methodname super


(*=======================================================*)
(*    Field Lookup                                      *)
(*                                                       *)
(* class table -> field name ->                          *)
(*       (class name * field value list) -> value *)
(*=======================================================*)

let rec lookupField table fieldname (classname,fieldvaluelist) =
  match lookup classname table with 
      None -> raise(EvalError("Error: class not found: "^classname))
    | Some (super,fields,_) ->
 	let rec search (a,b) = 
          match (a,b) with
              (name::namelist, value::valuelist) ->
		if fieldname=name then value else search (namelist,valuelist)
            | ([],valuelist) ->
		lookupField table fieldname (super,valuelist)
	    | (_,[]) ->
		raise(EvalError("Error: Some fields not defined."))
	in search (fields,fieldvaluelist)


(*=======================================================*)
(*    Interpreter                                        *)
(*                                                       *)
(* interp: class table -> env -> exp -> result           *)
(*=======================================================*)

let rec interp table = 
  let interpT env =
    let rec interpTE =
      fun a -> match a with 
          Var x -> let v' = lookup x env in
	    (match v' with
		 Some v -> v
	       | None   ->
		   raise(EvalError("Error: variable not found: "^x)))
	| Inv (objexp,methodname,arglist) -> 
	    let v = (interpTE objexp) in
	    let classname = match v with
		(Obj (c,_)) -> c in
	    let z = lookupMeth table methodname classname
	    and argvallist = (List.map interpTE arglist) in
            let (varlist,evalmeth) = z in
	      interp table (("this",v)::(zip (varlist,argvallist))) evalmeth
	| Sel (objexp,fieldname)    -> 
	    let Obj (classname,fieldvaluelist) = (interpTE objexp)
	    in (lookupField table fieldname (classname,fieldvaluelist))
	| New (classname,fieldvalueslist)   ->
 	    Obj (classname, (List.map interpTE fieldvalueslist))
    in interpTE
  in interpT