(*********************************************************************)
(*                                                                   *)
(*                        Ordres de terminaison                      *)
(*                                                                   *)
(*                          Jean-Yves Moyen                          *)
(*                              Mars 2001                            *)
(*                                                                   *)
(*********************************************************************)

open Langage

let rec get_fun set =
  function
      Var _ -> set
    | Con (c,tl) -> List.fold_left get_fun set tl
    | Fun (f,tl) -> List.fold_left get_fun (FunSet.add f set) tl

module FunMap = 
  (Map.Make(OrderedFun) : Map.S with type key = func)

type precedence = Langage.FunSet.t FunMap.t

let add_to_map map eq =
  let set= 
    try
      FunMap.find eq.lfun map
    with
	Not_found -> FunSet.empty
  in
    FunMap.add eq.lfun (get_fun set eq.rside) map
    
let build_map prg=
  List.fold_left add_to_map FunMap.empty prg

let clos_map_map map1 f d map2 =
  let rec clos_set_func set g =
    if FunSet.mem g set
    then set
    else clos_set_set (FunSet.add g set) (FunMap.find g map1)
  and clos_set_set set1 set2 =
    let l = List.map (clos_set_func set1) (FunSet.elements set2)
    in List.fold_left FunSet.union FunSet.empty l
  in 
    FunMap.add f (clos_set_func d f) map2

let clos_map mapf =
  FunMap.fold (clos_map_map mapf) mapf FunMap.empty

let prec mapf f g=
  if FunSet.mem f (FunMap.find g mapf)
  then (*f <= g*)
    if FunSet.mem g (FunMap.find f mapf)
    then 0
    else -1
  else
    if FunSet.mem g (FunMap.find f mapf)
    then 1
    else failwith "pas normal"

let rec subterm t1 t2=
  match t1,t2 with
      (Var x),(Var y) -> x=y
    | _,(Var _) -> false
    | (Var _),(Con(_,tl)) -> List.exists (subterm t1) tl
    | (Var _),(Fun(_,tl)) -> List.exists (subterm t1) tl
    | (Con(c1,tl1)),(Con(c2,tl2)) ->
	if c1.idc=c2.idc 
	then tl1=tl2
	else List.exists (subterm t1) tl2
    | (Con(_,_)),(Fun(_,tl)) -> List.exists (subterm t1) tl
    | (Fun(f1,tl1)),(Fun(f2,tl2)) ->
	if f1.idf=f2.idf
	then tl1=tl2
	else List.exists (subterm t1) tl2
    | (Fun(_,_)),(Con(_,tl)) -> List.exists (subterm t1) tl

exception Incomparables

let all_same valeur liste=
  let f a b= if a=b then a else raise Incomparables
  in List.fold_left f valeur liste

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



let is_ord_eq ord mapf eq=
  ord mapf (Fun(eq.lfun,List.map pat_to_term eq.lpat)) eq.rside>0

let is_ord ord prg=
  let eql=prg.rules in
  let mapf= clos_map (build_map eql) in
    List.for_all (is_ord_eq ord mapf) eql
