(** Représentation des termes **)

type ('a,'b) term = 
    Var of 'b 
  | Operation of 'a*('a,'b) term list;;
Operation ( "f" , [
              Operation("g", [Var "x"] );
              Operation("a", [])
            ]);;

(** Itérateur sur les termes **)

let rec term_iter funvar funop funcoller premier = function 
    (Var x) -> funvar x 
  | (Operation (oper,fils)) -> 
      let 
        recur term = term_iter funvar funop funcoller premier term
      in 
      let
        coller = fun t x -> funcoller (recur t) x
      in    
        funop oper (List.fold_right coller fils premier);;
let ajouter ens el = 
  if List.mem el ens then 
    ens 
  else el::ens;;
let union ens1 ens2 = List.fold_left ajouter ens1 ens2;;
let vars = term_iter 
	     (fun x -> [x]) 
	     (fun x y -> y) union [];;
let t = Operation("plus",
		  [Var "x"; 
		   Operation("fois", [Var "y";Var "z"])]);;
vars t;;
let t'= 
  Operation("plus",
	    [Var "x"; Operation("fois", 
				[Var "y";Var "x"])]);;
vars t';;
let t''= 
  Operation("plus",[
	      Var "x"; 
	      Operation("fois", [Var "y";Operation( "c", [])])
	    ]);;
vars t'';;
let occurs v t = List.mem v (vars t);;
occurs "x" t;;
occurs "w" t;;

(** Substitutions **)

let subst = 
  [ ("x",Operation ("plus", [Operation("2",[]);Operation("3",[])]));
    ("y",Operation("4",[])) ];;

let apply_subst s = 
  term_iter 
    (fun x -> try (List.assoc x s) with _ -> (Var x)) 
    (fun r l -> Operation(r,l)) 
    (fun x l -> x::l) [];;
apply_subst subst t;;
let rec filter p  = function
    []->[]
  | (a::l) -> if (p a) then (a::filter p l) else (filter p l);;
let compsubst s1 s2 =
  (List.map (fun (x,u) -> (x,apply_subst s1 u)) s2)@
  let var_s2=(List.map fst s2) in
    (List.filter (fun (x,t)-> not (List.mem x var_s2)) s1);;
let compsubst s1 s2 =
  (List.map (fun (x,u) -> (x,apply_subst s1 u)) s2)@s1;;

(** Filtrage **)

exception Match_exc;;
let add_subst s (x,t) = 
  try 
    let t' = (List.assoc x s)  in
      if t = t' then s
      else raise Match_exc
  with
      Not_found -> (x,t)::s;;
let matching  = 
  let rec 
    match_rec s = function
	(Var(x), t) -> add_subst s (x,t)
      |  (Operation(op_f,sons_f),Operation(op_t,sons_t)) ->
           if op_f = op_t then 
             (List.fold_left match_rec s 
                (List.combine sons_f sons_t))
           else raise Match_exc
      | _ -> raise Match_exc
  in
    match_rec [];;
let f = Operation("plus", 
                  [Var("x"); 
                   Operation("fois", 
			     [Var("y");Var("z")])]);;
let t = Operation("plus",
                  [  Operation("plus", [Var("a");Var("b")]); 
                     Operation("fois", [
                                 Operation("fois", [Var("x");Var("y")]);
                                 Operation("plus", [Var("a");Var("b")])])]);;
matching (f,t);;
let f' = Operation("plus", [
                     Var("x"); 
                     Operation("fois", [Var("y");Var("x")])]);;
matching (f',t);;
matching (f',t');;
let t''= Operation("plus", [
                     Var("x"); 
                     Operation("fois", [Var("y");Var("z")]);
                     Var("u")]);;
matching (f,t'');;
let matching'  =
  let rec 
    match_rec s = function  
        (Var(x), t) -> add_subst s (x,t)
      | ( Operation(op_f,sons_f),Operation(op_t,sons_t)) ->
          if op_f = op_t then 
            try 
              (List.fold_left match_rec s
                 (List.combine sons_f sons_t))
            with _ -> raise Match_exc
          else raise Match_exc
      | _ -> raise Match_exc
  in
    match_rec [];;
matching' (f,t'');;
exception Match_exc of string;;
let add_subst s (x,t) = 
  try 
    let t' = (List.assoc x s)  in
      if t = t' then s
      else  raise (Match_exc ("impossibility with "^x))
  with
      Not_found -> (x,t)::s;;
let matching  = 
  let rec 
    match_rec s = function 
        (Var(x), t) -> add_subst s (x,t)
      | (Operation(op_f,sons_f),Operation(op_t,sons_t)) ->
          if op_f = op_t then 
            try 
              (List.fold_left match_rec s 
                 (List.combine sons_f sons_t))
            with 
                (Invalid_argument "List.combine") -> 
                  raise (Match_exc("the operator "^op_f^
				   " has different numbers of arguments"))
          else raise (Match_exc "operator incompatibility")
      | _ -> raise (Match_exc "operator incompatibility")
  in
    match_rec [];;

matching (f,t);;
matching (f,t');;
matching (f',t);;
matching (f',t');;
matching (f',t'');;