(**************************************************************************)
(*                                                                        *)
(*                              Interpreters                              *)
(*                                                                        *)
(*                            Jean-Yves Moyen                             *)
(*                              April 2001                                *)
(*                                                                        *)
(**************************************************************************)


open Langage

module Environnement = Map.Make(OrderedVar)

let rec subst env=
  function
      Var x -> Environnement.find x env 
    | Con(c,tl) -> Con(c,List.map (subst env) tl)
    | Fun(f,tl) -> Fun(f,List.map (subst env) tl)

module HashedTerm =
struct
  type t = term
  let equal = (=)
  let hash = Hashtbl.hash
end

module Cache = Hashtbl.Make(HashedTerm)

let size_env env=
  Environnement.fold (fun x y->succ) env 0

let size_cache cache=
  let size=ref 0 in
    Cache.iter (fun x y->incr size) cache;
    !size

let chk_spc cpt env=
  cpt:= max !cpt (size_env env)

exception Not_unifiable

let rec unify semantics stk env t1 t2=
  match t1,t2 with
(*      Var x,Var y when x=y -> env*)
    | _,Var y -> let t'=semantics env stk t2 in unify semantics stk env t1 t'
    | Var x,_ -> Environnement.add x t2 env
    | Con(_,_),Fun(_,_) -> raise Not_unifiable
(*	let t'=semantics env t2 
	in unify semantics env t1 t'*)
    | Fun(_,_),Con(_,_) -> raise Not_unifiable
    | Con(c1,tl1),Con(c2,tl2) ->
	if c1.idc = c2.idc
	then List.fold_left2 (unify semantics stk) env tl1 tl2
	else raise Not_unifiable
    | Fun(f1,tl1),Fun(f2,tl2) ->
	if f1.idf = f2.idf
	then List.fold_left2 (unify semantics stk) env tl1 tl2
	else raise Not_unifiable

exception Undefined

let rec find_eq semantics env stk t=
  function
      [] -> raise Undefined
    | eq::prg -> 
	(try
	   eq.rside,
	   (unify semantics stk env 
	      (Fun(eq.lfun,List.map pat_to_term eq.lpat)) t)
	 with 
	     Not_unifiable -> find_eq semantics env stk t prg)

let cbv prg time heap stack total term =   (*Call by Value*)
  let count env=incr time;chk_spc heap env in
  let rec step env stk t=
    chk_spc heap env;
    total := max !total (!heap+stk);
    stack := max !stack stk;
    match t with
	Var x -> (count env;Environnement.find x env)
      | Con(c,[]) as x -> x
      | Con(c,tl) -> (count env;Con(c,List.map (step env stk) tl))
      | Fun(f,tl) ->
	  let vl=List.map (step env (stk+1)) tl in
	  let t,sigma=find_eq step env stk (Fun(f,vl)) prg.rules in
	    count sigma;
	    step sigma stk t
  in step Environnement.empty 0 term 
    


let memoize prg time heap stack total term =   (*Memoization*)
  let cache=Cache.create 17 in
  let count env=
    incr time;
    heap:=max !heap ((size_env env)+(size_cache cache)) in
  let rec step env stk t=
    heap:=max !heap ((size_env env)+(size_cache cache));
    total := max !total (!heap+stk);
    stack := max !stack stk;
    match t with
	Var x -> (count env;Environnement.find x env)
      | Con (c,[]) as x -> x
      | Con(c,tl) -> (count env;Con(c,List.map (step env stk) tl))
      | Fun(f,tl) ->
	  let vl=List.map (step env (stk+1)) tl in
	    (try
	       let v=Cache.find cache (Fun(f,vl))
	       in count env;v
	     with
		 Not_found ->
		   let t,sigma=find_eq step env stk (Fun(f,vl)) prg.rules in
		   let v=step sigma stk t in
		     Cache.add cache (Fun(f,vl)) v;
		     count env;
		     v)
  in step Environnement.empty 0 term




