(* Data definitions *)

type cae = 
    Num of int
  | Str of string
  | Add of cae * cae
  | Sub of cae * cae
  | IfZ of cae * cae * cae
  | Arg
  | This
  | New of string * cae list
  | Get of cae * string
  | DSend of cae * string * cae
  | SSend of cae * string * string * cae

and cdecl = Class of string * field list * meth list

and field = Field of string

and meth = Method of string * cae

and caeValue =
    NumV of int
  | StrV of string
  | ObjV of cdecl * caeValue list

exception Failed of string

(* Number operations *)

let mkNumOp = fun op
  -> function
      (NumV(a), NumV(b)) -> NumV(op a b)
    | _ -> raise (Failed "not numbers")
	  
let numPlus = mkNumOp (fun a b -> a + b)
let numMinus = mkNumOp (fun a b -> a - b)

(* Lookup *)

exception NoSuch of string * string

let rec find = fun what nameOf name vals ->
  match vals with
    [] -> raise (NoSuch (what, name))
  | a::rest -> 
      if (name = nameOf(a))
      then a
      else find what nameOf name rest
	  
let findClass = (find "class"
		   (fun (Class(name, _, _)) -> name))

let findMethod = (find "method"
		    (fun (Method(name, _)) -> name))

let getField = fun name fields vals ->
  snd (find "field" (fun (Field(name), _) -> name)
	 name (List.map2 (fun x y -> (x,y)) fields vals))

(* Interpreter *)

let rec interp : (cae * cdecl list * caeValue * caeValue 
		  -> caeValue ) 
    = function (expr, cdecls, this, arg) -> 
      let recur = fun e -> interp(e, cdecls, this, arg)
      in match expr with
      Num(n) -> NumV(n)
    | Str(n) -> StrV(n)
    | Add(l, r) -> numPlus(recur l, recur r)
    | Sub(l, r) -> numMinus(recur l, recur r)
    | IfZ(tst, thn, els) ->
	if (recur tst = NumV(0))
	then recur thn
	else recur els
    | This -> this
    | Arg -> arg
    | New(name, exprs) -> 
	let decl = findClass name cdecls
	in let vals = (List.map recur exprs)
	in ObjV(decl, vals)
    | Get(expr, fname) ->
	(match recur expr with
	  ObjV(Class(_, fields, _), vals) -> 
	    getField fname fields vals
	| _ -> raise (Failed "not an object for get"))
    | DSend(expr, mname, argExpr) ->
	(match recur expr with
	  (ObjV(Class(_, _, methods), _) as this) -> 
	    let Method(name, body) = findMethod mname methods
	    in interp(body, cdecls, this, recur argExpr)
	| _ -> raise (Failed "not an object for send"))
    | SSend(expr, cname, mname, argExpr) ->
	let this = recur expr
	in let Class(_, _, methods) = findClass cname cdecls
	in let Method(name, body) = findMethod mname methods
	in interp(body, cdecls, this, recur argExpr)

(* Examples *)

let posnClass = Class("posn",
		      [Field("x"); Field("y")],
		      [Method("mdist", Add(Get(This, "x"), Get(This, "y")));
		       Method("addDist", Add(DSend(This, "mdist", Num(0)),
					     DSend(Arg, "mdist", Num(0))));
		       Method("addX", Add(Get(This, "x"), Arg));
		       Method("subY", Sub(Arg, Get(This, "y")));
		       Method("factory01", New("posn", [Num(0); Num(1)]))])
    
let posn3DClass = Class("posn3D",
			[Field("x"); Field("y"); Field("z")],
			[Method("mdist", Add(Get(This, "z"), 
					     SSend(This, "posn", "mdist", Arg)));
			 Method("addDist", SSend(This, "posn", "addDist", Arg))])
    
let mkPosn27 = New("posn", [Num(2); Num(7)])
let mkPosn531 = New("posn3D", [Num(5); Num(3); Num(1)])

let mdist = fun o -> DSend(o, "mdist", Num(0))
let addDist = fun o p -> DSend(o, "addDist", p)
let addX = fun o y -> DSend(o, "addX", y)
let subY = fun o y -> DSend(o, "subY", y)

let interpPosn = fun x -> interp(x, [posnClass;posn3DClass], NumV(0), NumV(0))

;;

(* Testing *)

exception TestFailed of caeValue * caeValue

let test = function 
    (a, b) ->
      if (a = b)
      then true
      else raise (TestFailed (a, b))
	
;;
  
(* Test cases *)

test(interpPosn(mdist mkPosn27),
     NumV(9));;
test(interpPosn(addX mkPosn27 (Num 10)),
     NumV(12));;
test(interpPosn(subY (SSend(mkPosn27, "posn", "factory01", Num(0))) (Num 15)),
     NumV(14));;
test(interpPosn(addDist mkPosn531  mkPosn27),
     NumV(18));;