(*********************************************************************)
(*                                                                   *)
(*             un langage fonctionnel du premier ordre               *)
(*                                                                   *)
(*                          Jean-Yves Moyen                          *)
(*                            Octobre 2000                           *)
(*                                                                   *)
(*********************************************************************)


type vari = int and coni = int and funi = int and eqni = int
(*Identificateur de variable, constante, function, equation*)

type  cona = int and funa = int
(*arité de variable, function*)

type cons = { idc : coni ; arc : cona } 
and  func = { idf : funi ; arf : funa } 

type pattern =   PatVar of vari
	       | PatCon of cons * pattern list

type term =   Var of vari
	    | Con of cons * term list
	    | Fun of func * term list

type equation = { lfun : func ; lpat : pattern list ; rside : term}

type varp=int

type polynome =
    VarP of varp
  | Int of int
  | Sum of polynome * polynome
  | Dif of polynome * polynome
  | Prod of polynome * polynome
  | Power of polynome * int
  | Max of polynome * polynome
  | True | False (*beurk, pas propre*)

module OrderedVar = 
struct 
   type t=vari 
   let compare=compare 
 end 

module OrderedCon = 
struct 
   type t = cons 
   let compare c1 c2 = compare c1.idc c2.idc
 end 

module OrderedFun = 
struct 
   type t = func 
   let compare f1 f2 = compare f1.idf f2.idf
 end 

module VarSet =
  Set.Make(OrderedVar) 

module ConSet =
  Set.Make(OrderedCon) 

module FunSet =
  Set.Make(OrderedFun) 

type funcon = F of funi | C of coni

module OrderedFunCon =
struct
   type t = funcon
   let compare = compare
 end

module Interp =
  Map.Make(OrderedFunCon)

type prog = 
    { rules : equation list ;
      interp : (polynome*varp list) Interp.t ;
      funname : (funi,string) Hashtbl.t ;
      conname : (coni,string) Hashtbl.t }

exception Rside of eqni
exception Doublon of eqni
exception Lside of eqni
exception Bothside of eqni

let get_var_right (eqnumber : eqni)=
  let rec add_to_set s=
    function
	Var x -> VarSet.add x s
      | Con (c,tl) ->
	  if c.arc=(List.length tl)
	  then List.fold_left add_to_set s tl
	  else raise (Rside eqnumber)
      | Fun (f,tl) ->
	  if f.arf=(List.length tl)
	  then List.fold_left add_to_set s tl
	  else raise (Rside eqnumber)
  in
    add_to_set VarSet.empty

let get_var_left (eqnumber : eqni) =
  let rec add_to_set s=
    function
	PatVar x -> 
	  if VarSet.mem x s
	  then raise (Doublon eqnumber)
	  else VarSet.add x s
      | PatCon (c,pl) ->
	  if c.arc=(List.length pl)
	  then List.fold_left add_to_set s pl 
	  else raise (Lside eqnumber)
  in
    List.fold_left add_to_set VarSet.empty

let correct_equation (eqnumber : eqni) eq=
  (eq.lfun.arf=(List.length eq.lpat)) &&
  let lvar=get_var_left eqnumber eq.lpat
  and rvar=get_var_right eqnumber eq.rside in
    (VarSet.subset rvar lvar) ||
    (raise (Bothside eqnumber))
    
let correct_prog prg=
  let eqn = ref 0 in
    try
      List.for_all (fun eq -> incr eqn;correct_equation !eqn eq) prg
    with
	Rside e->
	  (Printf.printf "L'équation %i est incorrecte (terme droit)" e;
	   false)
      | Lside e->
	  (Printf.printf "L'équation %i est incorrecte (terme gauche)" e;
	   false)
      | Doublon e->
	  (Printf.printf "Variables en double dans le motif %i" e;
	   false)
      | Bothside e->
	  (Printf.printf "Variables non définies dans l'équation %i" e;
	   false)

let lowcase c=
  let c'=Char.code c in
    (c' >= (Char.code 'a')) & (c' <= (Char.code 'z'));;

let syntX s= s=(String.lowercase s);;
(*var names must be in lowercase letter*)

let syntF s=lowcase s.[0];;
(*function names must start with an lowercase letter*)

let syntC s= s=(String.uppercase s);;
(*constructors names must be in uppercase letter*)


let rec pat_to_term=
   function
      PatVar x -> Var x
    | PatCon (c,pl) -> Con (c,List.map pat_to_term pl)


(********    Polynomes    ************)

let pol_to_string =
   let rec go =
     function
	 VarP x -> "x"^(string_of_int x)
       | Int i -> string_of_int i
       | Sum (p1,p2) -> "("^(go p1)^")+("^(go p2)^")"
       | Dif (p1,p2) -> "("^(go p1)^")-("^(go p2)^")"
       | Prod (p1,p2) -> "("^(go p1)^")*("^(go p2)^")"
       | Power (p,i) -> "("^(go p)^")^"^(string_of_int i)
       | Max(p1,p2) -> "max("^(go p1)^","^(go p2)^")"
       | True | False -> failwith "Not a polynomial"
   in go
	
let applypol subst =
  let rec go =
    function
	VarP x -> List.assoc x subst
      | Int i -> Int i
      | Sum(p1,p2) -> Sum(go p1,go p2)
      | Dif(p1,p2) -> Dif(go p1,go p2)
      | Prod(p1,p2) -> Prod(go p1,go p2)
      | Power(p,i) -> Power(go p,i)
      | Max(p1,p2) -> Max(go p1,go p2)
      | True -> True
      | False -> False
  in go

exception NoQI
       
let term_to_pol prg term=
   let rec go=
     function
	 Var x -> VarP x
       | Con(c,tl) ->
	   let p,vl = Interp.find (C c.idc) prg.interp in
	     applypol (List.combine vl (List.map go tl)) p
       | Fun(f,tl) ->
	   let p,vl = Interp.find (F f.idf) prg.interp in
	     applypol (List.combine vl (List.map go tl)) p
   in 
     try 
       go term
     with Not_found -> raise NoQI
       
let rule_to_pol prg eq=
   (term_to_pol prg (Fun(eq.lfun,List.map pat_to_term eq.lpat))),
   (term_to_pol prg eq.rside)




