(*********************************************************************)
(*                                                                   *)
(*                         terminaison par MPO                       *)
(*                                                                   *)
(*                          Jean-Yves Moyen                          *)
(*                              Mars 2001                            *)
(*                                                                   *)
(*********************************************************************)

open Langage
open Ordering
module OrderedInt=struct type t = int let compare=compare end

module IntSet=Set.Make(OrderedInt)

let build_list comp l t=
  let rec aux i=
    function
	[] -> []
      | a::r -> 
	  (try
	     (match comp t a with
		  0 -> i::(aux (i+1) r)
		| x when x>0 -> (-i)::(aux (i+1) r)
		| x when x<0 -> aux (i+1) r
		| _ -> failwith "Scrogneugneu !")
	   with
	       Incomparables -> aux (i+1) r)
  in aux 1 l

let eqabs x y=(abs x)=(abs y)

let rec queens set=
  function
      [] -> IntSet.exists (fun x->x<0) set
    | l::rl -> 
	(match l with
	     [] -> false
	   | a::r -> 
	       ((not (IntSet.exists (eqabs a) set)) 
		&& (queens (IntSet.add a set) rl))
	       || (queens set (r::rl)))

let multiset comp l1 l2 = (*extension multiset*)
  if queens IntSet.empty (List.map (build_list comp l2) l1)
  then 1
  else 
    if queens IntSet.empty (List.map (build_list comp l1) l2)
    then -1
    else raise Incomparables
    
let rec mpo mapf t1 t2 =
  if t1=t2 
  then 0
  else
    match t1,t2 with
	(Var x),(Var y) -> if x=y then 0 else raise Incomparables
      | (Var x),_ -> if subterm t1 t2 then -1 else raise Incomparables
      | (Con(c1,tl1)),(Con(c2,tl2)) ->
	  if  subterm t1 t2 then -1
	  else 
	    if subterm t2 t1 then 1 
	    else raise Incomparables
      | (Con(c1,tl1)),(Fun(f2,tl2)) ->
	  if List.for_all (fun t->(mpo mapf t t2)= ~-1) tl1 then -1
	  else 
	    if List.exists (subterm t2) tl1 then 1
	    else raise Incomparables
      | (Fun(f1,tl1)),(Fun(f2,tl2)) ->
	  (match prec mapf f1 f2 with
	       -1 -> ~-(all_same 1 (List.map (mpo mapf t2) tl1))
	     | 0 -> multiset (mpo mapf) tl1 tl2
	     | 1 -> (all_same 1 (List.map (mpo mapf t1) tl2))
	     | _ -> failwith "grou ?")
      | _ -> ~-(mpo mapf t2 t1)	  

let is_mpo_eq = is_ord_eq mpo

let is_mpo = is_ord mpo

let mpo_prg prg = is_mpo prg

let chkmpo s=
  mpo_prg (Parser.prog Lexer.token (Lexing.from_string s))
	
