Imported Upstream version 8.1~gammaupstream/8.1.gamma

89 files changed, 6557 insertions, 2751 deletions

diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
index 3e2d11a2..8bdae54b 100644
--- a/contrib/cc/ccalgo.ml
+++ b/contrib/cc/ccalgo.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.ml 7298 2005-08-17 12:56:38Z corbinea $ *)
+(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
@@ -55,6 +55,8 @@ module ST=struct
 	Hashtbl.replace st.tosign t sign
 	  
   let query sign st=Hashtbl.find st.toterm sign
+
+  let rev_query term st=Hashtbl.find st.tosign term
 	  
   let delete st t=
     try let sign=Hashtbl.find st.tosign t in
@@ -72,10 +74,22 @@ type pa_constructor=
       arity : int;
       args  : int list}
 
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
+
+type pa_mark=
+    Fmark of pa_fun
+  | Cmark of pa_constructor
+
 module PacMap=Map.Make(struct 
 			 type t=pa_constructor 
 			 let compare=Pervasives.compare end) 
 
+module PafMap=Map.Make(struct 
+			 type t=pa_fun
+			 let compare=Pervasives.compare end)
+
 type cinfo=
     {ci_constr: constructor; (* inductive type *)
      ci_arity: int;     (* # args *)
@@ -87,16 +101,20 @@ type term=
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
+type ccpattern =
+    PApp of term * ccpattern list (* arguments are reversed *)
+  | PVar of int 
+
 type rule=
     Congruence
-  | Axiom of identifier * bool 
+  | Axiom of constr * bool 
   | Injection of int * pa_constructor * int * pa_constructor * int
 
 type from=
     Goal
-  | Hyp of identifier
-  | HeqG of identifier
-  | HeqnH of identifier * identifier
+  | Hyp of constr
+  | HeqG of constr
+  | HeqnH of constr * constr
 
 type 'a eq = {lhs:int;rhs:int;rule:'a}
 
@@ -104,6 +122,15 @@ type equality = rule eq
 
 type disequality = from eq
 
+type quant_eq =
+    {qe_hyp_id: identifier;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:bool;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:bool}
+
 let swap eq : equality =
   let swap_rule=match eq.rule with
       Congruence -> Congruence
@@ -122,6 +149,7 @@ type representative=
      mutable lfathers:Intset.t;
      mutable fathers:Intset.t;
      mutable inductive_status: inductive_status;
+     mutable functions: Intset.t PafMap.t;
      mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
 
 type cl = Rep of representative| Eqto of int*equality
@@ -138,7 +166,7 @@ type forest=
     {mutable max_size:int;
      mutable size:int;
      mutable map: node array;
-     axioms: (identifier,term*term) Hashtbl.t;
+     axioms: (constr,term*term) Hashtbl.t;
      mutable epsilons: pa_constructor list;
      syms:(term,int) Hashtbl.t}
 
@@ -147,9 +175,13 @@ type state =
      sigtable:ST.t;
      mutable terms: Intset.t; 
      combine: equality Queue.t; 
-     marks: (int * pa_constructor) Queue.t;
+     marks: (int * pa_mark) Queue.t;
      mutable diseq: disequality list;
-     mutable pa_classes: Intset.t}
+     mutable quant: quant_eq list;
+     mutable pa_classes: Intset.t;
+     q_history: (constr,unit) Hashtbl.t;
+     mutable rew_depth:int;
+     mutable changed:bool}
 
 let dummy_node =
   {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
@@ -157,7 +189,7 @@ let dummy_node =
    vertex=Leaf;
    term=Symb (mkRel min_int)}
 
-let empty ():state =
+let empty depth:state =
   {uf=
      {max_size=init_size;
       size=0;
@@ -170,7 +202,11 @@ let empty ():state =
   marks=Queue.create ();
   sigtable=ST.empty ();
   diseq=[];
-  pa_classes=Intset.empty}
+  quant=[];
+  pa_classes=Intset.empty;
+  q_history=Hashtbl.create init_size;
+  rew_depth=depth;
+  changed=false}
 
 let forest state = state.uf 
        
@@ -221,11 +257,19 @@ let append_pac t p =
 
 let tail_pac p=
   {p with arity=succ p.arity;args=List.tl p.args}
+
+let fsucc paf =
+  {paf with fnargs=succ paf.fnargs}
     
 let add_pac rep pac t =
   if not (PacMap.mem pac rep.constructors) then
     rep.constructors<-PacMap.add pac t rep.constructors
 
+let add_paf rep paf t =
+  let already = 
+    try PafMap.find paf rep.functions with Not_found -> Intset.empty in
+    rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
+
 let term uf i=uf.map.(i).term
 		
 let subterms uf i=
@@ -256,8 +300,36 @@ let new_representative ()=
    lfathers=Intset.empty;
    fathers=Intset.empty;
    inductive_status=Unknown;
+   functions=PafMap.empty;
    constructors=PacMap.empty}
     
+(* rebuild a constr from an applicative term *)
+    
+let rec constr_of_term = function
+    Symb s->s
+  | Eps -> anomaly "epsilon constant has no value" 
+  | Constructor cinfo -> mkConstruct cinfo.ci_constr 
+  | Appli (s1,s2)->
+      make_app [(constr_of_term s2)] s1
+and make_app l=function
+    Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1    
+  | other -> applistc (constr_of_term other) l 
+
+(* rebuild a term from a pattern and a substitution *)
+
+let build_subst uf subst =
+  Array.map (fun i -> 
+	       try term uf i 
+	       with _ -> anomaly "incomplete matching") subst
+
+let rec inst_pattern subst = function
+    PVar i -> 
+      subst.(pred i) 
+  | PApp (t, args) -> 
+      List.fold_right
+	(fun spat f -> Appli (f,inst_pattern subst spat))
+	   args t  
+
 let rec add_term state t= 
   let uf=state.uf in
     try Hashtbl.find uf.syms t with 
@@ -265,7 +337,16 @@ let rec add_term state t=
 	  let b=next uf in
 	  let new_node=
 	    match t with
-		Symb _ | Eps -> 
+		Symb _ ->
+		  let paf =
+		    {fsym=b;
+		     fnargs=0} in
+		    Queue.add (b,Fmark paf) state.marks;
+		    {clas= Rep (new_representative ());
+		     cpath= -1;
+		     vertex= Leaf;
+		     term= t}
+	      | Eps -> 
 		  {clas= Rep (new_representative ());
 		   cpath= -1;
 		   vertex= Leaf;
@@ -280,11 +361,15 @@ let rec add_term state t=
 		     vertex= Node(i1,i2);
 		     term= t}
 	      | Constructor cinfo ->
+		  let paf =
+		    {fsym=b;
+		     fnargs=0} in
+		    Queue.add (b,Fmark paf) state.marks;
 		  let pac =
 		    {cnode= b;
 		     arity= cinfo.ci_arity;
 		     args=[]} in
-		    Queue.add (b,pac) state.marks;
+		    Queue.add (b,Cmark pac) state.marks;
 		    {clas=Rep (new_representative ());
 		     cpath= -1;
 		     vertex=Leaf;
@@ -294,17 +379,54 @@ let rec add_term state t=
 	    Hashtbl.add uf.syms t b;
 	    b
 
-let add_equality state id s t=
+let add_equality state c s t=
   let i = add_term state s in
   let j = add_term state t in
-    Queue.add {lhs=i;rhs=j;rule=Axiom(id,false)} state.combine;
-    Hashtbl.add state.uf.axioms id (s,t)
+    Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine;
+    Hashtbl.add state.uf.axioms c (s,t)
 
 let add_disequality state from s t =
   let i = add_term state s in
   let j = add_term state t in
     state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq
 
+let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
+  state.quant<-
+    {qe_hyp_id= id;
+     qe_pol= pol;
+     qe_nvars=nvars;
+     qe_lhs= patt1;
+     qe_lhs_valid=valid1;
+     qe_rhs= patt2;
+     qe_rhs_valid=valid2}::state.quant
+
+let add_inst state (inst,int_subst) = 
+  if state.rew_depth > 0 then 
+  let subst = build_subst (forest state) int_subst in
+  let prfhead= mkVar inst.qe_hyp_id in
+  let args = Array.map constr_of_term subst in
+  let _ = array_rev args in (* highest deBruijn index first *)
+  let prf= mkApp(prfhead,args) in
+    try Hashtbl.find state.q_history prf
+    with Not_found ->
+      (* this instance is new, we can go on *)
+      let s = inst_pattern subst inst.qe_lhs 
+      and t = inst_pattern subst inst.qe_rhs in
+	state.changed<-true;
+	state.rew_depth<-pred state.rew_depth;
+	if inst.qe_pol then
+	  begin
+	    debug msgnl 
+	      (str "adding new equality, depth="++ int state.rew_depth);
+	    add_equality state prf s t
+	  end
+	else
+	  begin
+	    debug msgnl (str "adding new disequality, depth="++ 
+			   int state.rew_depth);
+	    add_disequality state (Hyp prf) s t 
+	  end
+
 let link uf i j eq = (* links i -> j *)
   let node=uf.map.(i) in 
     node.clas<-Eqto (j,eq);
@@ -336,7 +458,13 @@ let union state i1 i2 eq=
       r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
       ST.delete_set state.sigtable r1.fathers;
       state.terms<-Intset.union state.terms r1.fathers;       
-      PacMap.iter (fun pac b -> Queue.add (b,pac) state.marks) r1.constructors;
+      PacMap.iter 
+	(fun pac b -> Queue.add (b,Cmark pac) state.marks) 
+	r1.constructors;
+      PafMap.iter 
+	(fun paf -> Intset.iter 
+	   (fun b -> Queue.add (b,Fmark paf) state.marks)) 
+	r1.functions;
       match r1.inductive_status,r2.inductive_status with 
 	  Unknown,_ -> ()
 	| Partial pac,Unknown -> 
@@ -351,7 +479,7 @@ let union state i1 i2 eq=
 	    state.pa_classes<-Intset.remove i2 state.pa_classes;
 	    r2.inductive_status<-Partial_applied
 	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
-	| Total cpl,Total _ -> Queue.add cpl state.marks    
+	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks    
 	| _,_ -> () 
             
 let merge eq state = (* merge and no-merge *)
@@ -380,19 +508,22 @@ let update t state = (* update 1 and 2 *)
 	| _ -> ()
     end;
     PacMap.iter 
-      (fun pac _ -> Queue.add (t,append_pac v pac) state.marks) 
+      (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) 
       rep.constructors; 
+    PafMap.iter 
+      (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) 
+      rep.functions; 
     try 
       let s = ST.query sign state.sigtable in 
 	Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
     with 
 	Not_found -> ST.enter t sign state.sigtable
 
-let process_mark t pac state =
-  debug msgnl 
-    (str "Processing mark for term " ++ int t ++ str ".");
-  let i=find state.uf t in
-  let rep=get_representative state.uf i in
+let process_function_mark t rep paf state  =
+  add_paf rep paf t;
+  state.terms<-Intset.union rep.lfathers state.terms
+    
+let process_constructor_mark t i rep pac state =
     match rep.inductive_status with
 	Total (s,opac) ->
 	  if pac.cnode <> opac.cnode then (* Conflict *) 
@@ -424,6 +555,15 @@ let process_mark t pac state =
 	      state.pa_classes<- Intset.add i state.pa_classes
 	    end
 
+let process_mark t m state = 
+  debug msgnl 
+    (str "Processing mark for term " ++ int t ++ str ".");
+  let i=find state.uf t in
+  let rep=get_representative state.uf i in
+    match m with
+	Fmark paf -> process_function_mark t rep paf state
+      | Cmark pac -> process_constructor_mark t i rep pac state
+
 type explanation =
     Discrimination of (int*pa_constructor*int*pa_constructor)
   | Contradiction of disequality
@@ -447,15 +587,21 @@ let check_disequalities state =
 let one_step state =
     try
       let eq = Queue.take state.combine in
-	merge eq state
+	merge eq state;
+	true
     with Queue.Empty -> 
       try 
 	let (t,m) = Queue.take state.marks in
-	  process_mark t m state
+	  process_mark t m state;
+	  true
       with Queue.Empty ->
+	try
 	  let t = Intset.choose state.terms in
 	    state.terms<-Intset.remove t state.terms;
-	    update t state
+	    update t state;
+	    true
+	with Not_found -> false
+	  
 
 let complete_one_class state i=
   match (get_representative state.uf i).inductive_status with
@@ -470,38 +616,162 @@ let complete_one_class state i=
 let complete state =
   Intset.iter (complete_one_class state) state.pa_classes
 
+type matching_problem = 
+{mp_subst : int array;
+ mp_inst : quant_eq;
+ mp_stack : (ccpattern*int) list }
+
+let make_fun_table state =
+  let uf= state.uf in
+  let funtab=ref PafMap.empty in
+  for cl=0 to pred uf.size do 
+    match uf.map.(cl).clas with
+	Rep rep ->
+	  PafMap.iter 
+	    (fun paf _ -> 
+	       let elem = 
+		 try PafMap.find paf !funtab 
+		 with Not_found -> Intset.empty in
+		 funtab:= PafMap.add paf (Intset.add cl elem) !funtab) 
+	    rep.functions
+      | _ -> ()   
+  done;
+    !funtab
+  
+
+let rec do_match state res pb_stack =
+  let mp=Stack.pop pb_stack in
+    match mp.mp_stack with
+	[] -> 
+	  res:= (mp.mp_inst,mp.mp_subst) :: !res
+      | (patt,cl)::remains ->
+	  let uf=state.uf in
+	    match patt with
+		PVar i -> 
+		  if mp.mp_subst.(pred i)<0 then  
+		    begin
+		      mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *)
+		      Stack.push {mp with mp_stack=remains} pb_stack
+		    end
+		  else
+		    if mp.mp_subst.(pred i) = cl then
+		      Stack.push {mp with mp_stack=remains} pb_stack
+	      | PApp (f,[]) ->
+		  begin
+		    try let j=Hashtbl.find uf.syms f in
+		      if find uf j =cl then
+			Stack.push {mp with mp_stack=remains} pb_stack
+		    with Not_found -> ()
+		  end
+	      | PApp(f, ((last_arg::rem_args) as args)) ->
+		  try 
+		    let j=Hashtbl.find uf.syms f in
+		    let paf={fsym=j;fnargs=List.length args} in
+		    let rep=get_representative uf cl in
+		    let good_terms = PafMap.find paf rep.functions in
+		    let aux i = 
+		      let (s,t) = ST.rev_query i state.sigtable in
+			Stack.push 
+			  {mp with 
+			     mp_subst=Array.copy mp.mp_subst;
+			     mp_stack=
+			      (PApp(f,rem_args),s) :: 
+				(last_arg,t) :: remains} pb_stack in
+		      Intset.iter aux good_terms 
+		  with Not_found -> ()
+
+let paf_of_patt syms = function
+    PVar _ -> invalid_arg "paf_of_patt: pattern is trivial"
+  | PApp (f,args) ->
+      {fsym=Hashtbl.find syms f;
+       fnargs=List.length args}
+
+let init_pb_stack state = 
+  let syms= state.uf.syms in
+  let pb_stack = Stack.create () in
+  let funtab = make_fun_table state in
+  let aux inst =
+    begin
+      if inst.qe_lhs_valid then
+	try 
+	  let paf= paf_of_patt syms inst.qe_lhs in
+	  let good_classes = PafMap.find paf funtab in
+	    Intset.iter (fun i -> 
+			 Stack.push 
+			   {mp_subst = Array.make inst.qe_nvars (-1); 
+			    mp_inst=inst;
+			    mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
+	with Not_found -> ()
+    end;
+    begin 
+      if inst.qe_rhs_valid then
+	try 
+	  let paf= paf_of_patt syms inst.qe_rhs in
+	  let good_classes = PafMap.find paf funtab in
+	    Intset.iter (fun i -> 
+			   Stack.push 
+			     {mp_subst = Array.make inst.qe_nvars (-1); 
+			      mp_inst=inst;
+			      mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
+	with Not_found -> ()
+    end in
+    List.iter aux state.quant;
+    pb_stack
+
+let find_instances state = 
+  let pb_stack= init_pb_stack state in
+  let res =ref [] in
+  let _ =
+    debug msgnl (str "Running E-matching algorithm ... ");
+    try
+      while true do 
+	do_match state res pb_stack 
+      done;
+      anomaly "get out of here !"
+    with Stack.Empty -> () in
+    !res
+
 let rec execute first_run state =
   debug msgnl (str "Executing ... ");
   try
-    while true do 
-      one_step state
+    while one_step state do ()
     done;
-    anomaly "keep out of here" 
-  with 
-      Discriminable(s,spac,t,tpac) -> 
-	Some
-	begin
-	  if first_run then 
-	    Discrimination (s,spac,t,tpac)
-	  else
-	    Incomplete
-	end
-    | Not_found ->
-	match check_disequalities state with
-	    None -> 
-	      if not(Intset.is_empty state.pa_classes) then
-		begin 
-		  debug msgnl 
-		    (str "First run was incomplete, completing ... ");
-		  complete state;
-		  execute false state
-		end
-	      else None
-	  | Some dis -> Some
-	      begin
-		if first_run then 
-		  Contradiction dis
+    match check_disequalities state with
+	None -> 
+	  if not(Intset.is_empty state.pa_classes) then
+	    begin 
+	      debug msgnl (str "First run was incomplete, completing ... ");
+	      complete state;
+	      execute false state
+	    end
+	  else 
+	    if state.rew_depth>0 then
+	      let l=find_instances state in
+		List.iter (add_inst state) l;
+		if state.changed then 
+		  begin
+		    state.changed <- false;
+		    execute true state
+		  end
 		else
-		  Incomplete
+	      begin 
+		debug msgnl (str "Out of instances ... ");
+		None
+	      end
+	    else 
+	      begin 
+		debug msgnl (str "Out of depth ... ");
+		None
 	      end
+      | Some dis -> Some
+	  begin
+	    if first_run then Contradiction dis
+	    else Incomplete
+	  end
+  with Discriminable(s,spac,t,tpac) -> Some
+    begin
+      if first_run then Discrimination (s,spac,t,tpac)
+      else Incomplete
+    end
+
 
diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli
index 74132811..05a5c4d1 100644
--- a/contrib/cc/ccalgo.mli
+++ b/contrib/cc/ccalgo.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.mli 7298 2005-08-17 12:56:38Z corbinea $ *)
+(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 open Util
 open Term
@@ -23,6 +23,10 @@ type term =
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
+type ccpattern =
+    PApp of term * ccpattern list
+  | PVar of int 
+
 type pa_constructor =
     { cnode : int;
       arity : int;
@@ -36,14 +40,14 @@ type state
 
 type rule=
     Congruence
-  | Axiom of identifier * bool 
+  | Axiom of constr * bool 
   | Injection of int * pa_constructor * int * pa_constructor * int
 
 type from=
     Goal
-  | Hyp of identifier
-  | HeqG of identifier
-  | HeqnH of identifier * identifier
+  | Hyp of constr
+  | HeqG of constr
+  | HeqnH of constr*constr 
 
 type 'a eq = {lhs:int;rhs:int;rule:'a}
 
@@ -56,22 +60,28 @@ type explanation =
   | Contradiction of disequality
   | Incomplete
 
+val constr_of_term : term -> constr
+
 val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
 
 val forest : state -> forest
 
-val axioms : forest -> (identifier, term * term) Hashtbl.t
+val axioms : forest -> (constr, term * term) Hashtbl.t
 
 val epsilons : forest -> pa_constructor list
 
-val empty : unit -> state
+val empty : int -> state
 
 val add_term : state -> term -> int
 
-val add_equality : state -> identifier -> term -> term -> unit
+val add_equality : state -> constr -> term -> term -> unit
 
 val add_disequality : state -> from -> term -> term -> unit
 
+val add_quant : state -> identifier -> bool -> 
+  int * bool * ccpattern * bool * ccpattern -> unit
+
+
 val tail_pac : pa_constructor -> pa_constructor
 
 val find : forest -> int -> int
@@ -87,6 +97,35 @@ val subterms : forest -> int -> int * int
 val join_path : forest -> int -> int -> 
   ((int * int) * equality) list * ((int * int) * equality) list
 
+type quant_eq=
+    {qe_hyp_id: identifier;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:bool;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:bool}
+
+
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
+
+type matching_problem
+ 
+module PafMap: Map.S with type key = pa_fun
+
+val make_fun_table : state -> Intset.t PafMap.t 
+
+val do_match :  state ->
+    (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
+
+val init_pb_stack : state -> matching_problem Stack.t
+
+val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
+
+val find_instances : state -> (quant_eq * int array) list
+
 val execute : bool -> state -> explanation option
 
 
diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml
index 1200dc2e..1ffa347a 100644
--- a/contrib/cc/ccproof.ml
+++ b/contrib/cc/ccproof.ml
@@ -6,18 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.ml 7298 2005-08-17 12:56:38Z corbinea $ *)
+(* $Id: ccproof.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 (* This file uses the (non-compressed) union-find structure to generate *) 
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
 open Util
 open Names
+open Term
 open Ccalgo
   
 type proof=
-    Ax of identifier
-  | SymAx of identifier
+    Ax of constr
+  | SymAx of constr
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli
index 18c745bf..abdd6fea 100644
--- a/contrib/cc/ccproof.mli
+++ b/contrib/cc/ccproof.mli
@@ -6,14 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.mli 7298 2005-08-17 12:56:38Z corbinea $ *)
+(* $Id: ccproof.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 open Ccalgo
 open Names
+open Term
 
 type proof =
-    Ax of identifier
-  | SymAx of identifier
+    Ax of constr
+  | SymAx of constr
   | Refl of term
   | Trans of proof * proof
   | Congr of proof * proof
@@ -25,6 +26,6 @@ val build_proof :
   | `Prove of int * int ] -> proof
 
 val type_proof :
-  (identifier, (term * term)) Hashtbl.t -> proof -> term * term
+  (constr, (term * term)) Hashtbl.t -> proof -> term * term
 
 
diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml
index 4a719f38..ea8aceeb 100644
--- a/contrib/cc/cctac.ml
+++ b/contrib/cc/cctac.ml
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: cctac.ml 7909 2006-01-21 11:09:18Z herbelin $ *)
+(* $Id: cctac.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 (* This file is the interface between the c-c algorithm and Coq *)
 
@@ -63,7 +63,7 @@ let rec decompose_term env t=
 	  Constructor {ci_constr=c;
 		       ci_arity=nargs;
 		       ci_nhyps=nargs-oib.mind_nparams}
-    | _ ->(Symb t)
+    | _ ->if closed0 t then (Symb t) else raise Not_found
 	
 (* decompose equality in members and type *)
 	
@@ -79,34 +79,72 @@ let atom_of_constr env term =
 	  else `Other (decompose_term env term)
     | _ -> `Other (decompose_term env term)
 
-let rec litteral_of_constr env term=
+let rec pattern_of_constr env c =
+  match kind_of_term (whd env c) with
+      App (f,args)->
+	let pf = decompose_term env f in
+	let pargs,lrels = List.split 
+	  (array_map_to_list (pattern_of_constr env) args) in
+	  PApp (pf,List.rev pargs),
+	List.fold_left Intset.union Intset.empty lrels 
+    | Rel i -> PVar i,Intset.singleton i
+    | _ -> 
+	let pf = decompose_term env c in
+	  PApp (pf,[]),Intset.empty
+
+let non_trivial = function
+    PVar _ -> false
+  | _ -> true
+
+let patterns_of_constr env nrels term=
+  let f,args= 
+    try destApp (whd_delta env term) with _ -> raise Not_found in
+	if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
+	then 
+	  let patt1,rels1 = pattern_of_constr env args.(1)
+	  and patt2,rels2 = pattern_of_constr env args.(2) in
+	  let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) 
+	  and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in
+	    if valid1 || valid2 then 
+	      nrels,valid1,patt1,valid2,patt2
+	    else raise Not_found
+	else raise Not_found
+
+let rec quantified_atom_of_constr env nrels term =
   match kind_of_term (whd_delta env term) with
       Prod (_,atom,ff) -> 
 	if eq_constr ff (Lazy.force _False) then
+	  let patts=patterns_of_constr env nrels atom in
+	      `Nrule patts
+	else 
+	  quantified_atom_of_constr env (succ nrels) ff
+    | _ ->  
+	let patts=patterns_of_constr env nrels term in
+	    `Rule patts	  
+
+let litteral_of_constr env term=
+  match kind_of_term (whd_delta env term) with
+    | Prod (_,atom,ff) -> 
+	if eq_constr ff (Lazy.force _False) then
 	  match (atom_of_constr env atom) with
 	      `Eq(t,a,b) -> `Neq(t,a,b)
 	    | `Other(p) -> `Nother(p)
-	else 
-	  `Other (decompose_term env term)
-    | _ -> atom_of_constr env term
+	else
+	  begin
+	    try 
+	      quantified_atom_of_constr env 1 ff  
+	    with Not_found ->
+	      `Other (decompose_term env term)
+	  end
+    | _ -> 
+	atom_of_constr env term
 	
-(* rebuild a term from applicative format *)
-    
-let rec make_term = function
-    Symb s->s
-  | Eps -> anomaly "epsilon constant has no value" 
-  | Constructor cinfo -> mkConstruct cinfo.ci_constr 
-  | Appli (s1,s2)->
-      make_app [(make_term s2)] s1
-and make_app l=function
-    Appli (s1,s2)->make_app ((make_term s2)::l) s1    
-  | other -> applistc (make_term other) l 
 
 (* store all equalities from the context *)
 	
-let rec make_prb gls additionnal_terms =
+let rec make_prb gls depth additionnal_terms =
   let env=pf_env gls in
-  let state = empty () in
+  let state = empty depth in
   let pos_hyps = ref [] in
   let neg_hyps =ref [] in
     List.iter
@@ -116,21 +154,24 @@ let rec make_prb gls additionnal_terms =
     List.iter 
       (fun (id,_,e) ->
 	 begin
+	   let cid=mkVar id in
 	   match litteral_of_constr env e with
-	       `Eq (t,a,b) -> add_equality state id a b
-	     | `Neq (t,a,b) -> add_disequality state (Hyp id) a b
+	       `Eq (t,a,b) -> add_equality state cid a b
+	     | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b
 	     | `Other ph ->
 		 List.iter 
-		   (fun (idn,nh) -> 
-		      add_disequality state (HeqnH (id,idn)) ph nh) 
+		   (fun (cidn,nh) -> 
+		      add_disequality state (HeqnH (cid,cidn)) ph nh) 
 		   !neg_hyps;
-		 pos_hyps:=(id,ph):: !pos_hyps
+		 pos_hyps:=(cid,ph):: !pos_hyps
 	     | `Nother nh ->
 		 List.iter 
-		   (fun (idp,ph) -> 
-		      add_disequality state (HeqnH (idp,id)) ph nh) 
+		   (fun (cidp,ph) -> 
+		      add_disequality state (HeqnH (cidp,cid)) ph nh) 
 		   !pos_hyps;
-		 neg_hyps:=(id,nh):: !neg_hyps
+		 neg_hyps:=(cid,nh):: !neg_hyps
+	     | `Rule patts -> add_quant state id true patts
+	     | `Nrule patts -> add_quant state id false patts
 	 end) (Environ.named_context_of_val gls.it.evar_hyps);
     begin
       match atom_of_constr env gls.it.evar_concl with
@@ -170,18 +211,18 @@ let build_projection intype outtype (cstr:constructor) special default gls=
 (* generate an adhoc tactic following the proof tree  *)
 
 let rec proof_tac axioms=function
-    Ax id->exact_check (mkVar id)
-  | SymAx id->tclTHEN symmetry (exact_check (mkVar id))
-  | Refl t->reflexivity
-  | Trans (p1,p2)->let t=(make_term (snd (type_proof axioms p1))) in
+    Ax c -> exact_check c
+  | SymAx c -> tclTHEN symmetry (exact_check c)
+  | Refl t -> reflexivity
+  | Trans (p1,p2)->let t=(constr_of_term (snd (type_proof axioms p1))) in
       (tclTHENS (transitivity t) 
 	 [(proof_tac axioms p1);(proof_tac axioms p2)])
   | Congr (p1,p2)->
       fun gls->
 	let (f1,f2)=(type_proof axioms p1) 
 	and (x1,x2)=(type_proof axioms p2) in
-        let tf1=make_term f1 and tx1=make_term x1 
-	and tf2=make_term f2 and tx2=make_term x2 in
+        let tf1=constr_of_term f1 and tx1=constr_of_term x1 
+	and tf2=constr_of_term f2 and tx2=constr_of_term x2 in
 	let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1
 	and typfx=pf_type_of gls (mkApp(tf1,[|tx1|])) in
 	let id=pf_get_new_id (id_of_string "f") gls in
@@ -204,52 +245,52 @@ let rec proof_tac axioms=function
       (fun gls ->
 	 let ti,tj=type_proof axioms prf in
 	 let ai,aj=type_proof axioms gprf in
-	 let cti=make_term ti in
-	 let ctj=make_term tj in
-	 let cai=make_term ai in
+	 let cti=constr_of_term ti in
+	 let ctj=constr_of_term tj in
+	 let cai=constr_of_term ai in
 	 let intype=pf_type_of gls cti in
 	 let outtype=pf_type_of gls cai in
 	 let special=mkRel (1+nargs-argind) in
-	 let default=make_term ai in
+	 let default=constr_of_term ai in
 	 let proj=build_projection intype outtype cstr special default gls in
 	 let injt=
 	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;cti;ctj|]) in 
 	   tclTHEN (apply injt) (proof_tac axioms prf) gls)
 
-let refute_tac axioms id t1 t2 p gls =      
-  let tt1=make_term t1 and tt2=make_term t2 in
+let refute_tac axioms c t1 t2 p gls =      
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
   let intype=pf_type_of gls tt1 in
   let neweq=
     mkApp(Lazy.force _eq,
 	  [|intype;tt1;tt2|]) in
   let hid=pf_get_new_id (id_of_string "Heq") gls in
-  let false_t=mkApp (mkVar id,[|mkVar hid|]) in
+  let false_t=mkApp (c,[|mkVar hid|]) in
     tclTHENS (true_cut (Name hid) neweq)
       [proof_tac axioms p; simplest_elim false_t] gls
 
-let convert_to_goal_tac axioms id t1 t2 p gls =
-  let tt1=make_term t1 and tt2=make_term t2 in
+let convert_to_goal_tac axioms c t1 t2 p gls =
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
   let sort=pf_type_of gls tt2 in
   let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in 
   let e=pf_get_new_id (id_of_string "e") gls in
   let x=pf_get_new_id (id_of_string "X") gls in
   let identity=mkLambda (Name x,sort,mkRel 1) in 
   let endt=mkApp (Lazy.force _eq_rect,
-		  [|sort;tt1;identity;mkVar id;tt2;mkVar e|]) in
+		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
     tclTHENS (true_cut (Name e) neweq) 
       [proof_tac axioms p;exact_check endt] gls
 
-let convert_to_hyp_tac axioms id1 t1 id2 t2 p gls =
-  let tt2=make_term t2 in
+let convert_to_hyp_tac axioms c1 t1 c2 t2 p gls =
+  let tt2=constr_of_term t2 in
   let h=pf_get_new_id (id_of_string "H") gls in
-  let false_t=mkApp (mkVar id2,[|mkVar h|]) in
+  let false_t=mkApp (c2,[|mkVar h|]) in
     tclTHENS (true_cut (Name h) tt2)
-      [convert_to_goal_tac axioms id1 t1 t2 p;
+      [convert_to_goal_tac axioms c1 t1 t2 p;
        simplest_elim false_t] gls
   
 let discriminate_tac axioms cstr p gls =
   let t1,t2=type_proof axioms p in 
-  let tt1=make_term t1 and tt2=make_term t2 in
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
   let intype=pf_type_of gls tt1 in
   let concl=pf_concl gls in
   let outsort=mkType (new_univ ()) in
@@ -273,15 +314,15 @@ let discriminate_tac axioms cstr p gls =
 	
 let build_term_to_complete uf meta pac =
   let cinfo = get_constructor_info uf pac.cnode in
-  let real_args = List.map (fun i -> make_term (term uf i)) pac.args in
+  let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
   let dummy_args = List.rev (list_tabulate meta pac.arity) in
   let all_args = List.rev_append real_args dummy_args in
     applistc (mkConstruct cinfo.ci_constr) all_args
       
-let cc_tactic additionnal_terms gls=
+let cc_tactic depth additionnal_terms gls=
   Coqlib.check_required_library ["Coq";"Init";"Logic"];
   let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
-  let state = make_prb gls additionnal_terms in
+  let state = make_prb gls depth additionnal_terms in
   let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
   let sol = execute true state in
   let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
@@ -334,3 +375,8 @@ let cc_tactic additionnal_terms gls=
 
 let cc_fail gls =
   errorlabstrm  "Congruence" (Pp.str "congruence failed.")     
+
+let congruence_tac depth l = 
+  tclORELSE 
+    (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) 
+    cc_fail
diff --git a/contrib/cc/cctac.mli b/contrib/cc/cctac.mli
index 6082beb6..97fa4d77 100644
--- a/contrib/cc/cctac.mli
+++ b/contrib/cc/cctac.mli
@@ -6,11 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cctac.mli 7298 2005-08-17 12:56:38Z corbinea $ *)
+(* $Id: cctac.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 open Term 
 open Proof_type
 
-val cc_tactic : constr list -> tactic
+val cc_tactic : int -> constr list -> tactic
 
 val cc_fail : tactic
+
+val congruence_tac : int -> constr list -> tactic
diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4
index 0bdf7608..693aebb4 100644
--- a/contrib/cc/g_congruence.ml4
+++ b/contrib/cc/g_congruence.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_congruence.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 open Cctac
 open Tactics
@@ -17,13 +17,9 @@ open Tacticals
 (* Tactic registration *)
       
 TACTIC EXTEND cc
- [ "congruence" ] -> [ tclORELSE 
-			 (tclTHEN (tclREPEAT introf) (cc_tactic [])) 
-			 cc_fail ]
-END
-      
-TACTIC EXTEND cc_with
- [ "congruence" "with" ne_constr_list(l) ] -> [ tclORELSE 
-			 (tclTHEN (tclREPEAT introf) (cc_tactic l)) 
-			 cc_fail]
+ [ "congruence" ] -> [ congruence_tac 0 [] ]
+ |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
+ |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ]
+ |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> 
+   [ congruence_tac n l ]
 END
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
index c581c620..2d425e9f 100644
--- a/contrib/extraction/extract_env.ml
+++ b/contrib/extraction/extract_env.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.ml 6328 2004-11-18 17:31:41Z sacerdot $ i*)
+(*i $Id: extract_env.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 open Term
 open Declarations
@@ -74,7 +74,8 @@ let visit_ref v r =
 exception Impossible
 
 let check_arity env cb = 
-  if Reduction.is_arity env cb.const_type then raise Impossible
+  let t = Typeops.type_of_constant_type env cb.const_type in
+  if Reduction.is_arity env t then raise Impossible
 
 let check_fix env cb i = 
   match cb.const_body with 
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 2b4b7967..52e7f1dd 100644
--- a/contrib/extraction/extraction.ml
+++ b/contrib/extraction/extraction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.ml 9032 2006-07-07 16:30:34Z herbelin $ i*)
+(*i $Id: extraction.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -225,7 +225,7 @@ let rec extract_type env db j c args =
     | Const kn -> 
 	let r = ConstRef kn in 
 	let cb = lookup_constant kn env in 
-	let typ = cb.const_type in 
+	let typ = Typeops.type_of_constant_type env cb.const_type in 
 	(match flag_of_type env typ with 
 	   | (Info, TypeScheme) -> 
 	       let mlt = extract_type_app env db (r, type_sign env typ) args in 
@@ -321,7 +321,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
       Array.map 
 	(fun mip ->
 	   let b = snd (mind_arity mip) <> InProp in
-	   let ar = Inductive.type_of_inductive (mib,mip) in
+	   let ar = Inductive.type_of_inductive env (mib,mip) in
 	   let s,v = if b then type_sign_vl env ar else [],[] in
 	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
 	   { ip_typename = mip.mind_typename;
@@ -401,7 +401,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	(* Is this record officially declared with its projections ? *)
 	(* If so, we use this information. *)
 	begin try 
-	  let n = nb_default_params env (Inductive.type_of_inductive(mib,mip0))
+	  let n = nb_default_params env
+            (Inductive.type_of_inductive env (mib,mip0))
 	  in
 	  List.iter 
 	    (option_iter 
@@ -446,7 +447,7 @@ and mlt_env env r = match r with
 	   | _ -> None
        with Not_found -> 
 	 let cb = Environ.lookup_constant kn env in
-	 let typ = cb.const_type in
+	 let typ = Typeops.type_of_constant_type env cb.const_type in 
 	 match cb.const_body with
 	   | None -> None
 	   | Some l_body -> 
@@ -473,7 +474,7 @@ let record_constant_type env kn opt_typ =
     lookup_type kn 
   with Not_found ->
     let typ = match opt_typ with 
-      | None -> constant_type env kn 
+      | None -> Typeops.type_of_constant env kn
       | Some typ -> typ 
     in let mlt = extract_type env [] 1 typ [] 
     in let schema = (type_maxvar mlt, mlt)
@@ -814,7 +815,7 @@ let extract_fixpoint env vkn (fi,ti,ci) =
 		 
 let extract_constant env kn cb = 
   let r = ConstRef kn in 
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type env cb.const_type in 
   match cb.const_body with
     | None -> (* A logical axiom is risky, an informative one is fatal. *) 
         (match flag_of_type env typ with
@@ -846,7 +847,7 @@ let extract_constant env kn cb =
 
 let extract_constant_spec env kn cb = 
   let r = ConstRef kn in 
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type env cb.const_type in 
   match flag_of_type env typ with 
     | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
     | (Logic, Default) -> Sval (r, Tdummy Kother) 
@@ -884,7 +885,7 @@ let extract_declaration env r = match r with
 type kind = Logical | Term | Type 
     
 let constant_kind env cb = 
-  match flag_of_type env cb.const_type with 
+  match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with 
     | (Logic,_) -> Logical
     | (Info,TypeScheme) -> Type
     | (Info,Default) -> Term
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
index bd4fe924..b1a3cb31 100644
--- a/contrib/extraction/table.ml
+++ b/contrib/extraction/table.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.ml 6555 2005-01-03 19:25:36Z sacerdot $ i*)
+(*i $Id: table.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 open Names
 open Term
@@ -140,16 +140,14 @@ let error_axiom_scheme r i =
        str " type variable(s).") 
 
 let warning_info_ax r =
-  Options.if_verbose msg_warning
-    (str "You must realize axiom " ++
-     pr_global r ++ str " in the extracted code.")
+  msg_warning (str "You must realize axiom " ++
+		  pr_global r ++ str " in the extracted code.")
 
 let warning_log_ax r = 
-  Options.if_verbose msg_warning
-    (str "This extraction depends on logical axiom" ++ spc () ++ 
-     pr_global r ++ str "." ++ spc() ++ 
-     str "Having false logical axiom in the environment when extracting" ++ 
-     spc () ++ str "may lead to incorrect or non-terminating ML terms.")
+  msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ 
+		  pr_global r ++ str "." ++ spc() ++ 
+		  str "Having false logical axiom in the environment when extracting" ++ 
+		  spc () ++ str "may lead to incorrect or non-terminating ML terms.")
 
 let check_inside_module () = 
   try 
@@ -443,7 +441,7 @@ let extract_constant_inline inline r ids s =
   match g with 
     | ConstRef kn -> 
 	let env = Global.env () in 
-	let typ = Environ.constant_type env kn in 
+	let typ = Typeops.type_of_constant env kn in 
 	let typ = Reduction.whd_betadeltaiota env typ in
 	if Reduction.is_arity env typ 
 	  then begin 
diff --git a/contrib/field/LegacyField.v b/contrib/field/LegacyField.v
new file mode 100644
index 00000000..08397d02
--- /dev/null
+++ b/contrib/field/LegacyField.v
@@ -0,0 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *)
+
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
+Require Export LegacyField_Tactic.
+
+(* Command declarations are moved to the ML side *)
diff --git a/contrib/field/Field_Compl.v b/contrib/field/LegacyField_Compl.v
index f018359e..b37281e9 100644
--- a/contrib/field/Field_Compl.v
+++ b/contrib/field/LegacyField_Compl.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Compl.v 8866 2006-05-28 16:21:04Z herbelin $ *)
+(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *)
 
 Require Import List.
 
diff --git a/contrib/field/Field_Tactic.v b/contrib/field/LegacyField_Tactic.v
index 8d727536..2b6ff5b4 100644
--- a/contrib/field/Field_Tactic.v
+++ b/contrib/field/LegacyField_Tactic.v
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Tactic.v 8866 2006-05-28 16:21:04Z herbelin $ *)
+(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *)
 
 Require Import List.
-Require Import Ring.
-Require Export Field_Compl.
-Require Export Field_Theory.
+Require Import LegacyRing.
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
 
 (**** Interpretation A --> ExprA ****)
 
@@ -184,15 +184,15 @@ Ltac multiply mul :=
   match goal with
   |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
       let AzeroT := get_component Azero FT in
-      (cut (interp_ExprA FT X2 mul <> AzeroT);
-        [ intro; let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id)
-        | weak_reduce;
-           let AoneT := get_component Aone ltac:(body_of FT)
+      cut (interp_ExprA FT X2 mul <> AzeroT);
+       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
+       | weak_reduce;
+          (let AoneT := get_component Aone ltac:(body_of FT)
            with AmultT := get_component Amult ltac:(body_of FT) in
-           (try
+           try
              match goal with
              |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
-             end; clear FT X2) ])
+             end; clear FT X2) ]
   end.
 
 Ltac apply_multiply FT lvar trm :=
@@ -279,7 +279,7 @@ Ltac field_gen_aux FT :=
       let lvar := build_varlist FT (AplusT X1 X2) in
       let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
       let mul := give_mult (EAplus trm1 trm2) in
-      (cut
+      cut
         (let ft := FT in
          let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
         [ compute in |- *; auto
@@ -287,13 +287,14 @@ Ltac field_gen_aux FT :=
            apply_simplif apply_assoc; multiply mul;
            [ apply_simplif apply_multiply;
               apply_simplif ltac:(apply_inverse mul);
-              let id := grep_mult in
-              clear id; weak_reduce; clear ft vm; first
-              [ inverse_test FT; ring | field_gen_aux FT ]
-           | idtac ] ])
+              (let id := grep_mult in
+               clear id; weak_reduce; clear ft vm; first
+              [ inverse_test FT; legacy ring | field_gen_aux FT ])
+           | idtac ] ]
   end.
 
-Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT.
+Ltac field_gen FT :=
+  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
 
 (*****************************)
 (*    Term Simplification    *)
@@ -429,4 +430,4 @@ Ltac field_term FT exp :=
    simpl_all_monomials
     ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
   let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
-  (replace exp with trep; [ ring trep | field_gen FT ]).
+  (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/contrib/field/Field_Theory.v b/contrib/field/LegacyField_Theory.v
index fff3c414..9c3a12fb 100644
--- a/contrib/field/Field_Theory.v
+++ b/contrib/field/LegacyField_Theory.v
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Theory.v 8866 2006-05-28 16:21:04Z herbelin $ *)
+(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *)
 
 Require Import List.
 Require Import Peano_dec.
-Require Import Ring.
-Require Import Field_Compl.
+Require Import LegacyRing.
+Require Import LegacyField_Compl.
 
 Record Field_Theory : Type := 
   {A : Type;
@@ -88,66 +88,66 @@ Let AinvT := Ainv T.
 Let RTT := RT T.
 Let Th_inv_defT := Th_inv_def T.
 
-Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
+Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
  Azero T) (Aopp T) (Aeq T) (RT T).
 
-Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
+Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
 
 (***************************)
 (*    Lemmas to be used    *)
 (***************************)
 
-Lemma AplusT_sym : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
+Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_assoc :
  forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
-Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
+Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_assoc :
  forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_AplusT_distr :
  forall r1 r2 r3:AT,
    AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
 Proof.
   intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
-  ring.
+  legacy ring.
   transitivity (AplusT (AplusT (AoppT r) r) r2).
   repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
-  ring.
+  legacy ring.
 Qed.
  
 Lemma r_AmultT_mult :
@@ -162,28 +162,28 @@ Qed.
 
 Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
 Proof.
-  intros; rewrite AmultT_sym; apply Th_inv_defT; auto.
+  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
 Qed.
  
 Lemma Rmult_neq_0_reg :
  forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
 Proof.
-  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; ring.
+  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
 Qed.
 
 (************************)
@@ -276,7 +276,7 @@ Lemma merge_mult_correct :
    interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try (intros; simpl in |- *; ring).
+elim e0; try (intros; simpl in |- *; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AmultT (interp_ExprA lvar e2)
@@ -286,8 +286,8 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl in |- *; ring.
-ring.
+ simpl in |- *; legacy ring.
+legacy ring.
 Qed.
 
 Lemma assoc_mult_correct1 :
@@ -308,7 +308,7 @@ Lemma assoc_mult_correct :
 Proof.
 simple induction e; auto; intros.
 elim e0; intros.
-intros; simpl in |- *; ring.
+intros; simpl in |- *; legacy ring.
 simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
  rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
 simpl in |- *; rewrite (H0 lvar); auto.
@@ -317,9 +317,9 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
  rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
  rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
  fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
- rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1));
+ rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
  rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; 
- ring.
+ legacy ring.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
@@ -344,7 +344,7 @@ Lemma merge_plus_correct :
    interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try intros; try (simpl in |- *; ring).
+elim e0; try intros; try (simpl in |- *; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AplusT (interp_ExprA lvar e2)
@@ -354,8 +354,8 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl in |- *; ring.
-ring.
+ simpl in |- *; legacy ring.
+legacy ring.
 Qed.
 
 Lemma assoc_plus_correct :
@@ -387,7 +387,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
      (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
         (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
  rewrite
-  (AplusT_sym (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
+  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
   ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; 
  rewrite (H0 lvar);
  rewrite <-
@@ -397,10 +397,10 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
  rewrite
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
      (interp_ExprA lvar e3));
- rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3));
+ rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
  rewrite <-
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-     (interp_ExprA lvar e1)); apply AplusT_sym.
+     (interp_ExprA lvar e1)); apply AplusT_comm.
 unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
  fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
  rewrite (H0 lvar); simpl in |- *; auto.
@@ -454,8 +454,8 @@ Lemma distrib_mult_right_correct :
    AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
 Proof.
 simple induction e1; try intros; simpl in |- *; auto.
-rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
- rewrite (H0 e2 lvar); ring.
+rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
+ rewrite (H0 e2 lvar); legacy ring.
 Qed.
 
 Lemma distrib_mult_left_correct :
@@ -466,18 +466,18 @@ Proof.
 simple induction e1; try intros; simpl in |- *.
 rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
  apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. 
-rewrite AmultT_sym;
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. 
+rewrite AmultT_comm;
  rewrite
   (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
      (interp_ExprA lvar e0));
- rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e));
- rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
  rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
 Qed.
 
 Lemma distrib_correct :
@@ -491,7 +491,7 @@ simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
  unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
 simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
  unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
- simpl in |- *; fold AoppT in |- *; ring.
+ simpl in |- *; fold AoppT in |- *; legacy ring.
 Qed.
 
 (**** Multiplication by the inverse product ****)
@@ -527,7 +527,7 @@ Lemma multiply_aux_correct :
 Proof.
 simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
  auto.
-  simpl in |- *; rewrite (H0 lvar); ring.
+  simpl in |- *; rewrite (H0 lvar); legacy ring.
 Qed.
 
 Lemma multiply_correct :
@@ -595,8 +595,8 @@ simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
 rewrite e2; simpl in |- *; fold AinvT in |- *.
 rewrite <-
  (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-    (interp_ExprA lvar e1)); rewrite AinvT_r; [ ring | assumption ].
-simpl in |- *; rewrite H0; auto; ring.
+    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
+simpl in |- *; rewrite H0; auto; legacy ring.
 simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
  intros; [ inversion e1 | simpl in |- *; trivial ].
 unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
@@ -619,7 +619,7 @@ simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
 elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
  intros.
 rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
-ring.
+legacy ring.
 Qed.
 
 Lemma monom_simplif_correct :
@@ -644,3 +644,7 @@ unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
 Qed.
 
 End Theory_of_fields.
+
+(* Compatibility *)
+Notation AplusT_sym := AplusT_comm (only parsing).
+Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
index 47e583fd..dab5a45c 100644
--- a/contrib/field/field.ml4
+++ b/contrib/field/field.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: field.ml4 8866 2006-05-28 16:21:04Z herbelin $ *)
+(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *)
 
 open Names
 open Pp
@@ -86,7 +86,7 @@ let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
       Ring.add_theory true true false a None None None aplus amult aone azero
         (Some aopp) aeq rth Quote.ConstrSet.empty
      with | UserError("Add Semi Ring",_) -> ());
-    let th = mkApp ((constant ["Field_Theory"] "Build_Field_Theory"),
+    let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
       [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
     begin
       let _ = type_of (Global.env ()) Evd.empty th in ();
@@ -139,7 +139,7 @@ ARGUMENT EXTEND minus_div_arg
 END
 
 VERNAC COMMAND EXTEND Field
-  [ "Add" "Field" 
+  [ "Add" "Legacy" "Field" 
       constr(a) constr(aplus) constr(amult) constr(aone)
       constr(azero) constr(aopp) constr(aeq)
       constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
@@ -153,7 +153,7 @@ END
 
 (* Guesses the type and calls field_gen with the right theory *)
 let field g =
-  Coqlib.check_required_library ["Coq";"field";"Field"];
+  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
   let typ = 
     match Hipattern.match_with_equation (pf_concl g) with
       | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
@@ -175,7 +175,7 @@ let guess_theory env evc = function
 
 (* Guesses the type and calls Field_Term with the right theory *)
 let field_term l g =
-  Coqlib.check_required_library ["Coq";"field";"Field"];
+  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
   let env = (pf_env g)
   and evc = (project g) in
   let th = valueIn (VConstr (guess_theory env evc l))
@@ -187,7 +187,7 @@ let field_term l g =
 
 (* Declaration of Field *)
 
-TACTIC EXTEND field
-| [ "field" ] -> [ field ]
-| [ "field" ne_constr_list(l) ] -> [ field_term l ]
+TACTIC EXTEND legacy_field
+| [ "legacy" "field" ] -> [ field ]
+| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
 END
diff --git a/contrib/first-order/formula.ml b/contrib/first-order/formula.ml
index fde48d2b..0be468aa 100644
--- a/contrib/first-order/formula.ml
+++ b/contrib/first-order/formula.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.ml 7493 2005-11-02 22:12:16Z mohring $ *)
+(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Hipattern
 open Names
@@ -46,7 +46,6 @@ let rec nb_prod_after n c=
     | _ -> 0
 
 let construct_nhyps ind gls =
-  let env=pf_env gls in
   let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
   let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in 
   let hyp = nb_prod_after nparams in	
diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4
index f9c4cea2..366f563b 100644
--- a/contrib/first-order/g_ground.ml4
+++ b/contrib/first-order/g_ground.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
-(* $Id: g_ground.ml4 8752 2006-04-27 19:37:33Z herbelin $ *)
+(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Formula
 open Sequent
@@ -24,7 +24,7 @@ open Libnames
 
 (* declaring search depth as a global option *)
 
-let ground_depth=ref 5
+let ground_depth=ref 3
 
 let _=
   let gdopt=
@@ -34,13 +34,28 @@ let _=
       optread=(fun ()->Some !ground_depth); 
       optwrite=
    (function 
-	None->ground_depth:=5
+	None->ground_depth:=3
       |	Some i->ground_depth:=(max i 0))}
   in
     declare_int_option gdopt
-      
+
+let congruence_depth=ref 100
+
+let _=
+  let gdopt=
+    { optsync=true;
+      optname="Congruence Depth";
+      optkey=SecondaryTable("Congruence","Depth"); 
+      optread=(fun ()->Some !congruence_depth); 
+      optwrite=
+   (function 
+	None->congruence_depth:=0
+      |	Some i->congruence_depth:=(max i 0))}
+  in
+    declare_int_option gdopt
+
 let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
-    
+
 let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
 		      
 type external_env=
@@ -94,3 +109,19 @@ TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
      [ gen_ground_tac false (option_map eval_tactic t) Void ]
 END
+
+
+let default_declarative_automation gls = 
+  tclORELSE 
+    (Cctac.congruence_tac !congruence_depth []) 
+    (gen_ground_tac true 
+       (Some (tclTHEN
+		default_solver
+		(Cctac.congruence_tac !congruence_depth [])))
+       Void) gls
+
+
+
+let () = 
+  Decl_proof_instr.register_automation_tac default_declarative_automation
+
diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v
index 8836b76e..1a1a5055 100644
--- a/contrib/fourier/Fourier.v
+++ b/contrib/fourier/Fourier.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *)
 
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
@@ -17,7 +17,7 @@ Declare ML Module "fourierR".
 Declare ML Module "field".
 
 Require Export Fourier_util.
-Require Export Field.
+Require Export LegacyField.
 Require Export DiscrR.
 
 Ltac fourier := abstract (fourierz; field; discrR).
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
index 7977d4e0..14e2233f 100644
--- a/contrib/funind/functional_principles_proofs.ml
+++ b/contrib/funind/functional_principles_proofs.ml
@@ -39,12 +39,12 @@ let do_observe_tac s tac g =
 	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
    raise e;;
 
-
-let observe_tac s tac g =
+let observe_tac_stream s tac g = 
   if do_observe ()
-  then do_observe_tac (str s) tac g
+  then do_observe_tac  s tac g
   else tac g
 
+let observe_tac s tac g = observe_tac_stream (str s) tac g
 
 let tclTRYD tac = 
   if  !Options.debug  || do_observe ()
@@ -179,10 +179,11 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta
 let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  = 
   let nochange msg  = 
     begin 
-(*       observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t    ); *)
+      observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t    );
       failwith "NoChange"; 
     end
   in    
+  let eq_constr = Reductionops.is_conv env sigma in 
   if not (noccurn 1 end_of_type)
   then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
     if not (isApp t) then nochange "not an equality";
@@ -194,6 +195,7 @@ let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  =
     in 
     if not (closed0 t1) then nochange "not a closed lhs";    
     let rec compute_substitution sub t1 t2 = 
+      observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2);
       if isRel t2 
       then 
 	let t2 = destRel t2  in 
@@ -313,9 +315,13 @@ let h_reduce_with_zeta =
 
 
 let rewrite_until_var arg_num eq_ids : tactic =
+  (* tests if the declares recursive argument is neither a Constructor nor 
+     an applied Constructor since such a form for the recursive argument 
+     will break the Guard when trying to save the Lemma. 
+  *)
   let test_var g = 
     let _,args = destApp (pf_concl g) in 
-    not (isConstruct args.(arg_num))
+    not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
   in
   let rec do_rewrite eq_ids g  = 
     if test_var g 
@@ -499,7 +505,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
     tclTHENLIST 
       [
 	tac ;
-	(continue_tac new_infos)
+	observe_tac "clean_hyp_with_heq continue" (continue_tac new_infos)
       ]
       g    
 
@@ -779,7 +785,7 @@ let build_proof
       finish_proof dyn_infos)
   in
   observe_tac "build_proof"
-    (build_proof do_finish_proof dyn_infos) 
+    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) 
 
 
 
@@ -884,7 +890,8 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 (*   observe (str "f_body_with_params_and_other_fun " ++  pr_lconstr f_body_with_params_and_other_fun); *)
   let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
 (*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
-  let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) f_def.const_type in
+  let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) 
+    (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
   let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
   let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
   let f_id = id_of_label (con_label (destConst f)) in
@@ -1332,10 +1339,11 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic =
 	      h_intro hid;
 	      Elim.h_decompose_and (mkVar hid); 
 	      backtrack_eqs_until_hrec hrec eqs;
-	      tclCOMPLETE (tclTHENS  (* We must have exactly ONE subgoal !*)
-		(apply (mkVar hrec))
-		[ tclTHENSEQ 
-		    [
+	      observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" )
+		(tclTHENS  (* We must have exactly ONE subgoal !*)
+		   (apply (mkVar hrec))
+		   [ tclTHENSEQ 
+		       [
 			 thin [hrec];
 			 apply (Lazy.force acc_inv);
 			 (fun g -> 
@@ -1344,11 +1352,12 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic =
 			      unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g 
 			    else tclIDTAC g
 			 );
-			 tclTRY(Recdef.list_rewrite true eqs);
-			 observe_tac "finishing"  (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some [])))
+			 observe_tac "rew_and_finish"
+			   (tclTHEN 
+			      (tclTRY(Recdef.list_rewrite true eqs))
+			      (observe_tac "finishing"  (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some [])))))
 		       ]
-		]
-			  )
+		])
 	    ])
 	    gls
 
@@ -1371,7 +1380,7 @@ let is_valid_hypothesis predicates_name =
 	| _ -> false 
   in
   is_valid_hypothesis 
-
+(*
 let fresh_id avoid na = 
   let id =  
     match na with 
@@ -1450,7 +1459,7 @@ let prove_principle_for_gen
     let wf_tac = 
       if is_mes 
       then 
-	Recdef.tclUSER_if_not_mes 
+	(fun b -> Recdef.tclUSER_if_not_mes b None)
       else fun _ -> prove_with_tcc tcc_lemma_ref []
     in
     let start_tac g = 
@@ -1543,7 +1552,7 @@ let prove_principle_for_gen
 		   let pte_info = 
 		     { proving_tac =
 			 (fun eqs -> 
-			    observe_tac "prove_with_tcc" 
+			    observe_tac "new_prove_with_tcc" 
 			      (new_prove_with_tcc is_mes acc_inv hrec  tcc_lemma_ref (List.map mkVar eqs))
 			 );
 		       is_valid = is_valid_hypothesis predicates_names 
@@ -1583,13 +1592,160 @@ let prove_principle_for_gen
 	 arg_tac;
 	 start_tac
 	] g
+*)
 
-
-
-
-
-
-
+let prove_principle_for_gen
+    (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
+    rec_arg_num rec_arg_type relation gl = 
+  let princ_type = pf_concl gl in 
+  let princ_info = compute_elim_sig princ_type in 
+  let fresh_id = 
+    let avoid = ref (pf_ids_of_hyps gl) in 
+    fun na -> 
+      let new_id = 
+	  match na with 
+	    | Name id -> fresh_id !avoid (string_of_id id) 
+	    | Anonymous -> fresh_id !avoid "H" 
+      in
+      avoid := new_id :: !avoid;
+      Name new_id
+  in
+  let fresh_decl (na,b,t) = (fresh_id na,b,t) in
+  let princ_info : elim_scheme = 
+    { princ_info with 
+	params = List.map fresh_decl princ_info.params;
+	predicates = List.map fresh_decl princ_info.predicates; 
+	branches = List.map fresh_decl princ_info.branches; 
+	args = List.map fresh_decl princ_info.args
+    }
+  in
+  let wf_tac = 
+    if is_mes 
+    then 
+      (fun b -> Recdef.tclUSER_if_not_mes b None)
+    else fun _ -> prove_with_tcc tcc_lemma_ref []
+  in
+  let real_rec_arg_num = rec_arg_num - princ_info.nparams in 
+  let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in 
+  let (post_rec_arg,pre_rec_arg) = 
+    Util.list_chop npost_rec_arg princ_info.args
+  in
+  let rec_arg_id = 
+    match post_rec_arg with 
+      | (Name id,_,_)::_ -> id 
+      | _ -> assert false 
+  in
+  let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in 
+  let relation = substl subst_constrs relation in 
+  let input_type = substl subst_constrs rec_arg_type in 
+  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in 
+  let acc_rec_arg_id = 
+    Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
+  in 
+  let revert l = 
+    tclTHEN (h_generalize (List.map mkVar l)) (clear l) 
+  in
+  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in 
+  let prove_rec_arg_acc g = 
+      (observe_tac "prove_rec_arg_acc" 
+	 (tclCOMPLETE
+	    (tclTHEN
+	       (forward 
+		  (Some ((fun g -> observe_tac "prove wf" (tclCOMPLETE (wf_tac is_mes)) g)))
+		  (Genarg.IntroIdentifier wf_thm_id)
+		  (mkApp (delayed_force well_founded,[|input_type;relation|])))
+	       (
+		 observe_tac 
+		   "apply wf_thm" 
+		   (h_apply ((mkApp(mkVar wf_thm_id,
+				    [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+		   )
+	       )
+	    )
+	 )
+      )
+      g
+  in
+  let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
+  tclTHENSEQ
+    [ 
+      h_intros 
+	(List.rev_map (fun (na,_,_) -> Nameops.out_name na) 
+	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
+	);
+      observe_tac "" (forward
+	 (Some (prove_rec_arg_acc))
+	 (Genarg.IntroIdentifier acc_rec_arg_id)
+ 	 (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
+      );
+      observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids)));
+      observe_tac "h_fix" (h_fix (Some fix_id) (real_rec_arg_num + 1)); 
+      h_intros (List.rev (acc_rec_arg_id::args_ids));
+      Equality.rewriteLR (mkConst eq_ref);
+      observe_tac "finish" (fun gl' -> 
+	 let body = 
+	   let _,args = destApp (pf_concl gl') in 
+	   array_last args
+	 in
+	 let body_info rec_hyps = 
+	   {
+	     nb_rec_hyps = List.length rec_hyps;
+	     rec_hyps = rec_hyps;
+	     eq_hyps = [];
+	     info = body
+	   }
+	 in 
+	 let acc_inv = 
+	   lazy (
+	     mkApp (
+	       delayed_force acc_inv_id,
+	       [|input_type;relation;mkVar rec_arg_id|]
+	     )
+	   )
+	 in
+	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
+	 let predicates_names = 
+	   List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
+	 in
+	 let pte_info = 
+	   { proving_tac =
+	       (fun eqs -> 
+		  observe_tac "new_prove_with_tcc" 
+		    (new_prove_with_tcc 
+		       is_mes acc_inv fix_id tcc_lemma_ref (List.map mkVar eqs)
+		    )
+	       );
+	     is_valid = is_valid_hypothesis predicates_names
+	   }
+	 in
+	 let ptes_info : pte_info Idmap.t = 
+	   List.fold_left
+	     (fun map pte_id -> 
+		Idmap.add pte_id 
+		  pte_info			       
+		  map
+	     )
+	     Idmap.empty
+	     predicates_names
+	 in
+	 let make_proof rec_hyps = 
+	   build_proof 
+	     false 
+	     [f_ref]
+	     ptes_info
+	     (body_info rec_hyps)
+	 in
+	 observe_tac "instanciate_hyps_with_args" 
+	   (instanciate_hyps_with_args 
+	      make_proof
+	      (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
+	      (List.rev args_ids)
+	   )
+	   gl'
+      )
+			   
+    ]
+    gl    
 
 
 
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
index f83eae8d..89ebb75a 100644
--- a/contrib/funind/functional_principles_types.ml
+++ b/contrib/funind/functional_principles_types.ml
@@ -301,9 +301,18 @@ let pp_dur time time' =
   str (string_of_float (System.time_difference time time'))
 
 (* let qed () = save_named true  *)
-let defined () = Command.save_named false
-
-
+let defined () = 
+  try 
+    Command.save_named false 
+  with 
+    | UserError("extract_proof",msg) ->
+	Util.errorlabstrm
+	  "defined"
+	  ((try
+	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
+	    with _ -> mt ()
+	   ) ++msg)
+    | e -> raise e
 
 
 
@@ -346,6 +355,7 @@ let generate_functional_principle
     interactive_proof
     old_princ_type sorts new_princ_name funs i proof_tac
     =
+  try 
   let f = funs.(i) in
   let type_sort = Termops.new_sort_in_family InType in
   let new_sorts =
@@ -384,6 +394,9 @@ let generate_functional_principle
 	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
 	    )
 	);
+	Options.if_verbose 
+	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) 
+	  name;
 	names := name :: !names
       in
       register_with_sort InProp;
@@ -393,6 +406,10 @@ let generate_functional_principle
     build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook 
   in
   save false new_princ_name entry g_kind hook
+  with 
+    | Defining_principle _ as e -> raise e
+    | e -> raise (Defining_principle e)
+
 (*   defined  () *)
 
 
@@ -591,13 +608,6 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
     const::other_result
 
 let build_scheme fas = 
-(*         (fun (f,_) ->  *)
-(* 	 try Libnames.constr_of_global (Nametab.global f) *)
-(* 	 with Not_found ->  *)
-(* 	   Util.error ("Cannot find "^ Libnames.string_of_reference f) *)
-(*       ) *)
-(*       fas *)
-
   let bodies_types = 
     make_scheme 
       (List.map 
diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
index dffc8120..82bb2869 100644
--- a/contrib/funind/indfun.ml
+++ b/contrib/funind/indfun.ml
@@ -39,7 +39,8 @@ let functional_induction with_clean c princl pat =
 		      let finfo = (* we first try to find out a graph on f *)
 			try find_Function_infos c' 
 			with Not_found -> 
-			  errorlabstrm "" (str "Cannot find induction information on "++Printer.pr_lconstr (mkConst c') )
+			  errorlabstrm "" (str "Cannot find induction information on "++
+					     Printer.pr_lconstr (mkConst c') )
 		      in
 		      match Tacticals.elimination_sort_of_goal g with 
 			| InProp -> finfo.prop_lemma
@@ -49,8 +50,9 @@ let functional_induction with_clean c princl pat =
 		    let princ =  (* then we get the principle *)
 		      try mkConst (out_some princ_option )
 		      with Failure "out_some" -> 
-			(*i If there is not default lemma defined then, we cross our finger and try to 
-		    find a lemma named f_ind (or f_rec, f_rect) i*)
+			(*i If there is not default lemma defined then, 
+			  we cross our finger and try to find a lemma named f_ind 
+			  (or f_rec, f_rect) i*)
 			let princ_name = 
 			  Indrec.make_elimination_ident
 			    (id_of_label (con_label c'))
@@ -90,45 +92,45 @@ let functional_induction with_clean c princl pat =
     let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in 
     let old_idl = Idset.diff old_idl princ_vars in 
     let subst_and_reduce g = 
-      let idl = 
-	map_succeed 
-	  (fun id -> 
-	    if Idset.mem id old_idl then failwith "subst_and_reduce";
-	    id 
-	  )
-	  (Tacmach.pf_ids_of_hyps g)
-      in 
-      let flag = 
-	Rawterm.Cbv
-	  {Rawterm.all_flags 
-	  with Rawterm.rDelta = false; 		 
-	  }
-      in
       if with_clean 
       then
+	let idl = 
+	  map_succeed 
+	    (fun id -> 
+	       if Idset.mem id old_idl then failwith "subst_and_reduce";
+	       id 
+	    )
+	    (Tacmach.pf_ids_of_hyps g)
+	in 
+	let flag = 
+	  Rawterm.Cbv
+	    {Rawterm.all_flags 
+	     with Rawterm.rDelta = false; 		 
+	    }
+	in
 	Tacticals.tclTHEN
 	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
 	  (Hiddentac.h_reduce flag Tacticals.allClauses)	
 	  g
       else Tacticals.tclIDTAC g 
-
+	
     in
     Tacticals.tclTHEN
       (choose_dest_or_ind 
-	princ_infos
-	args_as_induction_constr
-	princ'
-	pat)
+	 princ_infos
+	 args_as_induction_constr
+	 princ'
+	 pat)
       subst_and_reduce
       g
-
-
+      
+      
 
 
 type annot = 
     Struct of identifier 
-  | Wf of Topconstr.constr_expr * identifier option
-  | Mes of Topconstr.constr_expr * identifier option
+  | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
+  | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
 
 
 type newfixpoint_expr =
@@ -184,7 +186,7 @@ let build_newrecursive
 	States.unfreeze fs; raise e in
     States.unfreeze fs; def
   in
-  recdef
+  recdef,rec_impls
 	
 
 let compute_annot (name,annot,args,types,body) =
@@ -238,29 +240,47 @@ let prepare_body (name,annot,args,types,body) rt =
   (fun_args,rt')
 
 
-let derive_inversion fix_names = 
-  try
-    Invfun.derive_correctness 
-      Functional_principles_types.make_scheme
-      functional_induction 
-	  (List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names)
-      (*i The next call to mk_rel_id is valid since we have just construct the graph 
-	Ensures by : register_built
-	i*) 
-      (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names)
-  with e -> 
-    msg_warning (str "Cannot define correction of function and graph" ++ Cerrors.explain_exn e)
-	  
+let derive_inversion fix_names =
+  try 
+    (* we first transform the fix_names identifier into their corresponding constant *)
+    let fix_names_as_constant = 
+      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names 
+    in 
+    (* 
+       Then we check that the graphs have been defined 
+       If one of the graphs haven't been defined 
+       we do nothing
+    *)
+    List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
+    try
+      Invfun.derive_correctness 
+	Functional_principles_types.make_scheme
+	functional_induction 
+	fix_names_as_constant
+	(*i The next call to mk_rel_id is valid since we have just construct the graph 
+	  Ensures by : register_built
+	  i*) 
+	(List.map
+	   (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
+	   fix_names
+	)
+    with e -> 
+      msg_warning 
+	(str "Cannot built inversion information" ++ 
+	   if do_observe () then Cerrors.explain_exn e else mt ())
+  with _ -> ()
+
 let generate_principle 
-    do_built fix_rec_l recdefs  interactive_proof parametrize 
-    (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit =
+    is_general do_built fix_rec_l recdefs  interactive_proof 
+    (continue_proof : int -> Names.constant array -> Term.constr array -> int -> 
+      Tacmach.tactic) : unit =
   let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in
   let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
   let funs_args = List.map fst fun_bodies in
   let funs_types =  List.map (function (_,_,_,types,_) -> types) fix_rec_l in
   try 
     (* We then register the Inductive graphs of the functions  *)
-    Rawterm_to_relation.build_inductive parametrize names funs_args funs_types recdefs;
+    Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
     if do_built 
     then
       begin
@@ -286,8 +306,7 @@ let generate_principle
 	  list_map_i
 	    (fun i x ->
 	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in 
-	       let princ_type = 
-		 (Global.lookup_constant princ).Declarations.const_type
+	       let princ_type = Typeops.type_of_constant (Global.env()) princ
 	       in
 	       Functional_principles_types.generate_functional_principle
 		 interactive_proof 
@@ -301,12 +320,22 @@ let generate_principle
 	    0
 	    fix_rec_l
 	in 
-	Array.iter add_Function funs_kn;
+	Array.iter (add_Function is_general) funs_kn;
 	()
       end
   with e -> 
-    Pp.msg_warning (Cerrors.explain_exn e) 
-
+    match e with 
+      | Building_graph e -> 
+	    Pp.msg_warning 
+	    (str "Cannot define graph(s) for " ++ 
+	       h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	       if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
+      | Defining_principle e -> 
+	    Pp.msg_warning
+	    (str "Cannot define principle(s) for "++ 
+	       h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	       if do_observe () then Cerrors.explain_exn e else mt ())
+      | _ -> anomaly ""
 
 let register_struct is_rec fixpoint_exprl = 
   match fixpoint_exprl with 
@@ -330,7 +359,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref
     tcc_lemma_ref is_mes  rec_arg_num rec_arg_type relation
 
 
-let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body
+let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
     pre_hook 
     =  
   let type_of_f = Command.generalize_constr_expr ret_type args in 
@@ -349,13 +378,13 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body
   in
   let unbounded_eq = 
     let f_app_args = 
-      Topconstr.CApp 
+      Topconstr.CAppExpl 
 	(dummy_loc, 
-	 (None,Topconstr.mkIdentC fname) ,
+	 (None,(Ident (dummy_loc,fname))) ,
 	 (List.map 
 	    (function
 	       | _,Anonymous -> assert false 
-	       | _,Name e -> (Topconstr.mkIdentC e,None)
+	       | _,Name e -> (Topconstr.mkIdentC e)
 	    ) 
 	    (Topconstr.names_of_local_assums args)
 	 )
@@ -365,7 +394,8 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body
 		    [(f_app_args,None);(body,None)])
   in
   let eq = Command.generalize_constr_expr unbounded_eq args in 
-  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation =
+  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
+      nb_args relation =
     try 
       pre_hook 
 	(generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
@@ -377,15 +407,16 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body
       ()
   in 
   Recdef.recursive_definition 
-    is_mes fname 
+    is_mes fname rec_impls
     type_of_f
     wf_rel_expr
     rec_arg_num
     eq
     hook
+    using_lemmas
 
     
-let register_mes fname wf_mes_expr wf_arg args ret_type body = 
+let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = 
   let wf_arg_type,wf_arg = 
     match wf_arg with 
       | None -> 
@@ -424,35 +455,38 @@ let register_mes fname wf_mes_expr wf_arg args ret_type body =
   let wf_rel_from_mes = 
     Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
   in
-  register_wf ~is_mes:true fname wf_rel_from_mes (Some wf_arg) args ret_type body
+  register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) 
+    using_lemmas args ret_type body
 	  
 
 let do_generate_principle register_built interactive_proof fixpoint_exprl  = 
-  let recdefs = build_newrecursive fixpoint_exprl in 
+  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in 
   let _is_struct = 
     match fixpoint_exprl with 
-      | [((name,Some (Wf (wf_rel,wf_x)),args,types,body))] -> 
+      | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> 
 	  let pre_hook = 
 	    generate_principle 
+	      true
 	      register_built
 	      fixpoint_exprl 
 	      recdefs
 	      true
-	      false
 	  in 
-	  if register_built then register_wf name wf_rel wf_x args types body pre_hook;
+	  if register_built 
+	  then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
 	  false
-      | [((name,Some (Mes (wf_mes,wf_x)),args,types,body))] -> 
+      | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> 
 	  let pre_hook = 
 	    generate_principle 
+	      true
 	      register_built
 	      fixpoint_exprl 
 	      recdefs
 	      true
-	      false
 	  in 
-	  if register_built then register_mes name wf_mes wf_x args types body pre_hook;
-	  false
+	  if register_built 
+	  then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
+	  true
       | _ -> 
 	  let fix_names = 
 	    List.map (function (name,_,_,_,_) -> name) fixpoint_exprl 
@@ -469,7 +503,9 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl  =
 		     in 
 		     let annot = 
 		       try Some (list_index (Name id) names - 1), Topconstr.CStructRec 
-		       with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id)) 
+		       with Not_found -> 
+			 raise (UserError("",str "Cannot find argument " ++ 
+					    Ppconstr.pr_id id)) 
 		     in 
  		     (name,annot,args,types,body),(None:Vernacexpr.decl_notation) 
 		 | (name,None,args,types,body),recdef -> 
@@ -479,10 +515,11 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl  =
 			 (dummy_loc,"Function",
 			  Pp.str "the recursive argument needs to be specified in Function")
 		     else 
-		       (name,(Some 0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation)
+		       (name,(Some 0, Topconstr.CStructRec),args,types,body),
+		     (None:Vernacexpr.decl_notation)
 		 | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> 
 		     error 
-		       ("Cannot use mutual definition with well-founded recursion")
+		       ("Cannot use mutual definition with well-founded recursion or measure")
 	      ) 
 	      (List.combine fixpoint_exprl recdefs)
 	  in
@@ -493,13 +530,13 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl  =
 	  let is_rec = List.exists (is_rec fix_names) recdefs in
 	  if register_built then register_struct is_rec old_fixpoint_exprl;
 	  generate_principle
+	    false
 	    register_built
 	    fixpoint_exprl
 	    recdefs 
 	    interactive_proof
-	    true
 	    (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
-	  if register_built then derive_inversion  fix_names;
+	  if register_built then derive_inversion fix_names;
 	  true;
   in
   ()
@@ -517,9 +554,13 @@ let rec add_args id new_args b =
   | CArrow(loc,b1,b2) -> 
       CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
   | CProdN(loc,nal,b1) -> 
-      CProdN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, add_args id new_args  b1)
+      CProdN(loc,
+	     List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, 
+	     add_args id new_args  b1)
   | CLambdaN(loc,nal,b1) -> 
-      CLambdaN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args  b2)) nal, add_args id new_args  b1)
+      CLambdaN(loc,
+	       List.map (fun (nal,b2) -> (nal,add_args id new_args  b2)) nal, 
+	       add_args id new_args  b1)
   | CLetIn(loc,na,b1,b2) -> 
       CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
   | CAppExpl(loc,(pf,r),exprl) -> 
@@ -530,10 +571,13 @@ let rec add_args id new_args b =
 	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
       end
   | CApp(loc,(pf,b),bl) -> 
-      CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl)
+      CApp(loc,(pf,add_args id new_args b), 
+	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
   | CCases(loc,b_option,cel,cal) -> 
       CCases(loc,option_map (add_args id new_args) b_option,
-	     List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,option_map (add_args id new_args) b_option)) cel, 
+	     List.map (fun (b,(na,b_option)) -> 
+			 add_args id new_args b,
+			 (na,option_map (add_args id new_args) b_option)) cel, 
 	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
 	    )
   | CLetTuple(loc,nal,(na,b_option),b1,b2) -> 
@@ -558,7 +602,63 @@ let rec add_args id new_args b =
   | CPrim _ -> b
   | CDelimiters _ -> anomaly "add_args : CDelimiters"
   | CDynamic _ -> anomaly "add_args : CDynamic"
+exception Stop of  Topconstr.constr_expr
+
+
+(* [chop_n_arrow n t] chops the [n] first arrows in [t] 
+   Acts on Topconstr.constr_expr 
+*)
+let rec chop_n_arrow n t = 
+  if n <= 0 
+  then t (* If we have already removed all the arrows then return the type *)
+  else (* If not we check the form of [t] *) 
+    match t with 
+      | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
+	  chop_n_arrow (n-1) t
+      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : 
+					     either we need to discard more than the number of arrows contained
+					     in this product declaration then we just recall [chop_n_arrow] on
+					     the remaining number of arrow to chop and [t'] we discard it and 
+					     recall [chop_n_arrow], either this product contains more arrows 
+					     than the number we need to chop and then we return the new type
+					  *)
+	  begin 
+	    try 
+	      let new_n =
+		let rec aux (n:int) = function 
+		    [] -> n
+		| (nal,t'')::nal_ta' -> 
+		    let nal_l = List.length nal in 
+		    if n >= nal_l
+		    then 
+		      aux (n - nal_l) nal_ta'
+		    else 
+		      let new_t' = Topconstr.CProdN(dummy_loc,((snd (list_chop n nal)),t'')::nal_ta',t')
+		      in 
+		      raise (Stop new_t')
+		in
+		aux n nal_ta'
+	    in 
+	      chop_n_arrow new_n t'
+	    with Stop t -> t
+	  end
+      | _ -> anomaly "Not enough products"
+  
 
+let rec get_args b t : Topconstr.local_binder list * 
+    Topconstr.constr_expr * Topconstr.constr_expr = 
+  match b with 
+    | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
+	begin
+	  let n = 
+	    (List.fold_left (fun n (nal,_) -> 
+			       n+List.length nal) 0 nal_ta )
+	  in
+	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
+	  (List.map (fun (nal,ta) -> 
+		       (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' 
+	end
+    | _ -> [],b,t
 
 
 let make_graph (f_ref:global_reference) =
@@ -578,68 +678,14 @@ let make_graph (f_ref:global_reference) =
 	let env = Global.env () in
 	let body = (force b) in
 	let extern_body,extern_type = 
-	  let old_implicit_args = Impargs.is_implicit_args ()
-	  and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
-	  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
-	  let old_rawprint = !Options.raw_print in 
-	  Options.raw_print := true;
-	  Impargs.make_implicit_args false;
-	  Impargs.make_strict_implicit_args false;
-	  Impargs.make_contextual_implicit_args false;
-	  try 
-	    let res =  Constrextern.extern_constr false env body in 
-	    let res' = Constrextern.extern_type false env  c_body.const_type in 
-	    Impargs.make_implicit_args old_implicit_args;
-	    Impargs.make_strict_implicit_args old_strict_implicit_args;
-	    Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-	    Options.raw_print := old_rawprint;
-	    res,res'
-	  with
-	    | UserError(s,msg) as e -> 
-		Impargs.make_implicit_args old_implicit_args;
-		Impargs.make_strict_implicit_args old_strict_implicit_args;
-		Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-		Options.raw_print := old_rawprint;
-		raise e
-	    | e -> 
-		Impargs.make_implicit_args old_implicit_args;
-		Impargs.make_strict_implicit_args old_strict_implicit_args;
-		Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-		Options.raw_print := old_rawprint;
-		raise e
-	in
-	let rec get_args b t : Topconstr.local_binder list * 
-	    Topconstr.constr_expr * Topconstr.constr_expr = 
-(* 	  Pp.msgnl (str "body: " ++Ppconstr.pr_lconstr_expr b); *)
-(* 	  Pp.msgnl (str "type: " ++ Ppconstr.pr_lconstr_expr t); *)
-(* 	  Pp.msgnl (fnl ()); *)
-	  match b with 
-	    | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
-		begin
-		  let n = 
-		    (List.fold_left (fun n (nal,_) -> 
-				       n+List.length nal) 0 nal_ta )
-		  in
-		  let rec chop_n_arrow n t = 
-		    if n > 0 
-		    then 
-		      match t with 
-			| Topconstr.CArrow(_,_,t) -> chop_n_arrow (n-1) t 
-			| Topconstr.CProdN(_,nal_ta',t') -> 
-			    let n' = 
-			      List.fold_left 
-				(fun n (nal,t'') -> 
-				   n+List.length nal) n nal_ta' 
-			    in
-(* 			    assert (n'<= n);  *)
-			    chop_n_arrow (n - n') t'
-			| _ -> anomaly "Not enough products"
-		    else t
-		  in 
-		  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
-		  (List.map (fun (nal,ta) -> (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' 
-		end
-	    | _ -> [],b,t
+	  with_full_print 
+	    (fun () -> 
+	       (Constrextern.extern_constr false env body, 
+		Constrextern.extern_type false env
+                  (Typeops.type_of_constant_type env c_body.const_type)
+	       )
+	    )
+	    ()
 	in
 	let (nal_tas,b,t)  = get_args extern_body extern_type in
 	let expr_list = 
@@ -659,7 +705,8 @@ let make_graph (f_ref:global_reference) =
 			   )
 		       in 
 		       let rec_id = 
-			 match List.nth bl' (out_some n)  with |(_,Name id) -> id | _ -> anomaly ""
+			 match List.nth bl' (out_some n)  with 
+			   |(_,Name id) -> id | _ -> anomaly ""
 		       in
 		       let new_args = 
 			 List.flatten 
@@ -667,7 +714,10 @@ let make_graph (f_ref:global_reference) =
 			      (function
  				 | Topconstr.LocalRawDef (na,_)-> []
 			      	 | Topconstr.LocalRawAssum (nal,_) -> 
-				     List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal
+				     List.map 
+				       (fun (loc,n) -> 
+					  CRef(Libnames.Ident(loc, Nameops.out_name n))) 
+				       nal
 			      )
 			      nal_tas
 			   )
@@ -685,7 +735,9 @@ let make_graph (f_ref:global_reference) =
 	do_generate_principle false false expr_list;
 	(* We register the infos *)
 	let mp,dp,_ = repr_con c in 
-	List.iter (fun (id,_,_,_,_) -> add_Function (make_con mp dp (label_of_id id))) expr_list
+	List.iter 
+	  (fun (id,_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) 
+	  expr_list
 
 
 (* let make_graph _ = assert false	 *)
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
index f41aac20..13b242d5 100644
--- a/contrib/funind/indfun_common.ml
+++ b/contrib/funind/indfun_common.ml
@@ -5,8 +5,8 @@ open Libnames
 
 let mk_prefix pre id = id_of_string (pre^(string_of_id id))
 let mk_rel_id = mk_prefix "R_"
-let mk_correct_id id = Nameops.add_suffix id "_correct"
-let mk_complete_id id = Nameops.add_suffix id "_complete"
+let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
+let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
 let mk_equation_id id = Nameops.add_suffix id "_equation"
 
 let msgnl m =
@@ -233,6 +233,32 @@ let get_proof_clean do_reduce =
   Pfedit.delete_current_proof ();
   result
 
+let with_full_print f a = 
+  let old_implicit_args = Impargs.is_implicit_args ()
+  and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
+  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+  let old_rawprint = !Options.raw_print in 
+  Options.raw_print := true;
+  Impargs.make_implicit_args false;
+  Impargs.make_strict_implicit_args false;
+  Impargs.make_contextual_implicit_args false;
+  try 
+    let res = f a in 
+    Impargs.make_implicit_args old_implicit_args;
+    Impargs.make_strict_implicit_args old_strict_implicit_args;
+    Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+    Options.raw_print := old_rawprint;
+    res
+  with  
+    | e -> 
+	Impargs.make_implicit_args old_implicit_args;
+	Impargs.make_strict_implicit_args old_strict_implicit_args;
+	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+	Options.raw_print := old_rawprint;
+	raise e
+
+
+
 
 
 
@@ -248,14 +274,18 @@ type function_info =
       rect_lemma : constant option;
       rec_lemma : constant option;
       prop_lemma : constant option;
+      is_general : bool; (* Has this function been defined using general recursive definition *)
     }
       
 
-type function_db  = function_info list
+(* type function_db  = function_info list *)
+
+(* let function_table = ref ([] : function_db) *)
 
-let function_table = ref ([] : function_db)
-  
 
+let from_function = ref Cmap.empty
+let from_graph = ref Indmap.empty
+(*
 let rec do_cache_info finfo = function 
   | [] -> raise Not_found 
   | (finfo'::finfos as l) -> 
@@ -274,6 +304,12 @@ let cache_Function (_,(finfos)) =
   in  
   if new_tbl != !function_table 
   then function_table := new_tbl
+*)
+
+let cache_Function (_,finfos) = 
+  from_function := Cmap.add finfos.function_constant finfos !from_function;
+  from_graph := Indmap.add finfos.graph_ind finfos !from_graph
+
 
 let load_Function _  = cache_Function
 let open_Function _ = cache_Function
@@ -307,6 +343,7 @@ let subst_Function (_,subst,finfos) =
       rect_lemma = rect_lemma' ;
       rec_lemma = rec_lemma';
       prop_lemma = prop_lemma';
+      is_general = finfos.is_general
     }
 
 let classify_Function (_,infos) = Libobject.Substitute infos
@@ -342,6 +379,7 @@ let discharge_Function (_,finfos) =
 	   rect_lemma = rect_lemma';
 	   rec_lemma = rec_lemma';
 	   prop_lemma = prop_lemma' ;
+	   is_general = finfos.is_general
 	 }    
 
 open Term
@@ -357,7 +395,8 @@ let pr_info f_info =
     str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
     str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () 
 
-let pr_table l = 
+let pr_table tb = 
+  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in 
   Util.prlist_with_sep fnl pr_info l
 
 let in_Function,out_Function = 
@@ -376,17 +415,16 @@ let in_Function,out_Function =
 
 (* Synchronisation with reset *)
 let freeze () = 
-  let tbl = !function_table in 
-(*   Pp.msgnl (str "freezing function_table : " ++ pr_table tbl); *)
-  tbl
-
-let unfreeze l = 
+  !from_function,!from_graph
+let unfreeze (functions,graphs) = 
 (*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
-  function_table :=
- l
+  from_function := functions;
+  from_graph := graphs
+
 let init () = 
 (*   Pp.msgnl (str "reseting function_table");  *)
-  function_table := []
+  from_function := Cmap.empty;
+  from_graph := Indmap.empty
 
 let _ = 
   Summary.declare_summary "functions_db_sum"
@@ -405,18 +443,18 @@ let find_or_none id =
 
 
 let find_Function_infos f = 
-  List.find (fun finfo ->  finfo.function_constant = f) !function_table
+  Cmap.find f !from_function
 
 
 let find_Function_of_graph ind = 
-  List.find (fun finfo ->  finfo.graph_ind = ind) !function_table
+  Indmap.find ind !from_graph
   
 let update_Function finfo = 
 (*   Pp.msgnl (pr_info finfo); *)
   Lib.add_anonymous_leaf (in_Function finfo)
       
   
-let add_Function f = 
+let add_Function is_general f = 
   let f_id = id_of_label (con_label f) in 
   let equation_lemma = find_or_none (mk_equation_id f_id)
   and correctness_lemma = find_or_none (mk_correct_id f_id) 
@@ -436,12 +474,14 @@ let add_Function f =
       rect_lemma = rect_lemma;
       rec_lemma = rec_lemma;
       prop_lemma = prop_lemma;
-      graph_ind = graph_ind
+      graph_ind = graph_ind;
+      is_general = is_general
+      
     }
   in
   update_Function finfos
 
-let pr_table () = pr_table !function_table
+let pr_table () = pr_table !from_function
 (*********************************)
 (* Debuging *)
 let function_debug = ref false 
@@ -464,3 +504,5 @@ let do_observe () =
       
       
     
+exception Building_graph of exn 
+exception Defining_principle of exn
diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli
index 00e1ce8d..7da1d6f0 100644
--- a/contrib/funind/indfun_common.mli
+++ b/contrib/funind/indfun_common.mli
@@ -73,6 +73,12 @@ val get_proof_clean : bool ->
     
 
 
+(* [with_full_print f a] applies [f] to [a] in full printing environment 
+   
+   This function preserves the print settings 
+*)
+val with_full_print : ('a -> 'b) -> 'a -> 'b
+
 
 (*****************)
 
@@ -86,12 +92,13 @@ type function_info =
       rect_lemma : constant option;
       rec_lemma : constant option;
       prop_lemma : constant option;
+      is_general : bool;
     }
 
 val find_Function_infos : constant -> function_info
 val find_Function_of_graph : inductive -> function_info
 (* WARNING: To be used just after the graph definition !!! *)
-val add_Function : constant -> unit
+val add_Function : bool -> constant -> unit
 
 val update_Function : function_info -> unit 
 
@@ -101,5 +108,10 @@ val pr_info : function_info -> Pp.std_ppcmds
 val pr_table : unit -> Pp.std_ppcmds
 
 
-val function_debug : bool ref 
+(* val function_debug : bool ref  *)
 val do_observe : unit -> bool
+
+(* To localize pb *)
+exception Building_graph of exn 
+exception Defining_principle of exn
+
diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4
index 00b5f28c..26a1066c 100644
--- a/contrib/funind/indfun_main.ml4
+++ b/contrib/funind/indfun_main.ml4
@@ -103,10 +103,28 @@ TACTIC EXTEND snewfunind
 END
 
 
+let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc
+
+ARGUMENT EXTEND constr_coma_sequence'
+  TYPED AS constr_list
+  PRINTED BY pr_constr_coma_sequence
+| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
+| [ constr(c) ] -> [ [c] ]
+END
+
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
+
+ARGUMENT EXTEND auto_using'
+  TYPED AS constr_list
+  PRINTED BY pr_auto_using
+| [ "using" constr_coma_sequence'(l) ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
 VERNAC ARGUMENT EXTEND rec_annotation2
   [ "{"  "struct" ident(id)  "}"] -> [ Struct id ]
-| [ "{" "wf" constr(r) ident_opt(id) "}" ] -> [ Wf(r,id) ]
-| [ "{" "measure" constr(r) ident_opt(id) "}" ] -> [ Mes(r,id) ] 
+| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
+| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] 
 END
 
 
@@ -131,8 +149,8 @@ VERNAC ARGUMENT EXTEND rec_definition2
      let check_exists_args an =
        try 
 	 let id = match an with 
-	   | Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id 
-	   | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args" 
+	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id 
+	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" 
 	 in 
 	 (try ignore(Util.list_index (Name id) names - 1); annot
 	  with Not_found ->  Util.user_err_loc
@@ -214,11 +232,17 @@ END
 (* FINDUCTION *)
 
 (* comment this line to see debug msgs *)
-(* let msg x = () ;; let pr_lconstr c = str "" *)
+let msg x = () ;; let pr_lconstr c = str ""
   (* uncomment this to see debugging *)
 let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
 let prlistconstr lc = List.iter prconstr lc
 let prstr s = msg(str s)
+let prNamedConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
+    msg(str "");
+  end
 
 
 
@@ -266,6 +290,55 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
     max_rel = max_rel; onlyvars = List.for_all isVar args } 
     ::subres
 
+let mkEq typ c1 c2 = 
+  mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
+
+
+let poseq_unsafe idunsafe cstr gl =
+  let typ = Tacmach.pf_type_of gl cstr in
+  tclTHEN
+    (Tactics.letin_tac true (Name idunsafe) cstr allClauses)
+    (tclTHENFIRST 
+      (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) 
+      Tactics.reflexivity)
+    gl
+  
+
+let poseq id cstr gl =
+  let x = Tactics.fresh_id [] id gl in
+  poseq_unsafe x cstr gl
+
+(* dirty? *)
+
+let list_constr_largs = ref []
+
+let rec poseq_list_ids_rec lcstr gl =
+  match lcstr with
+    | [] -> tclIDTAC gl
+    | c::lcstr' -> 
+	match kind_of_term c with
+	  | Var _ -> 
+	      (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
+	  | _ -> 
+	      let _ = prstr "c = " in
+	      let _ = prconstr c in
+	      let _ = prstr "\n" in
+	      let typ = Tacmach.pf_type_of gl c in
+	      let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in
+	      let x = Tactics.fresh_id [] cname gl in
+	      let _ = list_constr_largs:=mkVar x :: !list_constr_largs in
+	      let _ = prstr " list_constr_largs = " in
+	      let _ = prlistconstr !list_constr_largs in
+	      let _ = prstr "\n" in
+
+	      tclTHEN
+		(poseq_unsafe x c)
+		(poseq_list_ids_rec lcstr')
+		gl
+
+let poseq_list_ids lcstr gl = 
+  let _ = list_constr_largs := [] in
+  poseq_list_ids_rec lcstr gl
 
 (** [find_fapp test g] returns the list of [app_info] of all calls to
     functions that satisfy [test] in the conclusion of goal g. Trivial
@@ -296,11 +369,17 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l
   if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
   let taclist: Proof_type.tactic list = 
     List.map 
-      (fun info -> 
-	(tclTHEN 
-	  (functional_induction true (applist (info.fname, info.largs)) 
-	    None IntroAnonymous) 
+      (fun info ->
+	(tclTHEN
+	  (tclTHEN (poseq_list_ids info.largs)
+	    (
+	      fun gl -> 
+		  (functional_induction 
+		    true (applist (info.fname, List.rev !list_constr_largs)) 
+		    None IntroAnonymous) gl)) 
 	  nexttac)) ordered_info_list in
+  (* we try each (f t u v) until one does not fail *)
+  (* TODO: try also to mix functional schemes *)
   tclFIRST taclist g
 
 
@@ -313,9 +392,8 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
   match oi with
     | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
     | None -> 
-	(* Default heuristic: keep only occurrence where all arguments
+	(* Default heuristic: put first occurrences where all arguments
 	   are *bound* (meaning already introduced) variables *)
-	(* TODO: put other funcalls at the end instead of deleting them *)
 	let ordering x y =
 	  if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *)
 	  else if x.free && x.onlyvars then -1
@@ -325,6 +403,7 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
 	List.sort ordering
 
 
+
 TACTIC EXTEND finduction
     ["finduction" ident(id) natural_opt(oi)] -> 
       [ 
@@ -353,3 +432,36 @@ TACTIC EXTEND fauto
 
 END
 
+
+TACTIC EXTEND poseq
+  [ "poseq" ident(x) constr(c) ] -> 
+      [ poseq x c ]
+END
+
+VERNAC COMMAND EXTEND Showindinfo
+  [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
+END
+
+VERNAC COMMAND EXTEND MergeFunind
+  [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> 
+     [ 
+       let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in
+       let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in
+       let id1,args1 = 
+	 try 
+	   let hd,args = destApp c1 in
+	   if Term.isInd hd then hd , args 
+	   else raise (Util.error "Ill-formed (fst) argument")
+	 with Invalid_argument _ 
+	     -> Util.error ("Bad argument form for merging schemes") in
+       let id2,args2 = 
+	 try
+ 	   let hd,args = destApp c2 in
+	   if isInd hd then hd , args 
+	   else raise (Util.error "Ill-formed (snd) argument")
+	 with Invalid_argument _ 
+	     -> Util.error ("Bad argument form for merging schemes") in
+       (* TOFO: enlever le ignore et declarer l'inductif *)
+       ignore(Merge.merge c1 c2 args1 args2 id)
+     ]
+END
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
index 084ec7e0..04110ea9 100644
--- a/contrib/funind/invfun.ml
+++ b/contrib/funind/invfun.ml
@@ -44,25 +44,6 @@ let pr_with_bindings prc prlc (c,bl) =
 let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds = 
   pr_with_bindings prc prc  (c,bl)
 
-let pr_elim_scheme el = 
-  let env = Global.env () in 
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
-  let env = Environ.push_rel_context el.params env in 
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
-  let env = Environ.push_rel_context el.predicates env in 
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
-  let env = Environ.push_rel_context el.branches env in 
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
-  let env = Environ.push_rel_context el.args env in 
-  let msg = 
-    Util.option_fold_right
-      (fun o msg -> msg ++ fnl () ++ str "indarg := " ++ Printer.pr_rel_context env [o]) 
-      el.indarg
-      msg
-  in 
-  let env = Util.option_fold_right (fun o env -> Environ.push_rel_context [o] env) el.indarg env in 
-  msg ++ fnl () ++ str "concl := " ++ Printer.pr_lconstr_env env el.concl
-
 (* The local debuging mechanism *)
 let msgnl = Pp.msgnl
 
@@ -120,7 +101,7 @@ let id_to_constr id =
 
 let generate_type g_to_f f graph i = 
   (*i we deduce the number of arguments of the function and its returned type from the graph i*)
-  let graph_arity = Inductive.type_of_inductive (Global.lookup_inductive (destInd graph))  in 
+  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in 
   let ctxt,_ = decompose_prod_assum graph_arity in 
   let fun_ctxt,res_type = 
     match ctxt with 
@@ -443,17 +424,17 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       let params_bindings,avoid =
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
-	     let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in
+	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
 	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
 	  )
-	  ([],[])
+	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
 	  (List.rev params)
       in
       let lemmas_bindings =
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
-	     let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in
+	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in 
 	     (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
@@ -471,7 +452,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	  (observe_tac "functional_induction" (
 	     fun g -> 
 	       observe
-		 (str "princ" ++ pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
+		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
 	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
 		 (Some (mkVar principle_id,bindings))
 		 pat g
@@ -493,6 +474,31 @@ let generalize_depedent_of x hyp g =
     (pf_hyps g)
     g
 
+
+
+
+
+
+let rec reflexivity_with_destruct_cases g = 
+  let destruct_case () = 
+    try 
+      match kind_of_term (snd (destApp (pf_concl g))).(2) with 
+	| Case(_,_,v,_) -> 
+	    tclTHENSEQ[
+	      h_case (v,Rawterm.NoBindings);
+	      intros;
+	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases 
+	    ]
+	| _ -> reflexivity
+    with _ -> reflexivity
+  in
+  tclFIRST
+    [ reflexivity;
+      destruct_case ()
+    ]
+    g
+
+
 (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] 
    is the tactic used to prove completness lemma. 
    
@@ -567,11 +573,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     *)
     let rewrite_tac j ids : tactic = 
       let graph_def = graphs.(j) in 
-      if Rtree.is_infinite graph_def.mind_recargs
+      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in 
+      if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
       then 
 	let eq_lemma = 
-	  try out_some (find_Function_infos (destConst funcs.(j))).equation_lemma
-	  with Failure "out_some" | Not_found -> anomaly "Cannot find equation lemma"
+	  try out_some (infos).equation_lemma
+	  with Failure "out_some"  -> anomaly "Cannot find equation lemma"
 	in 
 	tclTHENSEQ[
 	  tclMAP h_intro ids;
@@ -677,8 +684,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
         observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
 	(* introduce hypothesis with some rewrite *)
         (intros_with_rewrite);
-	(* The proof is complete *)
-        observe_tac "reflexivity" (reflexivity)
+	(* The proof is (almost) complete *)
+        observe_tac "reflexivity" (reflexivity_with_destruct_cases)
       ]
 	g
     in
@@ -758,7 +765,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
 	   (fst lemmas_types_infos.(i))
 	   (fun _ _ -> ());
-	 Pfedit.by (observe_tac ("procve correctness ("^(string_of_id f_id)^")") (proving_tac i));
+	 Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in 
 	 update_Function
@@ -968,10 +975,17 @@ let invfun qhyp f g =
 			 functional_inversion kn hid  f2 f_correct g
 		       with
 			 | Failure "" -> 
-			     errorlabstrm "" (Ppconstr.pr_id hid ++ str " must contain at leat one function")
+			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
 			 | Failure "out_some"  ->  
-			     error "Cannot use equivalence with graph for any side of equality"
-			 | Not_found -> error "No graph found for any side of equality" 
+			     if do_observe () 
+			     then
+			       error "Cannot use equivalence with graph for any side of the equality"
+			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+			 | Not_found -> 
+			     if do_observe () 
+			     then
+			       error "No graph found for any side of equality" 
+			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 		   end
 	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
 	  )
diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml
new file mode 100644
index 00000000..1b796a81
--- /dev/null
+++ b/contrib/funind/merge.ml
@@ -0,0 +1,826 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Merging of induction principles. *)
+
+(*i $Id: i*)
+
+open Util
+open Topconstr
+open Vernacexpr
+open Pp
+open Names
+open Term
+open Declarations
+open Environ
+open Rawterm
+open Rawtermops
+
+(** {1 Utilities}  *)
+
+(** {2 Useful operations on constr and rawconstr} *)
+
+(** Substitutions in constr *)
+let compare_constr_nosub t1 t2 =
+  if compare_constr (fun _ _ -> false) t1 t2 
+  then true
+  else false
+
+let rec compare_constr' t1 t2 =
+  if compare_constr_nosub t1 t2 
+  then true
+  else (compare_constr (compare_constr') t1 t2)
+
+let rec substitterm prof t by_t in_u =
+  if (compare_constr' (lift prof t) in_u)
+  then (lift prof by_t)
+  else map_constr_with_binders succ 
+    (fun i -> substitterm i t by_t) prof in_u
+
+let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
+
+let understand = Pretyping.Default.understand Evd.empty (Global.env())
+
+(** Operations on names and identifiers *)
+let id_of_name = function
+    Anonymous -> id_of_string "H"
+  | Name id   -> id;;
+let name_of_string str = Name (id_of_string str)
+let string_of_name nme = string_of_id (id_of_name nme)
+
+(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
+let isVarf f x = 
+    match x with
+      | RVar (_,x) -> Pervasives.compare x f = 0 
+      | _ -> false
+
+(** [ident_global_exist id] returns true if identifier [id] is linked
+    in global environment. *)
+let ident_global_exist id = 
+  try 
+    let ans = CRef (Libnames.Ident (dummy_loc,id)) in
+    let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
+    true
+  with _ -> false 
+
+(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
+    global env) with base [id]. *)
+let next_ident_fresh (id:identifier) = 
+    let res = ref id in
+    while ident_global_exist !res do res := Nameops.lift_ident !res done;
+    !res
+
+
+(** {2 Debugging} *)
+(* comment this line to see debug msgs *)
+let msg x = () ;; let pr_lconstr c = str ""
+(* uncomment this to see debugging *)
+let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c)
+let prconstrnl c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+let prNamedConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
+    msg(str "");
+  end
+let prNamedRConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
+    msg(str "");
+  end
+let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
+let prNamedLConstr s lc = 
+  begin
+    prstr "[§§§ ";
+    prstr s;
+    prNamedLConstr_aux lc;
+    prstr " §§§]\n";
+  end
+let prNamedLDecl s lc = 
+  begin
+    prstr s; prstr "\n";
+    List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
+    prstr "\n";
+  end
+
+let showind (id:identifier) =
+  let cstrid = Tacinterp.constr_of_id (Global.env()) id in
+  let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
+  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
+  List.iter (fun (nm, optcstr, tp) -> 
+    print_string (string_of_name nm^":");
+    prconstr tp; print_string "\n") 
+    ib1.mind_arity_ctxt;
+  (match ib1.mind_arity with
+    | Monomorphic x ->
+        Printf.printf "arity :"; prconstr x.mind_user_arity
+    | Polymorphic x -> 
+        Printf.printf "arity : universe?");
+  Array.iteri 
+    (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
+    ib1.mind_user_lc
+
+(** {2 Misc} *)
+
+exception Found of int
+
+(* Array scanning *)
+let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = 
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    Array.length arr (* all elt are positive *)
+  with Found i -> i
+
+let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = 
+  let i = ref 0 in 
+  Array.fold_left 
+    (fun acc x -> 
+      let res = f !i acc x in i := !i + 1; res)
+    acc arr
+
+(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
+let list_chop_end i l =
+  let size_prefix = List.length l -i in
+  if size_prefix < 0 then failwith "list_chop_end"
+  else list_chop size_prefix l
+
+let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = 
+  let i = ref 0 in 
+  List.fold_left 
+    (fun acc x -> 
+      let res = f !i acc x in i := !i + 1; res)
+    acc arr
+
+let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = 
+  let i = ref 0 in 
+  List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
+
+
+(** Iteration module *)
+module For = 
+struct
+  let rec map i j (f: int -> 'a)  = if i>j then [] else f i :: (map (i+1) j f)
+  let rec foldup i j (f: 'a -> int -> 'a) acc = 
+    if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
+  let rec folddown i j (f: 'a -> int -> 'a) acc = 
+    if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
+  let fold i j = if i<j then foldup i j else folddown i j
+end
+
+
+(** {1 Parameters shifting and linking information} *)
+
+(** This type is used to deal with debruijn linked indices. When a
+    variable is linked to a previous one, we will ignore it and refer
+    to previous one. *)
+type linked_var =
+    | Linked of int
+    | Unlinked
+    | Funres
+
+(** When merging two graphs, parameters may become regular arguments,
+    and thus be shifted. This type describe the result of computing
+    the changes. *)
+type 'a shifted_params =
+    {
+      nprm1:'a;
+      nprm2:'a;
+      prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *)
+      nuprm1:'a;
+      nuprm2:'a;
+      nargs1:'a;
+      nargs2:'a;
+    }
+
+
+let prlinked x =
+  match x with
+    | Linked i -> Printf.sprintf "Linked %d" i
+    | Unlinked -> Printf.sprintf "Unlinked"
+    | Funres -> Printf.sprintf "Funres"
+
+let linkmonad f lnkvar = 
+  match lnkvar with
+    | Linked i -> Linked (f i)
+    | Unlinked -> Unlinked
+    | Funres -> Funres
+
+let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
+
+(* This map is used to deal with debruijn linked indices. *)
+module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
+
+let pr_links l = 
+  Printf.printf "links:\n";
+  Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
+  Printf.printf "_____________\n"
+
+type 'a merged_arg =
+    | Prm_stable of 'a
+    | Prm_linked of 'a
+    | Prm_arg of 'a
+    | Arg_stable of 'a
+    | Arg_linked of 'a
+    | Arg_funres
+
+type merge_infos =
+    {
+      ident:identifier; (* new inductive name *)
+      mib1: mutual_inductive_body;
+      oib1: one_inductive_body; 
+      mib2: mutual_inductive_body;
+      oib2: one_inductive_body; 
+      (* Array of links of the first inductive (should be all stable) *)
+      lnk1: int merged_arg array;
+      (* Array of links of the second inductive (point to the first ind param/args) *)
+      lnk2: int merged_arg array;
+      (* number of rec params of ind1 which remai rec param in merge *)
+      nrecprms1: int;
+      (* number of other rec params of ind1 (which become non parm) *)
+      notherprms1:int;
+      (* number of functional result params of ind2 (which become non parm) *)
+      nfunresprms1:int;
+      (* list of decl of rec parms from ind1 which remain parms *)
+      recprms1: rel_declaration list;
+      (* List of other rec parms from ind1 *)
+      otherprms1: rel_declaration list; (* parms that became args *)
+      funresprms1: rel_declaration list; (* parms that are functional result args *)
+      (* number of rec params of ind2 which remain rec param in merge (and not linked) *)
+      nrecprms2: int;
+      (* number of other params of ind2 (which become non rec parm) *)
+      notherprms2:int;
+      (* number of functional result params of ind2 (which become non parm) *)
+      nfunresprms2:int;
+      (* list of decl of rec parms from ind2 which remain parms (and not linked) *)
+      recprms2: rel_declaration list;
+      (* List of other rec parms from ind2 (which are linked or become non parm) *)
+      otherprms2: rel_declaration list;      
+      funresprms2: rel_declaration list; (* parms that are functional result args *)
+    }
+
+
+let pr_merginfo x =
+  let i,s=
+    match x with 
+      | Prm_linked i -> Some i,"Prm_linked"
+      | Arg_linked i -> Some i,"Arg_linked"
+      | Prm_stable i -> Some i,"Prm_stable"
+      | Prm_arg i -> Some i,"Prm_arg"
+      | Arg_stable i -> Some i,"Arg_stable"
+      | Arg_funres -> None , "Arg_funres" in
+  match i with
+    | Some i -> Printf.sprintf "%s(%d)" s i
+    | None -> Printf.sprintf "%s" s
+
+let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
+
+let isArg_stable x = match x with Arg_stable _ -> true | _ -> false
+
+let isArg_funres x = match x with Arg_funres -> true | _ -> false
+
+let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
+  let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in
+  let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in
+  let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in
+  prms@args@fres
+
+(** Reverse the link map, keeping only linked vars, elements are list
+    of int as several vars may be linked to the same var. *)
+let revlinked lnk =
+  For.fold 0 (Array.length lnk - 1)
+    (fun acc k -> 
+      match lnk.(k) with 
+        | Unlinked | Funres -> acc 
+        | Linked i -> 
+            let old = try Link.find i acc with Not_found -> [] in
+            Link.add i (k::old) acc)
+    Link.empty
+
+let array_switch arr i j = 
+  let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
+
+let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
+  let larr = Array.of_list l in
+  let _ =
+    Array.iteri
+      (fun j x -> 
+        match x with
+          | Prm_linked i -> array_switch larr i j
+          | Arg_linked i -> array_switch larr i j
+          | Prm_stable i -> ()
+          | Prm_arg i -> ()
+          | Arg_stable i -> ()
+          | Arg_funres -> ()
+      ) lnk in
+  filter_shift_stable lnk (Array.to_list larr)
+
+
+
+
+(** {1 Utilities for merging} *)
+
+let ind1name = id_of_string "__ind1"
+let ind2name = id_of_string "__ind2"
+
+(** Performs verifications on two graphs before merging: they must not
+    be co-inductive, and for the moment they must not be mutual
+    either. *)
+let verify_inds mib1 mib2 =
+  if not mib1.mind_finite then error "First argument is coinductive";
+  if not mib2.mind_finite then error "Second argument is coinductive";
+  if mib1.mind_ntypes <> 1 then error "First argument is mutual";
+  if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
+  ()
+
+
+(** {1 Merging function graphs} *)
+
+(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec
+    uniform and ordinary ones) of mutual inductives [mib1] and [mib2]
+    remain uniform when linked by [lnk]. All parameters are
+    considered, ie we take parameters of the first inductive body of
+    [mib1] and [mib2].
+    
+    Explanation: The two inductives have parameters, some of the first
+    are recursively uniform, some of the last are functional result of
+    the functional graph.
+
+   (I x1 x2 ... xk ... xk' ... xn)
+   (J y1 y2 ... xl ... yl' ... ym)
+
+   Problem is, if some rec unif params are linked to non rec unif
+   ones, they become non rec (and the following too). And functinal
+   argument have to be shifted at the end *)
+let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
+  let linked_targets = revlinked lnk2 in
+  let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
+  let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
+  let is_targetted_by_non_recparam_lnk1 i = 
+    try 
+      let targets = Link.find i linked_targets in 
+      List.exists (fun x -> not (is_param_of_mib2 x)) targets
+    with Not_found -> false in
+  let mlnk1 = 
+    Array.mapi
+      (fun i lkv -> 
+        let isprm = is_param_of_mib1 i in
+        let prmlost = is_targetted_by_non_recparam_lnk1 i in
+        match isprm , prmlost, lnk1.(i) with
+          | true , true , _ -> Prm_arg i (* recparam becoming ordinary *)
+          | true , false , _-> Prm_stable i (* recparam remains recparam*)
+          | false , false , Funres -> Arg_funres
+          | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
+          | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
+      lnk1 in
+  let mlnk2 = 
+    Array.mapi
+      (fun i lkv -> 
+        (* Is this correct if some param of ind2 is lost? *)
+        let isprm = is_param_of_mib2 i in
+        match isprm , lnk2.(i) with
+          | true , Linked j when not (is_param_of_mib1 j) -> 
+              Prm_arg j (* recparam becoming ordinary *)
+          | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
+          | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
+          | false , Linked j -> Arg_linked j (* Args of lnk2 lost *)
+          | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *)
+          | false , Funres -> Arg_funres
+          | true , Funres -> assert false (* fun res cannot be a rec param *)
+      )
+      lnk2 in
+  let oib1 = mib1.mind_packets.(0) in
+  let oib2 = mib2.mind_packets.(0) in
+  (* count params remaining params *)
+  let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
+  let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
+  let bldprms arity_ctxt mlnk = 
+    list_fold_lefti
+      (fun i (acc1,acc2,acc3) x -> 
+        match mlnk.(i) with
+          | Prm_stable _ -> x::acc1 , acc2 , acc3
+          | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3
+          | Arg_funres -> acc1 , acc2 , x::acc3
+          | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *)
+      ([],[],[]) arity_ctxt in
+  let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
+  let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
+  {
+    ident=id;
+    mib1=mib1;
+    oib1 = oib1;
+    mib2=mib2;
+    oib2 = oib2;
+    lnk1 = mlnk1;
+    lnk2 = mlnk2;
+    nrecprms1 = n_params1;
+    recprms1 = recprms1;
+    otherprms1 = otherprms1;
+    funresprms1 = funresprms1;
+    notherprms1 = Array.length mlnk1 - n_params1;
+    nfunresprms1 = List.length funresprms1;
+    nrecprms2 = n_params2;
+    recprms2 = recprms2;
+    otherprms2 = otherprms2;
+    funresprms2 = funresprms2;
+    notherprms2 = Array.length mlnk2 - n_params2;
+    nfunresprms2 = List.length funresprms2;
+  }
+
+
+
+
+(** {1 Merging functions} *)
+
+exception NoMerge
+
+(* lnk is an link array of *all* args (from 1 and 2) *)
+let merge_app c1 c2 id1 id2 shift filter_shift_stable = 
+  let lnk = Array.append shift.lnk1 shift.lnk2 in
+  match c1 , c2 with
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> 
+        let args = filter_shift_stable lnk (arr1 @ arr2) in
+        RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
+    | RApp(_,f1, arr1), RApp(_,f2,arr2)  -> raise NoMerge
+    | _ -> raise NoMerge
+
+let merge_app_unsafe c1 c2 shift filter_shift_stable = 
+  let lnk = Array.append shift.lnk1 shift.lnk2 in
+  match c1 , c2 with
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) -> 
+        let args = filter_shift_stable lnk (arr1 @ arr2) in
+        RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
+    | _ -> raise NoMerge
+
+
+
+(* Heuristic when merging two lists of hypothesis: merge every rec
+   calls of nrach 1 with all rec calls of branch 2. *)
+(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
+let onefoud = ref false (* Ugly *)
+
+let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) 
+    filter_shift_stable =
+  match ltyp with
+    | [] -> []
+    | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> 
+        let _ = onefoud := true in
+        let rechyps = 
+          List.map 
+            (fun (nme,ind) -> 
+              match ind with
+                | RApp(_,i,args) -> 
+                    nme, merge_app_unsafe ind t shift filter_shift_stable
+                | _ -> assert false)
+            accrec in
+        rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
+    | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
+
+
+let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = 
+  List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
+
+
+let find_app (nme:identifier) (ltyp: (name * rawconstr) list) = 
+  try
+    ignore
+      (List.map
+          (fun x -> 
+            match x with
+              | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+              | _ -> ())
+          ltyp);
+    false
+  with Found _ -> true
+        
+let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list)
+    concl1 (ltyp2:(name * rawconstr) list) concl2
+    : (name * rawconstr) list * rawconstr = 
+  let _ = prstr "MERGE_TYPES\n" in
+  let _ = prstr "ltyp 1 : " in
+  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in
+  let _ = prstr "\nltyp 2 : " in
+  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in
+  let _ = prstr "\n" in
+
+
+  let res =
+    match ltyp1 with
+      | [] -> 
+          let isrec1 = (accrec1<>[]) in
+          let isrec2 = find_app ind2name ltyp2 in
+          let _ = if isrec2 then prstr "  ISREC2 TRUE" else prstr "  ISREC2 FALSE" in
+          let _ = if isrec1 then prstr "  ISREC1 TRUE\n" else prstr "  ISREC1 FALSE\n" in
+          let rechyps =
+            if isrec1 && isrec2 
+            then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable
+            else if isrec1 
+                (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
+            then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",concl2])
+              filter_shift_stable
+            else if isrec2
+            then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2
+              filter_shift_stable_right
+            else [] in
+          let _ = prstr"\nrechyps : " in
+          let _ = List.iter 
+            (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps in
+          let _ = prstr "MERGE CONCL :  " in
+          let _ = prNamedRConstr "concl1" concl1 in
+          let _ = prstr " with " in
+          let _ = prNamedRConstr "concl2" concl2 in
+          let _ = prstr "\n" in
+          let concl = 
+            merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
+          let _ = prstr "FIN " in
+          let _ = prNamedRConstr "concl" concl in
+          let _ = prstr "\n" in
+          rechyps , concl
+      | (nme,t1)as e ::lt1 -> 
+          match t1 with
+            | RApp(_,f,carr) when isVarf ind1name f -> 
+                merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 
+            | _ -> 
+                let recres, recconcl2 =
+                  merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
+                ((nme,t1) :: recres) , recconcl2
+  in
+  res
+
+
+(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of
+    linked args [allargs2] to target args of [allargs1] as specified
+    in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
+    returns the list of unlinked vars of [allargs2]. *)
+let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
+    (lnk:int merged_arg array) =
+  array_fold_lefti
+    (fun i acc e -> 
+      if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
+      else 
+        match e with 
+          | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
+          | _ -> acc)
+    Idmap.empty lnk
+
+let build_link_map allargs1 allargs2 lnk =
+  let allargs1 =
+    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in
+  let allargs2 =
+    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs2)) in
+  build_link_map_aux allargs1 allargs2 lnk
+
+
+(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two
+    constructor rawtypes [typcstr1] and [typcstr2].  [typcstr1] and
+    [typcstr2] contain all parameters (including rec. unif. ones) of
+    their inductive.
+
+    if  [typcstr1] and [typcstr2] are of the form:
+
+    forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1)
+    forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2)
+
+    we build:
+
+    forall recparams1 (recparams2 without linked params),
+     forall ordparams1 (ordparams2 without linked params),
+      H1a' -> H2a' -> ...  -> H2a' -> H2b' -> ... 
+        -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
+
+    where Hix' have been adapted, ie: 
+      - linked vars have been changed,
+      - rec calls to I1 and I2 have been replaced by rec calls to
+        newI. More precisely calls to I1 and I2 have been merge by an
+        experimental heuristic (in particular if n o rec calls for I1
+        or I2 is found, we use the conclusion as a rec call). See
+        [merge_types] above.
+
+    Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
+
+    TODO: return nothing if equalities (after linking) are contradictory. *)
+let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
+    (typcstr2:rawconstr) : rawconstr =
+  (* FIXME: les noms des parametres corerspondent en principe au
+     parametres du niveau mib, mais il faudrait s'en assurer *)
+  (* shift.nfunresprmsx last args are functional result *)
+  let nargs1 = 
+    shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
+  let nargs2 =
+    shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
+  let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in
+  let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 in  
+  (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
+  let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
+  let rest2 = change_vars linked_map rest2 in
+  let hyps1,concl1 = raw_decompose_prod rest1 in
+  let hyps2,concl2' = raw_decompose_prod rest2 in
+  let ltyp,concl2 = 
+    merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
+  let typ = raw_compose_prod concl2 (List.rev ltyp) in
+  let revargs1 = 
+    list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
+  let revargs2 = 
+    list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
+  let typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) in
+  typwithprms
+
+
+(** constructor numbering *)
+let fresh_cstror_suffix , cstror_suffix_init =
+  let cstror_num = ref 0 in
+  (fun () -> 
+    let res = string_of_int !cstror_num in
+    cstror_num := !cstror_num + 1;
+    res) ,
+  (fun () -> cstror_num := 0)
+
+(** [merge_constructor_id id1 id2 shift] returns the identifier of the
+    new constructor from the id of the two merged constructor and
+    the merging info. *)
+let merge_constructor_id id1 id2 shift:identifier = 
+  let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
+  next_ident_fresh (id_of_string id)
+
+
+
+(** [merge_constructors lnk shift avoid] merges the two list of
+    constructor [(name*type)]. These are translated to rawterms
+    first, each of them having distinct var names. *)
+let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
+    (typcstr1:(identifier * types) list) 
+    (typcstr2:(identifier * types) list) : (identifier * rawconstr) list =
+  List.flatten 
+    (List.map
+        (fun (id1,typ1) -> 
+          let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in
+          let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in
+          let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in
+          List.map
+            (fun (id2,typ2) -> 
+              let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in
+              (* Avoid also rawtyp1 names *)
+              let avoid2 = Idset.union avoid idsoftyp1 in
+              let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in
+              let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
+              let newcstror_id = merge_constructor_id id1 id2 shift in
+              newcstror_id , typ)
+            typcstr2)
+        typcstr1)
+    
+(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
+    inductive bodies [oib1] and [oib2], linking with [lnk], params
+    info in [shift], avoiding identifiers in [avoid]. *)
+let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
+    (oib2:one_inductive_body) : (identifier * rawconstr) list =
+  let lcstr1 = Array.to_list oib1.mind_user_lc in
+  let lcstr2 = Array.to_list oib2.mind_user_lc in
+  let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
+  let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
+  cstror_suffix_init();
+  merge_constructors shift avoid lcstr1 lcstr2
+
+(** [build_raw_params prms_decl avoid] returns a list of variables
+    attributed to the list of decl [prms_decl], avoiding names in
+    [avoid]. *)
+let build_raw_params prms_decl avoid =
+  let dummy_constr = compose_prod prms_decl mkProp in
+  let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
+  let res,_ = raw_decompose_prod dummy_rawconstr in
+  res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
+
+(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
+    inductive bodies [mib1] and [mib2] linking vars with
+    [lnk]. [shift] information on parameters of the new inductive.
+    For the moment, inductives are supposed to be non mutual.
+*)
+let rec merge_mutual_inductive_body
+    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) 
+    (shift:merge_infos) =
+  (* Mutual not treated, we take first ind body of each. *)
+  let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *)
+  let prms1 = (* rec uniform parms of mib1 *)
+    List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in
+
+  (* useless: *)
+  let prms1_named,avoid' = build_raw_params prms1 [] in
+  let prms2_named,avoid = build_raw_params prms1 avoid' in
+  let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in  
+  (* *** *)
+
+  merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) 
+
+  
+
+let merge_rec_params_and_arity params1 params2 shift (concl:constr) = 
+  let params = shift.recprms1 @ shift.recprms2 in
+  let resparams, _ =
+    List.fold_left
+      (fun (acc,env) (nme,_,tp) -> 
+        let typ = Constrextern.extern_constr false env tp in
+        let newenv = Environ.push_rel (nme,None,tp) env in
+        LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv)
+      ([],Global.env())
+      params in
+  let concl = Constrextern.extern_constr false (Global.env()) concl in
+  let arity,_ = 
+    List.fold_left 
+      (fun (acc,env) (nm,_,c) -> 
+        let typ = Constrextern.extern_constr false env c in
+        let newenv = Environ.push_rel (nm,None,c) env in
+        CProdN (dummy_loc, [[(dummy_loc,nm)],typ] , acc) , newenv)
+      (concl,Global.env())
+      (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in  
+  resparams,arity
+
+  
+
+(** [rawterm_list_to_inductive_expr ident rawlist] returns the
+    induct_expr corresponding to the the list of constructor types
+    [rawlist], named ident.
+    FIXME: params et cstr_expr (arity) *)
+let rawterm_list_to_inductive_expr mib1 mib2 shift
+    (rawlist:(identifier * rawconstr) list):inductive_expr =
+  let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
+    Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in
+  let lident = dummy_loc, shift.ident in
+  let bindlist , cstr_expr = (* params , arities *)
+    merge_rec_params_and_arity 
+      mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in
+  let lcstor_expr : (bool * (lident * constr_expr)) list  = 
+    List.map (* zeta_normalize t ? *)
+      (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
+      rawlist in  
+  lident , bindlist , cstr_expr , lcstor_expr
+
+(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
+    variables specified in [lnk]. Graphs are not supposed to be mutual
+    inductives for the moment. *)
+let merge_inductive (ind1: inductive) (ind2: inductive) 
+    (lnk1: linked_var array) (lnk2: linked_var array) id =
+  let env = Global.env() in
+  let mib1,_ = Inductive.lookup_mind_specif env ind1 in
+  let mib2,_ = Inductive.lookup_mind_specif env ind2 in
+  let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
+  (* compute params that become ordinary args (because linked to ord. args) *)
+  let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
+  let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
+  let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in
+  (* Declare inductive *)
+  Command.build_mutual [(indexpr,None)] true (* means: not coinductive *)
+
+
+
+let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id =
+  let env = Global.env() in
+  let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in
+  let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in
+  let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *)
+    Array.mapi (fun i c -> Unlinked) args1 in
+  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *)
+  let lnk2 = (* args2 may be linked to args1 members. FIXME: same 
+                as above: vars may be linked inside args2?? *)
+    Array.mapi
+      (fun i c -> 
+        match array_find args1 (fun i x -> x=c) with
+          | Some j -> Linked j
+          | None -> Unlinked) 
+      args2 in
+  let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *)
+  let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in
+  resa
+
+
+
+
+
+(* @article{ bundy93rippling,
+    author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill",
+    title = "Rippling: A Heuristic for Guiding Inductive Proofs",
+    journal = "Artificial Intelligence",
+    volume = "62",
+    number = "2",
+    pages = "185-253",
+    year = "1993",
+    url = "citeseer.ist.psu.edu/bundy93rippling.html" }
+
+ *)
+(* 
+*** Local Variables: ***
+*** compile-command: "make -C ../.. contrib/funind/merge.cmo" ***
+*** indent-tabs-mode: nil ***
+*** End: ***
+*)
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
index dbf2f944..aca84f06 100644
--- a/contrib/funind/rawterm_to_relation.ml
+++ b/contrib/funind/rawterm_to_relation.ml
@@ -789,7 +789,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	    avoid
 	    matched_expr
 	in
-	(* We know create the precondition of this branch i.e.
+	(* We now create the precondition of this branch i.e.
 
 	   1- the list of variable appearing in the different patterns of this branch and 
 	      the list of equation stating than el = patl (List.flatten ...)
@@ -1074,8 +1074,8 @@ let rec rebuild_return_type rt =
     | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
 
 
-let build_inductive 
-    parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list)  
+let do_build_inductive 
+    funnames (funsargs: (Names.name * rawconstr * bool) list list)  
     returned_types 
     (rtl:rawconstr list) =
   let _time1 = System.get_time () in
@@ -1085,7 +1085,7 @@ let build_inductive
   let funsargs = Array.of_list funsargs in 
   let returned_types = Array.of_list returned_types in
   (* alpha_renaming of the body to prevent variable capture during manipulation *)
-  let rtl_alpha = List.map (function rt ->  (alpha_rt [] rt) ) rtl in
+  let rtl_alpha = List.map (function rt ->  expand_as (alpha_rt [] rt)) rtl in
   let rta = Array.of_list rtl_alpha in
   (*i The next call to mk_rel_id is valid since we are constructing the graph
     Ensures by: obvious
@@ -1108,19 +1108,7 @@ let build_inductive
       (function result (* (args',concl') *) -> 
 	 let rt = compose_raw_context result.context result.value in 
 	 let nb_args = List.length funsargs.(i) in 
-(* 	   let old_implicit_args = Impargs.is_implicit_args () *)
-(* 	   and old_strict_implicit_args =  Impargs.is_strict_implicit_args () *)
-(* 	   and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in *)
-(* 	   let old_rawprint = !Options.raw_print in  *)
-(* 	   Options.raw_print := true; *)
-(* 	   Impargs.make_implicit_args false; *)
-(* 	   Impargs.make_strict_implicit_args false; *)
-(* 	   Impargs.make_contextual_implicit_args false; *)
-(* 	   Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *)
-(* 	   Impargs.make_implicit_args old_implicit_args; *)
-(* 	   Impargs.make_strict_implicit_args old_strict_implicit_args; *)
-(* 	   Impargs.make_contextual_implicit_args old_contextual_implicit_args; *)
-(* 	   Options.raw_print := old_rawprint; *)
+	 (*  with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
 	 fst (
 	   rebuild_cons nb_args relnames.(i)
 	     []
@@ -1145,12 +1133,7 @@ let build_inductive
   in
   let rel_constructors = Array.mapi rel_constructors resa in
   (* Computing the set of parameters if asked *)
-  let rels_params = 
-    if parametrize 
-    then
-      compute_params_name relnames_as_set funsargs  rel_constructors 
-    else []
-  in
+  let rels_params = compute_params_name relnames_as_set funsargs  rel_constructors in
   let nrel_params = List.length rels_params in
   let rel_constructors = (* Taking into account the parameters in constructors *)
     Array.map (List.map 
@@ -1182,8 +1165,6 @@ let build_inductive
      Then save the graphs and reset Printing options to their primitive values 
   *)
   let rel_arities = Array.mapi rel_arity funsargs in
-  let old_rawprint = !Options.raw_print in 
-  Options.raw_print := true;
   let rel_params =  
     List.map 
       (fun (n,t,is_defined) -> 
@@ -1199,16 +1180,19 @@ let build_inductive
   let ext_rels_constructors = 
     Array.map (List.map 
       (fun (id,t) -> 
-	 false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty ((* zeta_normalize *) t))
+	 false,((dummy_loc,id),
+		Options.with_option
+		  Options.raw_print
+		  (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
+	       )
       ))
       (rel_constructors)
   in
   let rel_ind i ext_rel_constructors = 
-    (dummy_loc,relnames.(i)),
-    None,
+    ((dummy_loc,relnames.(i)),
     rel_params,
     rel_arities.(i),
-    ext_rel_constructors
+    ext_rel_constructors),None
   in
   let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in 
   let rel_inds = Array.to_list ext_rel_constructors in 
@@ -1232,58 +1216,36 @@ let build_inductive
 (* 	rel_inds *)
 (*     ) *)
 (*   in *)
-  let old_implicit_args = Impargs.is_implicit_args ()
-  and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
-  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
-  Impargs.make_implicit_args false;
-  Impargs.make_strict_implicit_args false;
-  Impargs.make_contextual_implicit_args false;
   let _time2 = System.get_time () in 
-(*   Pp.msgnl (str "Bulding Inductive : " ++ str (string_of_float (System.time_difference time1 time2))); *)
   try 
-    Options.silently (Command.build_mutual rel_inds) true;
-    let _time3 = System.get_time () in 
-(*     Pp.msgnl (str "Bulding Done: "++ str (string_of_float (System.time_difference time2 time3)));  *)
-(* 	let msg = *)
-(* 	  str "while trying to define"++ spc () ++ *)
-(* 	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () *)
-(* 	in *)
-(*  	Pp.msgnl msg; *)
-    Impargs.make_implicit_args old_implicit_args;
-    Impargs.make_strict_implicit_args old_strict_implicit_args;
-    Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-    Options.raw_print := old_rawprint;
-  with
-    | UserError(s,msg) ->
+    with_full_print (Options.silently (Command.build_mutual rel_inds)) true
+  with 
+    | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
 (* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	Impargs.make_implicit_args old_implicit_args;
-	Impargs.make_strict_implicit_args old_strict_implicit_args;
-	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-	Options.raw_print := old_rawprint;
 	let msg = 		     
 	  str "while trying to define"++ spc () ++
 	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++
 	    msg
 	in
 	observe (msg);
-	raise 
-	  (UserError(s, msg))
+	raise e
     | e -> 
 	let _time3 = System.get_time () in
 (* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	Impargs.make_implicit_args old_implicit_args;
-	Impargs.make_strict_implicit_args old_strict_implicit_args;
-	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-	Options.raw_print := old_rawprint;
 	let msg = 		     
 	  str "while trying to define"++ spc () ++
 	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++
 	    Cerrors.explain_exn e
 	in
  	observe msg;
-	raise 
-	  (UserError("",msg))
+	raise e
 
 
 
+let build_inductive funnames funsargs returned_types rtl = 
+  try 
+    do_build_inductive funnames funsargs returned_types rtl
+  with e -> raise (Building_graph e)
+      
+
diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli
index 9cd04123..0075fb0a 100644
--- a/contrib/funind/rawterm_to_relation.mli
+++ b/contrib/funind/rawterm_to_relation.mli
@@ -1,5 +1,6 @@
 
 
+
 (*
   [build_inductive parametrize funnames funargs returned_types bodies] 
   constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments 
@@ -7,7 +8,6 @@
 *)
 
 val build_inductive :
-  bool -> (* if true try to detect parameter. Always use it as true except for debug *)
   Names.identifier list -> (* The list of function name *)
   (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
   Topconstr.constr_expr list -> (* The list of function returned type *)
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
index 14805cf4..ed46ec72 100644
--- a/contrib/funind/rawtermops.ml
+++ b/contrib/funind/rawtermops.ml
@@ -35,6 +35,18 @@ let raw_decompose_prod =
 let raw_compose_prod = 
   List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
 
+let raw_decompose_prod_n n = 
+  let rec raw_decompose_prod i args c = 
+    if i<=0 then args,c
+    else
+      match c with
+	| RProd(_,n,t,b) -> 
+	    raw_decompose_prod (i-1) ((n,t)::args) b 
+	| rt -> args,rt
+  in
+  raw_decompose_prod n []
+
+
 let raw_decompose_app = 
   let rec decompose_rapp acc rt =
 (*     msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
@@ -321,14 +333,6 @@ let rec alpha_rt excluded rt =
 	     List.map (alpha_rt excluded) args
 	    )
   in 
-  if Indfun_common.do_observe ()  && false 
-  then
-    Pp.msgnl (str "debug: alpha_rt(" ++ str "[" ++
-	      prlist_with_sep (fun _ -> str";") Ppconstr.pr_id excluded ++
-	      str "]" ++ spc () ++ str "," ++ spc () ++
-	      Printer.pr_rawconstr rt ++ spc () ++ str ")" ++ spc () ++ str "=" ++
-	      spc () ++ Printer.pr_rawconstr new_rt
-	   );
   new_rt
 
 and alpha_br excluded (loc,ids,patl,res) = 
@@ -339,12 +343,6 @@ and alpha_br excluded (loc,ids,patl,res) =
   let new_res = alpha_rt new_excluded renamed_res in 
   (loc,new_ids,new_patl,new_res)
     
-
-
-
-
-
-
 (* 
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
@@ -541,6 +539,33 @@ let ids_of_pat =
   in
   ids_of_pat Idset.empty 
   
+let id_of_name = function 
+  | Names.Anonymous -> id_of_string "x" 
+  | Names.Name x -> x
+
+(* TODO: finish Rec caes *)
+let ids_of_rawterm c = 
+  let rec ids_of_rawterm acc c = 
+    let idof = id_of_name in
+    match c with
+      | RVar (_,id) -> id::acc
+      | RApp (loc,g,args) -> 
+          ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
+      | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+      | RCast (loc,c,k,t) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
+      | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
+      | RLetTuple (_,nal,(na,po),b,c) -> 
+          List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+      | RCases (loc,rtntypopt,tml,brchl) -> 
+	  List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
+      | RRec _ -> failwith "Fix inside a constructor branch"
+      | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> []
+  in
+  (* build the set *)
+  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
+  
 
 
 
@@ -601,3 +626,46 @@ let zeta_normalize =
     (loc,idl,patl,zeta_normalize_term res)
   in
   zeta_normalize_term 
+
+
+
+
+let expand_as = 
+  
+  let rec add_as map pat = 
+    match pat with 
+      | PatVar _ -> map 
+      | PatCstr(_,_,patl,Name id) -> 
+	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
+      | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
+  in 
+  let rec expand_as map rt = 
+    match rt with 
+      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt 
+      | RVar(_,id) -> 
+	  begin
+	    try 
+	      Idmap.find id map
+	    with Not_found -> rt 
+	  end
+      | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
+      | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b)
+      | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b)
+      | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
+      | RLetTuple(loc,nal,(na,po),v,b) ->
+	  RLetTuple(loc,nal,(na,option_map (expand_as map) po),
+		    expand_as map v, expand_as map b)
+      | RIf(loc,e,(na,po),br1,br2) ->
+	  RIf(loc,expand_as map e,(na,option_map (expand_as map) po),
+	      expand_as map br1, expand_as map br2)
+      | RRec _ ->  error "Not handled RRec"
+      | RDynamic _ -> error "Not handled RDynamic"
+      | RCast(loc,b,kind,t) -> RCast(loc,expand_as map b,kind,expand_as map t)
+      | RCases(loc,po,el,brl) ->
+	  RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+		List.map (expand_as_br map) brl)
+	    
+  and expand_as_br map (loc,idl,cpl,rt) = 
+    (loc,idl,cpl,    expand_as (List.fold_left add_as map cpl) rt)
+  in
+  expand_as Idmap.empty 
diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli
index aa355485..9647640c 100644
--- a/contrib/funind/rawtermops.mli
+++ b/contrib/funind/rawtermops.mli
@@ -31,6 +31,7 @@ val mkRCast : rawconstr* rawconstr -> rawconstr
   These are analogous to the ones constrs
 *)
 val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr
 val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list  ->  rawconstr 
 val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list)
 
@@ -107,8 +108,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
 *)
 val   ids_of_pat : cases_pattern -> Names.Idset.t 
 
+(* TODO: finish this function (Fix not treated) *)
+val ids_of_rawterm: rawconstr -> Names.Idset.t
 
 (* 
    removing let_in construction in a rawterm 
 *)
 val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
+
+
+val expand_as : rawconstr -> rawconstr
diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml
index 2877c19d..ce775e0b 100644
--- a/contrib/funind/tacinvutils.ml
+++ b/contrib/funind/tacinvutils.ml
@@ -72,10 +72,11 @@ let  rec mkevarmap_from_listex lex =
 		  let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in
 		  let _ = prstr "OF TYPE: " in
 		  let _ = prconstr typ in*)
-		  let info ={
+		  let info = {
 			 evar_concl = typ;
 			 evar_hyps = empty_named_context_val;
-			 evar_body = Evar_empty} in
+			 evar_body = Evar_empty;
+		         evar_extra = None} in
 		  Evd.add (mkevarmap_from_listex lex') ex info
 
 let mkEq typ c1 c2 = 
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
index 8f880a76..b6cc55f6 100644
--- a/contrib/interface/ascent.mli
+++ b/contrib/interface/ascent.mli
@@ -21,7 +21,7 @@ and ct_BINDING =
     CT_binding of ct_ID_OR_INT * ct_FORMULA
 and ct_BINDING_LIST =
     CT_binding_list of ct_BINDING list
-and ct_BOOL =
+and t_BOOL =
     CT_false
   | CT_true
 and ct_CASE =
@@ -46,7 +46,7 @@ and ct_COMMAND =
   | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL
   | CT_abort of ct_ID_OPT_OR_ALL
   | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST
-  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_LIST
+  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT
   | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID
   | CT_addpath of ct_STRING * ct_ID_OPT
   | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST
@@ -684,7 +684,7 @@ and ct_TACTIC_COM =
   | CT_reflexivity
   | CT_rename of ct_ID * ct_ID
   | CT_repeat of ct_TACTIC_COM
-  | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_ID_OPT * ct_TACTIC_OPT
+  | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT
   | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
   | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
   | CT_right of ct_SPEC_LIST
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
index 9e450068..dc27cf98 100644
--- a/contrib/interface/blast.ml
+++ b/contrib/interface/blast.ml
@@ -92,7 +92,7 @@ let rec def_const_in_term_rec vl x =
    | Case(_,x,t,a) 
         -> def_const_in_term_rec vl x
    | Cast(x,_,t)-> def_const_in_term_rec vl t
-   | Const(c)  -> def_const_in_term_rec vl (lookup_constant c vl).const_type
+   | Const(c)  -> def_const_in_term_rec vl (Typeops.type_of_constant vl c)
    | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x)
 ;;
 let def_const_in_term_ x =
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
index 8fcdb5d9..730e055b 100644
--- a/contrib/interface/centaur.ml4
+++ b/contrib/interface/centaur.ml4
@@ -396,7 +396,7 @@ let inspect n =
 			 let (_, _, v) = get_variable (basename sp) in
 			   add_search2 (Nametab.locate (qualid_of_sp sp)) v
 		     | (sp,kn), "CONSTANT" ->
-			 let {const_type=typ} = Global.lookup_constant (constant_of_kn kn) in
+			 let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in
 			   add_search2 (Nametab.locate (qualid_of_sp sp)) typ
 		     | (sp,kn), "MUTUALINDUCTIVE" ->
 			 add_search2 (Nametab.locate (qualid_of_sp sp))
diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml
index 578abc49..8096bc31 100644
--- a/contrib/interface/dad.ml
+++ b/contrib/interface/dad.ml
@@ -73,7 +73,7 @@ let rec map_subst (env :env) (subst:patvar_map) = function
   | CPatVar (_,(_,i)) ->
       let constr = List.assoc i subst in
       extern_constr false env constr
-  | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;;
+  | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;;
 
 let map_subst_tactic env subst = function
   | TacExtend (loc,("Rewrite" as x),[b;cbl]) ->
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
index e1b8e712..890bb3ce 100644
--- a/contrib/interface/debug_tac.ml4
+++ b/contrib/interface/debug_tac.ml4
@@ -336,7 +336,7 @@ let debug_tac = function
 add_tactic "DebugTac" debug_tac;;
 *)
 
-Refiner.add_tactic "OnThen" on_then;;
+Tacinterp.add_tactic "OnThen" on_then;;
 
 let rec clean_path tac l = 
   match tac, l with
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
index b06ba199..9a503cfb 100644
--- a/contrib/interface/name_to_ast.ml
+++ b/contrib/interface/name_to_ast.ml
@@ -107,10 +107,10 @@ let convert_one_inductive sp tyi =
   let env = Global.env () in
   let envpar = push_rel_context params env in
   let sp = sp_of_global (IndRef (sp, tyi)) in
-  ((dummy_loc,basename sp), None,
+  (((dummy_loc,basename sp),
    convert_env(List.rev params),
    (extern_constr true envpar arity),
-   convert_constructors envpar cstrnames cstrtypes);;
+   convert_constructors envpar cstrnames cstrtypes), None);;
 
 (* This function converts a Mutual inductive definition to a Coqast.t.
    It is obtained directly from print_mutual in pretty.ml.  However, all
@@ -149,7 +149,7 @@ let make_definition_ast name c typ implicits =
 let constant_to_ast_list kn =
   let cb = Global.lookup_constant kn in
   let c = cb.const_body in
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in
   let l = implicits_of_global (ConstRef kn) in
   (match c with
       None -> 
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
index ce2ee1e7..4bec7350 100644
--- a/contrib/interface/showproof.ml
+++ b/contrib/interface/showproof.ml
@@ -156,16 +156,16 @@ let seq_to_lnhyp sign sign' cl =
 
 let rule_is_complex r =
    match r with
-      Tactic (TacArg (Tacexp t),_) -> true  
-   |  Tactic (TacAtom (_,TacAuto _), _) -> true
-   |  Tactic (TacAtom (_,TacSymmetry _), _) -> true 
+       Nested (Tactic 
+		 ((TacArg (Tacexp _)
+		 |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true
    |_ -> false
 ;;
 
 let rule_to_ntactic r =
    let rt =
      (match r with
-       Tactic (t,_) -> t
+       Nested(Tactic (t,_),_) -> t
      | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h)
      | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
    if rule_is_complex r
@@ -234,17 +234,17 @@ let  to_nproof sigma osign pf =
               (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof)
 		 spfl) in
 	  (match r with
-	    Tactic (TacAtom (_, TacAuto _),_) ->
-	      if spfl=[]
-	      then
-	      	{t_info="to_prove";
-	    	  t_goal= {newhyp=[];
-			    t_concl=concl ntree;
-			    t_full_concl=ntree.t_goal.t_full_concl;
-			    t_full_env=ntree.t_goal.t_full_env};
-		  t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
-	      else ntree
-	  | _ -> ntree))
+	       Nested(Tactic (TacAtom (_, TacAuto _),_),_) ->
+		 if spfl=[]
+		 then
+	      	   {t_info="to_prove";
+	    	    t_goal= {newhyp=[];
+			     t_concl=concl ntree;
+			     t_full_concl=ntree.t_goal.t_full_concl;
+			     t_full_env=ntree.t_goal.t_full_env};
+		    t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
+		 else ntree
+	     | _ -> ntree))
       	else
 	  {t_info="to_prove";
 	    t_goal=(seq_to_lnhyp oldsign nsign cl);
@@ -725,7 +725,7 @@ let rec nsortrec vl x =
    | Case(_,x,t,a) 
         -> nsortrec vl x
    | Cast(x,_, t)-> nsortrec vl t
-   | Const c  -> nsortrec vl (lookup_constant c vl).const_type
+   | Const c  -> nsortrec vl (Typeops.type_of_constant vl c)
    | _ -> nsortrec vl (type_of vl Evd.empty x)
 ;;
 let nsort x =
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
index 064d20ab..fe227f99 100644
--- a/contrib/interface/vtp.ml
+++ b/contrib/interface/vtp.ml
@@ -112,19 +112,12 @@ and fCOMMAND = function
    fFORMULA x2;
    fINT_LIST x3;
    fNODE "abstraction" 3
-| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) ->
+| CT_add_field(x1, x2, x3, x4) ->
    fFORMULA x1;
    fFORMULA x2;
    fFORMULA x3;
-   fFORMULA x4;
-   fFORMULA x5;
-   fFORMULA x6;
-   fFORMULA x7;
-   fFORMULA x8;
-   fFORMULA x9;
-   fFORMULA x10;
-   fBINDING_LIST x11;
-   fNODE "add_field" 11
+   fFORMULA_OPT x4;
+   fNODE "add_field" 4
 | CT_add_natural_feature(x1, x2) ->
    fNATURAL_FEATURE x1;
    fID x2;
@@ -1711,7 +1704,7 @@ and fTACTIC_COM = function
 | CT_replace_with(x1, x2,x3,x4) ->
    fFORMULA x1;
    fFORMULA x2;
-   fID_OPT x3;
+   fCLAUSE x3;
    fTACTIC_OPT x4;
    fNODE "replace_with" 4
 | CT_rewrite_lr(x1, x2, x3) ->
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
index 024cb599..6c9e8239 100644
--- a/contrib/interface/xlate.ml
+++ b/contrib/interface/xlate.ml
@@ -497,6 +497,8 @@ let xlate_hyp_location =
   | (_, MetaId _),_ -> 
       xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)"
 
+
+
 let xlate_clause cls =
   let hyps_info =
     match cls.onhyps with
@@ -724,7 +726,9 @@ and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) =
     | Reference (Ident (_,s)) -> ident_tac s
     | ConstrMayEval(ConstrTerm a) ->
 	CT_formula_marker(xlate_formula a)
-    | TacFreshId s -> CT_fresh(ctf_STRING_OPT s)
+    | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None)
+    | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s))
+    | TacFreshId _ -> xlate_error "TODO: fresh with many args"
     | t -> xlate_error "TODO LATER: result other than tactic or constr"
 
 and xlate_red_tactic =
@@ -937,6 +941,8 @@ and xlate_tac =
      CT_injection_eq
          (xlate_quantified_hypothesis_opt
 	    (out_gen (wit_opt rawwit_quant_hyp) idopt))
+    | TacExtend (_,"injection_as", [idopt;ipat]) ->
+	xlate_error "TODO: injection as"
     | TacFix (idopt, n) ->
      CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
     | TacMutualFix (id, n, fixtac_list) ->
@@ -972,22 +978,36 @@ and xlate_tac =
     | TacRight bindl -> CT_right (xlate_bindings bindl)
     | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl)
     | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl)
-    | TacExtend (_,"replace", [c1; c2;id_opt;tac_opt]) ->
+    | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) ->
 	let c1 = xlate_formula (out_gen rawwit_constr c1) in
 	let c2 = xlate_formula (out_gen rawwit_constr c2) in
-	let id_opt = 
-	  match out_gen Extratactics.rawwit_in_arg_hyp id_opt with 
-	  | None -> ctv_ID_OPT_NONE
-	  | Some (_,id) ->   ctf_ID_OPT_SOME (xlate_ident id)
-	in
+	let cl = 
+	  (* J.F. : 18/08/2006 
+	     Hack to coerce the "clause" argument of replace to a real clause 
+	     To be remove if we can reuse the clause grammar entrie defined in g_tactic
+	  *)
+	  let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in 
+	  let cl_as_xlate_arg = 
+	    {cl_as_clause with 
+	       Tacexpr.onhyps = 
+		option_map 
+		  (fun l -> 
+		     List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
+		  )
+		  cl_as_clause.Tacexpr.onhyps
+	    }
+	  in
+	  cl_as_xlate_arg
+	in 
+	let cl = xlate_clause cl in 
 	let tac_opt = 
-	  match out_gen (Extratactics.rawwit_by_arg_tac) tac_opt with
+	  match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with
 	    | None -> CT_coerce_NONE_to_TACTIC_OPT  CT_none
 	    | Some tac ->
 		let tac =  xlate_tactic tac in
 		CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
 	in 
-	CT_replace_with (c1, c2,id_opt,tac_opt)
+	CT_replace_with (c1, c2,cl,tac_opt)
     | TacRewrite(b,cbindl,cl) -> 
      let cl = xlate_clause cl 
      and c = xlate_formula (fst cbindl) 
@@ -1077,12 +1097,12 @@ and xlate_tac =
 	let first_n =
 	  match out_gen (wit_opt rawwit_int_or_var) nopt with
 	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some ArgArg n -> xlate_int_to_id_or_int_opt n
+	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
 	    | None -> none_in_id_or_int_opt in
 	let second_n =
 	  match out_gen (wit_opt rawwit_int_or_var) popt with
 	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some ArgArg n -> xlate_int_to_id_or_int_opt n
+	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
 	    | None -> none_in_id_or_int_opt in
 	let _lems =
 	  match out_gen Eauto.rawwit_auto_using lems with
@@ -1625,6 +1645,15 @@ let rec xlate_vernac =
 	CT_solve (CT_int n, xlate_tactic tac,
 		  if b then CT_dotdot
                   else CT_coerce_NONE_to_DOTDOT_OPT CT_none)
+
+(* MMode *)
+
+    | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> 
+	anomaly "No MMode in CTcoq"
+
+
+(* /MMode *)
+
     | VernacFocus nopt -> CT_focus (xlate_int_opt nopt)
     | VernacUnfocus -> CT_unfocus
     |VernacExtend("Extraction", [f;l]) ->
@@ -1645,27 +1674,14 @@ let rec xlate_vernac =
 	CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
 				List.map loc_qualid_to_ct_ID l2))
     | VernacExtend("Field", 
-		   [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) ->
+		   [fth;ainv;ainvl;div]) ->
 	(match List.map (fun v -> xlate_formula(out_gen rawwit_constr v))
-                   [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl]
+                   [fth;ainv;ainvl]
  	 with
-             [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] ->
-	       let bind =
-		 match out_gen Field.rawwit_minus_div_arg minusdiv with
-		     None, None ->
-		       CT_binding_list[]
-		   | Some m, None ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)]
-		   | None, Some d ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)]
-		   | Some m, Some d ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m);
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in
-		 CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1,
-			      ainv1, fth1, ainvl1, bind)
+             [fth1;ainv1;ainvl1] ->
+	       let adiv1 =
+                 xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in
+	       CT_add_field(fth1, ainv1, ainvl1, adiv1)
 	   |_ -> assert false)
   | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) ->
       let orient = out_gen Extraargs.rawwit_orient o in
@@ -1768,9 +1784,10 @@ let rec xlate_vernac =
   | VernacShow ShowExistentials -> CT_show_existentials
   | VernacShow ShowScript -> CT_show_script
   | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)"
+  | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)"
   | VernacGo arg -> CT_go (xlate_locn arg)
-  | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l)
-  | VernacShow ExplainTree l ->
+  | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l)
+  | VernacShow (ExplainTree l) ->
       CT_explain_prooftree (nums_to_int_list l)
   | VernacCheckGuard -> CT_guarded
   | VernacPrint p ->
@@ -1874,7 +1891,7 @@ let rec xlate_vernac =
          build_record_field_list field_list)
    | VernacInductive (isind, lmi) ->
       let co_or_ind = if isind then "Inductive" else "CoInductive" in
-      let strip_mutind ((_,s), notopt, parameters, c, constructors) =
+      let strip_mutind (((_,s), parameters, c, constructors), notopt) =
           CT_ind_spec
             (xlate_ident s, xlate_binder_list parameters, xlate_formula c,
              build_constructors constructors,
@@ -1883,7 +1900,7 @@ let rec xlate_vernac =
 	  (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi))
    | VernacFixpoint ([],_) -> xlate_error "mutual recursive"
    | VernacFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutrec ((fid, (n, ro), bl, arf, ardef), ntn) =
+      let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) =
         let (struct_arg,bl,arf,ardef) =
 	 (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
 	 (* By the way, how could [bl = []] happen in V8 syntax ?  *)
@@ -1903,7 +1920,7 @@ let rec xlate_vernac =
 	  (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi))
    | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive"
    | VernacCoFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutcorec (fid, bl, arf, ardef) =
+      let strip_mutcorec ((fid, bl, arf, ardef), _ntn) =
 	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
                       xlate_formula arf, xlate_formula ardef) in
         CT_cofix_decl
diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4
index ed2e5b5f..353fcdb3 100644
--- a/contrib/recdef/recdef.ml4
+++ b/contrib/recdef/recdef.ml4
@@ -119,8 +119,7 @@ let def_of_const t =
 
 let type_of_const t =
    match (kind_of_term t) with
-    Const sp -> 
-      (Global.lookup_constant sp).const_type
+    Const sp -> Typeops.type_of_constant (Global.env()) sp
     |_ -> assert false
 
 let arg_type t =
@@ -133,7 +132,17 @@ let evaluable_of_global_reference r =
       ConstRef sp -> EvalConstRef sp
     | VarRef id -> EvalVarRef id
     | _ -> assert false;;
-  
+
+
+let rank_for_arg_list h = 
+  let predicate a b = 
+      try List.for_all2 eq_constr a b with
+        Invalid_argument _ -> false in
+  let rec rank_aux i = function
+  | [] -> None
+  | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
+  rank_aux 0;;
+
 let rec (find_call_occs:
 	   constr -> constr -> (constr list ->constr)*(constr  list list)) =
  fun f expr ->
@@ -144,19 +153,36 @@ let rec (find_call_occs:
      let (largs: constr list) = Array.to_list args in
      let rec find_aux = function
 	 []    -> (fun x -> []), []
-       | a::tl ->
-         (match find_aux tl with
-          (cf, ((arg1::args) as opt_args)) -> 
+       | a::upper_tl ->
+         (match find_aux upper_tl with
+          (cf, ((arg1::args) as args_for_upper_tl)) -> 
            (match find_call_occs f a with
              cf2, (_ :: _ as other_args) ->
-	       let len1 = List.length other_args in
-                 (fun l ->
-                   cf2 l::(cf (nthtl(l,len1)))), other_args@opt_args
-           | _, [] -> (fun x -> a::cf x), opt_args)
+               let rec avoid_duplicates args =
+                  match args with
+                  | [] -> (fun _ -> []), []
+                  | h::tl -> 
+                      let recomb_tl, args_for_tl =
+                          avoid_duplicates tl in
+                    match rank_for_arg_list h args_for_upper_tl with
+                    | None -> 
+                        (fun l -> List.hd l::recomb_tl(List.tl l)),
+                        h::args_for_tl
+                    | Some i ->
+                        (fun l -> List.nth l (i+List.length args_for_tl)::
+                            recomb_tl l),
+                        args_for_tl
+               in
+               let recombine, other_args' =
+                   avoid_duplicates other_args in
+	       let len1 = List.length other_args' in                   
+                   (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
+                     other_args'@args_for_upper_tl
+           | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
 	 | _, [] ->
 	   (match find_call_occs f a with
-	     cf, (arg1::args) -> (fun l -> cf l::tl), (arg1::args)
-	   | _, [] -> (fun x -> a::tl), [])) in
+	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
+	   | _, [] -> (fun x -> a::upper_tl), [])) in
      begin
        match (find_aux largs) with
 	   cf, [] -> (fun l -> mkApp(g, args)), []
@@ -168,7 +194,7 @@ let rec (find_call_occs:
   | Meta(_) -> error "find_call_occs : Meta"
   | Evar(_) -> error "find_call_occs : Evar"
   | Sort(_)  -> error "find_call_occs : Sort"
-  | Cast(_,_,_) -> error "find_call_occs : cast"
+  | Cast(b,_,_) -> find_call_occs f b
   | Prod(_,_,_) -> error "find_call_occs : Prod"
   | Lambda(_,_,_) -> error "find_call_occs : Lambda"
   | LetIn(_,_,_,_) -> error "find_call_occs : let in"
@@ -182,6 +208,8 @@ let rec (find_call_occs:
   | Fix(_) -> error "find_call_occs : Fix"
   | CoFix(_) -> error "find_call_occs : CoFix";;
 
+
+
 let coq_constant s =
   Coqlib.gen_constant_in_modules "RecursiveDefinition" 
     (Coqlib.init_modules @ Coqlib.arith_modules) s;;
@@ -268,8 +296,17 @@ let rec  mk_intros_and_continue (extra_eqn:bool)
 	  let teq = pf_get_new_id teq_id g in
 	    tclTHENLIST
 	      [ h_intro teq;
-		tclMAP (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) (List.rev eqs);
-	        cont_function (mkVar teq::eqs) expr
+		tclMAP 
+		  (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) 
+		  (List.rev eqs);
+		(fun g1 -> 
+		   let ty_teq = pf_type_of g1 (mkVar teq) in 
+		   let teq_lhs,teq_rhs = 
+		     let _,args = destApp ty_teq in 
+		     args.(1),args.(2) 
+		   in
+	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
+		)
 	      ]
 	      g
 	else
@@ -285,16 +322,18 @@ let simpl_iter () =
        {rBeta=true;rIota=true;rZeta= true; rDelta=false;
         rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
     onConcl
-    
+
+(* The boolean value is_mes expresses that the termination is expressed
+  using a measure function instead of a well-founded relation. *)
 let tclUSER is_mes l g = 
-  let b,l = 
+  let clear_tac = 
     match l with 
-	None -> true,[]
-      | Some l -> false,l
+      | None -> h_clear true []
+      | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
   in
   tclTHENSEQ 
     [
-      (h_clear b l);
+      clear_tac;
       if is_mes 
       then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))]
       else tclIDTAC
@@ -473,12 +512,17 @@ let rec introduce_all_values is_mes acc_inv func context_fn
 		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
 		 [ observe_tac "h_assumption" h_assumption
 		 ;
-		  observe_tac "user proof"  (fun g ->  
-					       tclUSER
-						 is_mes
-						 (Some (hrec::hspec::(retrieve_acc_var g)@specs))
-						 g
-					    )
+		  tclTHENLIST
+		    [
+		      tclTRY(list_rewrite true eqs);
+		      observe_tac "user proof" 
+			(fun g ->  
+			   tclUSER
+			     is_mes
+			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
+			     g
+			)		     
+		    ]
 		 ]
 	    )
 	   ]) g)
@@ -574,13 +618,14 @@ let hyp_terminates func =
 	     
 
 
-let tclUSER_if_not_mes is_mes = 
+let tclUSER_if_not_mes is_mes names_to_suppress = 
   if is_mes 
   then 
     tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings))
-  else tclUSER is_mes None
+  else tclUSER is_mes names_to_suppress
 
-let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = 
+let termination_proof_header is_mes input_type ids args_id relation
+    rec_arg_num rec_arg_id tac wf_tac : tactic = 
   begin 
     fun g -> 
       let nargs = List.length args_id in
@@ -596,7 +641,8 @@ let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_t
 	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
 	  (wf_thm::ids) 
       in 
-      let hrec = next_global_ident_away true hrec_id (wf_rec_arg::wf_thm::ids) in 
+      let hrec = next_global_ident_away true hrec_id
+	(wf_rec_arg::wf_thm::ids) in 
       let acc_inv = 
 	  lazy (
 	    mkApp (
@@ -630,9 +676,9 @@ let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_t
 		  )
 	       )
 	       [ 
-		 (* interactive proof of the well_foundness of the relation *) 
-		 wf_tac is_mes;
-		 (* well_foundness -> Acc for any element *)
+		 (* interactive proof that the relation is well_founded *)
+		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
+		 (* this gives the accessibility argument *)
 		 observe_tac 
 		   "apply wf_thm" 
 		   (h_apply ((mkApp(mkVar wf_thm,
@@ -694,7 +740,7 @@ let whole_start is_mes func input_type relation rec_arg_num  : tactic =
       in
       let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
       let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in 
-      start 
+      termination_proof_header 
 	is_mes
 	input_type
 	ids
@@ -716,7 +762,7 @@ let whole_start is_mes func input_type relation rec_arg_num  : tactic =
 	   )
 	     g 
 	)
-	tclUSER_if_not_mes
+	tclUSER_if_not_mes 
 	g 
   end
 
@@ -724,7 +770,7 @@ let whole_start is_mes func input_type relation rec_arg_num  : tactic =
 let get_current_subgoals_types () = 
   let pts =  get_pftreestate () in 
   let _,subs = extract_open_pftreestate pts in 
-  List.map snd subs 
+  List.map snd (List.sort (fun (x,_) (y,_) -> x -y )subs )
 
 
 let build_and_l l = 
@@ -745,8 +791,31 @@ let build_and_l l =
 	  ],nb+1
   in f l
 
+
+let is_rec_res id = 
+  let rec_res_name = string_of_id rec_res_id   in 
+  let id_name = string_of_id id in 
+  try 
+    String.sub id_name 0 (String.length rec_res_name) = rec_res_name 
+  with _ -> false
+
+let clear_goals = 
+  let rec clear_goal t = 
+    match kind_of_term t with 
+      | Prod(Name id as na,t,b) -> 
+	  let b' = clear_goal b in 
+	  if noccurn 1 b' && (is_rec_res id) 
+	  then pop b' 
+	  else if b' == b then t 
+	  else mkProd(na,t,b')
+      | _ -> map_constr clear_goal t
+  in 
+  List.map clear_goal 
+
+
 let build_new_goal_type () = 
   let sub_gls_types = get_current_subgoals_types () in 
+  let sub_gls_types = clear_goals sub_gls_types in 
   let res = build_and_l sub_gls_types in 
   res
   
@@ -767,7 +836,7 @@ let prove_with_tcc lemma _ : tactic =
       
 	     
 
-let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal)   = 
+let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal)   = 
   let current_proof_name = get_current_proof_name () in
   let name = match goal_name with 
     | Some s -> s 
@@ -782,7 +851,11 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal)   =
     Util.error "\"abstract\" cannot handle existentials";
   let hook _ _ = 
     let lemma = mkConst (Lib.make_con na) in 
-    Array.iteri (fun i _ -> by (observe_tac "tac" (prove_with_tcc lemma i))) (Array.make nb_goal ());
+    Array.iteri 
+      (fun i _ -> 
+	 by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i)))
+      (Array.make nb_goal ())
+    ;
     ref := Some lemma ;
     defined ();
   in
@@ -792,8 +865,28 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal)   =
     sign
     gls_type 
     hook ;
-  by (decompose_and_tac);
-  if Options.is_verbose () then (pp (Printer.pr_open_subgoals()))
+  by (
+    fun g -> 
+      tclTHEN 
+	(decompose_and_tac)
+	(tclORELSE 
+	(tclFIRST 
+	   (List.map
+	      (fun c -> 
+		 tclTHENSEQ
+		   [intros; 
+		    h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); 
+		    tclCOMPLETE Auto.default_auto
+		   ]
+	      )
+	      using_lemmas)
+	) tclIDTAC)
+	g);
+  try
+    by tclIDTAC; (* raises UserError _ if the proof is complete *)
+    if Options.is_verbose () then (pp (Printer.pr_open_subgoals()))
+  with UserError _ -> 
+    defined ()
   
     
 let com_terminate 
@@ -804,7 +897,7 @@ let com_terminate
     input_type
     relation 
     rec_arg_num
-    thm_name hook =
+    thm_name using_lemmas hook =
   let (evmap, env) = Command.get_current_context() in
   start_proof thm_name
     (Global, Proof Lemma) (Environ.named_context_val env)
@@ -813,7 +906,7 @@ let com_terminate
 				       input_type relation rec_arg_num ));
   try 
     let new_goal_type = build_new_goal_type () in 
-    open_new_goal tcc_lemma_ref
+    open_new_goal using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
       (new_goal_type)
   with Failure "empty list of subgoals!" -> 
@@ -895,9 +988,9 @@ let start_equation (f:global_reference) (term_f:global_reference)
   in
   tclTHENLIST [
     h_intros x;
-    unfold_constr f;
-    simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)));
-    cont_tactic x] g
+    observe_tac "unfold_constr f" (unfold_constr f);
+    observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))));
+    observe_tac "prove_eq" (cont_tactic x)] g
 ;;
 
 let base_leaf_eq func eqs f_id g =
@@ -1021,8 +1114,8 @@ let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
 	     _,[] -> 
 	       tclTHENS(mkCaseEq a)(* (simplest_case a) *)
 	  	 (List.map
-		    (mk_intros_and_continue true
-		       (prove_eq  termine f functional) eqs)
+		    (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true
+		       (prove_eq  termine f functional) eqs expr))
 		    (Array.to_list l))
 	   | _,_::_ ->
                	(match find_call_occs f expr with
@@ -1045,13 +1138,13 @@ let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
 
 let (com_eqn : identifier ->
        global_reference -> global_reference -> global_reference
-	 -> constr_expr -> unit) =
-  fun eq_name functional_ref f_ref terminate_ref eq ->
+	 -> constr -> unit) =
+  fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
     let (evmap, env) = Command.get_current_context() in
-    let eq_constr = interp_constr evmap env eq in
     let f_constr = (constr_of_reference f_ref) in
+    let equation_lemma_type = subst1 f_constr equation_lemma_type in
     (start_proof eq_name (Global, Proof Lemma)
-       (Environ.named_context_val env) eq_constr (fun _ _ -> ());
+       (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
      by
        (start_equation f_ref terminate_ref
 	  (fun x ->
@@ -1066,22 +1159,25 @@ let (com_eqn : identifier ->
 	       )
 	  )
        );
-     defined (); 
+     Options.silently defined (); 
     );;
 
 
-let recursive_definition is_mes function_name type_of_f r rec_arg_num eq 
-    generate_induction_principle : unit =
+let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq 
+    generate_induction_principle using_lemmas : unit =
   let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
-  let env = push_rel (Name function_name,None,function_type) (Global.env()) in
-  let res_vars,eq' = decompose_prod (interp_constr Evd.empty env eq) in 
+  let env = push_named (function_name,None,function_type) (Global.env()) in
+(*   Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
+  let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in 
+(*   Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *)
+  let res_vars,eq' = decompose_prod equation_lemma_type in 
   let res = 
 (*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
 (*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
 (*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
     match kind_of_term eq' with 
       | App(e,[|_;_;eq_fix|]) -> 
-	  mkLambda (Name function_name,function_type,compose_lam res_vars eq_fix)
+	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
       | _ -> failwith "Recursive Definition (res not eq)"
   in
   let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in 
@@ -1106,9 +1202,11 @@ let recursive_definition is_mes function_name type_of_f r rec_arg_num eq
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
 (*     message "start second proof"; *)
     begin 
-      try com_eqn equation_id functional_ref f_ref term_ref eq
+      try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
       with e -> 
 	begin 
+	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+	  then anomalylabstrm "" (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e);
 	  ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
 	  anomaly "Cannot create equation Lemma"
 	end
@@ -1134,6 +1232,7 @@ let recursive_definition is_mes function_name type_of_f r rec_arg_num eq
       rec_arg_type
       relation rec_arg_num
       term_id
+      using_lemmas
       hook 
   with e -> 
     begin
@@ -1154,10 +1253,10 @@ VERNAC COMMAND EXTEND RecursiveDefinition
 	| None -> 1
 	| Some n -> n 
     in
-    recursive_definition false f type_of_f r rec_arg_num eq (fun _ _ _ _ _  _ _ _ -> ())]
+    recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _  _ _ _ -> ()) []]
 | [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
      "[" ne_constr_list(proof) "]" constr(eq) ] ->
-  [ ignore(proof);ignore(wf);recursive_definition false f type_of_f r 1 eq  (fun  _ _  _ _ _ _ _ _ -> ())]
+  [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq  (fun  _ _  _ _ _ _ _ _ -> ()) []]
 END
 
 
diff --git a/contrib/ring/ArithRing.v b/contrib/ring/LegacyArithRing.v
index 68464c10..e062b731 100644
--- a/contrib/ring/ArithRing.v
+++ b/contrib/ring/LegacyArithRing.v
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* Instantiation of the Ring tactic for the naturals of Arith $*)
 
-Require Export Ring.
+Require Import Bool.
+Require Export LegacyRing.
 Require Export Arith.
 Require Import Eqdep_dec.
 
@@ -36,12 +37,12 @@ Hint Resolve nateq_prop: arithring.
 
 Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
   split; intros; auto with arith arithring.
-  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
-  trivial.
+(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
+  trivial.*)
 Defined.
 
 
-Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
+Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
 
 Goal forall n:nat, S n = 1 + n.
 intro; reflexivity.
diff --git a/contrib/ring/NArithRing.v b/contrib/ring/LegacyNArithRing.v
index 878346ba..c689fc40 100644
--- a/contrib/ring/NArithRing.v
+++ b/contrib/ring/LegacyNArithRing.v
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* Instantiation of the Ring tactic for the binary natural numbers *)
 
-Require Export Ring.
+Require Import Bool.
+Require Export LegacyRing.
 Require Export ZArith_base.
 Require Import NArith.
 Require Import Eqdep_dec.
@@ -37,8 +38,9 @@ Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq.
     apply Nmult_1_l.
     apply Nmult_0_l.
     apply Nmult_plus_distr_r.
-    apply Nplus_reg_l.
+(*    apply Nplus_reg_l.*)
     apply Neq_prop.
 Qed.
 
-Add Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
+Add Legacy Semi Ring
+  N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/contrib/ring/Ring.v b/contrib/ring/LegacyRing.v
index 6572e79a..dc8635bd 100644
--- a/contrib/ring/Ring.v
+++ b/contrib/ring/LegacyRing.v
@@ -9,7 +9,7 @@
 (* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Bool.
-Require Export Ring_theory.
+Require Export LegacyRing_theory.
 Require Export Quote.
 Require Export Ring_normalize.
 Require Export Ring_abstract.
@@ -32,5 +32,5 @@ destruct n; destruct m; destruct p; reflexivity.
 destruct x; destruct y; reflexivity || simpl in |- *; tauto.
 Defined.
 
-Add Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
- [ true false ].
\ No newline at end of file
+Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
+ [ true false ].
diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/LegacyRing_theory.v
index 5536294e..5df927a6 100644
--- a/contrib/ring/Ring_theory.v
+++ b/contrib/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_theory.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 Require Export Bool.
 
@@ -39,7 +39,7 @@ Record Semi_Ring_Theory : Prop :=
    SR_mult_one_left : forall n:A, 1 * n = n;
    SR_mult_zero_left : forall n:A, 0 * n = 0;
    SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;
+(*   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
    SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
 
 Variable T : Semi_Ring_Theory.
@@ -52,10 +52,10 @@ Let plus_zero_left := SR_plus_zero_left T.
 Let mult_one_left := SR_mult_one_left T. 
 Let mult_zero_left := SR_mult_zero_left T.
 Let distr_left := SR_distr_left T.
-Let plus_reg_left := SR_plus_reg_left T.
+(*Let plus_reg_left := SR_plus_reg_left T.*)
 
 Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left plus_reg_left.
+  mult_one_left mult_zero_left distr_left (*plus_reg_left*).
 
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
   not symmetry *) 
@@ -126,11 +126,11 @@ Qed.
 Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
 intro; elim mult_comm; auto.
 Qed.
-
+(*
 Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
 intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
 Qed.
-
+*)
 End Theory_of_semi_rings.
 
 Section Theory_of_rings.
@@ -320,7 +320,7 @@ symmetry  in |- *; apply Th_mult_opp_opp. Qed.
 Lemma Th_opp_zero : - 0 = 0.
 rewrite <- (plus_zero_left (- 0)).
 auto. Qed.
-
+(*
 Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
 intros; generalize (f_equal (fun z => - n + z) H).
 repeat rewrite plus_assoc.
@@ -336,7 +336,7 @@ rewrite (plus_comm n m).
 rewrite (plus_comm n p).
 auto.
 Qed.
-
+*)
 Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
 intros.
 repeat rewrite (mult_comm n).
@@ -349,7 +349,7 @@ Qed.
 
 End Theory_of_rings.
 
-Hint Resolve Th_mult_zero_left Th_plus_reg_left: core.
+Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
 
 Unset Implicit Arguments.
 
@@ -373,4 +373,4 @@ End product_ring.
 
 Section power_ring.
 
-End power_ring.
\ No newline at end of file
+End power_ring.
diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/LegacyZArithRing.v
index 3999b632..a410fbc5 100644
--- a/contrib/ring/ZArithRing.v
+++ b/contrib/ring/LegacyZArithRing.v
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *)
 
 (* Instantiation of the Ring tactic for the binary integers of ZArith *)
 
-Require Export ArithRing.
+Require Export LegacyArithRing.
 Require Export ZArith_base.
 Require Import Eqdep_dec.
+Require Import LegacyRing.
 
 Unboxed Definition Zeq (x y:Z) :=
   match (x ?= y)%Z with
@@ -32,5 +33,5 @@ Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
 Qed.
 
 (* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
+Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
  [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
index c0818da8..115ed5ca 100644
--- a/contrib/ring/Ring_abstract.v
+++ b/contrib/ring/Ring_abstract.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_abstract.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *)
 
-Require Import Ring_theory.
+Require Import LegacyRing_theory.
 Require Import Quote.
 Require Import Ring_normalize.
 
@@ -129,7 +129,7 @@ Hint Resolve (SR_mult_zero_left T).
 Hint Resolve (SR_mult_zero_left2 T).
 Hint Resolve (SR_distr_left T).
 Hint Resolve (SR_distr_left2 T).
-Hint Resolve (SR_plus_reg_left T).
+(*Hint Resolve (SR_plus_reg_left T).*)
 Hint Resolve (SR_plus_permute T).
 Hint Resolve (SR_mult_permute T).
 Hint Resolve (SR_distr_right T).
@@ -140,7 +140,7 @@ Hint Resolve (SR_plus_zero_right T).
 Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
-Hint Resolve (SR_plus_reg_right T).
+(*Hint Resolve (SR_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
@@ -439,7 +439,7 @@ Hint Resolve (Th_mult_zero_left T).
 Hint Resolve (Th_mult_zero_left2 T).
 Hint Resolve (Th_distr_left T).
 Hint Resolve (Th_distr_left2 T).
-Hint Resolve (Th_plus_reg_left T).
+(*Hint Resolve (Th_plus_reg_left T).*)
 Hint Resolve (Th_plus_permute T).
 Hint Resolve (Th_mult_permute T).
 Hint Resolve (Th_distr_right T).
@@ -449,7 +449,7 @@ Hint Resolve (Th_plus_zero_right T).
 Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
-Hint Resolve (Th_plus_reg_right T).
+(*Hint Resolve (Th_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
index 7b40328a..4a082396 100644
--- a/contrib/ring/Ring_normalize.v
+++ b/contrib/ring/Ring_normalize.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_normalize.v 6295 2004-11-12 16:40:39Z gregoire $ *)
+(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *)
 
-Require Import Ring_theory.
+Require Import LegacyRing_theory.
 Require Import Quote.
 
 Set Implicit Arguments.
@@ -356,7 +356,7 @@ Hint Resolve (SR_mult_zero_left T).
 Hint Resolve (SR_mult_zero_left2 T).
 Hint Resolve (SR_distr_left T).
 Hint Resolve (SR_distr_left2 T).
-Hint Resolve (SR_plus_reg_left T).
+(*Hint Resolve (SR_plus_reg_left T).*)
 Hint Resolve (SR_plus_permute T).
 Hint Resolve (SR_mult_permute T).
 Hint Resolve (SR_distr_right T).
@@ -367,7 +367,7 @@ Hint Resolve (SR_plus_zero_right T).
 Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
-Hint Resolve (SR_plus_reg_right T).
+(*Hint Resolve (SR_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
 Hint Immediate T.
@@ -785,7 +785,7 @@ Hint Resolve (Th_mult_zero_left T).
 Hint Resolve (Th_mult_zero_left2 T).
 Hint Resolve (Th_distr_left T).
 Hint Resolve (Th_distr_left2 T).
-Hint Resolve (Th_plus_reg_left T).
+(*Hint Resolve (Th_plus_reg_left T).*)
 Hint Resolve (Th_plus_permute T).
 Hint Resolve (Th_mult_permute T).
 Hint Resolve (Th_distr_right T).
@@ -796,7 +796,7 @@ Hint Resolve (Th_plus_zero_right T).
 Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
-Hint Resolve (Th_plus_reg_right T).
+(*Hint Resolve (Th_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4
index dccd1944..2f964988 100644
--- a/contrib/ring/g_ring.ml4
+++ b/contrib/ring/g_ring.ml4
@@ -8,13 +8,14 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_ring.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *)
 
 open Quote
 open Ring
+open Tacticals
 
 TACTIC EXTEND ring
-  [ "ring" constr_list(l) ] -> [ polynom l ]
+| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
 END
 
 (* The vernac commands "Add Ring" and co *)
@@ -23,7 +24,7 @@ let cset_of_constrarg_list l =
   List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
 
 VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Ring" 
+  [ "Add" "Legacy" "Ring" 
           constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
           constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
   -> [ add_theory true false false
@@ -40,7 +41,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Semi" "Ring" 
+| [ "Add" "Legacy" "Semi" "Ring" 
       	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
           constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
   -> [ add_theory false false false
@@ -57,7 +58,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Abstract" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Ring" 
     	  constr(a) constr(aplus) constr(amult) constr(aone)
           constr(azero) constr(aopp) constr(aeq) constr(t) ] 
   -> [ add_theory true true false
@@ -74,7 +75,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 ConstrSet.empty ]
 
-| [ "Add" "Abstract" "Semi" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Semi" "Ring" 
           constr(a) constr(aplus) constr(amult) constr(aone)
           constr(azero) constr(aeq) constr(t) ] 
   -> [ add_theory false true false
@@ -91,7 +92,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 ConstrSet.empty ]
 
-| [ "Add" "Setoid" "Ring"
+| [ "Add" "Legacy" "Setoid" "Ring"
       	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) 
 	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
 	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] 
@@ -112,7 +113,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Semi" "Setoid" "Ring" 
+| [ "Add" "Legacy" "Semi" "Setoid" "Ring" 
           constr(a) constr(aequiv) constr(asetth) constr(aplus)
 	  constr(amult) constr(aone) constr(azero) constr(aeq) 
           constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] 
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
index 462e5ed8..e0a6cba3 100644
--- a/contrib/ring/quote.ml
+++ b/contrib/ring/quote.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: quote.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
+(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *)
 
 (* The `Quote' tactic *)
 
@@ -298,7 +298,7 @@ let rec closed_under cset t =
   (ConstrSet.mem t cset) or
   (match (kind_of_term t) with
      | Cast(c,_,_) -> closed_under cset c  
-     | App(f,l) -> closed_under cset f & array_for_all (closed_under cset) l
+     | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
      | _ -> false)
     
 (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
index 5251dcc5..6b82b75b 100644
--- a/contrib/ring/ring.ml
+++ b/contrib/ring/ring.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ring.ml 7837 2006-01-11 09:47:32Z herbelin $ *)
+(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* ML part of the Ring tactic *)
 
@@ -43,7 +43,7 @@ let ring_dir = ["Coq";"ring"]
 let setoids_dir = ["Coq";"Setoids"]
 
 let ring_constant = Coqlib.gen_constant_in_modules "Ring"
-  [ring_dir@["Ring_theory"];
+  [ring_dir@["LegacyRing_theory"];
    ring_dir@["Setoid_ring_theory"];
    ring_dir@["Ring_normalize"];
    ring_dir@["Ring_abstract"];
@@ -885,7 +885,7 @@ let match_with_equiv c = match (kind_of_term c) with
   | _ -> None
 
 let polynom lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"Ring"];
+  Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
   match lc with 
    (* If no argument is given, try to recognize either an equality or
       a declared relation with arguments c1 ... cn, 
diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml
index 445dead2..a1f5e5aa 100644
--- a/contrib/rtauto/refl_tauto.ml
+++ b/contrib/rtauto/refl_tauto.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refl_tauto.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
+(* $Id: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 module Search = Explore.Make(Proof_search)
 
@@ -303,7 +303,6 @@ let rtauto_tac gls=
     end in
   let build_start_time=System.get_time () in
   let _ = step_count := 0; node_count := 0 in
-  let nhyps = List.length hyps in
   let main = mkApp (force node_count l_Reflect,
 		    [|build_env gamma;
 		      build_form formula;
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
new file mode 100644
index 00000000..5060bc69
--- /dev/null
+++ b/contrib/setoid_ring/ArithRing.v
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Mult.
+Require Export Ring.
+Set Implicit Arguments.
+
+Ltac isnatcst t :=
+  let t := eval hnf in t in
+  match t with
+    O => true
+  | S ?p => isnatcst p
+  | _ => false
+  end.
+Ltac natcst t :=
+  match isnatcst t with
+    true => t
+  | _ => NotConstant
+  end.
+
+Ltac Ss_to_add f acc :=
+  match f with
+  | S ?f1 => Ss_to_add f1 (S acc)
+  | _ => constr:(acc + f)%nat
+  end.
+
+Ltac natprering :=
+  match goal with
+    |- context C [S ?p] =>
+    match p with
+      O => fail 1 (* avoid replacing 1 with 1+0 ! *)
+    | p => match isnatcst p with 
+           | true => fail 1
+           | false => let v := Ss_to_add p (S 0) in
+                         fold v; natprering
+           end
+    end
+  | _ => idtac
+  end.
+
+ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
+ Proof.
+  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
+  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
+  exact mult_plus_distr_r. 
+ Qed.
+
+
+Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
+  match n, m with
+  | O, O => true
+  | S n', S m' => nateq n' m'
+  | _, _ => false
+  end.
+
+Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m.
+Proof.
+  simple induction n; simple induction m; simpl; intros; try discriminate.
+  trivial.
+  rewrite (H n1 H1).
+  trivial.
+Qed.
+
+Add Ring natr : natSRth
+  (decidable nateq_ok, constants [natcst], preprocess [natprering]).
diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v
index 0def087f..0d0fe5a4 100644
--- a/contrib/setoid_ring/BinList.v
+++ b/contrib/setoid_ring/BinList.v
@@ -1,46 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
 Set Implicit Arguments.
 Require Import BinPos.
+Require Export List.
+Require Export ListTactics.
 Open Scope positive_scope.
 
+Section MakeBinList.
+ Variable A : Type.
+ Variable default : A.
 
-Section LIST.
-
- Variable A:Type.
- Variable default:A.
-
- Inductive list : Type :=
-  | nil : list
-  | cons : A -> list -> list.
-  
- Infix "::" := cons (at level 60, right associativity).
-
- Definition hd l := match l with hd :: _ => hd | _ => default end. 
-
- Definition tl l := match l with _ :: tl => tl | _ => nil end. 
-
- Fixpoint jump (p:positive) (l:list) {struct p} : list :=
+ Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
   match p with
-  | xH => tl l
+  | xH => tail l
   | xO p => jump p (jump p l)
-  | xI p  => jump p (jump p (tl l))
+  | xI p  => jump p (jump p (tail l))
   end.
 
- Fixpoint nth (p:positive) (l:list) {struct p} : A:=
+ Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
   match p with
-  | xH => hd l
+  | xH => hd default l
   | xO p => nth p (jump p l)
-  | xI p => nth p (jump p (tl l))
+  | xI p => nth p (jump p (tail l))
   end. 
 
- Fixpoint rev_append (rev l : list) {struct l} : list :=
-  match l with
-  | nil => rev
-  | (cons h t) => rev_append (cons h rev) t 
-  end.
- 
- Definition rev l : list := rev_append nil l.
-
- Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l).
+ Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
  Proof. 
   induction j;simpl;intros.
   repeat rewrite IHj;trivial.
@@ -71,7 +61,7 @@ Section LIST.
  Qed.
 
  Lemma jump_Pdouble_minus_one : forall i l,
-  (jump (Pdouble_minus_one i) (tl l)) = (jump i (jump i l)).
+  (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
  Proof.
   induction i;intros;simpl.
   repeat rewrite jump_tl;trivial.
@@ -80,7 +70,7 @@ Section LIST.
  Qed.
 
  
- Lemma nth_jump : forall p l, nth p (tl l) = hd (jump p l).
+ Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
  Proof.
   induction p;simpl;intros.
   rewrite <-jump_tl;rewrite IHp;trivial.
@@ -89,7 +79,7 @@ Section LIST.
  Qed.
 
  Lemma nth_Pdouble_minus_one :
-  forall p l, nth (Pdouble_minus_one p) (tl l) = nth p (jump p l).
+  forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
  Proof.
   induction p;simpl;intros.
   repeat rewrite jump_tl;trivial.
@@ -98,4 +88,4 @@ Section LIST.
   trivial.
  Qed.
 
-End LIST.
+End MakeBinList.
diff --git a/contrib/field/Field.v b/contrib/setoid_ring/Field.v
index 3cc097fc..a944ba5f 100644
--- a/contrib/field/Field.v
+++ b/contrib/setoid_ring/Field.v
@@ -6,10 +6,5 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Field_Compl.
-Require Export Field_Theory.
-Require Export Field_Tactic.
-
-(* Command declarations are moved to the ML side *)
\ No newline at end of file
+Require Export Field_theory.
+Require Export Field_tac.
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
new file mode 100644
index 00000000..786654ab
--- /dev/null
+++ b/contrib/setoid_ring/Field_tac.v
@@ -0,0 +1,200 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Ring_tac BinList Ring_polynom InitialRing.
+Require Export Field_theory.
+
+ (* syntaxification *)
+ Ltac mkFieldexpr C Cst radd rmul rsub ropp rdiv rinv t fv := 
+ let rec mkP t :=
+    match Cst t with
+    | Ring_tac.NotConstant =>
+        match t with 
+        | (radd ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEadd e1 e2)
+        | (rmul ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEmul e1 e2)
+        | (rsub ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEsub e1 e2)
+        | (ropp ?t1) =>
+          let e1 := mkP t1 in constr:(FEopp e1)
+        | (rdiv ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+        | (rinv ?t1) =>
+          let e1 := mkP t1 in constr:(FEinv e1)
+        | _ =>
+          let p := Find_at t fv in constr:(@FEX C p)
+        end
+    | ?c => constr:(FEc c)
+    end
+ in mkP t.
+
+Ltac FFV Cst add mul sub opp div inv t fv :=
+ let rec TFV t fv :=
+  match Cst t with
+  | Ring_tac.NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => TFV t1 fv
+      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (inv ?t1) => TFV t1 fv
+      | _ => AddFvTail t fv
+      end
+  | _ => fv
+  end 
+ in TFV t fv.
+
+Ltac ParseFieldComponents lemma req :=
+  match type of lemma with
+  | context [@FEeval ?R ?rO ?add ?mul ?sub ?opp ?div ?inv ?C ?phi _ _] =>
+      (fun f => f add mul sub opp div inv C)
+  | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+  end.
+
+(* simplifying the non-zero condition... *)
+
+Ltac fold_field_cond req :=
+  let rec fold_concl t :=
+    match t with
+      ?x /\ ?y =>
+        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
+    | req ?x ?y -> False => constr:(~ req x y)
+    | _ => t
+    end in
+  match goal with
+    |- ?t => let ft := fold_concl t in change ft
+  end.
+
+Ltac simpl_PCond req :=
+  protect_fv "field_cond";
+  try (exact I);
+  fold_field_cond req.
+
+(* Rewriting (field_simplify) *)
+Ltac Field_simplify lemma Cond_lemma req Cst_tac :=
+  let Make_tac :=
+    match type of lemma with
+    | forall l fe nfe,
+      _ = nfe -> 
+      PCond _ _ _ _ _ _ _ _ _ ->
+      req (FEeval ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv (C:=?C) ?phi l fe)
+        _ =>
+        let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in
+        let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in
+        let simpl_field H := protect_fv "field" in H in
+        fun f rl => f mkFV mkFE simpl_field lemma req rl;
+                    try (apply Cond_lemma; simpl_PCond req)
+    | _ => fail 1 "field anomaly: bad correctness lemma (rewr)"
+    end in
+  Make_tac ReflexiveRewriteTactic.
+(* Pb: second rewrite are applied to non-zero condition of first rewrite... *)
+
+Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
+  field_lookup
+    (fun req cst_tac _ _ field_simplify_ok cond_ok pre post rl =>
+       pre(); Field_simplify field_simplify_ok cond_ok req cst_tac rl; post()).
+
+
+(* Generic form of field tactics *)
+Ltac Field_Scheme FV_tac SYN_tac SIMPL_tac lemma Cond_lemma req :=
+  let R := match type of req with ?R -> _ => R end in
+  let rec ParseExpr ilemma :=
+    match type of ilemma with
+      forall nfe, ?fe = nfe -> _ =>
+        (fun t => 
+           let x := fresh "fld_expr" in 
+           let H := fresh "norm_fld_expr" in
+           compute_assertion H x fe;
+           ParseExpr (ilemma x H) t;
+           try clear x H)
+    | _ => (fun t => t ilemma)
+    end in
+  let Main r1 r2 :=
+    let fv := FV_tac r1 (@List.nil R) in
+    let fv := FV_tac r2 fv in
+    let fe1 := SYN_tac r1 fv in
+    let fe2 := SYN_tac r2 fv in
+    ParseExpr (lemma fv fe1 fe2)
+    ltac:(fun ilemma =>
+           apply ilemma || fail "field anomaly: failed in applying lemma";
+            [ SIMPL_tac | apply Cond_lemma; simpl_PCond req]) in
+  OnEquation req Main.
+
+(* solve completely a field equation, leaving non-zero conditions to be
+   proved (field) *)
+Ltac Field lemma Cond_lemma req Cst_tac :=
+  let Main radd rmul rsub ropp rdiv rinv C :=
+    let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in
+    let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in
+    let Simpl :=
+      vm_compute; reflexivity || fail "not a valid field equation" in
+    Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in
+  ParseFieldComponents lemma req Main.
+
+Tactic Notation (at level 0) "field" :=
+  field_lookup
+    (fun req cst_tac field_ok _ _ cond_ok pre post rl =>
+       pre(); Field field_ok cond_ok req cst_tac; post()).
+
+(* transforms a field equation to an equivalent (simplified) ring equation,
+   and leaves non-zero conditions to be proved (field_simplify_eq) *)
+Ltac Field_simplify_eq lemma Cond_lemma req Cst_tac :=
+  let Main radd rmul rsub ropp rdiv rinv C :=
+    let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in
+    let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in
+    let Simpl := (protect_fv "field") in
+    Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in
+  ParseFieldComponents lemma req Main.
+
+Tactic Notation (at level 0) "field_simplify_eq" :=
+  field_lookup
+    (fun req cst_tac _ field_simplify_eq_ok _ cond_ok pre post rl =>
+       pre(); Field_simplify_eq field_simplify_eq_ok cond_ok req cst_tac;
+       post()).
+
+(* Adding a new field *)
+
+Ltac ring_of_field f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
+  end.
+
+Ltac coerce_to_almost_field set ext f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
+  end.
+
+Ltac field_elements set ext fspec rk :=
+  let afth := coerce_to_almost_field set ext fspec in
+  let rspec := ring_of_field fspec in
+  ring_elements set ext rspec rk
+  ltac:(fun arth ext_r morph f => f afth ext_r morph).
+
+
+Ltac field_lemmas set ext inv_m fspec rk :=
+  field_elements set ext fspec rk
+  ltac:(fun afth ext_r morph =>
+    let field_ok := constr:(Field_correct set ext_r inv_m afth morph) in
+    let field_simpl_ok :=
+      constr:(Pphi_dev_div_ok set ext_r inv_m afth morph) in
+    let field_simpl_eq_ok :=
+      constr:(Field_simplify_eq_correct set ext_r inv_m afth morph) in
+    let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph) in
+    let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph) in
+    (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok
+                cond1_ok cond2_ok)).
diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v
new file mode 100644
index 00000000..f810859c
--- /dev/null
+++ b/contrib/setoid_ring/Field_theory.v
@@ -0,0 +1,1460 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Ring.
+Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
+Require Import ZArith_base.
+Set Implicit Arguments.
+
+Section MakeFieldPol.
+
+(* Field elements *)     
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
+ Variable req : R -> R -> Prop.
+
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
+ Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
+ Notation "x == y" := (req x y) (at level 70, no associativity).
+
+ (* Equality properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable SRinv_ext : forall p q, p == q ->  / p == / q.
+
+ (* Field properties *)
+  Record almost_field_theory : Prop := mk_afield {
+    AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
+    AF_1_neq_0 : ~ 1 == 0;
+    AFdiv_def : forall p q, p / q == p * / q;
+    AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+ (* Coefficients *) 
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool. 
+ Variable phi : C -> R.
+
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                               cO cI cadd cmul csub copp ceqb phi.
+
+Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+  (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+case (ceqb c1 c2); auto.
+Qed.
+
+
+ (* C notations *)		 
+ Notation "x +! y" := (cadd x y) (at level 50).
+ Notation "x *! y " := (cmul x y) (at level 40).
+ Notation "x -! y " := (csub x y) (at level 50).
+ Notation "-! x" := (copp x) (at level 35).
+ Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
+ Notation "[ x ]" := (phi x) (at level 0).
+
+
+ (* Usefull tactics *)		  
+  Add Setoid R req Rsth as R_set1.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+  Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
+ 
+Let eq_trans := Setoid.Seq_trans _ _ Rsth.
+Let eq_sym := Setoid.Seq_sym _ _ Rsth.
+Let eq_refl := Setoid.Seq_refl _ _ Rsth.
+
+Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
+Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
+             (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
+Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
+             (ARmul_1_l  ARth) (ARmul_0_l  ARth) 
+             (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
+             (ARopp_mul_l ARth) (ARopp_add  ARth) 
+             (ARsub_def  ARth) .
+
+Notation NPEeval := (PEeval rO radd rmul rsub ropp phi).
+Notation Nnorm := (norm cO cI cadd cmul csub copp ceqb).
+Notation NPphi_dev := (Pphi_dev rO rI radd rmul cO cI ceqb phi).
+
+(* add abstract semi-ring to help with some proofs *)
+Add Ring Rring : (ARth_SRth ARth).
+
+
+(* additional ring properties *)
+
+Lemma rsub_0_l : forall r, 0 - r == - r.
+intros; rewrite (ARsub_def ARth) in |- *; ring.
+Qed.
+
+Lemma rsub_0_r : forall r, r - 0 == r.
+intros; rewrite (ARsub_def ARth) in |- *.
+rewrite (ARopp_zero Rsth Reqe ARth) in |- *;  ring.
+Qed.
+
+(***************************************************************************
+                                                                          
+                       Properties of division                             
+                                                                          
+  ***************************************************************************)
+ 
+Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
+intros p q H.
+rewrite rdiv_def in |- *.
+transitivity (/ q * q * p); [  ring | idtac ].
+rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv_simpl .
+ 
+Theorem SRdiv_ext:
+ forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 ->  p1 / q1 == p2 / q2.
+intros p1 p2 H q1 q2 H0.
+transitivity (p1 * / q1); auto.
+transitivity (p2 * / q2); auto.
+Qed.
+Hint Resolve SRdiv_ext .
+
+ Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed.
+
+Lemma rmul_reg_l : forall p q1 q2,
+  ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
+intros.
+rewrite <- (@rdiv_simpl q1 p) in |- *; trivial.
+rewrite <- (@rdiv_simpl q2 p) in |- *; trivial.
+repeat rewrite rdiv_def in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+auto.
+Qed.
+
+Theorem field_is_integral_domain : forall r1 r2,
+  ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
+Proof.
+red in |- *; intros.
+apply H0.
+transitivity (1 * r2); auto.
+transitivity (/ r1 * r1 * r2); auto.
+rewrite <- (ARmul_assoc ARth) in |- *.
+rewrite H1 in |- *.
+apply ARmul_0_r with (1 := Rsth) (2 := ARth).
+Qed.
+
+Theorem ropp_neq_0 : forall r,
+  ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
+intros.
+setoid_replace (- r) with (- (1) * r).
+ apply field_is_integral_domain; trivial.
+ rewrite <- (ARopp_mul_l ARth) in |- *.
+   rewrite (ARmul_1_l ARth) in |- *.
+   reflexivity.
+Qed.
+
+Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
+intros.
+rewrite (AFdiv_def AFth) in |- *.
+rewrite (ARmul_comm ARth) in |- *.
+apply (AFinv_l AFth).
+trivial.
+Qed.
+
+Theorem rdiv1: forall r,  r == r / 1.
+intros r; transitivity (1 * (r / 1)); auto.
+Qed.
+ 
+Theorem rdiv2:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
+ transitivity (r2 * (r4 * (r3 / r4))); auto.
+   transitivity (r2 * r3); auto.
+Qed.
+
+
+Theorem rdiv2b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2*r5) == 0 ->
+ ~ (r4*r5) == 0 ->
+ r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
+assert (HH4: ~ r2 * (r4 * r5) == 0) 
+   by complete (repeat apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
+ transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
+Qed.
+
+Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
+intros r1 r2.
+transitivity (- (r1 * / r2)); auto.
+transitivity (- r1 * / r2); auto.
+Qed.
+Hint Resolve rdiv5 .
+
+Theorem rdiv3:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
+transitivity (r1 / r2 + - (r3 / r4)); auto.
+transitivity (r1 / r2 + - r3 / r4); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto.
+apply rdiv2; auto.
+apply SRdiv_ext; auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+
+Theorem rdiv3b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2 * r5) == 0 ->
+ ~ (r4 * r5) == 0 ->
+ r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
+transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
+apply rdiv2b; auto; try ring.
+apply (SRdiv_ext); auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+Theorem rdiv6:
+ forall r1 r2,
+ ~ r1 == 0 -> ~ r2 == 0 ->  / (r1 / r2) == r2 / r1.
+intros r1 r2 H H0.
+assert (~ r1 / r2 == 0) as Hk.
+ intros H1; case H.
+   transitivity (r2 * (r1 / r2)); auto.
+   rewrite H1 in |- *;  ring.
+ apply rmul_reg_l with (r1 / r2); auto.
+   transitivity (/ (r1 / r2) * (r1 / r2)); auto.
+   transitivity 1; auto.
+   repeat rewrite rdiv_def in |- *.
+   transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
+   repeat rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv6 .
+ 
+ Theorem rdiv4:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
+repeat rewrite rdiv_simpl in |- *; trivial.
+Qed.
+
+ Theorem rdiv7:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r3 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
+Proof.
+intros.
+rewrite (rdiv_def (r1 / r2)) in |- *.
+rewrite rdiv6 in |- *; trivial.
+apply rdiv4; trivial.
+Qed.
+
+Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 ->  r1 / r2 == 0.
+intros r1 r2 H H0.
+transitivity (r1 * / r2); auto.
+transitivity (0 * / r2); auto.
+Qed.
+
+
+Theorem cross_product_eq : forall r1 r2 r3 r4,
+  ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
+intros.
+transitivity (r1 / r2 * (r4 / r4)).
+ rewrite rdiv_r_r in |- *; trivial.
+   symmetry  in |- *.
+   apply (ARmul_1_r Rsth ARth).
+ rewrite rdiv4 in |- *; trivial.
+   rewrite H1 in |- *.
+   rewrite (ARmul_comm ARth r2 r4) in |- *.
+   rewrite <- rdiv4 in |- *; trivial.
+   rewrite rdiv_r_r in |- *.
+  trivial.
+  apply (ARmul_1_r Rsth ARth).
+Qed.
+
+(***************************************************************************
+                                                                          
+                       Some equality test                             
+                                                                          
+  ***************************************************************************)
+
+Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
+ match p1, p2 with
+   xH, xH => true
+  | xO p3, xO p4 => positive_eq p3 p4
+  | xI p3, xI p4 => positive_eq p3 p4
+  | _, _ => false
+ end.
+ 
+Theorem positive_eq_correct:
+ forall p1 p2,  if positive_eq p1 p2 then p1 = p2 else p1 <> p2.
+intros p1; elim p1;
+ (try (intros p2; case p2; simpl; auto; intros; discriminate)).
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xI ); auto.
+intros H1 H2; case H1; injection H2; auto.
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xO ); auto.
+intros H1 H2; case H1; injection H2; auto.
+Qed.
+ 
+(* equality test *)
+Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
+ match e1, e2 with
+   PEc c1, PEc c2 => ceqb c1 c2
+  | PEX p1, PEX p2 => positive_eq p1 p2
+  | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEopp e3, PEopp e4 => PExpr_eq e3 e4
+  | _, _ => false
+ end.
+ 
+Theorem PExpr_eq_semi_correct:
+ forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
+intros l e1; elim e1.
+intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros c2; apply (morph_eq CRmorph).
+intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2);
+ (try (intros; discriminate)); intros H; rewrite H; auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
+intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); auto.
+Qed.
+
+(* add *)
+Definition NPEadd e1 e2 :=
+  match e1, e2 with
+    PEc c1, PEc c2 => PEc (cadd c1 c2)
+  | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
+  |  _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
+  | _, _ => PEadd e1 e2
+  end.
+
+Theorem NPEadd_correct:
+ forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
+Proof.
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
+ try rewrite (morph0 CRmorph) in |- *; try ring.
+apply (morph_add CRmorph).
+Qed.
+
+(* mul *) 
+Definition NPEmul x y :=
+  match x, y with
+    PEc c1, PEc c2 => PEc (cmul c1 c2)
+  | PEc c, _ =>
+      if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
+  |  _, PEc c =>
+      if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
+  |  _, _ => PEmul x y
+  end.
+             
+Theorem NPEmul_correct : forall l e1 e2,
+  NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity;
+ repeat apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
+ try rewrite (morph0 CRmorph) in |- *;
+ try rewrite (morph1 CRmorph) in |- *;
+ try ring.
+apply (morph_mul CRmorph).
+Qed.
+
+(* sub *)
+Definition NPEsub e1 e2 :=
+  match e1, e2 with
+    PEc c1, PEc c2 => PEc (csub c1 c2)
+  | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
+  |  _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
+  | _, _ => PEsub e1 e2
+  end.
+
+Theorem NPEsub_correct:
+ forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
+ try rewrite (morph0 CRmorph) in |- *; try reflexivity;
+ try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
+apply (morph_sub CRmorph).
+Qed.
+ 
+(* opp *)
+Definition NPEopp e1 :=
+  match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
+ 
+Theorem NPEopp_correct:
+ forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
+intros l e1; case e1; simpl; auto.
+intros; apply (morph_opp CRmorph).
+Qed.
+ 
+(* simplification *)
+Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
+ match e with
+   PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
+  | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
+  | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
+  | PEopp e1 => NPEopp (PExpr_simp e1)
+  | _ => e
+ end.
+ 
+Theorem PExpr_simp_correct:
+ forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
+intros l e; elim e; simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEadd_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEsub_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEmul_correct.
+simpl; auto.
+intros e1 He1.
+transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
+apply NPEopp_correct.
+simpl; auto.
+Qed.
+
+
+(****************************************************************************
+                                                                          
+                               Datastructure                              
+                                                                          
+  ***************************************************************************)
+
+(* The input: syntax of a field expression *)
+
+Inductive FExpr : Type :=
+   FEc: C ->  FExpr
+ | FEX: positive ->  FExpr
+ | FEadd: FExpr -> FExpr ->  FExpr
+ | FEsub: FExpr -> FExpr ->  FExpr
+ | FEmul: FExpr -> FExpr ->  FExpr
+ | FEopp: FExpr ->  FExpr
+ | FEinv: FExpr ->  FExpr
+ | FEdiv: FExpr -> FExpr ->  FExpr .
+
+Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
+  match pe with
+  | FEc c     => phi c
+  | FEX x     => BinList.nth 0 x l
+  | FEadd x y => FEeval l x + FEeval l y
+  | FEsub x y => FEeval l x - FEeval l y
+  | FEmul x y => FEeval l x * FEeval l y
+  | FEopp x   => - FEeval l x
+  | FEinv x   => / FEeval l x
+  | FEdiv x y => FEeval l x / FEeval l y
+  end.
+
+(* The result of the normalisation *)
+ 
+Record linear : Type := mk_linear {
+   num : PExpr C;
+   denum : PExpr C;
+   condition : list (PExpr C) }.
+
+(***************************************************************************
+
+                Semantics and properties of side condition
+
+  ***************************************************************************)
+ 
+Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
+  match le with
+  | nil => True
+  | e1 :: nil => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO
+  | e1 :: l1 => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO /\ PCond l l1
+  end.
+
+Theorem PCond_cons_inv_l :
+   forall l a l1, PCond l (a::l1) ->  ~ NPEeval l a == 0.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+ 
+Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+
+Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
+intros l l1 l2; elim l1; simpl app in |- *.
+ simpl in |- *; auto.
+ destruct l0; simpl in *.
+  destruct l2; firstorder.
+  firstorder.
+Qed.
+ 
+Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
+intros l l1 l2; elim l1; simpl app; auto.
+intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
+Qed.
+ 
+(* An unsatisfiable condition: issued when a division by zero is detected *)
+Definition absurd_PCond := cons (PEc cO) nil.
+
+Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
+unfold absurd_PCond in |- *; simpl in |- *.
+red in |- *; intros.
+apply H.
+apply (morph0 CRmorph).
+Qed.
+
+(***************************************************************************
+                                                                          
+                               Normalisation                              
+                                                                          
+  ***************************************************************************)
+
+
+Fixpoint isIn (e1 e2: PExpr C) {struct e2}: option (PExpr C) :=
+  match e2 with
+  | PEmul e3 e4 =>
+       match isIn e1 e3 with
+         Some e5 => Some (NPEmul e5 e4)
+       | None => match isIn e1 e4 with
+                 | Some e5 => Some (NPEmul e3 e5)
+                 | None => None
+                 end
+       end
+  | _ =>
+       if PExpr_eq e1 e2 then Some (PEc cI) else None
+   end.
+
+Theorem isIn_correct: forall l e1 e2,
+  match isIn e1 e2 with 
+    (Some e3) => NPEeval l e2 == NPEeval l (NPEmul e1 e3)
+  |  _ => True
+  end.
+Proof.
+intros l e1 e2; elim e2; simpl; auto.
+  intros c;
+   generalize (PExpr_eq_semi_correct l e1 (PEc c));
+   case (PExpr_eq e1 (PEc c)); simpl; auto; intros H.
+   rewrite NPEmul_correct; simpl; auto.
+   rewrite H; auto; simpl. 
+   rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto.
+  intros p;
+   generalize (PExpr_eq_semi_correct l e1 (PEX C p));
+   case (PExpr_eq e1 (PEX C p)); simpl; auto; intros H.
+   rewrite NPEmul_correct; simpl; auto.
+   rewrite H; auto; simpl. 
+   rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto.
+ intros p Hrec p1 Hrec1.
+   generalize (PExpr_eq_semi_correct l e1 (PEadd p p1));
+   case (PExpr_eq e1 (PEadd p p1)); simpl; auto; intros H.
+   rewrite NPEmul_correct; simpl; auto.
+   rewrite H; auto; simpl. 
+   rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto.
+ intros p Hrec p1 Hrec1.
+   generalize (PExpr_eq_semi_correct l e1 (PEsub p p1));
+   case (PExpr_eq e1 (PEsub p p1)); simpl; auto; intros H.
+   rewrite NPEmul_correct; simpl; auto.
+   rewrite H; auto; simpl. 
+   rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto.
+ intros p; case (isIn e1 p).
+   intros p2 Hrec p1 Hrec1.
+   rewrite Hrec; auto; simpl. 
+   repeat (rewrite NPEmul_correct; simpl; auto).
+   intros _ p1; case (isIn e1 p1); auto.
+   intros p2 H; rewrite H.
+   repeat (rewrite NPEmul_correct; simpl; auto).
+   ring.
+  intros p;
+   generalize (PExpr_eq_semi_correct l e1 (PEopp p));
+   case (PExpr_eq e1 (PEopp p)); simpl; auto; intros H.
+   rewrite NPEmul_correct; simpl; auto.
+   rewrite H; auto; simpl. 
+   rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto.
+Qed.
+
+Record rsplit : Type := mk_rsplit {
+   rsplit_left : PExpr C;
+   rsplit_common : PExpr C;
+   rsplit_right : PExpr C}.
+
+(* Stupid name clash *)
+Let left := rsplit_left.
+Let right := rsplit_right.
+Let common := rsplit_common.
+
+Fixpoint split (e1 e2: PExpr C) {struct e1}: rsplit :=
+  match e1 with
+  | PEmul e3 e4 =>
+      let r1 := split e3 e2 in
+      let r2 := split e4 (right r1) in
+          mk_rsplit (NPEmul (left r1) (left r2))
+                    (NPEmul (common r1) (common r2))
+                    (right r2)
+  | _ => 
+       match isIn e1 e2 with
+         Some e3 => mk_rsplit (PEc cI) e1 e3
+       | None => mk_rsplit e1 (PEc cI) e2
+       end
+  end. 
+
+Theorem split_correct: forall l e1 e2,
+  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
+                                   (common (split e1 e2)))
+/\
+  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
+                                   (common (split e1 e2))).
+Proof.
+intros l e1; elim e1; simpl; auto.
+  intros c e2; generalize (isIn_correct l (PEc c) e2);
+    case (isIn (PEc c) e2); auto; intros p;
+    [intros Hp1; rewrite Hp1 | idtac];
+    simpl left; simpl common;  simpl right; auto;
+    repeat rewrite NPEmul_correct; simpl; split; 
+    try rewrite  (morph1 CRmorph); ring.
+  intros p e2; generalize (isIn_correct l (PEX C p) e2);
+    case (isIn (PEX C p) e2); auto; intros p1;
+    [intros Hp1; rewrite Hp1 | idtac];
+    simpl left; simpl common;  simpl right; auto;
+    repeat rewrite NPEmul_correct; simpl; split; 
+    try rewrite  (morph1 CRmorph); ring.
+  intros p1 _ p2 _ e2; generalize (isIn_correct l (PEadd p1 p2) e2);
+    case (isIn (PEadd p1 p2) e2); auto; intros p;
+    [intros Hp1; rewrite Hp1 | idtac];
+    simpl left; simpl common;  simpl right; auto;
+    repeat rewrite NPEmul_correct; simpl; split; 
+    try rewrite  (morph1 CRmorph); ring.
+  intros p1 _ p2 _ e2; generalize (isIn_correct l (PEsub p1 p2) e2);
+    case (isIn (PEsub p1 p2) e2); auto; intros p;
+    [intros Hp1; rewrite Hp1 | idtac];
+    simpl left; simpl common;  simpl right; auto;
+    repeat rewrite NPEmul_correct; simpl; split; 
+    try rewrite  (morph1 CRmorph); ring.
+  intros p1 Hp1 p2 Hp2 e2.
+    repeat rewrite NPEmul_correct; simpl; split.
+    case (Hp1 e2); case (Hp2 (right (split p1 e2))).
+    intros tmp1 _ tmp2 _; rewrite tmp1; rewrite tmp2.
+    repeat rewrite NPEmul_correct; simpl.
+    ring.
+    case (Hp1 e2); case (Hp2 (right (split p1 e2))).
+    intros _ tmp1 _ tmp2; rewrite tmp2;
+    repeat rewrite NPEmul_correct; simpl.
+    rewrite tmp1.
+    repeat rewrite NPEmul_correct; simpl.
+    ring.
+  intros p _ e2; generalize (isIn_correct l (PEopp p) e2);
+    case (isIn (PEopp p) e2); auto; intros p1;
+    [intros Hp1; rewrite Hp1 | idtac];
+    simpl left; simpl common;  simpl right; auto;
+    repeat rewrite NPEmul_correct; simpl; split; 
+    try rewrite  (morph1 CRmorph); ring.
+Qed.
+
+
+Theorem split_correct_l: forall l e1 e2,
+  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
+                                   (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_correct l e1 e2); auto.
+Qed.
+
+Theorem split_correct_r: forall l e1 e2,
+  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
+                                   (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_correct l e1 e2); auto.
+Qed.
+
+Fixpoint Fnorm (e : FExpr) : linear := 
+  match e with
+  | FEc c => mk_linear (PEc c) (PEc cI) nil
+  | FEX x => mk_linear (PEX C x) (PEc cI) nil
+  | FEadd e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      let s := split (denum x) (denum y) in
+      mk_linear
+        (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+        (NPEmul (left s) (NPEmul (right s) (common s)))
+        (condition x ++ condition y)
+ 
+  | FEsub e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      let s := split (denum x) (denum y) in
+      mk_linear
+        (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+        (NPEmul (left s) (NPEmul (right s) (common s)))
+        (condition x ++ condition y)
+  | FEmul e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      mk_linear (NPEmul (num x) (num y))
+        (NPEmul (denum x) (denum y))
+        (condition x ++ condition y)
+  | FEopp e1 =>
+      let x := Fnorm e1 in
+      mk_linear (NPEopp (num x)) (denum x) (condition x)
+  | FEinv e1 =>
+      let x := Fnorm e1 in
+      mk_linear (denum x) (num x) (num x :: condition x)
+  | FEdiv e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      mk_linear (NPEmul (num x) (denum y))
+        (NPEmul (denum x) (num y))
+        (num y :: condition x ++ condition y)
+  end.
+
+
+(* Example *)
+(*
+Eval compute
+   in (Fnorm
+        (FEdiv
+          (FEc cI)
+          (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
+*)
+
+Theorem Pcond_Fnorm:
+ forall l e,
+ PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
+intros l e; elim e.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+   intros HH; case Hrec1; auto.
+     apply PCond_app_inv_l with (1 := Hcond).
+   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+   rewrite NPEmul_correct; simpl; rewrite HH; ring.
+   intros HH; case Hrec2; auto.
+     apply PCond_app_inv_r with (1 := Hcond).
+   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+   intros HH; case Hrec1; auto.
+     apply PCond_app_inv_l with (1 := Hcond).
+   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+   rewrite NPEmul_correct; simpl; rewrite HH; ring.
+   intros HH; case Hrec2; auto.
+     apply PCond_app_inv_r with (1 := Hcond).
+   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+  apply Hrec1.
+    apply PCond_app_inv_l with (1 := Hcond).
+  apply Hrec2.
+    apply PCond_app_inv_r with (1 := Hcond).
+ intros e1 Hrec1 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   auto.
+ intros e1 Hrec1 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   apply PCond_cons_inv_l with (1:=Hcond).
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+  apply Hrec1.
+    specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
+    apply PCond_app_inv_l with (1 := Hcond1).
+   apply PCond_cons_inv_l with (1:=Hcond).
+Qed.
+Hint Resolve Pcond_Fnorm.
+
+
+(***************************************************************************
+                                                                          
+                       Main theorem                                       
+                                                                          
+  ***************************************************************************)
+
+Theorem Fnorm_FEeval_PEeval:
+ forall l fe,
+ PCond l (condition (Fnorm fe)) ->
+ FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
+Proof.
+intros l fe; elim fe; simpl.
+intros c H; rewrite CRmorph.(morph1); apply rdiv1.
+intros p H; rewrite CRmorph.(morph1); apply rdiv1.
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEadd_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv2b; auto.
+  rewrite <- U1; auto.
+  rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEsub_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv3b; auto.
+  rewrite <- U1; auto.
+  rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct; simpl.
+apply rdiv4; auto.
+
+intros e1 He1 HH.
+rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
+
+intros e1 He1 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); apply rdiv6; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with (condition (Fnorm e2)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with (condition (Fnorm e1)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct;simpl.
+apply rdiv7; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+Qed.
+
+Theorem Fnorm_crossproduct:
+ forall l fe1 fe2,
+ let nfe1 := Fnorm fe1 in
+ let nfe2 := Fnorm fe2 in
+ NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
+ NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
+rewrite Fnorm_FEeval_PEeval in |- *.
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite Fnorm_FEeval_PEeval in |- *.
+  apply PCond_app_inv_r with (1 := Hcond).
+  apply cross_product_eq; trivial.
+   apply Pcond_Fnorm.
+     apply PCond_app_inv_l with (1 := Hcond).
+   apply Pcond_Fnorm.
+     apply PCond_app_inv_r with (1 := Hcond).
+Qed.
+
+(* Correctness lemmas of reflexive tactics *)
+
+Theorem Fnorm_correct:
+ forall l fe,
+ Peq ceqb (Nnorm (num (Fnorm fe))) (Pc cO) = true ->
+ PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
+intros l fe H H1;
+ apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
+apply rdiv8; auto.
+transitivity (NPEeval l (PEc cO)); auto.
+apply (ring_correct Rsth Reqe ARth CRmorph); auto.
+simpl; apply (morph0 CRmorph); auto.
+Qed.
+
+(* simplify a field expression into a fraction *)
+(* TODO: simplify when den is constant... *)
+Definition display_linear l num den :=
+  NPphi_dev l num / NPphi_dev l den.
+
+Theorem Pphi_dev_div_ok:
+ forall l fe nfe,
+ Fnorm fe = nfe ->
+ PCond l (condition nfe) ->
+ FEeval l fe == display_linear l (Nnorm (num nfe)) (Nnorm (denum nfe)).
+Proof.
+  intros l fe nfe eq_nfe H; subst nfe.
+  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+  unfold display_linear; apply SRdiv_ext;
+  apply (Pphi_dev_ok Rsth Reqe ARth CRmorph); reflexivity.
+Qed.
+
+(* solving a field equation *)
+Theorem Field_correct :
+ forall l fe1 fe2,
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ Peq ceqb (Nnorm (PEmul (num nfe1) (denum nfe2)))
+          (Nnorm (PEmul (num nfe2) (denum nfe1))) = true ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros l fe1 fe2 nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2.
+apply Fnorm_crossproduct; trivial.
+apply (ring_correct Rsth Reqe ARth CRmorph); trivial.
+Qed.
+
+(* simplify a field equation : generate the crossproduct and simplify
+   polynomials *)
+Theorem Field_simplify_eq_old_correct :
+ forall l fe1 fe2 nfe1 nfe2,
+ Fnorm fe1 = nfe1 ->
+ Fnorm fe2 = nfe2 ->
+ NPphi_dev l (Nnorm (PEmul (num nfe1) (denum nfe2))) ==
+ NPphi_dev l (Nnorm (PEmul (num nfe2) (denum nfe1))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
+apply Fnorm_crossproduct; trivial.
+rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *.
+rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *.
+trivial.
+Qed.
+
+Theorem Field_simplify_eq_correct :
+ forall l fe1 fe2,
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ NPphi_dev l (Nnorm (PEmul (num nfe1) (right den))) ==
+ NPphi_dev l (Nnorm (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros l fe1 fe2 nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+  subst nfe1 nfe2 den.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+elim (split_correct l (denum (Fnorm fe1)) (denum (Fnorm fe2))); intros.
+rewrite H in |- *.
+rewrite H0 in |- *.
+clear H H0.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod.
+rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Section Fcons_impl.
+
+Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
+
+Hypothesis PCond_fcons_inv : forall l a l1,
+  PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+
+Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
+  match l with
+  | nil => m
+  | cons a l1 => Fcons a (Fapp l1 m)
+  end.
+
+Lemma fcons_correct : forall l l1,
+  PCond l (Fapp l1 nil) -> PCond l l1.
+induction l1; simpl in |- *; intros.
+ trivial.
+ elim PCond_fcons_inv with (1 := H); intros.
+   destruct l1; auto.
+Qed.
+
+End Fcons_impl.
+
+Section Fcons_simpl.
+
+(* Some general simpifications of the condition: eliminate duplicates,
+   split multiplications *)
+
+Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+   nil       => cons e nil
+ | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1)
+ end.
+ 
+Theorem PFcons_fcons_inv:
+ forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons; auto.
+simpl; auto.
+intros a0 l0.
+generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+(* equality of normal forms rather than syntactic equality *)
+Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+   nil       => cons e nil
+ | cons a l1 =>
+     if Peq ceqb (Nnorm e) (Nnorm a) then l else cons a (Fcons0 e l1)
+ end.
+ 
+Theorem PFcons0_fcons_inv:
+ forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons0; auto.
+simpl; auto.
+intros a0 l0.
+generalize (ring_correct Rsth Reqe ARth CRmorph l a a0);
+  case (Peq ceqb (Nnorm a) (Nnorm a0)).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+   PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l)
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons00_fcons_inv:
+  forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ intros p H p0 H0 l1 H1.
+   simpl in H1.
+   case (H _ H1); intros H2 H3.
+   case (H0 _ H3); intros H4 H5; split; auto.
+   simpl in |- *.
+   apply field_is_integral_domain; trivial.
+Qed.
+
+
+Definition Pcond_simpl_gen := 
+  fcons_correct _ PFcons00_fcons_inv.
+
+
+(* Specific case when the equality test of coefs is complete w.r.t. the
+   field equality: non-zero coefs can be eliminated, and opposite can
+   be simplified (if -1 <> 0) *)
+
+Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
+
+Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+  (phi c1 == phi c2 -> P x) ->
+  (~ phi c1 == phi c2 -> P y) ->
+  P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+generalize (@ceqb_complete c1 c2).
+case (c1 ?=! c2); auto; intros.
+apply X0.
+red in |- *; intro.
+absurd (false = true); auto;  discriminate.
+Qed.
+
+Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+   PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
+ | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
+ | PEc c => if ceqb c cO then absurd_PCond else l
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons1_fcons_inv:
+  forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ simpl in |- *; intros c l1.
+   apply ceqb_rect_complete; intros.
+  elim (@absurd_PCond_bottom l H0).
+  split; trivial.
+    rewrite <- (morph0 CRmorph) in |- *; trivial.
+ intros p H p0 H0 l1 H1.
+   simpl in H1.
+   case (H _ H1); intros H2 H3.
+   case (H0 _ H3); intros H4 H5; split; auto.
+   simpl in |- *.
+   apply field_is_integral_domain; trivial.
+ simpl in |- *; intros p H l1.
+   apply ceqb_rect_complete; intros.
+  elim (@absurd_PCond_bottom l H1).
+  destruct (H _ H1).
+    split; trivial.
+    apply ropp_neq_0; trivial.
+    rewrite (morph_opp CRmorph) in H0.
+    rewrite (morph1 CRmorph) in H0.
+    rewrite (morph0 CRmorph) in H0.
+    trivial.
+Qed.
+
+Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
+ 
+Theorem PFcons2_fcons_inv:
+ forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+unfold Fcons2 in |- *; intros l a l1 H; split;
+ case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
+intros H1 H2 H3; case H1.
+transitivity (NPEeval l a); trivial.
+apply PExpr_simp_correct.
+Qed.
+
+Definition Pcond_simpl_complete := 
+  fcons_correct _ PFcons2_fcons_inv.
+
+End Fcons_simpl.
+
+Let Mpc := MPcond_map cO cI cadd cmul csub copp ceqb.
+Let Mp := MPcond_dev rO rI radd rmul req cO cI ceqb phi.
+Let Subst := PNSubstL cO cI cadd cmul ceqb.
+
+(* simplification + rewriting *)
+Theorem Field_subst_correct :
+forall l ul fe m n,
+ PCond l (Fapp Fcons00 (condition (Fnorm fe)) nil) ->
+ Mp (Mpc ul) l ->
+ Peq ceqb (Subst (Nnorm (num (Fnorm fe))) (Mpc ul) m n) (Pc cO) = true ->
+ FEeval l fe == 0.
+intros l ul fe m n H H1 H2.
+assert (H3 := (Pcond_simpl_gen _ _ H)).
+apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe 
+                           (Pcond_simpl_gen _ _ H)).
+apply rdiv8; auto.
+rewrite (PNSubstL_dev_ok Rsth Reqe ARth CRmorph m n
+              _ (num (Fnorm fe)) l H1).
+rewrite <-(Ring_polynom.Pphi_Pphi_dev Rsth Reqe ARth CRmorph).
+rewrite (fun x => Peq_ok Rsth Reqe CRmorph x (Pc cO)); auto.
+simpl; apply (morph0 CRmorph); auto.
+Qed.
+
+
+End AlmostField.
+
+Section FieldAndSemiField.
+
+  Record field_theory : Prop := mk_field {
+    F_R : ring_theory rO rI radd rmul rsub ropp req;
+    F_1_neq_0 : ~ 1 == 0;
+    Fdiv_def : forall p q, p / q == p * / q;
+    Finv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+  Definition F2AF f :=
+    mk_afield
+      (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l).
+
+  Record semi_field_theory : Prop := mk_sfield {
+    SF_SR : semi_ring_theory rO rI radd rmul req;
+    SF_1_neq_0 : ~ 1 == 0;
+    SFdiv_def : forall p q, p / q == p * / q;
+    SFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+End FieldAndSemiField.
+
+End MakeFieldPol.
+
+  Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth 
+    (sf:semi_field_theory rO rI radd rmul rdiv rinv req)  :=
+    mk_afield _ _
+      (SRth_ARth Rsth sf.(SF_SR))
+      sf.(SF_1_neq_0)
+      sf.(SFdiv_def)
+      sf.(SFinv_l).
+
+
+Section Complete.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x / y " := (rdiv x y).  Notation "/ x" := (rinv x).
+  Notation "x == y" := (req x y) (at level 70, no associativity).
+ Variable Rsth : Setoid_Theory R req.
+   Add Setoid R req Rsth as R_setoid3.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+   Add Morphism radd : radd_ext3.  exact (Radd_ext Reqe). Qed.
+   Add Morphism rmul : rmul_ext3.  exact (Rmul_ext Reqe). Qed.
+   Add Morphism ropp : ropp_ext3.  exact (Ropp_ext Reqe). Qed.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
+
+Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Lemma add_inj_r : forall p x y,
+   gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
+intros p x y.
+elim p using Pind; simpl in |- *; intros.
+ apply S_inj; trivial.
+ apply H.
+   apply S_inj.
+   repeat rewrite (ARadd_assoc ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial.
+Qed.
+
+Lemma gen_phiPOS_inj : forall x y,
+  gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
+  x = y.
+intros x y.
+repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
+ElimPcompare x y; intro.
+ intros.
+   apply Pcompare_Eq_eq; trivial.
+ intro.
+   elim gen_phiPOS_not_0 with (y - x)%positive.
+   apply add_inj_r with x.
+   symmetry  in |- *.
+   rewrite (ARadd_0_r Rsth ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+   rewrite Pplus_minus in |- *; trivial.
+   change Eq with (CompOpp Eq) in |- *.
+   rewrite <- Pcompare_antisym in |- *; trivial.
+   rewrite H in |- *; trivial.
+ intro.
+   elim gen_phiPOS_not_0 with (x - y)%positive.
+   apply add_inj_r with y.
+   rewrite (ARadd_0_r Rsth ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+   rewrite Pplus_minus in |- *; trivial.
+Qed.
+
+
+Lemma gen_phiN_inj : forall x y,
+  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+  x = y.
+destruct x; destruct y; simpl in |- *; intros; trivial.
+ elim gen_phiPOS_not_0 with p.
+   symmetry  in |- *.
+   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial.
+Qed.
+
+Lemma gen_phiN_complete : forall x y,
+  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+  Neq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Neq_bool in |- *.
+   rewrite Ncompare_refl in |- *; trivial.
+ apply gen_phiN_inj; trivial.
+Qed.
+
+End AlmostField.
+
+Section Field.
+
+ Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let Rth := Fth.(F_R).
+ Let rI_neq_rO := Fth.(F_1_neq_0).
+ Let rdiv_def := Fth.(Fdiv_def).
+ Let rinv_l := Fth.(Finv_l).
+ Let AFth := F2AF Rsth Reqe Fth.
+ Let ARth := Rth_ARth Rsth Reqe Rth.
+
+Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
+intros.
+transitivity (x + (1 + - (1))).
+ rewrite (Ropp_def Rth) in |- *.
+   symmetry  in |- *.
+   apply (ARadd_0_r Rsth ARth).
+ transitivity (y + (1 + - (1))).
+  repeat rewrite <- (ARplus_assoc ARth) in |- *.
+    repeat rewrite (ARadd_assoc ARth) in |- *.
+    apply (Radd_ext Reqe).
+   repeat rewrite <- (ARadd_comm ARth 1) in |- *.
+     trivial.
+   reflexivity.
+  rewrite (Ropp_def Rth) in |- *.
+    apply (ARadd_0_r Rsth ARth).
+Qed.
+
+
+ Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Let gen_phiPOS_inject :=
+   gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
+
+Lemma gen_phiPOS_discr_sgn : forall x y,
+  ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
+red in |- *; intros.
+apply gen_phiPOS_not_0 with (y + x)%positive.
+rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
+ apply (Radd_ext Reqe); trivial.
+  reflexivity.
+  rewrite (same_gen Rsth Reqe ARth) in |- *.
+    rewrite (same_gen Rsth Reqe ARth) in |- *.
+    trivial.
+ apply (Ropp_def Rth).
+Qed.
+
+Lemma gen_phiZ_inj : forall x y,
+  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+  x = y.
+destruct x; destruct y; simpl in |- *; intros.
+ trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   symmetry  in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite <- H in |- *.
+   apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   trivial.
+ rewrite gen_phiPOS_inject  with (1 := H) in |- *; trivial.
+ elim gen_phiPOS_discr_sgn with (1 := H).
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite H in |- *.
+   apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_discr_sgn with p0 p.
+   symmetry  in |- *; trivial.
+ replace p0 with p; trivial.
+   apply gen_phiPOS_inject.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *.
+   rewrite H in |- *; trivial.
+   reflexivity.
+Qed.
+
+Lemma gen_phiZ_complete : forall x y,
+  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+  Zeq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Zeq_bool in |- *.
+   rewrite Zcompare_refl in |- *; trivial.
+ apply gen_phiZ_inj; trivial.
+Qed.
+
+End Field.
+
+End Complete.
+
diff --git a/contrib/setoid_ring/ZRing_th.v b/contrib/setoid_ring/InitialRing.v
index 9060428b..7df68cc0 100644
--- a/contrib/setoid_ring/ZRing_th.v
+++ b/contrib/setoid_ring/InitialRing.v
@@ -1,11 +1,21 @@
-Require Import Ring_th.
-Require Import Pol.
-Require Import Ring_tac.
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
 Require Import ZArith_base.
 Require Import BinInt.
 Require Import BinNat.
 Require Import Setoid.
- Set Implicit Arguments.
+Require Import Ring_theory.
+Require Import Ring_tac.
+Require Import Ring_polynom.
+Set Implicit Arguments.
+
+Import RingSyntax.
 
 (** Z is a ring and a setoid*)
 
@@ -187,7 +197,7 @@ Section ZMORPHISM.
   replace Eq with (CompOpp Eq);trivial.
   rewrite <- Pcompare_antisym;simpl.
   rewrite match_compOpp.    
-  rewrite (Radd_sym Rth).
+  rewrite (Radd_comm Rth).
   apply gen_phiZ1_add_pos_neg.
   rewrite (ARgen_phiPOS_add ARth); norm.
  Qed.
@@ -255,6 +265,14 @@ Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y.
   rewrite H;trivial. 
  Qed.
 
+Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y.
+ Proof.
+  intros x y;unfold Neq_bool.
+  assert (H:=Ncompare_Eq_eq x y); 
+   destruct (Ncompare x y);intros;try discriminate.
+  rewrite H;trivial. 
+ Qed.
+
 (**Same as above : definition of two,extensionaly equal, generic morphisms *)
 (**from N to any semi-ring*)
 Section NMORPHISM.
@@ -326,271 +344,9 @@ Section NMORPHISM.
  Qed.
 
 End NMORPHISM.
-(*
-Section NNMORPHISM.
-Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-  Variable Rsth : Setoid_Theory R req.
-     Add Setoid R req Rsth as R_setoid5.
-     Ltac rrefl := gen_reflexivity Rsth.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext5.  exact Reqe.(Radd_ext). Qed.
-   Add Morphism rmul : rmul_ext5.  exact Reqe.(Rmul_ext). Qed.
-   Add Morphism ropp : ropp_ext5.  exact Reqe.(Ropp_ext). Qed.
-
- Lemma SReqe : sring_eq_ext radd rmul req.
-  case Reqe; constructor; trivial.
- Qed.
-
- Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
-   Add Morphism rsub : rsub_ext6. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
-   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-
- Lemma SRth : semi_ring_theory 0 1 radd rmul req. 
-  case ARth; constructor; trivial.
- Qed.
-
-  Definition NN := prod N N.
-  Definition gen_phiNN (x:NN) :=
-    rsub (gen_phiN rO rI radd rmul (fst x)) (gen_phiN rO rI radd rmul (snd x)).
-  Notation "[ x ]" := (gen_phiNN x).   
-
-  Definition NNadd (x y : NN) : NN :=
-    (fst x + fst y, snd x + snd y)%N.
-  Definition NNmul (x y : NN) : NN :=
-    (fst x * fst y + snd x * snd y, fst y * snd x + fst x * snd y)%N.
-  Definition NNopp (x:NN) : NN := (snd x, fst x)%N.
-  Definition NNsub (x y:NN) : NN := (fst x + snd y, fst y + snd x)%N.
-
-
- Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y].
- Proof.
-intros.
-unfold NNadd, gen_phiNN in |- *; simpl in |- *.
-repeat  rewrite (gen_phiN_add Rsth SReqe SRth).
-norm.
-add_push (- gen_phiN 0 1 radd rmul (snd x)).
-rrefl.
-Qed.
- 
-  Hypothesis ropp_involutive : forall x, - - x == x.
-
-
- Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y].
- Proof.
-intros.
-unfold NNmul, gen_phiNN in |- *; simpl in |- *.
-repeat  rewrite (gen_phiN_add Rsth SReqe SRth).
-repeat  rewrite (gen_phiN_mult Rsth SReqe SRth).
-norm.
-rewrite ropp_involutive.
-add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))).
-add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)).
-rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y))
-            (gen_phiN 0 1 radd rmul (snd x))).
-rrefl.
-Qed.
-
- Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y].
-intros.
-unfold NNsub, gen_phiNN; simpl.
-repeat rewrite (gen_phiN_add Rsth SReqe SRth).
-repeat rewrite (ARsub_def ARth).
-repeat rewrite (ARopp_add ARth).
-repeat rewrite (ARadd_assoc ARth).
-rewrite ropp_involutive.
-add_push (- gen_phiN 0 1 radd rmul (fst y)).
-add_push ( - gen_phiN 0 1 radd rmul (snd x)).
-rrefl.
-Qed.
-
-
-Definition NNeqbool (x y: NN) :=
-  andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)).
-
-Lemma NNeqbool_ok0 : forall x y,
-  NNeqbool x y = true -> x = y.
-unfold NNeqbool in |- *.
-intros.
-assert (Neq_bool (fst x) (fst y) = true).
- generalize H.
-   case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial.
- assert (Neq_bool (snd x) (snd y) = true).
-   rewrite H0 in H; simpl in |- *; trivial.
-  generalize H0 H1.
-    destruct x; destruct y; simpl in |- *.
-    intros.
-     replace n with n1.
-    replace n2 with n0; trivial.
-     apply Neq_bool_ok; trivial.
-   symmetry  in |- *.
-     apply Neq_bool_ok; trivial.
-Qed.
-
-
-(*gen_phiN satisfies morphism specifications*)
- Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req
-                        (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN.
- Proof.
-  constructor;intros;simpl; try rrefl.
-  apply gen_phiN_add. apply gen_phiN_sub.  apply gen_phiN_mult.
-  rewrite (Neq_bool_ok x y);trivial. rrefl.
- Qed.
-
-End NNMORPHISM.
-
-Section NSTARMORPHISM.
-Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-  Variable Rsth : Setoid_Theory R req.
-     Add Setoid R req Rsth as R_setoid3.
-     Ltac rrefl := gen_reflexivity Rsth.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext3.  exact Reqe.(Radd_ext). Qed.
-   Add Morphism rmul : rmul_ext3.  exact Reqe.(Rmul_ext). Qed.
-   Add Morphism ropp : ropp_ext3.  exact Reqe.(Ropp_ext). Qed.
-
- Lemma SReqe : sring_eq_ext radd rmul req.
-  case Reqe; constructor; trivial.
- Qed.
-
- Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
-   Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
-   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-
- Lemma SRth : semi_ring_theory 0 1 radd rmul req. 
-  case ARth; constructor; trivial.
- Qed.
-
-  Inductive Nword : Set :=
-    Nlast (p:positive)
-  | Ndigit (n:N) (w:Nword).
-
-  Fixpoint opp_iter (n:nat) (t:R) {struct n} : R :=
-    match n with 
-      O => t
-    | S k => ropp (opp_iter k t)
-    end.
-
-  Fixpoint gen_phiNword (x:Nword) (n:nat) {struct x} : R :=
-    match x with
-      Nlast p => opp_iter n (gen_phi_pos p)
-    | Ndigit N0 w => gen_phiNword w (S n)
-    | Ndigit m w => radd (opp_iter n (gen_phiN m)) (gen_phiNword w (S n))
-    end.
-  Notation "[ x ]" := (gen_phiNword x).   
-
-  Fixpoint Nwadd (x y : Nword) {struct x} : Nword :=
-    match x, y with
-      Nlast p1, Nlast p2 => Nlast (p1+p2)%positive
-    | Nlast p1, Ndigit n w => Ndigit (Npos p1 + n)%N w
-    | Ndigit n w, Nlast p1 => Ndigit (n + Npos p1)%N w
-    | Ndigit n1 w1, Ndigit n2 w2 => Ndigit (n1+n2)%N (Nwadd w1 w2)
-    end.
-  Fixpoint Nwmulp (x:positive) (y:Nword) {struct y} : Nword :=
-    match y with
-      Nlast p => Nlast (x*p)%positive
-    | Ndigit n w => Ndigit (Npos x * n)%N (Nwmulp x w)
-    end.
-  Definition Nwmul (x y : Nword) {struct x} : Nword :=
-    match x with
-      Nlast k => Nmulp k y
-    | Ndigit N0 w => Ndigit N0 (Nwmul w y)
-    | Ndigit (Npos k) w =>
-        Nwadd (Nwmulp k y) (Ndigit N0 (Nwmul w y))
-   end.
-
-  Definition Nwopp (x:Nword) : Nword := Ndigit N0 x.
-  Definition Nwsub (x y:NN) : NN := (Nwadd x (Ndigit N0 y)).
-
-
- Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y].
- Proof.
-intros.
-unfold NNadd, gen_phiNN in |- *; simpl in |- *.
-repeat  rewrite (gen_phiN_add Rsth SReqe SRth).
-norm.
-add_push (- gen_phiN 0 1 radd rmul (snd x)).
-rrefl.
-Qed.
-
- Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y].
- Proof.
-intros.
-unfold NNmul, gen_phiNN in |- *; simpl in |- *.
-repeat  rewrite (gen_phiN_add Rsth SReqe SRth).
-repeat  rewrite (gen_phiN_mult Rsth SReqe SRth).
-norm.
-rewrite ropp_involutive.
-add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))).
-add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)).
-rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y))
-            (gen_phiN 0 1 radd rmul (snd x))).
-rrefl.
-Qed.
 
- Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y].
-intros.
-unfold NNsub, gen_phiNN; simpl.
-repeat rewrite (gen_phiN_add Rsth SReqe SRth).
-repeat rewrite (ARsub_def ARth).
-repeat rewrite (ARopp_add ARth).
-repeat rewrite (ARadd_assoc ARth).
-rewrite ropp_involutive.
-add_push (- gen_phiN 0 1 radd rmul (fst y)).
-add_push ( - gen_phiN 0 1 radd rmul (snd x)).
-rrefl.
-Qed.
-
-
-Definition NNeqbool (x y: NN) :=
-  andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)).
-
-Lemma NNeqbool_ok0 : forall x y,
-  NNeqbool x y = true -> x = y.
-unfold NNeqbool in |- *.
-intros.
-assert (Neq_bool (fst x) (fst y) = true).
- generalize H.
-   case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial.
- assert (Neq_bool (snd x) (snd y) = true).
-   rewrite H0 in H; simpl in |- *; trivial.
-  generalize H0 H1.
-    destruct x; destruct y; simpl in |- *.
-    intros.
-     replace n with n1.
-    replace n2 with n0; trivial.
-     apply Neq_bool_ok; trivial.
-   symmetry  in |- *.
-     apply Neq_bool_ok; trivial.
-Qed.
-
-
-(*gen_phiN satisfies morphism specifications*)
- Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req
-                        (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN.
- Proof.
-  constructor;intros;simpl; try rrefl.
-  apply gen_phiN_add. apply gen_phiN_sub.  apply gen_phiN_mult.
-  rewrite (Neq_bool_ok x y);trivial. rrefl.
- Qed.
-
-End NSTARMORPHISM.
-*)
-
- (* syntaxification of constants in an abstract ring *)
+ (* syntaxification of constants in an abstract ring:
+    the inverse of gen_phiPOS *)
  Ltac inv_gen_phi_pos rI add mul t :=
    let rec inv_cst t :=
    match t with
@@ -600,7 +356,7 @@ End NSTARMORPHISM.
    | (mul (add rI rI) ?p) => (* 2p *)
        match inv_cst p with
          NotConstant => NotConstant
-       | 1%positive => NotConstant
+       | 1%positive => NotConstant (* 2*1 is not convertible to 2 *)
        | ?p => constr:(xO p)
        end
    | (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
@@ -613,6 +369,7 @@ End NSTARMORPHISM.
    end in
    inv_cst t.
 
+(* The inverse of gen_phiN *)
  Ltac inv_gen_phiN rO rI add mul t :=
    match t with
      rO => constr:0%N
@@ -623,6 +380,7 @@ End NSTARMORPHISM.
      end
    end.
 
+(* The inverse of gen_phiZ *)
  Ltac inv_gen_phiZ rO rI add mul opp t :=
    match t with
      rO => constr:0%Z
@@ -637,6 +395,7 @@ End NSTARMORPHISM.
      | ?p => constr:(Zpos p)
      end
    end.
+
 (* coefs = Z (abstract ring) *)
 Module Zpol.
 
@@ -646,23 +405,15 @@ Definition ring_gen_correct
                 (Rth_ARth rSet req_th Rth)
                 Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
                 (@gen_phiZ R rO rI radd rmul ropp)
-            (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth).
+                (gen_phiZ_morph rSet req_th Rth).
 
 Definition ring_rw_gen_correct
   R rO rI radd rmul rsub ropp req rSet req_th Rth :=
-  @Pphi_dev_ok  R rO rI radd rmul rsub ropp req rSet req_th
-                (Rth_ARth rSet req_th Rth)
-                Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
-                (@gen_phiZ R rO rI radd rmul ropp)
-            (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth).
-
-Definition ring_rw_gen_correct'
-  R rO rI radd rmul rsub ropp req rSet req_th Rth :=
-  @Pphi_dev_ok'  R rO rI radd rmul rsub ropp req rSet req_th
+  @Pphi_dev_ok   R rO rI radd rmul rsub ropp req rSet req_th
                  (Rth_ARth rSet req_th Rth)
                  Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool
                  (@gen_phiZ R rO rI radd rmul ropp)
-            (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth).
+                 (gen_phiZ_morph rSet req_th Rth).
 
 Definition ring_gen_eq_correct R rO rI radd rmul rsub ropp Rth :=
   @ring_gen_correct
@@ -672,10 +423,6 @@ Definition ring_rw_gen_eq_correct R rO rI radd rmul rsub ropp Rth :=
   @ring_rw_gen_correct
      R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth.
 
-Definition ring_rw_gen_eq_correct' R rO rI radd rmul rsub ropp Rth :=
-  @ring_rw_gen_correct'
-     R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth.
-
 End Zpol.
 
 (* coefs = N (abstract semi-ring) *)
@@ -688,115 +435,77 @@ Definition ring_gen_correct
                 (SRth_ARth rSet SRth)
                 N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool
                 (@gen_phiN R rO rI radd rmul)
-            (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth).
+                (gen_phiN_morph rSet req_th SRth).
 
 Definition ring_rw_gen_correct
   R rO rI radd rmul req rSet req_th SRth :=
-  @Pphi_dev_ok  R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet
-                (SReqe_Reqe req_th)
-                (SRth_ARth rSet SRth)
-                N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool
-                (@gen_phiN R rO rI radd rmul)
-            (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth).
-
-Definition ring_rw_gen_correct'
-  R rO rI radd rmul req rSet req_th SRth :=
-  @Pphi_dev_ok'  R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet
+  @Pphi_dev_ok   R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet
                  (SReqe_Reqe req_th)
                  (SRth_ARth rSet SRth)
                  N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool
                  (@gen_phiN R rO rI radd rmul)
-            (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth).
+                 (gen_phiN_morph rSet req_th SRth).
 
 Definition ring_gen_eq_correct R rO rI radd rmul SRth :=
   @ring_gen_correct
      R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth.
 
-Definition ring_rw_gen_eq_correct R rO rI radd rmul SRth :=
-  @ring_rw_gen_correct
-     R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth.
-
 Definition ring_rw_gen_eq_correct' R rO rI radd rmul SRth :=
-  @ring_rw_gen_correct'
+  @ring_rw_gen_correct
      R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth.
 
 End Npol.
 
-(* Z *)
-
-Ltac isZcst t :=
-  match t with
-    Z0 => constr:true
-  | Zpos ?p => isZcst p
-  | Zneg ?p => isZcst p
-  | xI ?p => isZcst p
-  | xO ?p => isZcst p
-  | xH => constr:true
-  | _ => constr:false
-  end.
-Ltac Zcst t :=
-  match isZcst t with
-    true => t
-  | _ => NotConstant
-  end.
-
-Add New Ring Zr : Zth Computational Zeqb_ok Constant Zcst.
 
-(* N *)
-
-Ltac isNcst t :=
-  match t with
-    N0 => constr:true
-  | Npos ?p => isNcst p
-  | xI ?p => isNcst p
-  | xO ?p => isNcst p
-  | xH => constr:true
-  | _ => constr:false
-  end.
-Ltac Ncst t :=
-  match isNcst t with
-    true => t
-  | _ => NotConstant
+Ltac coerce_to_almost_ring set ext rspec :=
+  match type of rspec with
+  | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec)
+  | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec)
+  | almost_ring_theory _ _ _ _ _ _ _ => rspec
+  | _ => fail 1 "not a valid ring theory"
   end.
 
-Add New Ring Nr : Nth Computational Neq_bool_ok Constant Ncst.
-
-(* nat *)
-
-Ltac isnatcst t :=
-  match t with
-    O => true
-  | S ?p => isnatcst p
-  | _ => false
-  end.
-Ltac natcst t :=
-  match isnatcst t with
-    true => t
-  | _ => NotConstant
+Ltac coerce_to_ring_ext ext :=
+  match type of ext with
+  | ring_eq_ext _ _ _ _ => ext
+  | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext)
+  | _ => fail 1 "not a valid ring_eq_ext theory"
   end.
 
- Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
- Proof.
-  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
-  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
-  exact mult_plus_distr_r. 
- Qed.
-
-
-Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
-  match n, m with
-  | O, O => true
-  | S n', S m' => nateq n' m'
-  | _, _ => false
+Ltac abstract_ring_morphism set ext rspec :=
+  match type of rspec with
+  | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec)
+  | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec)
+  | almost_ring_theory _ _ _ _ _ _ _ =>
+      fail 1 "an almost ring cannot be abstract"
+  | _ => fail 1 "bad ring structure"
   end.
 
-Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m.
-Proof.
-  simple induction n; simple induction m; simpl; intros; try discriminate.
-  trivial.
-  rewrite (H n1 H1).
-  trivial.
-Qed.
+Ltac ring_elements set ext rspec rk :=
+  let arth := coerce_to_almost_ring set ext rspec in
+  let ext_r := coerce_to_ring_ext ext in
+  let morph :=
+    match rk with
+    | Abstract => abstract_ring_morphism set ext rspec
+    | @Computational ?reqb_ok =>
+        match type of arth with
+        | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ =>
+            constr:(IDmorph rO rI add mul sub opp set _ reqb_ok)
+        | _ => fail 2 "ring anomaly"
+        end
+    | @Morphism ?m => m
+    | _ => fail 1 "ill-formed ring kind"
+    end in
+  fun f => f arth ext_r morph.
+
+(* Given a ring structure and the kind of morphism,
+   returns 2 lemmas (one for ring, and one for ring_simplify). *)
+
+Ltac ring_lemmas set ext rspec rk :=
+  ring_elements set ext rspec rk
+    ltac:(fun arth ext_r morph =>
+      let lemma1 := constr:(ring_correct set ext_r arth morph) in
+      let lemma2 := constr:(Pphi_dev_ok set ext_r arth morph) in
+      fun f => f arth ext_r morph lemma1 lemma2).
 
-Add New Ring natr : natSRth Computational nateq_ok Constant natcst.
 
diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v
new file mode 100644
index 00000000..33e3cb4e
--- /dev/null
+++ b/contrib/setoid_ring/NArithRing.v
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export Ring.
+Require Import BinPos BinNat.
+Import InitialRing.
+
+Set Implicit Arguments.
+
+Ltac isNcst t :=
+  let t := eval hnf in t in
+  match t with
+    N0 => constr:true
+  | Npos ?p => isNcst p
+  | xI ?p => isNcst p
+  | xO ?p => isNcst p
+  | xH => constr:true
+  | _ => constr:false
+  end.
+Ltac Ncst t :=
+  match isNcst t with
+    true => t
+  | _ => NotConstant
+  end.
+
+Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v
new file mode 100644
index 00000000..13896123
--- /dev/null
+++ b/contrib/setoid_ring/RealField.v
@@ -0,0 +1,105 @@
+Require Import Raxioms.
+Require Import Rdefinitions.
+Require Export Ring Field.
+
+Open Local Scope R_scope.
+
+Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)).
+Proof.
+constructor.
+ intro; apply Rplus_0_l.
+ exact Rplus_comm.
+ symmetry  in |- *; apply Rplus_assoc.
+ intro; apply Rmult_1_l.
+ exact Rmult_comm.
+ symmetry  in |- *; apply Rmult_assoc.
+ intros m n p.
+   rewrite Rmult_comm in |- *.
+   rewrite (Rmult_comm n p) in |- *.
+   rewrite (Rmult_comm m p) in |- *.
+   apply Rmult_plus_distr_l.
+ reflexivity.
+ exact Rplus_opp_r.
+Qed.
+
+Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)).
+Proof.
+constructor.
+ exact RTheory.
+ exact R1_neq_R0.
+ reflexivity.
+ exact Rinv_l.
+Qed.
+
+Lemma Rlt_n_Sn : forall x, x < x + 1.
+Proof.
+intro.
+elim archimed with x; intros.
+destruct H0.
+ apply Rlt_trans with (IZR (up x)); trivial.
+    replace (IZR (up x)) with (x + (IZR (up x) - x))%R.
+  apply Rplus_lt_compat_l; trivial.
+  unfold Rminus in |- *.
+    rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+    rewrite <- Rplus_assoc in |- *.
+    rewrite Rplus_opp_r in |- *.
+    apply Rplus_0_l.
+ elim H0.
+   unfold Rminus in |- *.
+   rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+   rewrite <- Rplus_assoc in |- *.
+   rewrite Rplus_opp_r in |- *.
+   rewrite Rplus_0_l in |- *; trivial.
+Qed.
+
+Notation Rset := (Eqsth R).
+Notation Rext := (Eq_ext Rplus Rmult Ropp).
+
+Lemma Rlt_0_2 : 0 < 2.
+apply Rlt_trans with (0 + 1).
+ apply Rlt_n_Sn.
+ rewrite Rplus_comm in |- *.
+   apply Rplus_lt_compat_l.
+    replace 1 with (0 + 1).
+  apply Rlt_n_Sn.
+  apply Rplus_0_l.
+Qed.
+
+Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0.
+unfold Rgt in |- *.
+induction x; simpl in |- *; intros.
+ apply Rlt_trans with (1 + 0).
+  rewrite Rplus_comm in |- *.
+    apply Rlt_n_Sn.
+  apply Rplus_lt_compat_l.
+    rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+    rewrite Rmult_comm in |- *.
+    apply Rmult_lt_compat_l.
+   apply Rlt_0_2.
+   trivial.
+ rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+   rewrite Rmult_comm in |- *.
+   apply Rmult_lt_compat_l.
+  apply Rlt_0_2.
+  trivial.
+  replace 1 with (0 + 1).
+  apply Rlt_n_Sn.
+  apply Rplus_0_l.
+Qed.
+
+
+Lemma Rgen_phiPOS_not_0 :
+  forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0.
+red in |- *; intros.
+specialize (Rgen_phiPOS x).
+rewrite H in |- *; intro.
+apply (Rlt_asym 0 0); trivial.
+Qed.
+
+Lemma Zeq_bool_complete : forall x y, 
+  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x =
+  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y ->
+  Zeq_bool x y = true.
+Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0.
+
+Add Field RField : Rfield (infinite Zeq_bool_complete).
diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v
new file mode 100644
index 00000000..167e026f
--- /dev/null
+++ b/contrib/setoid_ring/Ring.v
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Bool.
+Require Export Ring_theory.
+Require Export Ring_base.
+Require Export Ring_tac.
+
+Lemma BoolTheory :
+  ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
+split; simpl in |- *.
+destruct x; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; reflexivity.
+Qed.
+
+Unboxed Definition bool_eq (b1 b2:bool) :=
+  if b1 then b2 else negb b2.
+
+Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2.
+destruct b1; destruct b2; auto.
+Qed.
+
+Ltac bool_cst t :=
+  let t := eval hnf in t in
+  match t with
+    true => constr:true
+  | false => constr:false
+  | _ => NotConstant
+  end.
+
+Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v
new file mode 100644
index 00000000..95b037e3
--- /dev/null
+++ b/contrib/setoid_ring/Ring_base.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* This module gathers the necessary base to build an instance of the
+   ring tactic. Abstract rings need more theory, depending on
+   ZArith_base. *)
+
+Declare ML Module "newring".
+Require Export Ring_theory.
+Require Export Ring_tac.
+Require Import InitialRing.
diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v
new file mode 100644
index 00000000..945f6c68
--- /dev/null
+++ b/contrib/setoid_ring/Ring_equiv.v
@@ -0,0 +1,74 @@
+Require Import Setoid_ring_theory.
+Require Import LegacyRing_theory.
+Require Import Ring_theory.
+
+Set Implicit Arguments.
+
+Section Old2New.
+
+Variable A : Type.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+Let Aminus := fun x y => Aplus x (Aopp y).
+
+Lemma ring_equiv1 :
+  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
+Proof.
+destruct R.
+split;  eauto.
+Qed.
+
+End Old2New.
+
+Section New2OldRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma ring_equiv2 :
+   Ring_Theory radd  rmul rI rO ropp reqb.
+Proof.
+elim Rth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+ Definition default_eqb : R -> R -> bool := fun x y => false.
+ Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
+Proof.
+discriminate 1.
+Qed.
+
+End New2OldRing.
+
+Section New2OldSemiRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul: R->R->R).
+ Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma sring_equiv2 :
+   Semi_Ring_Theory radd rmul rI rO reqb.
+Proof.
+elim SRth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+End New2OldSemiRing.
diff --git a/contrib/setoid_ring/Pol.v b/contrib/setoid_ring/Ring_polynom.v
index 2bf2574f..7317ab21 100644
--- a/contrib/setoid_ring/Pol.v
+++ b/contrib/setoid_ring/Ring_polynom.v
@@ -1,9 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
 Set Implicit Arguments.
 Require Import Setoid.
-Require Export BinList.
+Require Import BinList.
 Require Import BinPos.
 Require Import BinInt.
-Require Export Ring_th.
+Require Export Ring_theory.
+
+Import RingSyntax.
 
 Section MakeRingPol.
  
@@ -313,7 +323,13 @@ Section MakeRingPol.
   end.
  Notation "P ** P'" := (Pmul P P').
  
- (** Evaluation of a polynomial towards R *)
+
+ (** Monomial **)
+     
+  Inductive Mon: Set :=
+    mon0: Mon 
+  | zmon: positive -> Mon -> Mon 
+  | vmon: positive -> Mon -> Mon.
 
  Fixpoint pow (x:R) (i:positive) {struct i}: R :=
   match i with
@@ -322,6 +338,96 @@ Section MakeRingPol.
   | xI i => let p := pow x i in x * p * p
   end.
 
+ Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R :=
+  match M with
+     mon0 => rI
+  | zmon j M1  => Mphi (jump j l) M1
+  | vmon i M1 =>
+     let x := hd 0 l in
+     let xi := pow x i in
+    (Mphi (tail l) M1) * xi 
+  end.
+
+ Definition zmon_pred j M :=
+   match j with xH => M | _ => zmon (Ppred j) M end.
+
+ Definition mkZmon j M :=
+   match M with mon0 => mon0 | _ => zmon j M end.
+
+ Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+   match P, M with
+        _, mon0 => (Pc cO, P)
+   | Pc _, _    => (P, Pc cO)
+   | Pinj j1 P1, zmon j2 M1 =>
+      match (j1 ?= j2) Eq with
+        Eq => let (R,S) := MFactor P1 M1 in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Gt => (P, Pc cO)
+      end
+  | Pinj _ _, vmon _ _ => (P, Pc cO)
+  | PX P1 i Q1, zmon j M1 =>
+             let M2 := zmon_pred j M1 in
+             let (R1, S1) := MFactor P1 M in
+             let (R2, S2) := MFactor Q1 M2 in
+               (mkPX R1 i R2, mkPX S1 i S2)
+  | PX P1 i Q1, vmon j M1 =>
+      match (i ?= j) Eq with
+        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, S1)
+      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+                 (mkPX R1 i Q1, S1)
+      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+      end
+   end.
+
+  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+    let (Q1,R1) := MFactor P1 M1 in
+    match R1 with 
+     (Pc c) => if c ?=! cO then None 
+               else Some (Padd Q1 (Pmul P2 R1))
+    | _ => Some (Padd Q1 (Pmul P2 R1))
+    end.
+
+  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+    match POneSubst P1 M1 P2 with 
+     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+    | _ => P1
+    end.
+
+  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+    match POneSubst P1 M1 P2 with 
+     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+    | _ => None
+    end.
+            
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: 
+     Pol :=
+    match LM1 with 
+     cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+    | _ => P1
+    end.
+
+  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+    match LM1 with 
+     cons (M1,P2) LM2 =>
+      match PNSubst P1 M1 P2 n with 
+        Some P3 => Some (PSubstL1 P3 LM2 n)
+     |  None => PSubstL P1 LM2 n
+     end
+    | _ => None
+    end.
+
+  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+    match PSubstL P1 LM1 n with 
+     Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+    | _ => P1
+    end.
+
+ (** Evaluation of a polynomial towards R *)
+
  Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
   match P with
   | Pc c => [c]
@@ -329,7 +435,7 @@ Section MakeRingPol.
   | PX P i Q => 
      let x := hd 0 l in
      let xi := pow x i in
-    (Pphi l P) * xi + (Pphi (tl l) Q)      
+    (Pphi l P) * xi + (Pphi (tail l) Q)      
   end.
 
  Reserved Notation "P @ l " (at level 10, no associativity).
@@ -418,7 +524,7 @@ Section MakeRingPol.
  Qed.
 
  Lemma mkPX_ok : forall l P i Q, 
-  (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tl l).
+  (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tail l).
  Proof.
   intros l P i Q;unfold mkPX.
   destruct P;try (simpl;rrefl).
@@ -500,7 +606,7 @@ Section MakeRingPol.
   induction P';simpl;intros;Esimpl2.
   generalize P p l;clear P p l.
   induction P;simpl;intros.
-  Esimpl2;apply (ARadd_sym ARth).
+  Esimpl2;apply (ARadd_comm ARth).
   assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
   rewrite H;Esimpl. rewrite IHP';rrefl.
   rewrite H;Esimpl. rewrite IHP';Esimpl.
@@ -519,33 +625,33 @@ Section MakeRingPol.
   rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl.
   rewrite IHP'2;simpl.
   rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl. add_push (P @ (tl l));rrefl.
+  rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl.
   assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
   rewrite IHP'1;rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tl l));rewrite H;rrefl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
   rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
   rewrite H;rewrite Pplus_comm.
   rewrite pow_Pplus;rsimpl.
-  add_push (P3 @ (tl l));rrefl.
+  add_push (P3 @ (tail l));rrefl.
   assert (forall P k l, 
            (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow (hd 0 l) k).
-   induction P;simpl;intros;try apply (ARadd_sym ARth).
-   destruct p2;simpl;try apply (ARadd_sym ARth).
-   rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth).
+   induction P;simpl;intros;try apply (ARadd_comm ARth).
+   destruct p2;simpl;try apply (ARadd_comm ARth).
+   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth).
     assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
-    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tl l0));rrefl.
+    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
     rewrite IHP'1;simpl;Esimpl.
     rewrite H1;rewrite Pplus_comm.
     rewrite pow_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tl l0));rrefl.
+    add_push (P5 @ (tail l0));rrefl.
     rewrite IHP1;rewrite H1;rewrite Pplus_comm.
     rewrite pow_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tl l0));rrefl.
+    add_push (P5 @ (tail l0));rrefl.
   rewrite H0;rsimpl.
-  add_push (P3 @ (tl l)).
+  add_push (P3 @ (tail l)).
   rewrite H;rewrite Pplus_comm.
   rewrite IHP'2;rewrite pow_Pplus;rsimpl.
-  add_push (P3 @ (tl l));rrefl.
+  add_push (P3 @ (tail l));rrefl.
  Qed.
 
  Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
@@ -553,7 +659,7 @@ Section MakeRingPol.
   induction P';simpl;intros;Esimpl2;trivial.
   generalize P p l;clear P p l.
   induction P;simpl;intros.
-  Esimpl2;apply (ARadd_sym ARth).
+  Esimpl2;apply (ARadd_comm ARth).
   assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
   rewrite H;Esimpl. rewrite IHP';rsimpl. 
   rewrite H;Esimpl. rewrite IHP';Esimpl.
@@ -569,35 +675,35 @@ Section MakeRingPol.
   repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
   destruct p0;simpl;Esimpl2.
   rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));trivial.
-  add_push (P @ (jump p0 (jump p0 (tl l))));rrefl.
+  add_push (P @ (jump p0 (jump p0 (tail l))));rrefl.
   rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl.
   add_push (- (P'1 @ l * pow (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl;add_push (P @ (tl l));rrefl.
+  rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl.
   assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
   rewrite IHP'1; rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tl l));rewrite H;rrefl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
    rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
   rewrite H;rewrite Pplus_comm.
   rewrite pow_Pplus;rsimpl.
-  add_push (P3 @ (tl l));rrefl.
+  add_push (P3 @ (tail l));rrefl.
   assert (forall P k l, 
            (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow (hd 0 l) k).
    induction P;simpl;intros.
-   rewrite Popp_ok;rsimpl;apply (ARadd_sym ARth);trivial.
+   rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
    destruct p2;simpl;rewrite Popp_ok;rsimpl.
-   apply (ARadd_sym ARth);trivial.
-   rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth);trivial.
-   apply (ARadd_sym ARth);trivial.
+   apply (ARadd_comm ARth);trivial.
+   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial.
+   apply (ARadd_comm ARth);trivial.
     assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
-    rewrite IHP'1;rsimpl;add_push (P5 @ (tl l0));rewrite H1;rrefl.
+    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
     rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
     rewrite pow_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tl l0));rrefl.
+    add_push (P5 @ (tail l0));rrefl.
     rewrite IHP1;rewrite H1;rewrite Pplus_comm.
     rewrite pow_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tl l0));rrefl.
+    add_push (P5 @ (tail l0));rrefl.
   rewrite H0;rsimpl.
-  rewrite IHP'2;rsimpl;add_push (P3 @ (tl l)).
+  rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
   rewrite H;rewrite Pplus_comm.
   rewrite pow_Pplus;rsimpl.
  Qed.
@@ -609,7 +715,7 @@ Section MakeRingPol.
     (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
  Proof.
   induction P;simpl;intros.
-  Esimpl2;apply (ARmul_sym ARth).
+  Esimpl2;apply (ARmul_comm ARth).
   assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
   rewrite H1; rewrite H;rrefl.
   rewrite H1; rewrite H.
@@ -639,13 +745,198 @@ Section MakeRingPol.
  Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
  Proof.
   destruct P;simpl;intros.
-  Esimpl2;apply (ARmul_sym ARth).
+  Esimpl2;apply (ARmul_comm ARth).
   rewrite (PmulI_ok P (Pmul_aux_ok P)).
-  apply (ARmul_sym ARth).
+  apply (ARmul_comm ARth).
   rewrite Padd_ok; Esimpl2.
   rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
   rewrite Pmul_aux_ok;mul_push (P' @ l).
-  rewrite (ARmul_sym ARth (P' @ l));rrefl.
+  rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+
+
+ Lemma mkZmon_ok: forall M j l,
+   Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+
+ Lemma Mphi_ok: forall P M l, 
+    let (Q,R) := MFactor P M in
+      P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+   intros c M l; case M; simpl; auto; try intro p; try intro m;
+   try rewrite (morph0 CRmorph); rsimpl.
+
+   intros i P Hrec M l; case M; simpl; clear M.
+     rewrite (morph0 CRmorph); rsimpl.
+     intros j M.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec M (jump j l)); case (MFactor P M);
+        simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       generalize (Hrec (zmon (j -i) M) (jump i l)); 
+       case (MFactor P (zmon (j -i) M)); simpl.
+       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
+       rewrite Pplus_comm; rewrite jump_Pplus; auto.
+       rewrite (morph0 CRmorph); rsimpl.
+       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+   rewrite (morph0 CRmorph); rsimpl.
+   intros j M1.
+     generalize (Hrec1 (zmon j M1) l); 
+     case (MFactor P2 (zmon j M1)).
+     intros R1 S1 H1.
+     generalize (Hrec2 (zmon_pred j M1) (List.tail l)); 
+     case (MFactor Q2 (zmon_pred j M1)); simpl.
+     intros R2 S2 H2; rewrite H1; rewrite H2.
+     repeat rewrite mkPX_ok; simpl.
+     rsimpl.  
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     case j; simpl; auto; try intros j1; rsimpl.
+     rewrite jump_Pdouble_minus_one; rsimpl.
+   intros j M1.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite mkZmon_ok.
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       generalize (Hrec1 (vmon (j - i) M1) l); 
+             case (MFactor P2 (vmon (j - i) M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_Pplus.
+       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+       generalize (Hrec1 (mkZmon 1 M1) l); 
+             case (MFactor P2 (mkZmon 1 M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       rewrite mkZmon_ok.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       rewrite mkPX_ok; simpl; rsimpl.
+       rewrite (morph0 CRmorph); rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_Pplus.
+       rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+   intros c H; rewrite H.
+   generalize (morph_eq CRmorph c cO);
+        case (c ?=! cO); simpl; auto.
+   intros H1 H2; rewrite H1; auto; rsimpl.
+   discriminate.
+   intros _ H1 H2; injection H1; intros; subst.
+   rewrite H2; rsimpl.
+   rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ intros i P5 H; rewrite H.
+   intros HH H1; injection HH; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite Pmul_ok; rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   injection H2; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ Qed.
+
+
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+    Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+   intros P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate). 
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
+    match LM1 with 
+     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+    | _ => True
+    end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+   rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
  Qed.
 
  (** Definition of polynomial expressions *)
@@ -714,7 +1005,7 @@ Section MakeRingPol.
   | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
   | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
   | |- context [(norm (PEopp ?pe))@?l] => rewrite (norm_PEopp l pe)
-  end;Esimpl2;try rrefl;try apply (ARadd_sym ARth).
+  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
 
  Lemma norm_ok : forall l pe,  PEeval l pe == (norm pe)@l.
  Proof.
@@ -757,12 +1048,12 @@ Section MakeRingPol.
  Fixpoint add_mult_dev (rP:R) (P:Pol) (fv lm:list R) {struct P} : R :=
   (* rP + P@l * lm *)
   match P with
-  | Pc c => if c ?=! cI then mkadd_mult rP (rev lm) 
-    else mkadd_mult rP (cons [c] (rev lm))
+  | Pc c => if c ?=! cI then mkadd_mult rP (rev' lm) 
+    else mkadd_mult rP (cons [c] (rev' lm))
   | Pinj j Q => add_mult_dev rP Q (jump j fv) lm
   | PX P i Q => 
      let rP := add_mult_dev rP P fv (powl i (hd 0 fv) lm) in
-     if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm
+     if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm
   end.
  
  Definition mkmult1 lm :=
@@ -774,14 +1065,14 @@ Section MakeRingPol.
  Fixpoint mult_dev (P:Pol) (fv lm : list R) {struct P} : R :=
   (* P@l * lm *)							      
   match P with
-  | Pc c => if c ?=! cI then mkmult1 (rev lm) else mkmult [c] (rev lm)
+  | Pc c => if c ?=! cI then mkmult1 (rev' lm) else mkmult [c] (rev' lm)
   | Pinj j Q => mult_dev Q (jump j fv) lm
   | PX P i Q => 
      let rP := mult_dev P fv (powl i (hd 0 fv) lm) in
-     if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm
+     if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm
   end. 
 
- Definition Pphi_dev fv P := mult_dev P fv (nil R).
+ Definition Pphi_dev fv P := mult_dev P fv nil.
 
  Add Morphism mkmult : mkmult_ext.
   intros r r0 eqr l;generalize l r r0 eqr;clear l r r0 eqr;
@@ -808,21 +1099,21 @@ Section MakeRingPol.
  Qed.
 
  Lemma mkmult_rev_append : forall lm l r,
-  mkmult r (rev_append l lm) == mkmult (mkmult r l) lm.
+  mkmult r (rev_append lm l) == mkmult (mkmult r l) lm.
  Proof.
  induction lm; simpl in |- *; intros.
  rrefl.
  rewrite IHlm; simpl in |- *.
-   repeat rewrite <- (ARmul_sym ARth a); rewrite <- mul_mkmult.
+   repeat rewrite <- (ARmul_comm ARth a); rewrite <- mul_mkmult.
    rrefl.
  Qed.
 
  Lemma powl_mkmult_rev : forall p r x lm,
-  mkmult r (rev (powl p x lm)) == mkmult (pow x p * r) (rev lm).
+  mkmult r (rev' (powl p x lm)) == mkmult (pow x p * r) (rev' lm).
  Proof.
   induction p;simpl;intros.
   repeat rewrite IHp.
-  unfold rev;simpl.
+  unfold rev';simpl.
   repeat rewrite mkmult_rev_append.
   simpl.
   setoid_replace (pow x p * (pow x p * r) * x) 
@@ -831,18 +1122,18 @@ Section MakeRingPol.
   repeat rewrite IHp.
   setoid_replace (pow x p * (pow x p * r) ) 
     with (pow x p * pow x p * r);Esimpl.
-  unfold rev;simpl. repeat rewrite mkmult_rev_append;simpl.
-  rewrite (ARmul_sym ARth);rrefl.
+  unfold rev';simpl. repeat rewrite mkmult_rev_append;simpl.
+  rewrite (ARmul_comm ARth);rrefl.
  Qed.
 
  Lemma Pphi_add_mult_dev : forall P rP fv lm, 
-    rP + P@fv * mkmult1 (rev lm) == add_mult_dev rP P fv lm.
+    rP + P@fv * mkmult1 (rev' lm) == add_mult_dev rP P fv lm.
  Proof.
   induction P;simpl;intros.
   assert (H := (morph_eq CRmorph) c cI).
    destruct (c ?=! cI).
     rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl.
-    destruct (rev lm);Esimpl;rrefl.
+    destruct (rev' lm);Esimpl;rrefl.
     rewrite mkmult1_mkmult;rrefl.
    apply IHP.
    replace (match P3 with
@@ -865,7 +1156,7 @@ Section MakeRingPol.
  Qed.
                                      
  Lemma Pphi_mult_dev : forall P fv lm,
-	 P@fv * mkmult1 (rev lm) == mult_dev P fv lm.
+	 P@fv * mkmult1 (rev' lm) == mult_dev P fv lm.
  Proof.
   induction P;simpl;intros.
    assert (H := (morph_eq CRmorph) c cI).
@@ -898,298 +1189,44 @@ Section MakeRingPol.
   rewrite <- Pphi_mult_dev;simpl;Esimpl.
  Qed.
 
- Lemma Pphi_dev_ok :  forall l pe,  PEeval l pe == Pphi_dev l (norm pe).
+ Lemma Pphi_dev_gen_ok :  forall l pe,  PEeval l pe == Pphi_dev l (norm pe).
  Proof.
   intros l pe;rewrite <- Pphi_Pphi_dev;apply norm_ok.
  Qed.
 
- Lemma Pphi_dev_ok' :
+ Lemma Pphi_dev_ok :
    forall l pe npe, norm pe = npe -> PEeval l pe == Pphi_dev l npe.
  Proof.
-  intros l pe npe npe_eq; subst npe; apply Pphi_dev_ok.
- Qed.
- 
-(* The same but building a PExpr *)
-(*
- Fixpoint Pmkmult (r:PExpr) (lm:list PExpr) {struct lm}: PExpr :=
-  match lm with
-  | nil => r
-  | cons h t => Pmkmult (PEmul r h) t
-  end.
-		       
- Definition Pmkadd_mult rP lm :=
-  match lm with
-  | nil => PEadd rP (PEc cI)
-  | cons h t => PEadd rP (Pmkmult h t)
-  end.
-
- Fixpoint Ppowl (i:positive) (x:PExpr) (l:list PExpr) {struct i}: list PExpr :=
-  match i with
-  | xH => cons x l
-  | xO i => Ppowl i x (Ppowl i x l)
-  | xI i => Ppowl i x (Ppowl i x (cons x l))
-  end.
-			       
- Fixpoint Padd_mult_dev
-     (rP:PExpr) (P:Pol) (fv lm:list PExpr) {struct P} : PExpr :=
-  (* rP + P@l * lm *)
-  match P with
-  | Pc c => if c ?=! cI then Pmkadd_mult rP (rev lm) 
-    else Pmkadd_mult rP (cons [PEc c] (rev lm))
-  | Pinj j Q => Padd_mult_dev rP Q (jump j fv) lm
-  | PX P i Q => 
-     let rP := Padd_mult_dev rP P fv (Ppowl i (hd P0 fv) lm) in
-     if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm
-  end.
- 
- Definition Pmkmult1 lm :=
-  match lm with
-  | nil => PEc cI
-  | cons h t => Pmkmult h t
-  end.
-   
- Fixpoint Pmult_dev (P:Pol) (fv lm : list PExpr) {struct P} : PExpr :=
-  (* P@l * lm *)							      
-  match P with
-  | Pc c => if c ?=! cI then Pmkmult1 (rev lm) else Pmkmult [PEc c] (rev lm)
-  | Pinj j Q => Pmult_dev Q (jump j fv) lm
-  | PX P i Q => 
-     let rP := Pmult_dev P fv (Ppowl i (hd (PEc r0) fv) lm) in
-     if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm
-  end. 
-
- Definition Pphi_dev2 fv P := Pmult_dev P fv (nil PExpr).
-
-...
-*)
-  (************************************************)
- (* avec des parentheses mais un peu plus efficace *)
-
-
- (**************************************************
-
-  Fixpoint pow_mult (i:positive) (x r:R){struct i}:R :=
-  match i with
-  | xH => r * x
-  | xO i => pow_mult i x (pow_mult i x r)
-  | xI i => pow_mult i x (pow_mult i x (r * x))
-  end.
- 
- Definition pow_dev i x :=
-  match i with
-  | xH => x
-  | xO i => pow_mult (Pdouble_minus_one i) x x
-  | xI i => pow_mult (xO i) x x
-  end.
-
- Lemma pow_mult_pow : forall i x r, pow_mult i x r == pow x i * r.
- Proof.
-  induction i;simpl;intros.
-  rewrite (IHi x (pow_mult i x (r * x)));rewrite (IHi x (r*x));rsimpl.
-  mul_push x;rrefl.
-  rewrite (IHi x (pow_mult i x r));rewrite (IHi x r);rsimpl.
-  apply ARth.(ARmul_sym).
- Qed.
-
- Lemma pow_dev_pow : forall p x, pow_dev p x == pow x p.
- Proof.
-  destruct p;simpl;intros.
-  rewrite (pow_mult_pow p x (pow_mult p x x)).
-  rewrite (pow_mult_pow p x x);rsimpl;mul_push x;rrefl.
-  rewrite (pow_mult_pow (Pdouble_minus_one p) x x).
-  rewrite (ARth.(ARmul_sym) (pow x (Pdouble_minus_one p)) x).
-  rewrite <- (pow_Psucc x (Pdouble_minus_one p)).
-  rewrite Psucc_o_double_minus_one_eq_xO;simpl; rrefl.
-  rrefl.
- Qed.
-
- Fixpoint Pphi_dev (fv:list R) (P:Pol) {struct P} : R :=
-  match P with
-  | Pc c => [c]
-  | Pinj j Q => Pphi_dev (jump j fv) Q
-  | PX P i Q => 
-    let rP := mult_dev P fv (pow_dev i (hd 0 fv)) in
-    add_dev rP Q (tl fv)
-  end
+  intros l pe npe npe_eq; subst npe; apply Pphi_dev_gen_ok.
+ Qed. 
 
- with add_dev (ra:R) (P:Pol) (fv:list R) {struct P} : R :=
-   match P with
-  | Pc c => if c ?=! cO then ra else ra + [c] 
-  | Pinj j Q => add_dev ra Q (jump j fv)
-  | PX P i Q =>
-    let ra := add_mult_dev ra P fv (pow_dev i (hd 0 fv)) in
-    add_dev ra Q (tl fv)
-  end
- 
- with mult_dev (P:Pol) (fv:list R) (rm:R) {struct P} : R :=
-  match P with
-  | Pc c => if c ?=! cI then rm else [c]*rm
-  | Pinj j Q => mult_dev Q (jump j fv) rm
-  | PX P i Q =>
-    let ra := mult_dev P fv (pow_mult i (hd 0 fv) rm) in
-    add_mult_dev ra Q (tl fv) rm
-  end
-
- with add_mult_dev (ra:R) (P:Pol) (fv:list R) (rm:R) {struct P} : R :=
-  match P with
-  | Pc c =>  if c ?=! cO then ra else ra + [c]*rm
-  | Pinj j Q => add_mult_dev ra Q (jump j fv) rm
-  | PX P i Q =>
-    let rmP := pow_mult i (hd 0 fv) rm in
-    let raP := add_mult_dev ra P fv rmP in
-    add_mult_dev raP Q (tl fv) rm
-  end.
- 
- Lemma Pphi_add_mult_dev : forall P ra fv rm,
-    add_mult_dev ra P fv rm == ra + P@fv * rm.
- Proof.
-  induction P;simpl;intros.
-  assert (H := CRmorph.(morph_eq) c cO).
-   destruct (c ?=! cO).
-    rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl.
-    rrefl.
-  apply IHP.
-  rewrite (IHP2 (add_mult_dev ra P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm).
-  rewrite (IHP1 ra fv (pow_mult p (hd 0 fv) rm)).
-  rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl.
- Qed.
-  
- Lemma Pphi_add_dev : forall P ra fv, add_dev ra P fv == ra + P@fv.
- Proof.
-  induction P;simpl;intros.
-  assert (H := CRmorph.(morph_eq) c cO).
-   destruct (c ?=! cO).
-    rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl.
-    rrefl.
-  apply IHP.
-  rewrite (IHP2 (add_mult_dev ra P2 fv (pow_dev p (hd 0 fv))) (tl fv)).
-  rewrite (Pphi_add_mult_dev P2 ra fv (pow_dev p (hd 0 fv))).
-  rewrite  (pow_dev_pow p (hd 0 fv));rsimpl. 
- Qed.
+ Fixpoint MPcond_dev (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
+    match LM1 with 
+     cons (M1,P2) LM2 =>  (Mphi l M1 == Pphi_dev l P2) /\ (MPcond_dev LM2 l)
+    | _ => True
+    end.
 
- Lemma Pphi_mult_dev : forall P fv rm, mult_dev P fv rm == P@fv * rm.
- Proof.
-  induction P;simpl;intros.
-  assert (H := CRmorph.(morph_eq) c cI).
-   destruct (c ?=! cI).
-    rewrite (H (refl_equal true));rewrite CRmorph.(morph1);Esimpl.
-    rrefl.
-  apply IHP.
-  rewrite (Pphi_add_mult_dev P3 
-	    (mult_dev P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm).
-  rewrite (IHP1 fv  (pow_mult p (hd 0 fv) rm)).
-  rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl.
- Qed.
+ Fixpoint MPcond_map (LM1: list (Mon * PExpr)): list (Mon * Pol) :=            
+    match LM1 with 
+     cons (M1,P2) LM2 =>  cons (M1, norm P2) (MPcond_map LM2)
+    | _ => nil
+    end.
 
- Lemma Pphi_Pphi_dev : forall P fv, P@fv == Pphi_dev fv P.
+ Lemma MP_cond_dev_imp_MP_cond: forall LM1 l,
+     MPcond_dev LM1 l -> MPcond LM1 l.
  Proof.
-  induction P;simpl;intros.
-  rrefl. trivial.
-  rewrite (Pphi_add_dev P3 (mult_dev P2 fv (pow_dev p (hd 0 fv))) (tl fv)).
-  rewrite (Pphi_mult_dev P2 fv (pow_dev p (hd 0 fv))).
-  rewrite (pow_dev_pow p (hd 0 fv));rsimpl.
+ intros LM1; elim LM1; simpl; auto.
+ intros (M2,P2) LM2 Hrec l [H1 H2]; split; auto.
+ rewrite H1; rewrite Pphi_Pphi_dev; rsimpl. 
  Qed.
 
- Lemma Pphi_dev_ok :  forall l pe,  PEeval l pe == Pphi_dev l (norm pe).
- Proof.
-  intros l pe;rewrite <- (Pphi_Pphi_dev (norm pe) l);apply norm_ok.
+ Lemma PNSubstL_dev_ok: forall m n lm pe l,
+    let LM :=  MPcond_map lm in
+    MPcond_dev LM l -> PEeval l pe == Pphi_dev l (PNSubstL (norm pe) LM m n).
+ intros m n lm p3 l LM H.
+ rewrite <- Pphi_Pphi_dev; rewrite <- PNSubstL_ok; auto.
+   apply MP_cond_dev_imp_MP_cond; auto.
+ rewrite Pphi_Pphi_dev; apply Pphi_dev_ok; auto.
  Qed.
 
- Ltac Trev l :=  
-  let rec rev_append rev l :=
-   match l with
-   | (nil _) => constr:(rev)
-   | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t 
-   end in
- rev_append (nil R) l.
-
- Ltac TPphi_dev add mul :=
-  let tl l := match l with (cons ?h ?t) => constr:(t) end in
-  let rec jump j l :=
-   match j with
-   | xH => tl l
-   | (xO ?j) => let l := jump j l in jump j l
-   | (xI ?j) => let t := tl l in let l := jump j l in jump j l
-   end in
-  let rec pow_mult i x r :=
-   match i with
-   | xH => constr:(mul r x)
-   | (xO ?i) => let r := pow_mult i x r in pow_mult i x r
-   | (xI ?i) => 
-     let r := constr:(mul r x) in
-     let r := pow_mult i x r in 
-     pow_mult i x r
-   end in
-  let pow_dev i x :=
-   match i with
-   | xH => x
-   | (xO ?i) => 
-      let i := eval compute in (Pdouble_minus_one i) in pow_mult i x x
-   | (xI ?i) => pow_mult (xO i) x x
-   end in
-  let rec add_mult_dev ra P fv rm :=
-   match P with
-   | (Pc ?c) => 
-     match eval compute in (c ?=! cO) with
-     | true => constr:ra 
-     | _ => let rc := eval compute in [c] in constr:(add ra (mul rc rm))
-     end
-   | (Pinj ?j ?Q) => 
-     let fv := jump j fv in add_mult_dev ra Q fv rm
-   | (PX ?P ?i ?Q) =>
-     match fv with 
-     | (cons ?hd ?tl) =>
-       let rmP := pow_mult i hd rm in
-       let raP := add_mult_dev ra P fv rmP in
-       add_mult_dev raP Q tl rm
-     end
-   end in
-  let rec mult_dev P fv rm :=
-   match P with
-   | (Pc ?c) =>
-     match eval compute in (c ?=! cI) with
-     | true => constr:rm 
-     | false => let rc := eval compute in [c] in constr:(mul rc rm)
-     end
-   | (Pinj ?j ?Q) => let fv := jump j fv in mult_dev Q fv rm
-   | (PX ?P ?i ?Q) =>
-     match fv with
-     | (cons ?hd ?tl) =>
-       let rmP := pow_mult i hd rm in
-       let ra := mult_dev P fv rmP in
-       add_mult_dev ra Q tl rm
-     end
-   end in
-  let rec add_dev ra P fv :=
-   match P with
-   | (Pc ?c) =>
-     match eval compute in (c ?=! cO) with
-     | true => ra
-     | false => let rc := eval compute in [c] in constr:(add ra rc)
-     end
-   | (Pinj ?j ?Q) => let fv := jump j fv in add_dev ra Q fv
-   | (PX ?P ?i ?Q) =>
-     match fv with
-     | (cons ?hd ?tl) =>
-       let rmP := pow_dev i hd in
-       let ra := add_mult_dev ra P fv rmP in
-       add_dev ra Q tl
-     end
-   end in
-  let rec Pphi_dev fv P :=
-   match P with
-   | (Pc ?c) => eval compute in [c]
-   | (Pinj ?j ?Q) => let fv := jump j fv in Pphi_dev fv Q
-   | (PX ?P ?i ?Q) =>
-     match fv with
-     | (cons ?hd ?tl) =>
-       let rm := pow_dev i hd in
-       let rP := mult_dev P fv rm in
-       add_dev rP Q tl
-     end
-   end in
-  Pphi_dev.
- 
- **************************************************************)
-
 End MakeRingPol. 
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
index 6c3f87a5..95efde7f 100644
--- a/contrib/setoid_ring/Ring_tac.v
+++ b/contrib/setoid_ring/Ring_tac.v
@@ -1,76 +1,73 @@
 Set Implicit Arguments.
 Require Import Setoid.
-Require Import BinList.
 Require Import BinPos.
-Require Import Pol.
+Require Import Ring_polynom.
+Require Import BinList.
 Declare ML Module "newring".
 
-(* Some Tactics *)
-
-Ltac compute_assertion id t :=
-  let t' := eval compute in t in
-  (assert (id : t = t'); [exact_no_check (refl_equal t')|idtac]).
 
-Ltac compute_assertion' id  id' t :=
-  let t' := eval compute in t in
+(* adds a definition id' on the normal form of t and an hypothesis id
+   stating that t = id' (tries to produces a proof as small as possible) *)
+Ltac compute_assertion id  id' t :=
+  let t' := eval vm_compute in t in
   (pose (id' := t');
    assert (id : t = id');
    [exact_no_check (refl_equal id')|idtac]).
 
-Ltac compute_replace' id t :=
-  let t' := eval compute in t in
-  (replace t with t' in id; [idtac|exact_no_check (refl_equal t')]).
+(********************************************************************)
+(* Tacticals to build reflexive tactics *)
 
-Ltac bin_list_fold_right fcons fnil l :=
-  match l with
-  | (cons ?x ?tl) => fcons x ltac:(bin_list_fold_right fcons fnil tl)
-  | (nil _) => fnil
+Ltac OnEquation req :=
+  match goal with
+  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
+  | _ => fail 1 "Goal is not an equation (of expected equality)"
   end.
 
-Ltac bin_list_fold_left fcons fnil l :=
-  match l with
-  | (cons ?x ?tl) => bin_list_fold_left fcons ltac:(fcons x fnil) tl
-  | (nil _) => fnil
-  end.
 
-Ltac bin_list_iter f l :=
-  match l with
-  | (cons ?x ?tl) => f x; bin_list_iter f tl
-  | (nil _) => idtac
+Ltac OnMainSubgoal H ty :=
+  match ty with
+  | _ -> ?ty' =>
+     let subtac := OnMainSubgoal H ty' in
+     fun tac => lapply H; [clear H; intro H; subtac tac | idtac]
+  | _ => (fun tac => tac)
   end.
- 
-(** A tactic that reverses a list *)
-Ltac Trev R l :=  
-  let rec rev_append rev l :=
-   match l with
-   | (nil _) => constr:(rev)
-   | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t 
-   end in
- rev_append (nil R) l.
 
-(* to avoid conflicts with Coq booleans*)
+Ltac ApplyLemmaAndSimpl tac lemma pe:=
+  let npe := fresh "ast_nf" in
+  let H := fresh "eq_nf" in
+  let Heq := fresh "thm" in
+  let npe_spec :=
+    match type of (lemma pe) with
+      forall npe, ?npe_spec = npe -> _ => npe_spec
+    | _ => fail 1 "ApplyLemmaAndSimpl: cannot find norm expression"
+    end in
+  (compute_assertion H npe npe_spec;
+   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
+   clear H;
+   OnMainSubgoal Heq ltac:(type of Heq)
+     ltac:(tac Heq; rewrite Heq; clear Heq npe)).
+
+(* General scheme of reflexive tactics using of correctness lemma
+   that involves normalisation of one expression *)
+Ltac ReflexiveRewriteTactic FV_tac SYN_tac SIMPL_tac lemma2 req rl :=
+  let R := match type of req with ?R -> _ => R end in
+  (* build the atom list *)
+  let fv := list_fold_left FV_tac (@List.nil R) rl in
+  (* some type-checking to avoid late errors *)
+  (check_fv fv;
+   (* rewrite steps *)
+   list_iter
+     ltac:(fun r =>
+       let ast := SYN_tac r fv in
+       try ApplyLemmaAndSimpl SIMPL_tac (lemma2 fv) ast)
+     rl).
+
+(********************************************************)
+
+(* An object to return when an expression is not recognized as a constant *)
 Definition NotConstant := false.
- 		       
-Ltac IN a l :=
- match l with
- | (cons a ?l) => true
- | (cons _ ?l) => IN a l
- | (nil _) => false
- end.
-
-Ltac AddFv a l :=
- match (IN a l) with
- | true => l
- | _ => constr:(cons a l)
- end.
-
-Ltac Find_at a l :=
- match l with
- | (nil _) => fail 1 "ring anomaly"
- | (cons a _) => constr:1%positive
- | (cons _ ?l) => let p := Find_at a l in eval compute in (Psucc p)
- end.
 		      
+(* Building the atom list of a ring expression *)
 Ltac FV Cst add mul sub opp t fv :=
  let rec TFV t fv :=
   match Cst t with
@@ -80,13 +77,13 @@ Ltac FV Cst add mul sub opp t fv :=
       | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (opp ?t1) => TFV t1 fv
-      | _ => AddFv t fv
+      | _ => AddFvTail t fv
       end
   | _ => fv
-  end 
+  end
  in TFV t fv.
 
- (* syntaxification *)
+ (* syntaxification of ring expressions *)
  Ltac mkPolexpr C Cst radd rmul rsub ropp t fv := 
  let rec mkP t :=
     match Cst t with
@@ -111,644 +108,53 @@ Ltac FV Cst add mul sub opp t fv :=
  in mkP t.
 
 (* ring tactics *)
-Ltac Make_ring_rewrite_step lemma pe:=
-  let npe := fresh "npe" in
-  let H := fresh "eq_npe" in
-  let Heq := fresh "ring_thm" in
-  let npe_spec :=
-    match type of (lemma pe) with
-      forall (npe:_), ?npe_spec = npe -> _ => npe_spec
-    | _ => fail 1 "cannot find norm expression"
-    end in
-  (compute_assertion' H  npe npe_spec;
-   assert (Heq:=lemma _ _ H); clear H;
-   protect_fv in Heq;
-   (rewrite Heq; clear Heq npe) || clear npe).
-
-
-Ltac Make_ring_rw_list Cst_tac lemma req rl :=
-  match type of lemma with
-    forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C),
-    _ = npe ->
-    req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ =>
-  let mkFV := FV Cst_tac add mul sub opp in
-  let mkPol := mkPolexpr C Cst_tac add mul sub opp in
-  (* build the atom list *)
-  let rfv := bin_list_fold_left mkFV (nil R) rl in
-  let fv := Trev R rfv in
-  (* rewrite *)
-  bin_list_iter
-    ltac:(fun r =>
-      let pe := mkPol r fv in
-      Make_ring_rewrite_step (lemma fv) pe)
-    rl
-  | _ => fail 1 "bad lemma"
-  end.
-
-Ltac Make_ring_rw Cst_tac lemma req r :=
-  Make_ring_rw_list Cst_tac lemma req (cons r (nil _)).
-
- (* Building the generic tactic *)
-
- Ltac Make_ring_tac Cst_tac lemma1 lemma2 req :=
-  match type of lemma2 with
-    forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C),
-    _ = npe ->
-    req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ =>
-  match goal with
-  | |- req ?r1 ?r2 =>
-    let mkFV := FV Cst_tac add mul sub opp in
-    let mkPol := mkPolexpr C Cst_tac add mul sub opp in
-    let rfv := mkFV (add r1 r2) (nil R) in
-    let fv := Trev R rfv in
-    let pe1 := mkPol r1 fv in
-    let pe2 := mkPol r2 fv in
-    ((apply (lemma1 fv pe1 pe2);
-      vm_compute;
-      exact (refl_equal true)) ||
-     (Make_ring_rewrite_step (lemma2 fv) pe1;
-      Make_ring_rewrite_step (lemma2 fv) pe2))
-  | _ => fail 1 "goal is not an equality from a declared ring"
-  end
-  end.
-
-
-(* coefs belong to the same type as the target ring (concrete ring) *)
-Definition ring_id_correct
-  R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok :=
-  @ring_correct R rO rI radd rmul rsub ropp req rSet req_th ARth
-                R rO rI radd rmul rsub ropp reqb
-               (@IDphi R)
-               (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok).
-
-Definition ring_rw_id_correct
-  R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok :=
-  @Pphi_dev_ok  R rO rI radd rmul rsub ropp req rSet req_th ARth
-                R rO rI radd rmul rsub ropp reqb
-               (@IDphi R)
-               (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok).
-
-Definition ring_rw_id_correct'
-  R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok :=
-  @Pphi_dev_ok'  R rO rI radd rmul rsub ropp req rSet req_th ARth
-                 R rO rI radd rmul rsub ropp reqb
-                (@IDphi R)
-                (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok).
-
-Definition ring_id_eq_correct R rO rI radd rmul rsub ropp ARth reqb reqb_ok :=
- @ring_id_correct R rO rI radd rmul rsub ropp (@eq R)
-    (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok.
-
-Definition ring_rw_id_eq_correct
-   R rO rI radd rmul rsub ropp ARth reqb reqb_ok :=
- @ring_rw_id_correct R rO rI radd rmul rsub ropp (@eq R)
-    (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok.
-
-Definition ring_rw_id_eq_correct'
-   R rO rI radd rmul rsub ropp ARth reqb reqb_ok :=
- @ring_rw_id_correct' R rO rI radd rmul rsub ropp (@eq R)
-    (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok.
-
-(*
-Require Import ZArith.
-Require Import Setoid.
-Require Import Ring_tac.
-Import BinList.
-Import Ring_th.
-Open Scope Z_scope.
-
-Add New Ring Zr : (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth)
-  Computational Zeqb_ok
-  Constant Zcst.
-
-Goal forall a b, (a+b*2)*(a+b*2)=1.
-intros.
- setoid ring ((a + b * 2) * (a + b * 2)).
-
-  Make_ring_rw_list Zcst
-    (ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _)
-      (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok)
-    (eq (A:=Z))
-   (cons ((a+b)*(a+b)) (nil _)).
-
-
-Goal forall a b, (a+b)*(a+b)=1.
-intros.
-Ltac zringl :=
-  Make_ring_rw3_list ltac:(inv_gen_phiZ 0 1 Zplus Zmult Zopp)
-    (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-      (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok)
-    (eq (A:=Z))
-(BinList.cons ((a+b)*(a+b)) (BinList.nil _)).
-
-Open Scope Z_scope.
-
-let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in
-let lemma :=
-    constr:(ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _)
-             (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in
-let req := constr:(eq (A:=Z)) in
-let rl := constr:(cons ((a+b)*(a+b)) (nil _)) in
-Make_ring_rw_list Cst_tac lemma req rl.
-
-let fv := constr:(cons a (cons b (nil _))) in
-let pe :=
-  constr:(PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in
-Make_ring_rewrite_step (lemma fv) pe.
-
-
-
-
-OK
-
-Lemma L0 :
- forall (l : list Z) (pe : PExpr Z) pe',
-       pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe ->
-       PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe =
-       Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'.
-intros;  subst pe'.
-apply
- (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-    (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok).
-Qed.
-Lemma L0' :
- forall (l : list Z) (pe : PExpr Z) pe',
-       norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe = pe' ->
-       PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe =
-       Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'.
-intros;  subst pe'.
-apply
- (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-    (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok).
-Qed.
-
-pose (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))).
-compute_assertion ipattern:H (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe).
-let fv := constr:(cons a (cons b (nil _))) in
-assert (Heq := L0 fv _ (sym_equal H)); clear H.
- protect_fv' in Heq.
- rewrite Heq; clear Heq; clear pe.
-
-
-MIEUX (mais taille preuve = taille de pe + taille de nf(pe)... ):
-
-
-Lemma L :
- forall (l : list Z) (pe : PExpr Z) pe' (x y :Z),
-       pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe ->
-       x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe ->
-       y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' ->
-       x=y.
-intros;  subst x y pe'.
-apply
- (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-    (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok).
-Qed.
-Lemma L' :
- forall (l : list Z) (pe : PExpr Z) pe' (x y :Z),
-       Peq Zeq_bool pe'  (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe) = true ->
-       x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe ->
-       y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' ->
-       forall (P:Z->Type), P y -> P x.
-intros.
- rewrite L with (2:=H0) (3:=H1); trivial.
-apply (Peq_ok (Eqsth Z) (Eq_ext _ _ _)
-   (IDmorph 0 1 Zplus Zminus Zmult Zopp (Eqsth Z) Zeq_bool Zeqb_ok) ).
-
-  (IDmorph (Eqsth Z) (Eq_ext _ _ _) Zeqb_ok).
-
-
-    (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth)).
-Qed.
-
-eapply L'
- with (x:=(a+b)*(a+b))
-      (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))
-      (l:=cons a (cons b (nil Z)));[compute;reflexivity|reflexivity|idtac|idtac];norm_evars;[protect_fv';reflexivity|idtac];norm_evars.
-
-
-
-
-
-set (x:=a).
-set (x0:=b).
-set (fv:=cons x (cons x0 (nil Z))).
-let fv:=constr:(cons a (cons b (nil Z))) in
-let lemma := constr : (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-      (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in
-let pe :=
-  constr :  (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in
-assert (Heq := lemma fv pe).
-set (npe:=norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool
-             (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))).
-fold npe in Heq.
-move npe after fv.
-let fv' := eval red in fv in
-compute in npe.
-subst npe.
-let fv' := eval red in fv in
-compute_without_globals_of (fv',Zplus,0,1,Zmult,Zopp,Zminus) in Heq.
-rewrite Heq.
-clear Heq fv; subst x x0.
-
-
-simpl in Heq.
-unfold Pphi_dev in Heq.
-unfold mult_dev in Heq.
-unfold P0, Peq in *.
-unfold Zeq_bool at 3, Zcompare, Pcompare in Heq.
-unfold fv, hd, tl in Heq.
-unfold powl, rev, rev_append in Heq.
-unfold mkmult1 in Heq.
-unfold mkmult in Heq.
-unfold add_mult_dev in |- *.
-unfold add_mult_dev at 2 in Heq.
-unfold P0, Peq at 1 in Heq.
-unfold Zeq_bool at 2 3 4 5 6, Zcompare, Pcompare in Heq.
-unfold hd, powl, rev, rev_append in Heq.
-unfold mkadd_mult in Heq.
-unfold mkmult in Heq.
-unfold add_mult_dev in Heq.
-unfold P0, Peq in Heq.
-unfold Zeq_bool, Zcompare, Pcompare in Heq.
-unfold hd,powl, rev,rev_append in Heq.
-unfold mkadd_mult in Heq.
-unfold mkmult in Heq.
-unfold IDphi in Heq.
-
- fv := cons x (cons x0 (nil Z))
- PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))
- Heq : PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) fv
-          (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) =
-        Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) fv
-          (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool
-             (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))))
-
-
 
-let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in
-let lemma :=
-    constr:(ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _)
-             (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in
-let req := constr:(eq (A:=Z)) in
-let rl := constr:(BinList.cons ((a+b)*(a+b)) (BinList.nil _)) in
-  match type of lemma with
-    forall (l:list ?R) (pe:PExpr ?C),
-    req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ =>
-  Constant natcst.
-
-
-Require Import Setoid.
-Open Scope nat_scope.
-
-Require Import Ring_th.
-Require Import Arith.
-
-Add New Ring natr : (SRth_ARth (Eqsth nat) natSRth)
-  Computational nateq_ok
-  Constant natcst.
-
-
-Require Import Rbase.
-Open Scope R_scope.	      
-
- Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R).
- Proof.
-  constructor. exact Rplus_0_l. exact Rplus_comm. 
-  intros;symmetry;apply Rplus_assoc.
-  exact Rmult_1_l. exact Rmult_comm. 
-  intros;symmetry;apply Rmult_assoc.
-  exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r.
- Qed.
-
-Add New Ring Rr : Rth Abstract.
-
-Goal forall a b, (a+b*10)*(a+b*10)=1.
-intros.
-
-Module Zring.
-  Import Zpol.
-  Import BinPos.
-  Import BinInt.
-
-Ltac is_PCst p :=
- match p with
- | xH => true
- | (xO ?p') => is_PCst p'
- | (xI ?p') => is_PCst p'
- | _ => false
- end.
-
-Ltac ZCst t :=
- match t with
- | Z0 => constr:t 
- | (Zpos ?p) =>
-    match (is_PCst p) with
-    | false => NotConstant
-    | _ => constr:t
-    end
- | (Zneg ?p) =>
-    match (is_PCst p) with
-    | false => NotConstant
-    | _ => constr:t
-    end
- | _ => NotConstant
- end.
-		  
-Ltac zring := 
-  Make_ring_tac ZCst
-    (Zpol.ring_gen_eq_correct Zth) (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z).
-
-Ltac zrewrite :=
-  Make_ring_rw3 ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z).
-
-Ltac zrewrite_list :=
-  Make_ring_rw3_list ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z).
-
-End Zring.
-*)
-
-
-
-(*
-(*** Intanciation for Z*)
-Require Import ZArith.
-Open Scope Z_scope.
-
-Module Zring.
-  Let R := Z.
-  Let rO := 0.
-  Let rI := 1.
-  Let radd := Zplus.
-  Let rmul := Zmult.
-  Let rsub := Zminus.
-  Let ropp := Zopp.
-  Let Rth := Zth.
-  Let reqb := Zeq_bool.
-  Let req_morph := Zeqb_ok.
-
-  (* CE_Entries *)
-  Let C := R.
-  Let cO := rO.
-  Let cI := rI.
-  Let cadd := radd.
-  Let cmul := rmul.
-  Let csub := rsub.
-  Let copp := ropp.
-  Let req := (@eq R). 
-  Let ceqb := reqb.
-  Let phi := @IDphi R.
-  Let Rsth : Setoid_Theory R req := Eqsth R.
-  Let Reqe : ring_eq_ext radd rmul ropp req :=
-   (@Eq_ext R radd rmul ropp).
-  Let ARth : almost_ring_theory rO rI radd rmul rsub ropp req :=
-   (@Rth_ARth R rO rI radd rmul rsub ropp req Rsth Reqe Rth).
-  Let CRmorph : ring_morph rO rI radd rmul rsub ropp req
-                           cO cI cadd cmul csub copp ceqb phi :=
-   (@IDmorph R rO rI radd rmul rsub ropp req Rsth reqb req_morph).
-
-  Definition Peq := Eval red in (Pol.Peq ceqb).
-  Definition mkPinj := Eval red in (@Pol.mkPinj C). 
-  Definition mkPX :=
-   Eval red;
-        change (Pol.Peq ceqb) with Peq;
-        change (@Pol.mkPinj Z) with mkPinj in
-   (Pol.mkPX cO ceqb). 
-
-  Definition P0 := Eval red in (Pol.P0 cO).
-  Definition P1 := Eval red in (Pol.P1 cI).
-
-  Definition X :=
-   Eval red; change (Pol.P0 cO) with P0; change (Pol.P1 cI) with P1 in
-   (Pol.X cO cI).
-
-  Definition mkX :=
-   Eval red; change (Pol.X cO cI) with X in
-   (mkX cO cI).
-
-  Definition PaddC
-  Definition PaddI
-  Definition PaddX
-
-  Definition Padd :=
-   Eval red in
-        
-   (Pol.Padd cO cadd ceqb)
-
-  Definition PmulC
-  Definition PmulI
-  Definition Pmul_aux
-  Definition Pmul
-
-  Definition PsubC
-  Definition PsubI
-  Definition PsubX
-  Definition Psub
-
-
-
-  Definition norm :=
-   Eval red;
-        change (Pol.Padd cO cadd ceqb) with Padd;
-        change (Pol.Pmul cO cI cadd cmul ceqb) with Pmul;
-        change (Pol.Psub cO cadd csub copp ceqb) with Psub;
-        change (Pol.Popp copp) with Psub;
-  
- in
-   (Pol.norm cO cI cadd cmul csub copp ceqb).
-
-
-
-End Zring.
-		  
-Ltac is_PCst p :=
- match p with
- | xH => true
- | (xO ?p') => is_PCst p'
- | (xI ?p') => is_PCst p'
- | _ => false
- end.
-
-Ltac ZCst t :=
- match t with
- | Z0 => constr:t 
- | (Zpos ?p) =>
-    match (is_PCst p) with
-    | false => NotConstant
-    | _ => t
-    end
- | (Zneg ?p) =>
-    match (is_PCst p) with
-    | false => NotConstant
-    | _ => t
-    end
- | _ => NotConstant
- end.
-		  
-Ltac zring := 
-  Zring.Make_ring_tac Zplus Zmult Zminus Zopp (@eq Z) ZCst.
-
-Ltac zrewrite :=
-  Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst.
-*)
-
-(*	      
-(* Instanciation for Bool *)	      
-Require Import Bool.
-	      
-Module BCE.
- Definition R := bool.
- Definition rO := false.
- Definition rI := true.
- Definition radd := xorb.
- Definition rmul := andb.
- Definition rsub := xorb.
- Definition ropp b:bool := b.
- Lemma Rth : ring_theory rO rI radd rmul rsub ropp (@eq bool).
- Proof.
-  constructor.
-   exact false_xorb.
-   exact xorb_comm.
-   intros; symmetry  in |- *; apply xorb_assoc.
-   exact andb_true_b.
-   exact andb_comm.
-   exact andb_assoc.
-   destruct x; destruct y; destruct z; reflexivity.
-   intros; reflexivity.
-   exact xorb_nilpotent.
- Qed.
-
- Definition reqb := eqb.
- Definition req_morph := eqb_prop.
-End BCE.
-
-Module BEntries := CE_Entries BCE.
-
-Module Bring := MakeRingPol BEntries.
-
-Ltac BCst t :=
-  match t with
-   | true => true
-   | false => false
-   | _ => NotConstant
-   end.
-
-Ltac bring := 
-  Bring.Make_ring_tac xorb andb xorb (fun b:bool => b) (@eq bool) BCst.
-
-Ltac brewrite :=
-  Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst.
-*)
-
-(*Module Rring.
-
-(* Instanciation for R *)	      
-Require Import Rbase.
-Open Scope R_scope.	      
-
- Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R).
- Proof.
-  constructor. exact Rplus_0_l. exact Rplus_comm. 
-  intros;symmetry;apply Rplus_assoc.
-  exact Rmult_1_l. exact Rmult_comm. 
-  intros;symmetry;apply Rmult_assoc.
-  exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r.
- Qed.
-
-Ltac RCst := inv_gen_phiZ 0 1 Rplus Rmul Ropp.
-
-Ltac rring :=
-  Make_ring_tac RCst
-    (Zpol.ring_gen_eq_correct Rth) (Zpol.ring_rw_gen_eq_correct Rth) (@eq R).
-
-Ltac rrewrite :=
-  Make_ring_rw3 RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R).
-
-Ltac rrewrite_list :=
-  Make_ring_rw3_list RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R).
-
-End Rring.
-*)
-(************************)
-(*
-(* Instanciation for N *)	     
-Require Import NArith.
-Open Scope N_scope.
-		
-Module NCSE.
- Definition R := N.
- Definition rO := 0.
- Definition rI := 1.
- Definition radd := Nplus.
- Definition rmul := Nmult.
- Definition SRth := Nth.
- Definition reqb := Neq_bool.
- Definition req_morph := Neq_bool_ok.
-End NCSE.
-
-Module NEntries := CSE_Entries NCSE.
-
-Module Nring := MakeRingPol NEntries.
-
-Ltac NCst := inv_gen_phiN 0 1 Nplus Nmult.
-
-Ltac nring :=  
-  Nring.Make_ring_tac Nplus Nmult (@SRsub N Nplus) (@SRopp N) (@eq N) NCst.
-
-Ltac nrewrite :=
-  Nring.Make_ring_rw3 Nplus Nmult  (@SRsub N Nplus) (@SRopp N) NCst.
-	       
-(* Instanciation for nat *)	       
-Open Scope nat_scope.
-
-Module NatASE.
- Definition R := nat.
- Definition rO := 0.
- Definition rI := 1.
- Definition radd := plus.
- Definition rmul := mult.
- Lemma SRth : semi_ring_theory O (S O) plus mult (@eq nat).
- Proof.
-  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
-  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
-  exact mult_plus_distr_r. 
- Qed.
-End NatASE.
-
-Module NatEntries := ASE_Entries NatASE.
+ Ltac Ring Cst_tac lemma1 req :=
+  let Make_tac :=
+    match type of lemma1 with
+    | forall (l:list ?R) (pe1 pe2:PExpr ?C),
+      _ = true ->
+      req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe1) _ =>
+        let mkFV := FV Cst_tac add mul sub opp in
+        let mkPol := mkPolexpr C Cst_tac add mul sub opp in
+        fun f => f R mkFV mkPol
+    | _ => fail 1 "ring anomaly: bad correctness lemma"
+    end in
+  let Main r1 r2 R mkFV mkPol :=
+    let fv := mkFV r1 (@List.nil R) in
+    let fv := mkFV r2 fv in
+    check_fv fv;
+    (let pe1 := mkPol r1 fv in
+     let pe2 := mkPol r2 fv in
+     apply (lemma1 fv pe1 pe2) || fail "typing error while applying ring";
+     vm_compute;
+     exact (refl_equal true) || fail "not a valid ring equation") in
+  Make_tac ltac:(OnEquation req Main).
+
+Ltac Ring_simplify Cst_tac lemma2 req rl :=
+  let Make_tac :=
+    match type of lemma2 with 
+      forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C),
+      _ = npe ->
+      req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ =>
+      let mkFV := FV Cst_tac add mul sub opp in
+      let mkPol := mkPolexpr C Cst_tac add mul sub opp in
+      let simpl_ring H := protect_fv "ring" in H in
+      (fun tac => tac mkFV mkPol simpl_ring lemma2 req rl)
+    | _ => fail 1 "ring anomaly: bad correctness lemma"
+    end in
+  Make_tac ReflexiveRewriteTactic.
 
-Module Natring := MakeRingPol NatEntries.
 
-Ltac natCst t := 
- match t with
- | O => N0
- | (S ?n) =>
-    match (natCst n) with
-    | NotConstant => NotConstant
-    | ?p => constr:(Nsucc p)
-    end
- | _ => NotConstant
- end.
-		  
-Ltac natring :=
- Natring.Make_ring_tac plus mult (@SRsub nat plus) (@SRopp nat) (@eq nat) natCst.
+Tactic Notation (at level 0) "ring" :=
+  ring_lookup
+    (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl =>
+       pre(); Ring cst_tac lemma1 req).
 
-Ltac natrewrite :=
-  Natring.Make_ring_rw3 plus mult (@SRsub nat plus) (@SRopp nat) natCst.
-	  
-(* Generic tactic, checks the type of the terms and applies the
-suitable instanciation*)
-		  
-Ltac newring :=  
- match goal with
- | |- (?r1 = ?r2) =>
-   match (type of r1) with
-   | Z => zring
-   | R => rring
-   | bool => bring
-   | N => nring
-   | nat => natring
-   end
- end.
+Tactic Notation (at level 0) "ring_simplify" constr_list(rl) :=
+  ring_lookup
+    (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl =>
+       pre(); Ring_simplify cst_tac lemma2 req rl; post()) rl.
 
-*)
+(* A simple macro tactic to be prefered to ring_simplify *)
+Ltac ring_replace t1 t2 := replace t1 with t2 by ring.
diff --git a/contrib/setoid_ring/Ring_th.v b/contrib/setoid_ring/Ring_theory.v
index 9583dd2d..2f7378eb 100644
--- a/contrib/setoid_ring/Ring_th.v
+++ b/contrib/setoid_ring/Ring_theory.v
@@ -1,7 +1,15 @@
-Require Import Setoid.
- Set Implicit Arguments.
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
 
+Require Import Setoid.
+Set Implicit Arguments.
 
+Module RingSyntax.
 Reserved Notation "x ?=! y" (at level 70, no associativity).
 Reserved Notation "x +! y " (at level 50, left associativity).
 Reserved Notation "x -! y" (at level 50, left associativity).
@@ -11,14 +19,13 @@ Reserved Notation "-! x" (at level 35, right associativity).
 Reserved Notation "[ x ]" (at level 1, no associativity).
 
 Reserved Notation "x ?== y" (at level 70, no associativity).
-Reserved Notation "x ++ y " (at level 50, left associativity).
 Reserved Notation "x -- y" (at level 50, left associativity).
 Reserved Notation "x ** y" (at level 40, left associativity).
 Reserved Notation "-- x" (at level 35, right associativity).
 
 Reserved Notation "x == y" (at level 70, no associativity).
-
-
+End RingSyntax.
+Import RingSyntax.
 
 Section DEFINITIONS.
  Variable R : Type.
@@ -32,24 +39,24 @@ Section DEFINITIONS.
  (** Semi Ring *)
  Record semi_ring_theory : Prop := mk_srt {
     SRadd_0_l   : forall n, 0 + n == n;
-    SRadd_sym   : forall n m, n + m == m + n ;
+    SRadd_comm   : forall n m, n + m == m + n ;
     SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
     SRmul_1_l   : forall n, 1*n == n;
     SRmul_0_l   : forall n, 0*n == 0; 
-    SRmul_sym   : forall n m, n*m == m*n;
+    SRmul_comm   : forall n m, n*m == m*n;
     SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
     SRdistr_l   : forall n m p, (n + m)*p == n*p + m*p
   }.
   
  (** Almost Ring *)
-(*Almost ring are no ring : Ropp_def is missi**)
+(*Almost ring are no ring : Ropp_def is missing **)
  Record almost_ring_theory : Prop := mk_art {
     ARadd_0_l   : forall x, 0 + x == x;
-    ARadd_sym   : forall x y, x + y == y + x;
+    ARadd_comm   : forall x y, x + y == y + x;
     ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z;
     ARmul_1_l   : forall x, 1 * x == x;
     ARmul_0_l   : forall x, 0 * x == 0;
-    ARmul_sym   : forall x y, x * y == y * x;
+    ARmul_comm   : forall x y, x * y == y * x;
     ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
     ARdistr_l   : forall x y z, (x + y) * z == (x * z) + (y * z);
     ARopp_mul_l : forall x y, -(x * y) == -x * y;
@@ -60,10 +67,10 @@ Section DEFINITIONS.
  (** Ring *)
  Record ring_theory : Prop := mk_rt {
     Radd_0_l    : forall x, 0 + x == x;
-    Radd_sym    : forall x y, x + y == y + x;
+    Radd_comm    : forall x y, x + y == y + x;
     Radd_assoc  : forall x y z, x + (y + z) == (x + y) + z;
     Rmul_1_l    : forall x, 1 * x == x;
-    Rmul_sym    : forall x y, x * y == y * x;
+    Rmul_comm    : forall x y, x * y == y * x;
     Rmul_assoc  : forall x y z, x * (y * z) == (x * y) * z;
     Rdistr_l    : forall x y z, (x + y) * z == (x * z) + (y * z);
     Rsub_def    : forall x y, x - y == x + -y;
@@ -193,9 +200,9 @@ Section ALMOST_RING.
 
  Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req.
  Proof (mk_art 0 1 radd rmul SRsub SRopp req
-    (SRadd_0_l SRth) (SRadd_sym SRth) (SRadd_assoc SRth)
+    (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth)
     (SRmul_1_l SRth) (SRmul_0_l SRth)
-    (SRmul_sym SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
+    (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
     SRopp_mul_l SRopp_add SRsub_def).
  
  (** Identity morphism for semi-ring equipped with their almost-ring structure*)
@@ -246,17 +253,17 @@ Section ALMOST_RING.
 
   rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth).
   rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite (Radd_sym Rth); rewrite (Radd_0_l Rth);sreflexivity.
+  rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity.
  Qed.
 
  Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y.
  Proof.
   intros x y;rewrite <-(Radd_0_l Rth (- x * y)).
-  rewrite (Radd_sym Rth).
+  rewrite (Radd_comm Rth).
   rewrite <-(Ropp_def Rth (x*y)).
   rewrite (Radd_assoc Rth).
   rewrite <- (Rdistr_l Rth).
-  rewrite (Rth.(Radd_sym) (-x));rewrite (Ropp_def Rth).
+  rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
   rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
  Qed.
  
@@ -266,17 +273,17 @@ Section ALMOST_RING.
   rewrite <- ((Ropp_def Rth) x).
   rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))).
   rewrite <- ((Ropp_def Rth) y).
-  rewrite ((Radd_sym Rth) x).
-  rewrite ((Radd_sym Rth) y).
+  rewrite ((Radd_comm Rth) x).
+  rewrite ((Radd_comm Rth) y).
   rewrite <- ((Radd_assoc Rth) (-y)).
   rewrite <- ((Radd_assoc Rth) (- x)).
   rewrite ((Radd_assoc Rth)  y).
-  rewrite ((Radd_sym Rth) y).
+  rewrite ((Radd_comm Rth) y).
   rewrite <- ((Radd_assoc Rth)  (- x)).
   rewrite ((Radd_assoc Rth) y).
-  rewrite ((Radd_sym Rth) y);rewrite (Ropp_def Rth).
-  rewrite ((Radd_sym Rth) (-x) 0);rewrite (Radd_0_l Rth).
-  apply (Radd_sym Rth).
+  rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth).
+  rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
+  apply (Radd_comm Rth).
  Qed.
  
  Lemma Ropp_opp : forall x, - -x == x.
@@ -284,13 +291,13 @@ Section ALMOST_RING.
   intros x; rewrite <- (Radd_0_l Rth (- -x)).
   rewrite <- (Ropp_def Rth x).
   rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite ((Radd_sym Rth) x);apply (Radd_0_l Rth).
+  rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth).
  Qed.
 
  Lemma  Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
  Proof
-  (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_sym Rth) (Radd_assoc Rth)
-    (Rmul_1_l Rth) Rmul_0_l (Rmul_sym Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
+  (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth)
+    (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
     Ropp_mul_l Ropp_add (Rsub_def Rth)).
 
  (** Every semi morphism between two rings is a morphism*) 
@@ -315,12 +322,12 @@ Section ALMOST_RING.
  Proof.
   intros x;rewrite <-  (Rth.(Radd_0_l) [-!x]).
   rewrite <- ((Ropp_def Rth) [x]).
-  rewrite ((Radd_sym Rth) [x]).
+  rewrite ((Radd_comm Rth) [x]).
   rewrite <- (Radd_assoc Rth).
   rewrite <- (Smorph_add Smorph).
   rewrite (Ropp_def Cth).
   rewrite (Smorph0 Smorph).
-  rewrite (Radd_sym Rth (-[x])).
+  rewrite (Radd_comm Rth (-[x])).
   apply (Radd_0_l Rth);sreflexivity.
  Qed. 
 
@@ -343,6 +350,12 @@ Section ALMOST_RING.
  (** Usefull lemmas on almost ring *)
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
 
+ Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req.
+Proof.
+elim ARth; intros.
+constructor; trivial.
+Qed.
+
  Lemma ARsub_ext :
       forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
  Proof.
@@ -358,15 +371,15 @@ Section ALMOST_RING.
  Ltac mrewrite :=
    repeat first
      [ rewrite (ARadd_0_l ARth)
-     | rewrite <- ((ARadd_sym ARth) 0)
+     | rewrite <- ((ARadd_comm ARth) 0)
      | rewrite (ARmul_1_l ARth)
-     | rewrite <- ((ARmul_sym ARth) 1)
+     | rewrite <- ((ARmul_comm ARth) 1)
      | rewrite (ARmul_0_l ARth)
-     | rewrite <- ((ARmul_sym ARth) 0)
+     | rewrite <- ((ARmul_comm ARth) 0)
      | rewrite (ARdistr_l ARth)
      | sreflexivity
      | match goal with
-       | |- context [?z * (?x + ?y)] => rewrite ((ARmul_sym ARth) z (x+y))
+       | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
        end].
  
  Lemma ARadd_0_r : forall x, (x + 0) == x.
@@ -381,37 +394,37 @@ Section ALMOST_RING.
  Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
  Proof. 
   intros;mrewrite. 
-  repeat rewrite (ARth.(ARmul_sym) z);sreflexivity.
+  repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
  Qed.
 
  Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
  Proof.
   intros;rewrite <-(ARth.(ARadd_assoc) x).
-  rewrite (ARth.(ARadd_sym) x);sreflexivity.
+  rewrite (ARth.(ARadd_comm) x);sreflexivity.
  Qed.
 
  Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
  Proof.
   intros; repeat rewrite <- (ARadd_assoc ARth);
-   rewrite ((ARadd_sym ARth) x); sreflexivity.
+   rewrite ((ARadd_comm ARth) x); sreflexivity.
  Qed.
 
  Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x.
  Proof.
   intros;rewrite <-((ARmul_assoc ARth) x).
-  rewrite ((ARmul_sym ARth) x);sreflexivity.
+  rewrite ((ARmul_comm ARth) x);sreflexivity.
  Qed.
  
  Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
  Proof.
   intros; repeat rewrite <- (ARmul_assoc ARth);
-   rewrite ((ARmul_sym ARth) x); sreflexivity.
+   rewrite ((ARmul_comm ARth) x); sreflexivity.
  Qed.
 
  Lemma ARopp_mul_r : forall x y,  - (x * y) == x * -y.
  Proof.
-  intros;rewrite ((ARmul_sym ARth) x y);
-   rewrite (ARopp_mul_l ARth); apply (ARmul_sym ARth).
+  intros;rewrite ((ARmul_comm ARth) x y);
+   rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth).
  Qed.
 
  Lemma ARopp_zero : -0 == 0.
@@ -420,8 +433,37 @@ Section ALMOST_RING.
   repeat rewrite ARmul_0_r; sreflexivity.
  Qed.
 
+
+
 End ALMOST_RING.
 
+Section AddRing.
+
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+
+Inductive ring_kind : Type :=
+| Abstract
+| Computational
+    (R:Type)
+    (req : R -> R -> Prop)
+    (reqb : R -> R -> bool)
+    (_ : forall x y, (reqb x y) = true -> req x y)
+| Morphism
+    (R : Type)
+    (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R)
+    (req : R -> R -> Prop)
+    (C : Type)
+    (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C)
+    (ceqb : C->C->bool)
+    phi
+    (_ : ring_morph rO rI radd rmul rsub ropp req
+                    cO cI cadd cmul csub copp ceqb phi).
+
+End AddRing.
+
+
 (** Some simplification tactics*)
 Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
 
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
new file mode 100644
index 00000000..4f47fff0
--- /dev/null
+++ b/contrib/setoid_ring/ZArithRing.v
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Export Ring.
+Require Import ZArith_base.
+Import InitialRing.
+
+Set Implicit Arguments.
+
+Ltac isZcst t :=
+  let t := eval hnf in t in
+  match t with
+    Z0 => constr:true
+  | Zpos ?p => isZcst p
+  | Zneg ?p => isZcst p
+  | xI ?p => isZcst p
+  | xO ?p => isZcst p
+  | xH => constr:true
+  | _ => constr:false
+  end.
+Ltac Zcst t :=
+  match isZcst t with
+    true => t
+  | _ => NotConstant
+  end.
+
+Add Ring Zr : Zth
+  (decidable Zeqb_ok, constants [Zcst], preprocess [unfold Zsucc]).
diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4
index bc2bcb0c..daa2fedb 100644
--- a/contrib/setoid_ring/newring.ml4
+++ b/contrib/setoid_ring/newring.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: newring.ml4 8878 2006-05-30 16:44:25Z herbelin $ i*)
+(*i $Id: newring.ml4 9302 2006-10-27 21:21:17Z barras $ i*)
 
 open Pp
 open Util
@@ -16,6 +16,7 @@ open Names
 open Term
 open Closure
 open Environ
+open Libnames
 open Tactics
 open Rawterm
 open Tacticals
@@ -27,139 +28,53 @@ open Setoid_replace
 open Proof_type
 open Coqlib
 open Tacmach
-open Ppconstr
 open Mod_subst
 open Tacinterp
 open Libobject
 open Printer
-
-(****************************************************************************)
-(* Library linking *)
-
-let contrib_name = "setoid_ring"
-
-
-let ring_dir = ["Coq";contrib_name]
-let setoids_dir = ["Coq";"Setoids"]
-let ring_modules = 
-  [ring_dir@["BinList"];ring_dir@["Ring_th"];ring_dir@["Pol"];
-   ring_dir@["Ring_tac"];ring_dir@["ZRing_th"]]
-let stdlib_modules = [setoids_dir@["Setoid"]]
-
-let coq_constant c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
-let ring_constant c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" ring_modules c)
-let ringtac_constant m c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" [ring_dir@["ZRing_th";m]] c)
-
-let new_ring_path =
-  make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"])
-let ltac s =
-  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
-let znew_ring_path =
-  make_dirpath (List.map id_of_string ["ZRing_th";contrib_name;"Coq"])
-let zltac s =
-  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
-let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
-
-let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
-let pol_cst s = mk_cst [contrib_name;"Pol"] s ;;
-
-let ic c =
-  let env = Global.env() and sigma = Evd.empty in
-  Constrintern.interp_constr sigma env c
-
-
-(* Ring theory *)
-
-(* almost_ring defs *)
-let coq_almost_ring_theory = ring_constant "almost_ring_theory"
-let coq_ring_lemma1 = ring_constant "ring_correct"
-let coq_ring_lemma2 = ring_constant "Pphi_dev_ok'"
-let ring_comp1 = ring_constant "ring_id_correct"
-let ring_comp2 = ring_constant "ring_rw_id_correct'"
-let ring_abs1 = ringtac_constant "Zpol" "ring_gen_correct"
-let ring_abs2 = ringtac_constant "Zpol" "ring_rw_gen_correct'"
-let sring_abs1 = ringtac_constant "Npol" "ring_gen_correct"
-let sring_abs2 = ringtac_constant "Npol" "ring_rw_gen_correct'"
-
-(* setoid and morphism utilities *)
-let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
-let coq_eq_setoid = ring_constant "Eqsth"
-let coq_eq_morph = ring_constant "Eq_ext"
-
-(* ring -> almost_ring utilities *)
-let coq_ring_theory = ring_constant "ring_theory"
-let coq_ring_morph = ring_constant "ring_morph"
-let coq_Rth_ARth = ring_constant "Rth_ARth"
-let coq_mk_reqe = ring_constant "mk_reqe"
-
-(* semi_ring -> almost_ring utilities *)
-let coq_semi_ring_theory = ring_constant "semi_ring_theory"
-let coq_SRth_ARth = ring_constant "SRth_ARth"
-let coq_sring_morph = ring_constant "semi_morph"
-let coq_SRmorph_Rmorph = ring_constant "SRmorph_Rmorph"
-let coq_mk_seqe = ring_constant "mk_seqe"
-let coq_SRsub = ring_constant "SRsub"
-let coq_SRopp = ring_constant "SRopp"
-let coq_SReqe_Reqe = ring_constant "SReqe_Reqe"
-
-let ltac_setoid_ring = ltac"Make_ring_tac"
-let ltac_setoid_ring_rewrite = ltac"Make_ring_rw_list"
-let ltac_inv_morphZ = zltac"inv_gen_phiZ"
-let ltac_inv_morphN = zltac"inv_gen_phiN"
-
-let coq_cons = ring_constant "cons"
-let coq_nil = ring_constant "nil"
-
-let lapp f args = mkApp(Lazy.force f,args)
-
-let dest_rel t =
-  match kind_of_term t with
-      App(f,args) when Array.length args >= 2 ->
-        mkApp(f,Array.sub args 0 (Array.length args - 2))
-    | _ -> failwith "cannot find relation"
+open Declare
+open Decl_kinds
+open Entries
 
 (****************************************************************************)
 (* controlled reduction *)
 
-let mark_arg i c = mkEvar(i,[|c|]);;
+let mark_arg i c = mkEvar(i,[|c|])
 let unmark_arg f c =
   match destEvar c with
     | (i,[|c|]) -> f i c
-    | _ -> assert false;;
+    | _ -> assert false
 
-type protect_flag = Eval|Prot|Rec ;;
+type protect_flag = Eval|Prot|Rec
 
-let tag_arg tag_rec map i c =
+let tag_arg tag_rec map subs i c =
   match map i with
-      Eval -> inject c
+      Eval -> mk_clos subs c
     | Prot -> mk_atom c
-    | Rec -> if i = -1 then inject c else tag_rec c
+    | Rec -> if i = -1 then mk_clos subs c else tag_rec c
 
-let rec mk_clos_but f_map t =
+let rec mk_clos_but f_map subs t =
   match f_map t with
-    | Some map -> tag_arg (mk_clos_but f_map) map (-1) t
+    | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
     | None ->
         (match kind_of_term t with
-            App(f,args) -> mk_clos_app_but f_map f args 0
-          (* unspecified constants are evaluated *)
-          | _ -> inject t)
+            App(f,args) -> mk_clos_app_but f_map subs f args 0
+          | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
+          | _ -> mk_atom t)
 
-and mk_clos_app_but f_map f args n =
-  if n >= Array.length args then inject(mkApp(f, args))
+and mk_clos_app_but f_map subs f args n =
+  if n >= Array.length args then mk_atom(mkApp(f, args))
   else
     let fargs, args' = array_chop n args in
     let f' = mkApp(f,fargs) in
     match f_map f' with
         Some map ->
           mk_clos_deep
-            (fun _ -> unmark_arg (tag_arg (mk_clos_but f_map) map))
-            (Esubst.ESID 0)
+            (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
+            subs
             (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
-      | None -> mk_clos_app_but f_map f args (n+1)
-;;
+      | None -> mk_clos_app_but f_map subs f args (n+1)
+
 
 let interp_map l c =
   try
@@ -174,98 +89,320 @@ let interp_map l c =
 let interp_map l t =
   try Some(List.assoc t l) with Not_found -> None
 
-let arg_map =
-  [mk_cst [contrib_name;"BinList"] "cons",(function -1->Eval|2->Rec|_->Prot);
-   mk_cst [contrib_name;"BinList"] "nil", (function -1->Eval|_ -> Prot);
-   (* Pphi_dev: evaluate polynomial and coef operations, protect
-       ring operations and make recursive call on morphism and var map *)
-   pol_cst "Pphi_dev", (function -1|6|7|8|11->Eval|9|10->Rec|_->Prot);
-   (* PEeval: evaluate polynomial, protect ring operations
-      and make recursive call on morphism and var map *)
-   pol_cst "PEeval", (function -1|9->Eval|7|8->Rec|_->Prot);
-   (* Do not evaluate ring operations... *)
-   ring_constant "gen_phiZ", (function -1|6->Eval|_->Prot);
-   ring_constant "gen_phiN", (function -1|5->Eval|_->Prot);
-];;
+let protect_maps = ref ([]:(string*(constr->'a)) list)
+let add_map s m = protect_maps := (s,m) :: !protect_maps
+let lookup_map map =
+  try List.assoc map !protect_maps
+  with Not_found ->
+    errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
 
-(* Equality: do not evaluate but make recursive call on both sides *)
-let is_ring_thm req =
-  interp_map
-    ((req,(function -1->Prot|_->Rec))::
-    List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
-;;
-
-let protect_red env sigma c =
-  let req = dest_rel c in
+let protect_red map env sigma c =
   kl (create_clos_infos betadeltaiota env)
-    (mk_clos_but (is_ring_thm req) c);;
+    (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);;
 
-let protect_tac =
-  Tactics.reduct_option (protect_red,DEFAULTcast) None ;;
+let protect_tac map =
+  Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
-let protect_tac_in id =
-  Tactics.reduct_option (protect_red,DEFAULTcast) (Some(([],id),InHyp));;
+let protect_tac_in map id =
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));;
 
 
 TACTIC EXTEND protect_fv
-  [ "protect_fv" "in" ident(id) ] -> 
-    [ protect_tac_in id ]
-| [ "protect_fv" ] -> 
-    [ protect_tac ]
+  [ "protect_fv" string(map) "in" ident(id) ] -> 
+    [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] -> 
+    [ protect_tac map ]
 END;;
 
 (****************************************************************************)
-(* Ring database *)
+
+let closed_term t l =
+  let l = List.map constr_of_global l in
+  let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
+  if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
+;;
+
+TACTIC EXTEND closed_term
+  [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+    [ closed_term t l ]
+END
+;;
+(*
+let closed_term_ast l =
+  TacFun([Some(id_of_string"t")],
+  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+  [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
+   Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
+*)
+let closed_term_ast l =
+  let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
+  TacFun([Some(id_of_string"t")],
+  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+  [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
+   Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
+(*
+let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
+*)
+
+(****************************************************************************)
+
+let ic c =
+  let env = Global.env() and sigma = Evd.empty in
+  Constrintern.interp_constr sigma env c
 
 let ty c = Typing.type_of (Global.env()) Evd.empty c
 
+let decl_constant na c =
+  mkConst(declare_constant (id_of_string na) (DefinitionEntry 
+    { const_entry_body = c;
+      const_entry_type = None;
+      const_entry_opaque = true;
+      const_entry_boxed = true}, 
+    IsProof Lemma))
+
+let ltac_call tac args =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+
+let ltac_lcall tac args =
+  TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+
+let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
+
+let dummy_goal env =
+  {Evd.it=
+    {Evd.evar_concl=mkProp;
+     Evd.evar_hyps=named_context_val env;
+     Evd.evar_body=Evd.Evar_empty;
+     Evd.evar_extra=None};
+   Evd.sigma=Evd.empty}
+
+let exec_tactic env n f args =
+  let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
+  let res = ref [||] in
+  let get_res ist =
+    let l = List.map (fun id ->  List.assoc id ist.lfun) lid in
+    res := Array.of_list l;
+    TacId[] in
+  let getter =
+    Tacexp(TacFun(List.map(fun id -> Some id) lid,
+                  glob_tactic(tacticIn get_res))) in
+  let _ =
+    Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
+  !res
+
+let constr_of = function
+  | VConstr c -> c
+  | _ -> failwith "Ring.exec_tactic: anomaly"
+
+let stdlib_modules =
+  [["Coq";"Setoids";"Setoid"];
+   ["Coq";"Lists";"List"]
+  ]
+
+let coq_constant c =
+  lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+
+let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
+let coq_cons = coq_constant "cons"
+let coq_nil = coq_constant "nil"
+
+let lapp f args = mkApp(Lazy.force f,args)
+
+let rec dest_rel t =
+  match kind_of_term t with
+      App(f,args) when Array.length args >= 2 ->
+        let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
+        if closed0 rel then
+          (rel,args.(Array.length args - 2),args.(Array.length args - 1))
+        else error "ring: cannot find relation (not closed)"
+    | Prod(_,_,c) -> dest_rel c
+    | _ -> error "ring: cannot find relation"
+
+(****************************************************************************)
+(* Library linking *)
+
+let contrib_name = "setoid_ring"
+
+let cdir = ["Coq";contrib_name]
+let contrib_modules =
+  List.map (fun d -> cdir@d)
+    [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
+     ["Field_tac"]; ["Field_theory"]
+    ]
+
+let my_constant c =
+  lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c)
+
+let new_ring_path =
+  make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"])
+let ltac s =
+  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
+let znew_ring_path =
+  make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"])
+let zltac s =
+  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
+
+let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
+let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;;
+
+(* Ring theory *)
+
+(* almost_ring defs *)
+let coq_almost_ring_theory = my_constant "almost_ring_theory"
+
+(* setoid and morphism utilities *)
+let coq_eq_setoid = my_constant "Eqsth"
+let coq_eq_morph = my_constant "Eq_ext"
+let coq_eq_smorph = my_constant "Eq_s_ext"
+
+(* ring -> almost_ring utilities *)
+let coq_ring_theory = my_constant "ring_theory"
+let coq_mk_reqe = my_constant "mk_reqe"
+
+(* semi_ring -> almost_ring utilities *)
+let coq_semi_ring_theory = my_constant "semi_ring_theory"
+let coq_mk_seqe = my_constant "mk_seqe"
+
+let ltac_inv_morphZ = zltac"inv_gen_phiZ"
+let ltac_inv_morphN = zltac"inv_gen_phiN"
+
+let coq_abstract = my_constant"Abstract"
+let coq_comp = my_constant"Computational"
+let coq_morph = my_constant"Morphism"
+
+(* Equality: do not evaluate but make recursive call on both sides *)
+let map_with_eq arg_map c =
+  let (req,_,_) = dest_rel c in
+  interp_map
+    ((req,(function -1->Prot|_->Rec))::
+    List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
+let _ = add_map "ring"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+    coq_nil, (function -1->Eval|_ -> Prot);
+    (* Pphi_dev: evaluate polynomial and coef operations, protect
+       ring operations and make recursive call on the var map *)
+    pol_cst "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot);
+    (* PEeval: evaluate morphism and polynomial, protect ring 
+       operations and make recursive call on the var map *)
+    pol_cst "PEeval", (function -1|7|9->Eval|8->Rec|_->Prot)])
+
+(****************************************************************************)
+(* Ring database *)
 
 type ring_info =
     { ring_carrier : types;
       ring_req : constr;
+      ring_setoid : constr;
+      ring_ext : constr;
+      ring_morph : constr;
+      ring_th : constr;
       ring_cst_tac : glob_tactic_expr;
       ring_lemma1 : constr;
-      ring_lemma2 : constr }
+      ring_lemma2 : constr;
+      ring_pre_tac : glob_tactic_expr;
+      ring_post_tac : glob_tactic_expr }
 
 module Cmap = Map.Make(struct type t = constr let compare = compare end)
 
 let from_carrier = ref Cmap.empty
 let from_relation = ref Cmap.empty
+let from_name = ref Spmap.empty
+
+let ring_for_carrier r = Cmap.find r !from_carrier
+let ring_for_relation rel = Cmap.find rel !from_relation
+let ring_lookup_by_name ref =
+  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name
+
+
+let find_ring_structure env sigma l cl oname =
+  match oname, l with
+      Some rf, _ ->
+        (try ring_lookup_by_name rf
+        with Not_found ->
+          errorlabstrm "ring"
+            (str "found no ring named "++pr_reference rf))
+    | None, t::cl' ->
+        let ty = Retyping.get_type_of env sigma t in
+        let check c =
+          let ty' = Retyping.get_type_of env sigma c in
+          if not (Reductionops.is_conv env sigma ty ty') then
+            errorlabstrm "ring"
+              (str"arguments of ring_simplify do not have all the same type")
+        in
+        List.iter check cl';
+        (try ring_for_carrier ty
+        with Not_found ->
+          errorlabstrm "ring"
+            (str"cannot find a declared ring structure over"++
+             spc()++str"\""++pr_constr ty++str"\""))
+    | None, [] ->
+        let (req,_,_) = dest_rel cl in
+        (try ring_for_relation req
+        with Not_found ->
+          errorlabstrm "ring"
+            (str"cannot find a declared ring structure for equality"++
+             spc()++str"\""++pr_constr req++str"\""))
 
 let _ = 
   Summary.declare_summary "tactic-new-ring-table"
-    { Summary.freeze_function = (fun () -> !from_carrier,!from_relation);
+    { Summary.freeze_function =
+        (fun () -> !from_carrier,!from_relation,!from_name);
       Summary.unfreeze_function =
-        (fun (ct,rt) -> from_carrier := ct; from_relation := rt);
+        (fun (ct,rt,nt) ->
+          from_carrier := ct; from_relation := rt; from_name := nt);
       Summary.init_function =
-        (fun () -> from_carrier := Cmap.empty; from_relation := Cmap.empty);
+        (fun () ->
+          from_carrier := Cmap.empty; from_relation := Cmap.empty;
+          from_name := Spmap.empty);
       Summary.survive_module = false;
       Summary.survive_section = false }
 
-let add_entry _ e =
-  let _ = ty e.ring_lemma1 in
+let add_entry (sp,_kn) e =
+(*  let _ = ty e.ring_lemma1 in
   let _ = ty e.ring_lemma2 in
+*)
   from_carrier := Cmap.add e.ring_carrier e !from_carrier;
-  from_relation := Cmap.add e.ring_req e !from_relation
+  from_relation := Cmap.add e.ring_req e !from_relation;
+  from_name := Spmap.add sp e !from_name 
 
 
 let subst_th (_,subst,th) = 
   let c' = subst_mps subst th.ring_carrier in                   
   let eq' = subst_mps subst th.ring_req in
+  let set' = subst_mps subst th.ring_setoid in
+  let ext' = subst_mps subst th.ring_ext in
+  let morph' = subst_mps subst th.ring_morph in
+  let th' = subst_mps subst th.ring_th in
   let thm1' = subst_mps subst th.ring_lemma1 in
   let thm2' = subst_mps subst th.ring_lemma2 in
   let tac'= subst_tactic subst th.ring_cst_tac in
+  let pretac'= subst_tactic subst th.ring_pre_tac in
+  let posttac'= subst_tactic subst th.ring_post_tac in
   if c' == th.ring_carrier &&
      eq' == th.ring_req &&
+     set' = th.ring_setoid &&
+     ext' == th.ring_ext &&
+     morph' == th.ring_morph &&
+     th' == th.ring_th &&
      thm1' == th.ring_lemma1 &&
      thm2' == th.ring_lemma2 &&
-     tac' == th.ring_cst_tac then th
+     tac' == th.ring_cst_tac &&
+     pretac' == th.ring_pre_tac &&
+     posttac' == th.ring_post_tac then th
   else
     { ring_carrier = c';
       ring_req = eq';
+      ring_setoid = set';
+      ring_ext = ext';
+      ring_morph = morph';
+      ring_th = th';
       ring_cst_tac = tac';
       ring_lemma1 = thm1';
-      ring_lemma2 = thm2' }
+      ring_lemma2 = thm2';
+      ring_pre_tac = pretac';
+      ring_post_tac = posttac' }
 
 
 let (theory_to_obj, obj_to_theory) = 
@@ -280,10 +417,6 @@ let (theory_to_obj, obj_to_theory) =
       export_function = export_th }
 
 
-let ring_for_carrier r = Cmap.find r !from_carrier
-
-let ring_for_relation rel = Cmap.find rel !from_relation
-
 let setoid_of_relation r =
   lapp coq_mk_Setoid
     [|r.rel_a; r.rel_aeq;
@@ -293,43 +426,19 @@ let op_morph r add mul opp req m1 m2 m3 =
   lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
 
 let op_smorph r add mul req m1 m2 =
-  lapp coq_SReqe_Reqe
-    [| r;add;mul;req;lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]|]
-
-let sr_sub r add = lapp coq_SRsub [|r;add|]
-let sr_opp r = lapp coq_SRopp [|r|]
+  lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
 
-let dest_morphism kind th sth =
-  let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in
-  match kind_of_term th_typ with
-      App(f,[|_;_;_;_;_;_;_;_;c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-        when f = Lazy.force coq_ring_morph ->
-          (th,[|c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-    | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
-        when f = Lazy.force coq_sring_morph && kind=Some true->
-        let th =
-          lapp coq_SRmorph_Rmorph
-            [|r;zero;one;add;mul;req;sth;c;czero;cone;cadd;cmul;ceqb;phi;th|]in
-        (th,[|c;czero;cone;cadd;cmul;cadd;sr_opp c;ceqb;phi|])
-    | _ -> failwith "bad ring_morph lemma"
-
-let dest_eq_test th =
-  let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in
-  match decompose_prod th_typ with
-      (_,h)::_,_ ->
-        (match snd(destApplication h) with
-            [|_;lhs;_|] -> fst(destApplication lhs)
-          | _ -> failwith "bad lemma for decidability of equality")
-    | _ -> failwith "bad lemma for decidability of equality"
-
-let default_ring_equality is_semi (r,add,mul,opp,req) =
+let default_ring_equality (r,add,mul,opp,req) =
   let is_setoid = function
       {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
     | _ -> false in
   match default_relation_for_carrier ~filter:is_setoid r with
       Leibniz _ ->
         let setoid = lapp coq_eq_setoid [|r|] in
-        let op_morph = lapp coq_eq_morph [|r;add;mul;opp|] in
+        let op_morph =
+          match opp with
+              Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
+            | None -> lapp coq_eq_smorph [|r;add;mul|] in
         (setoid,op_morph)
     | Relation rel ->
         let setoid = setoid_of_relation rel in
@@ -347,8 +456,12 @@ let default_ring_equality is_semi (r,add,mul,opp,req) =
           with Not_found ->
             error "ring multiplication should be declared as a morphism" in
         let op_morph =
-          if is_semi <> Some true then
-            (let opp_m = default_morphism ~filter:is_endomorphism opp in
+          match opp with
+            | Some opp ->
+            (let opp_m =
+              try default_morphism ~filter:is_endomorphism opp
+              with Not_found ->
+                error "ring opposite should be declared as a morphism" in
              let op_morph =
                op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in
              msgnl
@@ -358,7 +471,7 @@ let default_ring_equality is_semi (r,add,mul,opp,req) =
                str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++
                str"\"");
              op_morph)
-          else
+            | None ->
             (msgnl
               (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++  
                str"and morphisms \""++pr_constr add_m.morphism_theory++
@@ -367,159 +480,475 @@ let default_ring_equality is_semi (r,add,mul,opp,req) =
             op_smorph r add mul req add_m.lem mul_m.lem) in
         (setoid,op_morph)
 
-let build_setoid_params is_semi r add mul opp req eqth =
+let build_setoid_params r add mul opp req eqth =
   match eqth with
       Some th -> th
-    | None -> default_ring_equality is_semi (r,add,mul,opp,req)
+    | None -> default_ring_equality (r,add,mul,opp,req)
 
-let dest_ring th_spec =
-  let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th_spec in
+let dest_ring env sigma th_spec =
+  let th_typ = Retyping.get_type_of env sigma th_spec in
   match kind_of_term th_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req|])
         when f = Lazy.force coq_almost_ring_theory ->
-          (None,r,zero,one,add,mul,sub,opp,req)
+          (None,r,zero,one,add,mul,Some sub,Some opp,req)
     | App(f,[|r;zero;one;add;mul;req|])
         when f = Lazy.force coq_semi_ring_theory ->
-        (Some true,r,zero,one,add,mul,sr_sub r add,sr_opp r,req)
+        (Some true,r,zero,one,add,mul,None,None,req)
     | App(f,[|r;zero;one;add;mul;sub;opp;req|])
         when f = Lazy.force coq_ring_theory ->
-        (Some false,r,zero,one,add,mul,sub,opp,req)
+        (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
     | _ -> error "bad ring structure"
 
 
-let build_almost_ring kind r zero one add mul sub opp req sth morph th =
-  match kind with
-      None -> th
-    | Some true ->
-        lapp coq_SRth_ARth [|r;zero;one;add;mul;req;sth;th|]
-    | Some false ->
-        lapp coq_Rth_ARth [|r;zero;one;add;mul;sub;opp;req;sth;morph;th|]
-
 
 type coeff_spec =
     Computational of constr (* equality test *)
   | Abstract (* coeffs = Z *)
   | Morphism of constr (* general morphism *)
 
+
+let reflect_coeff rkind =
+  (* We build an ill-typed terms on purpose... *)
+  match rkind with
+      Abstract -> Lazy.force coq_abstract
+    | Computational c -> lapp coq_comp [|c|]
+    | Morphism m -> lapp coq_morph [|m|]
+
 type cst_tac_spec =
     CstTac of raw_tactic_expr
-  | Closed of constr list
-
-
-let add_theory name rth eqth morphth cst_tac =
-  Coqlib.check_required_library ["Coq";"setoid_ring";"Ring_tac"];
-  let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring rth in
-  let (sth,morph) = build_setoid_params kind r add mul opp req eqth in
-  let args0 = [|r;zero;one;add;mul;sub;opp;req;sth;morph|] in
-  let (lemma1,lemma2) =
-    match morphth with
-      | Computational c ->
-          let reqb = dest_eq_test c in
-          let rth = 
-            build_almost_ring
-              kind r zero one add mul sub opp req sth  morph rth in
-          let args = Array.append args0 [|rth;reqb;c|] in
-          (lapp ring_comp1 args, lapp ring_comp2 args)
-      | Morphism m ->
-          let (m,args1) = dest_morphism kind m sth in
-          let rth = 
-            build_almost_ring
-              kind r zero one add mul sub opp req sth morph rth in
-          let args = Array.concat [args0;[|rth|]; args1; [|m|]] in
-          (lapp coq_ring_lemma1 args, lapp coq_ring_lemma2 args)
-      | Abstract ->
-          Coqlib.check_required_library ["Coq";"setoid_ring";"ZRing_th"];
-          let args1 = Array.append args0 [|rth|] in
-          (match kind with
-              None -> error "an almost_ring cannot be abstract"
-            | Some true ->
-                (lapp sring_abs1 args1, lapp sring_abs2 args1)
-            | Some false ->
-                (lapp ring_abs1 args1, lapp ring_abs2 args1)) in
-  let cst_tac = match cst_tac with
+  | Closed of reference list
+
+let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac =
+  match cst_tac with
       Some (CstTac t) -> Tacinterp.glob_tactic t
-    | Some (Closed lc) -> failwith "TODO"
+    | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc)
     | None ->
-        (match kind with
-            Some true ->
+        (match opp, kind with
+            None, _ ->
               let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
               TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
-          | Some false ->
+          | Some opp, Some _ ->
               let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
               TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | _ -> error"a tactic must be specified for an almost_ring") in
+          | _ -> error"a tactic must be specified for an almost_ring")
+
+let add_theory name rth eqth morphth cst_tac (pre,post) =
+  let env = Global.env() in
+  let sigma = Evd.empty in
+  let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
+  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+  let rk = reflect_coeff morphth in
+  let params =
+    exec_tactic env 5 (zltac"ring_lemmas") (List.map carg[sth;ext;rth;rk]) in
+  let lemma1 = constr_of params.(3) in
+  let lemma2 = constr_of params.(4) in
+
+  let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
+  let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
+  let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in
+  let pretac =
+    match pre with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let posttac =
+    match post with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
   let _ =
     Lib.add_leaf name
       (theory_to_obj
         { ring_carrier = r;
           ring_req = req;
+          ring_setoid = sth;
+          ring_ext = constr_of params.(1);
+          ring_morph = constr_of params.(2);
+          ring_th = constr_of params.(0);
           ring_cst_tac = cst_tac;
           ring_lemma1 = lemma1;
-          ring_lemma2 = lemma2 }) in
+          ring_lemma2 = lemma2;
+          ring_pre_tac = pretac;
+          ring_post_tac = posttac }) in
   ()
 
-VERNAC ARGUMENT EXTEND ring_coefs
-| [ "Computational" constr(c)] -> [ Computational (ic c) ]
-| [ "Abstract" ] -> [ Abstract ]
-| [ "Coefficients" constr(m)] -> [ Morphism (ic m) ]
-| [ ] -> [ Abstract ]
+type ring_mod =
+    Ring_kind of coeff_spec
+  | Const_tac of cst_tac_spec
+  | Pre_tac of raw_tactic_expr
+  | Post_tac of raw_tactic_expr
+  | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
+
+VERNAC ARGUMENT EXTEND ring_mod
+  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
+  | [ "abstract" ] -> [ Ring_kind Abstract ]
+  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
+  | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+  | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+  | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+  | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+  | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
 END
 
-VERNAC ARGUMENT EXTEND ring_cst_tac
-| [ "Constant" tactic(c)] -> [ Some(CstTac c) ]
-| [ "[" ne_constr_list(l) "]" ] -> [ Some(Closed (List.map ic l)) ]
-| [ ] -> [ None ]
-END
+let set_once s r v =
+  if !r = None then r := Some v else error (s^" cannot be set twice")
+
+let process_ring_mods l =
+  let kind = ref None in
+  let set = ref None in
+  let cst_tac = ref None in
+  let pre = ref None in
+  let post = ref None in
+  List.iter(function
+      Ring_kind k -> set_once "ring kind" kind k
+    | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
+    | Pre_tac t -> set_once "preprocess tactic" pre t
+    | Post_tac t -> set_once "postprocess tactic" post t
+    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)) l;
+  let k = match !kind with Some k -> k | None -> Abstract in
+  (k, !set, !cst_tac, !pre, !post)
 
 VERNAC COMMAND EXTEND AddSetoidRing
-| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c)
-      "Setoid" constr(e) constr(m) ring_cst_tac(tac) ] ->
-    [ add_theory id (ic t) (Some (ic e, ic m)) c tac ]
-| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c) 
-      ring_cst_tac(tac) ] ->
-    [ add_theory id (ic t) None c tac ]
+  | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
+    [ let (k,set,cst,pre,post) = process_ring_mods l in
+      add_theory id (ic t) set k cst (pre,post) ]
 END
 
-
 (*****************************************************************************)
 (* The tactics consist then only in a lookup in the ring database and
    call the appropriate ltac. *)
 
-let ring gl = 
-  let req = dest_rel (pf_concl gl) in
-  let e =
-    try ring_for_relation req
-    with Not_found ->
-      errorlabstrm "ring"
-        (str"cannot find a declared ring structure for equality"++
-         spc()++str"\""++pr_constr req++str"\"") in
-  Tacinterp.eval_tactic
-    (TacArg(TacCall(dummy_loc,
-      ArgArg(dummy_loc, Lazy.force ltac_setoid_ring),
-      Tacexp e.ring_cst_tac::
-      List.map carg [e.ring_lemma1;e.ring_lemma2;e.ring_req])))
-    gl
-
-let ring_rewrite rl =
-  let ty = Retyping.get_type_of (Global.env()) Evd.empty (List.hd rl) in
-  let e =
-    try ring_for_carrier ty
-    with Not_found ->
-      errorlabstrm "ring"
-        (str"cannot find a declared ring structure over"++
-         spc()++str"\""++pr_constr ty++str"\"") in
-  let rl = List.fold_right (fun x l -> lapp coq_cons [|ty;x;l|]) rl
-    (lapp coq_nil [|ty|]) in
+let make_term_list carrier rl gl =
+  let rl = 
+    match rl with
+	[] -> let (_,t1,t2) = dest_rel (pf_concl gl) in [t1;t2]
+      | _ -> rl in
+  List.fold_right
+    (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
+    (lapp coq_nil [|carrier|])
+
+let ring_lookup (f:glob_tactic_expr) rl gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let e = find_ring_structure env sigma rl (pf_concl gl) None in
+  let rl = carg (make_term_list e.ring_carrier rl gl) in
+  let req = carg e.ring_req in
+  let sth = carg e.ring_setoid in
+  let ext = carg e.ring_ext in
+  let morph = carg e.ring_morph in
+  let th = carg e.ring_th in
+  let cst_tac = Tacexp e.ring_cst_tac in
+  let lemma1 = carg e.ring_lemma1 in
+  let lemma2 = carg e.ring_lemma2 in
+  let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
+  let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
   Tacinterp.eval_tactic
-    (TacArg(TacCall(dummy_loc,
-      ArgArg(dummy_loc, Lazy.force ltac_setoid_ring_rewrite),
-      Tacexp e.ring_cst_tac::List.map carg [e.ring_lemma2;e.ring_req;rl])))
+    (TacLetIn
+      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+       ltac_lcall "f"
+         [req;sth;ext;morph;th;cst_tac;lemma1;lemma2;pretac;posttac;rl])) gl
+
+TACTIC EXTEND ring_lookup
+| [ "ring_lookup" tactic(f) constr_list(l) ] -> [ ring_lookup (fst f) l ]
+END
+
+(***********************************************************************)
+
+let new_field_path =
+  make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"])
+
+let field_ltac s =
+  lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
+
+
+let _ = add_map "field"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+    coq_nil, (function -1->Eval|_ -> Prot);
+    (* display_linear: evaluate polynomials and coef operations, protect
+       field operations and make recursive call on the var map *)
+    my_constant "display_linear",
+      (function -1|7|8|9|10|12|13->Eval|11->Rec|_->Prot);
+    (* Pphi_dev: evaluate polynomial and coef operations, protect
+       ring operations and make recursive call on the var map *)
+    my_constant "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot);
+    (* PEeval: evaluate morphism and polynomial, protect ring 
+       operations and make recursive call on the var map *)
+    my_constant "FEeval", (function -1|9|11->Eval|10->Rec|_->Prot)]);;
+
+
+let _ = add_map "field_cond"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+     coq_nil, (function -1->Eval|_ -> Prot);
+    (* PCond: evaluate morphism and denum list, protect ring
+       operations and make recursive call on the var map *)
+     my_constant "PCond", (function -1|8|10->Eval|9->Rec|_->Prot)]);;
+
+
+let afield_theory = my_constant "almost_field_theory"
+let field_theory = my_constant "field_theory"
+let sfield_theory = my_constant "semi_field_theory"
+let af_ar = my_constant"AF_AR"
+let f_r = my_constant"F_R"
+let sf_sr = my_constant"SF_SR"
+let dest_field env sigma th_spec =
+  let th_typ = Retyping.get_type_of env sigma th_spec in
+  match kind_of_term th_typ with
+    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+        when f = Lazy.force afield_theory ->
+        let rth = lapp af_ar
+          [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+        (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+        when f = Lazy.force field_theory ->
+        let rth =
+          lapp f_r
+            [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+        (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+    | App(f,[|r;zero;one;add;mul;div;inv;req|])
+        when f = Lazy.force sfield_theory ->
+        let rth = lapp sf_sr
+          [|r;zero;one;add;mul;div;inv;req;th_spec|] in
+        (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
+    | _ -> error "bad field structure"
+
+type field_info =
+    { field_carrier : types;
+      field_req : constr;
+      field_cst_tac : glob_tactic_expr;
+      field_ok : constr;
+      field_simpl_eq_ok : constr;
+      field_simpl_ok : constr;
+      field_cond : constr;
+      field_pre_tac : glob_tactic_expr;
+      field_post_tac : glob_tactic_expr }
+
+let field_from_carrier = ref Cmap.empty
+let field_from_relation = ref Cmap.empty
+let field_from_name = ref Spmap.empty
+
+
+let field_for_carrier r = Cmap.find r !field_from_carrier
+let field_for_relation rel = Cmap.find rel !field_from_relation
+let field_lookup_by_name ref =
+  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref)))
+    !field_from_name
+
+
+let find_field_structure env sigma l cl oname =
+  check_required_library (cdir@["Field_tac"]);
+  match oname, l with
+      Some rf, _ ->
+        (try field_lookup_by_name rf
+        with Not_found ->
+          errorlabstrm "field"
+            (str "found no field named "++pr_reference rf))
+    | None, t::cl' ->
+        let ty = Retyping.get_type_of env sigma t in
+        let check c =
+          let ty' = Retyping.get_type_of env sigma c in
+          if not (Reductionops.is_conv env sigma ty ty') then
+            errorlabstrm "field"
+              (str"arguments of field_simplify do not have all the same type")
+        in
+        List.iter check cl';
+        (try field_for_carrier ty
+        with Not_found ->
+          errorlabstrm "field"
+            (str"cannot find a declared field structure over"++
+             spc()++str"\""++pr_constr ty++str"\""))
+    | None, [] ->
+        let (req,_,_) = dest_rel cl in
+        (try field_for_relation req
+        with Not_found ->
+          errorlabstrm "field"
+            (str"cannot find a declared field structure for equality"++
+             spc()++str"\""++pr_constr req++str"\""))
+
+let _ = 
+  Summary.declare_summary "tactic-new-field-table"
+    { Summary.freeze_function =
+        (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
+      Summary.unfreeze_function =
+        (fun (ct,rt,nt) ->
+          field_from_carrier := ct; field_from_relation := rt;
+          field_from_name := nt);
+      Summary.init_function =
+        (fun () ->
+          field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
+          field_from_name := Spmap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let add_field_entry (sp,_kn) e =
+(*
+  let _ = ty e.field_ok in
+  let _ = ty e.field_simpl_eq_ok in
+  let _ = ty e.field_simpl_ok in
+  let _ = ty e.field_cond in
+*)
+  field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
+  field_from_relation := Cmap.add e.field_req e !field_from_relation;
+  field_from_name := Spmap.add sp e !field_from_name 
+
+let subst_th (_,subst,th) = 
+  let c' = subst_mps subst th.field_carrier in                   
+  let eq' = subst_mps subst th.field_req in
+  let thm1' = subst_mps subst th.field_ok in
+  let thm2' = subst_mps subst th.field_simpl_eq_ok in
+  let thm3' = subst_mps subst th.field_simpl_ok in
+  let thm4' = subst_mps subst th.field_cond in
+  let tac'= subst_tactic subst th.field_cst_tac in
+  let pretac'= subst_tactic subst th.field_pre_tac in
+  let posttac'= subst_tactic subst th.field_post_tac in
+  if c' == th.field_carrier &&
+     eq' == th.field_req &&
+     thm1' == th.field_ok &&
+     thm2' == th.field_simpl_eq_ok &&
+     thm3' == th.field_simpl_ok &&
+     thm4' == th.field_cond &&
+     tac' == th.field_cst_tac &&
+     pretac' == th.field_pre_tac &&
+     posttac' == th.field_post_tac then th
+  else
+    { field_carrier = c';
+      field_req = eq';
+      field_cst_tac = tac';
+      field_ok = thm1';
+      field_simpl_eq_ok = thm2';
+      field_simpl_ok = thm3';
+      field_cond = thm4';
+      field_pre_tac = pretac';
+      field_post_tac = posttac' }
+
+let (ftheory_to_obj, obj_to_ftheory) = 
+  let cache_th (name,th) = add_field_entry name th
+  and export_th x = Some x in
+  declare_object
+    {(default_object "tactic-new-field-theory") with
+      open_function = (fun i o -> if i=1 then cache_th o);
+      cache_function = cache_th;
+      subst_function = subst_th;
+      classify_function = (fun (_,x) -> Substitute x);
+      export_function = export_th }
 
-let setoid_ring = function
-  | [] -> ring
-  | l -> ring_rewrite l
+let default_field_equality r inv req =
+  let is_setoid = function
+      {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
+    | _ -> false in
+  match default_relation_for_carrier ~filter:is_setoid r with
+      Leibniz _ ->
+        mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+    | Relation rel ->
+        let is_endomorphism = function
+            { args=args } -> List.for_all
+                (function (var,Relation rel) ->
+                  var=None && eq_constr req rel
+                  | _ -> false) args in
+        let inv_m =
+          try default_morphism ~filter:is_endomorphism inv
+          with Not_found ->
+            error "field inverse should be declared as a morphism" in
+        inv_m.lem
+
+let add_field_theory name fth eqth morphth cst_tac inj (pre,post) =
+  let env = Global.env() in
+  let sigma = Evd.empty in
+  let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
+    dest_field env sigma fth in
+  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+  let eqth = Some(sth,ext) in
+  let _ = add_theory name rth eqth morphth cst_tac (None,None) in
+  let inv_m = default_field_equality r inv req in
+  let rk = reflect_coeff morphth in
+  let params =
+    exec_tactic env 8 (field_ltac"field_lemmas")
+      (List.map carg[sth;ext;inv_m;fth;rk]) in
+  let lemma1 = constr_of params.(3) in
+  let lemma2 = constr_of params.(4) in
+  let lemma3 = constr_of params.(5) in
+  let cond_lemma =
+    match inj with
+      | Some thm -> mkApp(constr_of params.(7),[|thm|])
+      | None -> constr_of params.(6) in
+  let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
+  let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
+  let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
+  let cond_lemma = decl_constant (string_of_id name^"_lemma4") cond_lemma in
+  let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in
+  let pretac =
+    match pre with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let posttac =
+    match post with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let _ =
+    Lib.add_leaf name
+      (ftheory_to_obj
+        { field_carrier = r;
+          field_req = req;
+          field_cst_tac = cst_tac;
+          field_ok = lemma1;
+          field_simpl_eq_ok = lemma2;
+          field_simpl_ok = lemma3;
+          field_cond = cond_lemma;
+          field_pre_tac = pretac;
+          field_post_tac = posttac }) in  ()
+
+type field_mod =
+    Ring_mod of ring_mod
+  | Inject of Topconstr.constr_expr
+
+VERNAC ARGUMENT EXTEND field_mod
+  | [ ring_mod(m) ] -> [ Ring_mod m ]
+  | [ "infinite" constr(inj) ] -> [ Inject inj ]
+END
 
-TACTIC EXTEND setoid_ring
-  [ "setoid" "ring" constr_list(l) ] -> [ setoid_ring l ]
+let process_field_mods l =
+  let kind = ref None in
+  let set = ref None in
+  let cst_tac = ref None in
+  let pre = ref None in
+  let post = ref None in
+  let inj = ref None in
+  List.iter(function
+      Ring_mod(Ring_kind k) -> set_once "field kind" kind k
+    | Ring_mod(Const_tac t) ->
+        set_once "tactic recognizing constants" cst_tac t
+    | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
+    | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
+    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
+    | Inject i -> set_once "infinite property" inj (ic i)) l;
+  let k = match !kind with Some k -> k | None -> Abstract in
+  (k, !set, !inj, !cst_tac, !pre, !post)
+
+VERNAC COMMAND EXTEND AddSetoidField
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> 
+  [ let (k,set,inj,cst_tac,pre,post) = process_field_mods l in
+    add_field_theory id (ic t) set k cst_tac inj (pre,post) ]
 END
 
+let field_lookup (f:glob_tactic_expr) rl gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let e = find_field_structure env sigma rl (pf_concl gl) None in
+  let rl = carg (make_term_list e.field_carrier rl gl) in
+  let req = carg e.field_req in
+  let cst_tac = Tacexp e.field_cst_tac in
+  let field_ok = carg e.field_ok in
+  let field_simpl_ok = carg e.field_simpl_ok in
+  let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
+  let cond_ok = carg e.field_cond in
+  let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
+  let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+  Tacinterp.eval_tactic
+    (TacLetIn
+      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+       ltac_lcall "f"
+         [req;cst_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;cond_ok;
+          pretac;posttac;rl])) gl
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(f) constr_list(l) ] -> [ field_lookup (fst f) l ]
+END
diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v
index b1694d7c..219cd75b 100644
--- a/contrib/subtac/Utils.v
+++ b/contrib/subtac/Utils.v
@@ -4,7 +4,7 @@ Notation "'fun' { x : A | P } => Q" :=
   (fun x:{x:A|P} => Q)
   (at level 200, x ident, right associativity).
 
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+Notation "( x & ? )" := (@exist _ _ x _) : core_scope.
 
 Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A.
 intros.
@@ -44,3 +44,4 @@ end.
 
 Ltac destruct_exists := repeat (destruct_one_pair) .
 
+Extraction Inline proj1_sig.
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
index 859f9013..790e61a0 100644
--- a/contrib/subtac/eterm.ml
+++ b/contrib/subtac/eterm.ml
@@ -32,47 +32,48 @@ let list_assoc_index x l =
     | [] -> raise Not_found
   in aux 0 l
 
+
 (** Substitute evar references in t using De Bruijn indices, 
   where n binders were passed through. *)
-let subst_evars evs n t = 
+let subst_evar_constr evs n t = 
+  let seen = ref Intset.empty in
   let evar_info id = 
     let rec aux i = function
-	(k, h, v) :: tl -> 
-	  trace (str "Searching for " ++ int id ++ str " found: " ++ int k);
-	  if k = id then (i, h, v) else aux (succ i) tl
+	(k, x) :: tl -> 
+	  if k = id then x else aux (succ i) tl
       | [] -> raise Not_found
-    in 
-    let (idx, hyps, v) = aux 0 evs in
-      n + idx + 1, hyps
+    in aux 0 evs
   in
   let rec substrec depth c = match kind_of_term c with
     | Evar (k, args) ->
-	(let index, hyps = 
-	   try evar_info k
-	   with Not_found -> 
-	     anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
-	 in
-	 (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++
-		       int (List.length hyps) ++ str " hypotheses"); 	      with _ -> () );
-	 let ex = mkRel (index + depth) in
-	   (* Evar arguments are created in inverse order, 
-	      and we must not apply to defined ones (i.e. LetIn's)
-	   *)
-	 let args =
-	   let rec aux hyps args acc =
+	let (id, idstr), hyps, _, _ = 
+	  try evar_info k
+	  with Not_found -> 
+	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
+	in
+        seen := Intset.add id !seen;
+	  (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++
+			int (List.length hyps) ++ str " hypotheses"); 	      with _ -> () );
+	  (* Evar arguments are created in inverse order, 
+	     and we must not apply to defined ones (i.e. LetIn's)
+	  *)
+	let args =
+	  let rec aux hyps args acc =
 	     match hyps, args with
 		 ((_, None, _) :: tlh), (c :: tla) -> 
 		   aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
 	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
 		   aux tlh tla acc
 	       | [], [] -> acc
-	       | _, _ -> failwith "subst_evars: invalid argument"
+	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
 	   in aux hyps (Array.to_list args) [] 
 	 in
-	   mkApp (ex, Array.of_list args))
+	   mkApp (mkVar idstr, Array.of_list args)
     | _ -> map_constr_with_binders succ substrec depth c
   in 
-    substrec 0 t
+  let t' = substrec 0 t in
+    t', !seen
+
       
 (** Substitute variable references in t using De Bruijn indices, 
   where n binders were passed through. *)
@@ -89,73 +90,80 @@ let subst_vars acc n t =
 
 (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
   to a product : forall H1 : t1, ..., forall Hn : tn, concl.
-  Changes evars and hypothesis references to De Bruijn indices.
+    Changes evars and hypothesis references to variable references.
 *)
 let etype_of_evar evs ev hyps =
   let rec aux acc n = function
       (id, copt, t) :: tl ->
-	let t' = subst_evars evs n t in
+	let t', s = subst_evar_constr evs n t in
 	let t'' = subst_vars acc 0 t' in
- 	  mkNamedProd_or_LetIn (id, copt, t'') (aux (id :: acc) (succ n) tl)
+	let copt', s = 
+	  match copt with
+	      Some c -> 
+		let c', s' = subst_evar_constr evs n c in
+		  Some c', Intset.union s s'
+	    | None -> None, s
+	in
+	let copt' = option_map (subst_vars acc 0) copt' in
+ 	let rest, s' = aux (id :: acc) (succ n) tl in
+	  mkNamedProd_or_LetIn (id, copt', t'') rest, Intset.union s' s
     | [] ->
-	let t' = subst_evars evs n ev.evar_concl in
-	  subst_vars acc 0 t'	
+	let t', s = subst_evar_constr evs n ev.evar_concl in
+	  subst_vars acc 0 t', s
   in aux [] 0 (rev hyps)
 
 
 open Tacticals
     
-let eterm_term evm t tycon = 
+let rec take n l = 
+  if n = 0 then [] else List.hd l :: take (pred n) (List.tl l)    
+
+let trunc_named_context n ctx = 
+  let len = List.length ctx in
+    take (len - n) ctx
+  
+let eterm_obligations name nclen evm t tycon = 
   (* 'Serialize' the evars, we assume that the types of the existentials
      refer to previous existentials in the list only *)
   let evl = List.rev (to_list evm) in
-    trace (str "Eterm, transformed to list");
+  trace (str "Eterm, transformed to list");
+  let evn = 
+    let i = ref (-1) in
+      List.rev_map (fun (id, ev) -> incr i; 
+		  (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl
+  in
   let evts = 
     (* Remove existential variables in types and build the corresponding products *)
     fold_right 
-      (fun (id, ev) l ->
+      (fun (id, (n, nstr), ev) l ->
 	 trace (str "Eterm: " ++ str "treating evar: " ++ int id);
 	 let hyps = Environ.named_context_of_val ev.evar_hyps in
-	 let y' = (id, hyps, etype_of_evar l ev hyps) in
+	 let hyps = trunc_named_context nclen hyps in
+	 trace (str "Named context is: " ++ Printer.pr_named_context (Global.env ()) hyps);
+	 let evtyp, deps = etype_of_evar l ev hyps in
+	 trace (str "Evar " ++ str (string_of_int n) ++ str "'s type is: " ++ Termops.print_constr_env (Global.env ()) evtyp);
+	 let y' = (id, ((n, nstr), hyps, evtyp, deps)) in
 	   y' :: l) 
-      evl []
+      evn []
   in 
-  let t' = (* Substitute evar refs in the term by De Bruijn indices *)
-    subst_evars evts 0 t 
-  in
-  let evar_names = 
-    List.map (fun (id, _, c) -> (id_of_string ("Evar" ^ string_of_int id)), c) evts
-  in
-  let evar_bl =
-    List.map (fun (id, c) -> Name id, None, c) evar_names
-  in
-  let anon_evar_bl = List.map (fun (_, x, y) -> (Anonymous, x, y)) evar_bl in
-    (* Generalize over the existential variables *)
-  let t'' = Termops.it_mkLambda_or_LetIn t' evar_bl 
-  and tycon = option_map 
-		(fun typ -> Termops.it_mkProd_wo_LetIn typ anon_evar_bl) tycon
-  in
-  let _declare_evar (id, c) =
-    let id = id_of_string ("Evar" ^ string_of_int id) in
-      ignore(Declare.declare_variable id (Names.empty_dirpath, Declare.SectionLocalAssum c,
-					  Decl_kinds.IsAssumption Decl_kinds.Definitional))
+  let t', _ = (* Substitute evar refs in the term by variables *)
+    subst_evar_constr evts 0 t 
   in
-  let _declare_assert acc (id, c) =
-    let id = id_of_string ("Evar" ^ string_of_int id) in
-      tclTHEN acc (Tactics.assert_tac false (Name id) c)
+  let evars = 
+    List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts
   in
     (try 
        trace (str "Term given to eterm" ++ spc () ++
-	      Termops.print_constr_env (Global.env ()) t);
+		Termops.print_constr_env (Global.env ()) t);
        trace (str "Term constructed in eterm" ++ spc () ++
-	      Termops.print_constr_env (Global.env ()) t'');
-       ignore(option_map 
-		(fun typ ->
-		   trace (str "Type :" ++ spc () ++
-			  Termops.print_constr_env (Global.env ()) typ))
-		tycon);
+		Termops.print_constr_env (Global.env ()) t');
+       ignore(iter
+		(fun (name, typ, deps) ->
+		   trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++
+			    Termops.print_constr_env (Global.env ()) typ))
+		evars);
      with _ -> ());
-    t'', tycon, evar_names
+    Array.of_list (List.rev evars), t'
 
 let mkMetas n = 
   let rec aux i acc = 
@@ -163,12 +171,12 @@ let mkMetas n =
     else acc
   in aux n []
 
-let eterm evm t (tycon : types option) = 
-  let t, tycon, evs = eterm_term evm t tycon in
-    match tycon with
-	Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) []
-      | None -> Tactics.apply_term t (mkMetas (List.length evs))
+(* let eterm evm t (tycon : types option) =  *)
+(*   let t, tycon, evs = eterm_term evm t tycon in *)
+(*     match tycon with *)
+(* 	Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *)
+(*       | None -> Tactics.apply_term t (mkMetas (List.length evs)) *)
      
-open Tacmach
+(* open Tacmach *)
 
-let etermtac (evm, t) = eterm evm t None
+let etermtac (evm, t) = assert(false) (*eterm evm t None *)
diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli
index fbe2ac1d..3a571ee1 100644
--- a/contrib/subtac/eterm.mli
+++ b/contrib/subtac/eterm.mli
@@ -6,15 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eterm.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
+(*i $Id: eterm.mli 9326 2006-10-31 12:57:26Z msozeau $ i*)
 
 open Tacmach
 open Term
 open Evd
 open Names
+open Util
 
 val mkMetas : int -> constr list
 
-val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list
+(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *)
+
+val eterm_obligations : identifier -> int -> evar_map -> constr -> types option -> 
+  (identifier * types * Intset.t) array * constr (* Obl. name, type as product and dependencies as indexes into the array *)
 
 val etermtac : open_constr -> tactic
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
index b56ecc3d..243cb191 100644
--- a/contrib/subtac/g_subtac.ml4
+++ b/contrib/subtac/g_subtac.ml4
@@ -10,7 +10,7 @@
   Syntax for the subtac terms and types.
   Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
 
-(* $Id: g_subtac.ml4 8917 2006-06-07 16:59:05Z herbelin $ *)
+(* $Id: g_subtac.ml4 9326 2006-10-31 12:57:26Z msozeau $ *)
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
@@ -30,6 +30,7 @@ open Topconstr
 
 module Gram = Pcoq.Gram
 module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
 
 module SubtacGram =
 struct
@@ -40,15 +41,31 @@ end
 
 open SubtacGram 
 open Util
+open Pcoq
+
+let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
 
 GEXTEND Gram
-  GLOBAL: subtac_gallina_loc;
+  GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder;
  
   subtac_gallina_loc:
     [ [ g = Vernac.gallina -> loc, g ] ]
     ;
+
+  Constr.binder_let:
+    [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> 
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in
+	    LocalRawAssum ([id], typ)
+    ] ];
+
+  Constr.binder:
+    [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], c, p)]) in
+	    ([id], typ) ] ];
+
   END
 
+
 type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type
 
 let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype),
@@ -57,6 +74,11 @@ let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_arg
   Genarg.create_arg "subtac_gallina_loc"
 
 VERNAC COMMAND EXTEND Subtac
-[ "Program" subtac_gallina_loc(g) ] -> 
-  [ Subtac.subtac g ]
+[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
+| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name) ]
+| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None) ]      
+| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ]
+| [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ]
+| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ]
+| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ]
 END
diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml
index ffb16a19..26e8f715 100644
--- a/contrib/subtac/subtac.ml
+++ b/contrib/subtac/subtac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 8964 2006-06-20 13:52:21Z msozeau $ *)
+(* $Id: subtac.ml 9284 2006-10-26 12:06:57Z msozeau $ *)
 
 open Global
 open Pp
@@ -156,19 +156,19 @@ let subtac (loc, command) =
     match command with
 	VernacDefinition (defkind, (locid, id), expr, hook) -> 
 	    (match expr with
-		 ProveBody (bl, c) -> 
-		   let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c None in
-		     trace (str "Starting proof");
-		     Command.start_proof id goal_kind c hook;
-		     trace (str "Started proof");	     
+		 ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None
+(* 		   let evm, c, ctyp =  in *)
+(* 		     trace (str "Starting proof"); *)
+(* 		     Command.start_proof id goal_kind c hook; *)
+(* 		     trace (str "Started proof");	      *)
 		     
 	       | DefineBody (bl, _, c, tycon) -> 
-		   let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c tycon in
-		   let tac = Eterm.etermtac (evm, c) in 
-		     trace (str "Starting proof");
-		     Command.start_proof id goal_kind ctyp hook;
-		     trace (str "Started proof");
-		     Pfedit.by tac)
+		   Subtac_pretyping.subtac_proof env isevars id bl c tycon
+		     (* let tac = Eterm.etermtac (evm, c) in  *)
+		     (* 		     trace (str "Starting proof"); *)
+		     (* 		     Command.start_proof id goal_kind ctyp hook; *)
+		     (* 		     trace (str "Started proof"); *)
+		     (* 		     Pfedit.by tac) *))
       | VernacFixpoint (l, b) -> 
 	  let _ = trace (str "Building fixpoint") in
 	    ignore(Subtac_command.build_recursive l b)
@@ -223,24 +223,30 @@ let subtac (loc, command) =
 		++ x ++ spc () ++ str "and" ++ spc () ++ y
 	in msg_warning cmds
     
-    | Type_errors.TypeError (env, e) ->
-	debug 2 (Himsg.explain_type_error env e)
+    | Type_errors.TypeError (env, exn) as e ->
+	debug 2 (Himsg.explain_type_error env exn);
+	raise e
 	  
-    | Pretype_errors.PretypeError (env, e) ->
-	debug 2 (Himsg.explain_pretype_error env e)
+    | Pretype_errors.PretypeError (env, exn) as e ->
+	debug 2 (Himsg.explain_pretype_error env exn);
+	raise e
 	  
-    | Stdpp.Exc_located (loc, e) ->
+    | (Stdpp.Exc_located (loc, e')) as e ->
 	debug 2 (str "Parsing exception: ");
-	(match e with
-	   | Type_errors.TypeError (env, e) ->
-	       debug 2 (Himsg.explain_type_error env e)
+	(match e' with
+	   | Type_errors.TypeError (env, exn) ->
+	       debug 2 (Himsg.explain_type_error env exn);
+	       raise e
 		 
-	   | Pretype_errors.PretypeError (env, e) ->
-	       debug 2 (Himsg.explain_pretype_error env e)
+	   | Pretype_errors.PretypeError (env, exn) ->
+	       debug 2 (Himsg.explain_pretype_error env exn);
+	       raise e
 
-	   | e -> msg_warning (str "Unexplained exception: " ++ Cerrors.explain_exn e))
+	   | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+	       raise e)
   
     | e -> 
-	msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e)
+	msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+	raise e
 
 
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
index 78c3c70b..da5c497c 100644
--- a/contrib/subtac/subtac_coercion.ml
+++ b/contrib/subtac/subtac_coercion.ml
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: subtac_coercion.ml 8964 2006-06-20 13:52:21Z msozeau $ *)
+(* $Id: subtac_coercion.ml 9284 2006-10-26 12:06:57Z msozeau $ *)
 
 open Util
 open Names
@@ -91,7 +91,9 @@ module Coercion = struct
   let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c
 
   let rec mu env isevars t =   
+    let isevars = ref isevars in
     let rec aux v = 
+      let v = hnf env isevars v in
       match disc_subset v with
 	  Some (u, p) -> 
 	    let f, ct = aux u in
@@ -135,8 +137,9 @@ module Coercion = struct
 		 | Type x, Type y when x = y -> None (* false *)
 		 | _ -> subco ())
 	  | Prod (name, a, b), Prod (name', a', b') ->
-	      let c1 = coerce_unify env a' a in
+	      let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
 	      let env' = push_rel (name', None, a') env in
+	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
 	      let c2 = coerce_unify env' b b' in
 		(match c1, c2 with
 		     None, None -> failwith "subtac.coerce': Should have detected equivalence earlier"
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
index c738d7a6..b433af2c 100644
--- a/contrib/subtac/subtac_command.ml
+++ b/contrib/subtac/subtac_command.ml
@@ -43,6 +43,7 @@ open Notation
 module SPretyping = Subtac_pretyping.Pretyping
 open Subtac_utils
 open Pretyping
+open Subtac_obligations
 
 (*********************************************************************)
 (* Functions to parse and interpret constructions *)
@@ -149,15 +150,6 @@ let collect_non_rec env =
   in 
   searchrec [] 
 
-let definition_message id =
-  Options.if_verbose message ((string_of_id id) ^ " is defined")
-
-let recursive_message v =
-  match Array.length v with
-    | 0 -> error "no recursive definition"
-    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
-		    spc () ++ str "are recursively defined")
 
 let filter_map f l = 
   let rec aux acc = function
@@ -190,9 +182,12 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   let env = Global.env() in 
   let pr c = my_print_constr env c in
   let prr = Printer.pr_rel_context env in
+  let prn = Printer.pr_named_context env in
   let pr_rel env = Printer.pr_rel_context env in
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
   let _ = 
-    try debug 2 (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ 
+    try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ 
 		 Ppconstr.pr_binders bl ++ str " : " ++ 
 		 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++
 		 Ppconstr.pr_constr_expr body)
@@ -204,25 +199,35 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   let argid = match argname with Name n -> n | _ -> assert(false) in
   let _liftafter = lift_binders 1 after_length after in
   let envwf = push_rel_context before env in
-  let wf_rel, measure_fn = 
-    let rconstr = interp_constr isevars envwf r in
-    if measure then
-      let lt_rel = constr_of_global (Lazy.force lt_ref) in
-      let name s = Name (id_of_string s) in
-	mkLambda (name "x", argtyp,
-		  mkLambda (name "y", argtyp,
-			    mkApp (lt_rel,
-				   [| mkApp (rconstr, [| mkRel 2 |]) ;
-				      mkApp (rconstr, [| mkRel 1 |]) |]))),
-	Some rconstr
-    else rconstr, None
+  let wf_rel, wf_rel_fun, measure_fn = 
+    let rconstr_body, rconstr = 
+      let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in
+       let env = push_rel_context [arg] envwf in
+       let capp = interp_constr isevars env app in
+ 	capp, mkLambda (argname, argtyp, capp)
+     in
+       if measure then
+ 	let lt_rel = constr_of_global (Lazy.force lt_ref) in
+ 	let name s = Name (id_of_string s) in
+ 	let wf_rel_fun = 
+ 	  (fun x y ->
+ 	      mkApp (lt_rel, [| subst1 x rconstr_body; 
+ 				subst1 y rconstr_body |])) 
+ 	in
+ 	let wf_rel = 
+ 	  mkLambda (name "x", argtyp,
+ 		    mkLambda (name "y", lift 1 argtyp,
+ 			      wf_rel_fun (mkRel 2) (mkRel 1)))
+ 	in
+ 	  wf_rel, wf_rel_fun , Some rconstr
+       else rconstr, (fun x y -> mkApp (rconstr, [|x; y|])), None
   in
   let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |])
   in
   let argid' = id_of_string (string_of_id argid ^ "'") in
   let wfarg len = (Name argid', None, 
-		   mkSubset (Name argid') argtyp 
-		     (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|])))
+  		   mkSubset (Name argid') argtyp 
+		     (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
   in
   let top_bl = after @ (arg :: before) in
   let intern_bl = after @ (wfarg 1 :: arg :: before) in
@@ -234,7 +239,7 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   let projection = 
     mkApp (proj, [| argtyp ;
 		    (mkLambda (Name argid', argtyp,
-			       (mkApp (wf_rel, [|mkRel 1; mkRel 3|])))) ;
+			       (wf_rel_fun (mkRel 1) (mkRel 3)))) ;
 		    mkRel 1
 		 |])
   in
@@ -299,40 +304,16 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   in
   let evm = non_instanciated_map env isevars in
   let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in
-  let evars_def, evars_typ, evars = Eterm.eterm_term evm fullcoqc (Some fullctyp) in 	
-  let evars_typ = out_some evars_typ in
-  (try trace (str "Building evars sum for : ");
-     List.iter
-       (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t))
-       evars;
-   with _ -> ());
-  let (sum_tac, sumg) = Subtac_utils.build_dependent_sum evars in
-  (try trace (str "Evars sum: " ++ my_print_constr env sumg);
-     trace (str "Evars type: " ++ my_print_constr env evars_typ);
-   with _ -> ());
-  let proofid = id_of_string (string_of_id recname ^ "_evars_proof") in
-    Command.start_proof proofid goal_proof_kind sumg
-      (fun strength gr -> 
-	 debug 2 (str "Proof finished");
-	 let def = constr_of_global gr in
-	 let args = Subtac_utils.destruct_ex def sumg in
-	 let _, newdef = decompose_lam_n (List.length args) evars_def in
-	 let constr = Term.substl (List.rev args) newdef in
-	   debug 2 (str "Applied existentials : " ++ my_print_constr env constr);
-	   let ce = 
-	     { const_entry_body = constr;
-	       const_entry_type = Some fullctyp;
-	       const_entry_opaque = false;
-	       const_entry_boxed = boxed} 
-	   in
-	   let _constant = Declare.declare_constant 
-			    recname (DefinitionEntry ce,IsDefinition Definition)
-	   in
-	     definition_message recname);
-    trace (str "Started existentials proof");
-    Pfedit.by sum_tac;
-    trace (str "Applied sum tac")  
-
+  let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in
+    (try trace (str "Generated obligations : ");
+       Array.iter
+	 (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t))
+	 evars;
+     with _ -> ());    
+      trace (str "Adding to obligations list");
+      Subtac_obligations.add_entry recname evars_def fullctyp evars;
+      trace (str "Added to obligations list")
+(*
 let build_mutrec l boxed = 
   let sigma = Evd.empty
   and env0 = Global.env()
@@ -543,7 +524,7 @@ let build_mutrec l boxed =
 		 Environ.NoBody -> trace (str "Constant has no body")
 	       | Environ.Opaque -> trace (str "Constant is opaque")
       )
-
+*)
 let out_n = function
     Some n -> n
   | None -> 0
@@ -563,8 +544,8 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed
 		       errorlabstrm "Subtac_command.build_recursive"
 			 (str "Well-founded fixpoints not allowed in mutually recursive blocks"))
 	    lnameargsardef
-	in
-	  build_mutrec lnameargsardef boxed;
-	  assert(false)
+	in assert(false)
+	     (*build_mutrec lnameargsardef boxed*)
+	  
       
       
diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli
index 90ffb892..846e06cf 100644
--- a/contrib/subtac/subtac_command.mli
+++ b/contrib/subtac/subtac_command.mli
@@ -37,7 +37,6 @@ val interp_constr_judgment :
   env ->
   constr_expr -> unsafe_judgment
 val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
-val recursive_message : global_reference array -> std_ppcmds
 
 val build_recursive :
   (fixpoint_expr * decl_notation) list -> bool -> unit
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
new file mode 100644
index 00000000..7b13b402
--- /dev/null
+++ b/contrib/subtac/subtac_obligations.ml
@@ -0,0 +1,249 @@
+open Printf
+open Pp
+open Subtac_utils
+
+open Term
+open Names
+open Libnames
+open Summary
+open Libobject
+open Entries
+open Decl_kinds
+open Util
+open Evd
+
+type obligation =
+    { obl_name : identifier;
+      obl_type : types;
+      obl_body : constr option;
+      obl_deps : Intset.t;
+    }
+
+type obligations = (obligation array * int)
+
+type program_info = {
+  prg_name: identifier;
+  prg_body: constr;
+  prg_type: types;
+  prg_obligations: obligations;
+}
+
+let evar_of_obligation o = { evar_hyps = Environ.empty_named_context_val ; 
+			     evar_concl = o.obl_type ; 
+			     evar_body = Evar_empty ;
+			     evar_extra = None }
+
+module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
+
+let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
+
+let map_cardinal m = 
+  let i = ref 0 in 
+    ProgMap.iter (fun _ _ -> incr i) m;
+    !i
+
+exception Found of program_info
+
+let map_first m = 
+  try
+    ProgMap.iter (fun _ v -> raise (Found v)) m;
+    assert(false)
+  with Found x -> x
+    
+let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
+
+let _ = 
+  Summary.declare_summary "program-tcc-table"
+    { Summary.freeze_function = (fun () -> !from_prg);
+      Summary.unfreeze_function =
+        (fun v -> from_prg := v);
+      Summary.init_function =
+        (fun () -> from_prg := ProgMap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let declare_definition prg = 
+(*  let obls_constrs = 
+    Array.fold_right (fun x acc -> (out_some x.obl_evar.evar_body) :: acc) (fst prg.prg_obligations) []
+  in*)
+  let ce = 
+    { const_entry_body = prg.prg_body;
+      const_entry_type = Some prg.prg_type;
+      const_entry_opaque = false;
+      const_entry_boxed = false} 
+  in
+  let _constant = Declare.declare_constant 
+    prg.prg_name (DefinitionEntry ce,IsDefinition Definition)
+  in
+    Subtac_utils.definition_message prg.prg_name
+    
+open Evd
+
+let terms_of_evar ev = 
+  match ev.evar_body with
+      Evar_defined b ->
+	let nc = Environ.named_context_of_val ev.evar_hyps in
+	let body = Termops.it_mkNamedLambda_or_LetIn b nc in
+	let typ = Termops.it_mkNamedProd_or_LetIn ev.evar_concl nc in
+	  body, typ
+    | _ -> assert(false)
+	  
+let declare_obligation obl body =
+  let ce = 
+    { const_entry_body = body;
+      const_entry_type = Some obl.obl_type;
+      const_entry_opaque = true;
+      const_entry_boxed = false} 
+  in
+  let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property)
+  in
+    Subtac_utils.definition_message obl.obl_name;
+    { obl with obl_body = Some (mkConst constant) }
+      
+let try_tactics obls = 
+  Array.map
+    (fun obl ->
+       match obl.obl_body with
+	   None ->
+	     (try
+		let ev = evar_of_obligation obl in
+		let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in	       
+		  declare_obligation obl c		  
+	      with _ -> obl)
+	 | _ -> obl)
+    obls
+        
+let add_entry n b t obls =
+  Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
+  let init_obls e = 
+    Array.map
+      (fun (n, t, d) ->
+         { obl_name = n ; obl_body = None; obl_type = t; obl_deps = d })
+      e
+  in
+    if Array.length obls = 0 then (
+      Options.if_verbose ppnl (str ".");
+    declare_definition { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = ([||], 0) } )
+    else (
+      let len = Array.length obls in
+      let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
+      let obls = init_obls obls in
+      let rem = Array.fold_left (fun acc obl -> if obl.obl_body = None then succ acc else acc) 0 obls in
+      let prg = { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = (obls, rem) } in
+	if rem < len then 
+	  Options.if_verbose ppnl (int rem ++ str " obligation(s) remaining.");
+	if rem = 0 then 
+	  declare_definition prg
+	else
+	  from_prg := ProgMap.add n prg !from_prg)
+	    
+let error s = Util.error s
+
+let get_prog name =
+  let prg_infos = !from_prg in
+    match name with
+	Some n -> ProgMap.find n prg_infos
+      | None -> 
+	  (let n = map_cardinal prg_infos in
+	     match n with 
+		 0 -> error "No obligations remaining"
+	       | 1 -> map_first prg_infos
+	       | _ -> error "More than one program with unsolved obligations")
+
+let update_obls prg obls rem = 
+  let prg' = { prg with prg_obligations = (obls, rem) } in
+    if rem > 1 then (
+      debug 2 (int rem ++ str " obligations remaining");
+      from_prg := map_replace prg.prg_name prg' !from_prg)
+    else (
+      declare_definition prg';
+      from_prg := ProgMap.remove prg.prg_name !from_prg
+    )		 
+	    
+let is_defined obls x = obls.(x).obl_body <> None
+
+let deps_remaining obls x = 
+  let deps = obls.(x).obl_deps in
+    Intset.fold
+      (fun x acc -> 
+	 if is_defined obls x then acc
+	 else x :: acc)
+      deps []
+
+let subst_deps obls obl =
+  let t' = 
+    Intset.fold
+      (fun x acc ->
+	 let xobl = obls.(x) in
+	 let oblb = out_some xobl.obl_body in
+	   Term.subst1 oblb (Term.subst_var xobl.obl_name acc))
+      obl.obl_deps obl.obl_type
+  in { obl with obl_type = t' }
+
+let subtac_obligation (user_num, name) =
+  let num = pred user_num in
+  let prg = get_prog name in
+  let obls, rem = prg.prg_obligations in
+    if num < Array.length obls then
+      let obl = obls.(num) in
+	match obl.obl_body with
+	    None -> 
+	      (match deps_remaining obls num with
+		  [] ->
+		    let obl = subst_deps obls obl in
+		    Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type
+		      (fun strength gr -> 
+			 debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished");		   
+			 let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in
+			 let obls = Array.copy obls in
+			 let _ = obls.(num) <- obl in
+			   update_obls prg obls (pred rem));
+		    trace (str "Started obligation " ++ int user_num ++ str "  proof")
+     		 | l -> msgnl (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
+		     ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)))
+	  | Some r -> error "Obligation already solved"
+    else error (sprintf "Unknown obligation number %i" (succ num))
+      
+      
+let obligations_of_evars evars =
+  let arr = 
+    Array.of_list
+      (List.map
+	 (fun (n, t) ->
+	    { obl_name = n;
+	      obl_type = t;
+	      obl_body = None;
+	      obl_deps = Intset.empty;
+	    }) evars)
+  in arr, Array.length arr
+
+let solve_obligations n tac = 
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+  let rem = ref rem in
+  let obls' = 
+    Array.map (fun x -> 
+		 match x.obl_body with 
+		     Some _ -> x
+		   | None -> 
+		       try
+			 let t = Subtac_utils.solve_by_tac (evar_of_obligation x) tac in
+			   decr rem;
+			   { x with obl_body = Some t }
+		       with _ -> x)
+      obls
+  in
+    update_obls prg obls' !rem
+
+open Pp
+let show_obligations n =
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+    msgnl (int rem ++ str " obligation(s) remaining: ");
+    Array.iteri (fun i x -> 
+		   match x.obl_body with 
+		       None -> msgnl (int (succ i) ++ str " : " ++ spc () ++ 
+					my_print_constr (Global.env ()) x.obl_type)
+		    | Some _ -> ())
+      obls
+			
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
new file mode 100644
index 00000000..7d93d57b
--- /dev/null
+++ b/contrib/subtac/subtac_obligations.mli
@@ -0,0 +1,10 @@
+open Util
+
+val add_entry : Names.identifier -> Term.constr -> Term.types ->
+  (Names.identifier * Term.types * Intset.t) array -> unit
+
+val subtac_obligation : int * Names.identifier option -> unit
+
+val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit
+
+val show_obligations : Names.identifier option -> unit
diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml
index 261e0c5b..a243ba34 100644
--- a/contrib/subtac/subtac_pretyping.ml
+++ b/contrib/subtac/subtac_pretyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping.ml 8889 2006-06-01 20:23:56Z msozeau $ *)
+(* $Id: subtac_pretyping.ml 9326 2006-10-31 12:57:26Z msozeau $ *)
 
 open Global
 open Pp
@@ -151,3 +151,13 @@ let subtac_process env isevars id l c tycon =
   let evm = non_instanciated_map env isevars in
   let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in
     evm, fullcoqc, fullctyp
+
+open Subtac_obligations
+
+let subtac_proof env isevars id l c tycon =
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
+  let evm, coqc, coqt = subtac_process env isevars id l c tycon in
+  let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in
+    trace (str "Adding to obligations list");
+    add_entry id def coqt evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli
index 97e56ecb..b62a8766 100644
--- a/contrib/subtac/subtac_pretyping.mli
+++ b/contrib/subtac/subtac_pretyping.mli
@@ -10,3 +10,6 @@ module Pretyping : Pretyping.S
 
 val subtac_process : env -> evar_defs ref -> identifier -> local_binder list ->
   constr_expr -> constr_expr option -> evar_map * constr * types
+
+val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list ->
+  constr_expr -> constr_expr option -> unit
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml
index 65952750..46af5886 100644
--- a/contrib/subtac/subtac_pretyping_F.ml
+++ b/contrib/subtac/subtac_pretyping_F.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping_F.ml 8889 2006-06-01 20:23:56Z msozeau $ *)
+(* $Id: subtac_pretyping_F.ml 9316 2006-10-29 22:49:11Z herbelin $ *)
 
 open Pp
 open Util
@@ -315,12 +315,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
 	let resj =
 	  match kind_of_term resj.uj_val with
-	  | App (f,args) when isInd f ->
+	  | App (f,args) when isInd f or isConst f ->
 	      let sigma = evars_of !isevars in
-	      let t = Retyping.type_of_inductive_knowing_parameters env sigma (destInd f) args in
-	      let s = snd (splay_arity env sigma t) in
-	      on_judgment_type (set_inductive_level env s) resj
-		(* Rem: no need to send sigma: no head evar, it's an arity *)
+	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
+	      let t = Retyping.get_type_of env sigma c in
+	      make_judge c t
 	  | _ -> resj in
 	inh_conv_coerce_to_tycon loc env isevars resj tycon
 
@@ -557,35 +556,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  (pretype_type empty_valcon env isevars lvar c).utj_val in
       nf_evar (evars_of !isevars) c'
 
-  (* [check_evars] fails if some unresolved evar remains *)
-  (* it assumes that the defined existentials have already been substituted
-     (should be done in unsafe_infer and unsafe_infer_type) *)
-
-  let check_evars env initial_sigma isevars c =
-    let sigma = evars_of !isevars in
-    let rec proc_rec c =
-      match kind_of_term c with
-	| Evar (ev,args) ->
-            assert (Evd.mem sigma ev);
-	    if not (Evd.mem initial_sigma ev) then
-              let (loc,k) = evar_source ev !isevars in
-		error_unsolvable_implicit loc env sigma k
-	| _ -> iter_constr proc_rec c
-    in
-      proc_rec c(*;
-		  let (_,pbs) = get_conv_pbs !isevars (fun _ -> true) in
-		  if pbs <> [] then begin
-		  pperrnl
-		  (str"TYPING OF "++Termops.print_constr_env env c++fnl()++
-		  prlist_with_sep fnl
-		  (fun  (pb,c1,c2) ->
-		  Termops.print_constr c1 ++
-		  (if pb=Reduction.CUMUL then str " <="++ spc()
-		  else str" =="++spc()) ++
-		  Termops.print_constr c2)
-		  pbs ++ fnl())
-		  end*)
-
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
      retourne aussi le nouveau sigma...
@@ -595,6 +565,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     let isevars = ref (create_evar_defs sigma) in
     let j = pretype empty_tycon env isevars ([],[]) c in
     let j = j_nf_evar (evars_of !isevars) j in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
       check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
       j
 
@@ -611,8 +582,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   let ise_pretype_gen fail_evar sigma env lvar kind c =
     let isevars = ref (Evd.create_evar_defs sigma) in
     let c = pretype_gen isevars env lvar kind c in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
+    let c = nf_evar (evars_of isevars) c in
       if fail_evar then check_evars env sigma isevars c;
-      !isevars, c
+      isevars, c
 
   (** Entry points of the high-level type synthesis algorithm *)
 
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
index d4db7c27..7b96758a 100644
--- a/contrib/subtac/subtac_utils.ml
+++ b/contrib/subtac/subtac_utils.ml
@@ -80,25 +80,34 @@ open Pp
 let my_print_constr = Termops.print_constr_env
 let my_print_constr_expr = Ppconstr.pr_constr_expr
 let my_print_context = Termops.print_rel_context
+let my_print_named_context = Termops.print_named_context
 let my_print_env = Termops.print_env
 let my_print_rawconstr = Printer.pr_rawconstr_env
 let my_print_evardefs = Evd.pr_evar_defs
 
 let my_print_tycon_type = Evarutil.pr_tycon_type
 
-let debug_level = 2
+let debug_level = 1
+
+let debug_on = true
 
 let debug n s = 
-  if !Options.debug && n >= debug_level then
-    msgnl s
+  if debug_on then
+    if !Options.debug && n >= debug_level then
+      msgnl s
+    else ()
   else ()
 
 let debug_msg n s = 
-  if !Options.debug  && n >= debug_level then s
+  if debug_on then
+    if !Options.debug  && n >= debug_level then s
+    else mt ()
   else mt ()
 
 let trace s = 
-  if !Options.debug  && debug_level > 0 then msgnl s
+  if debug_on then
+    if !Options.debug  && debug_level > 0 then msgnl s
+    else ()
   else ()
 
 let wf_relations = Hashtbl.create 10
@@ -167,30 +176,6 @@ let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixp
 open Tactics
 open Tacticals
 
-let build_dependent_sum l =
-  let rec aux (tac, typ) = function
-      (n, t) :: tl ->
-	let t' = mkLambda (Name n, t, typ) in
-	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
-	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) t)	    	     
-	   with _ -> ());
-	let tac' = 
-	  tclTHENS (assert_tac true (Name n) t) 
-	    ([intros;
-	      (tclTHENSEQ 
-		 [constructor_tac (Some 1) 1 
-		    (Rawterm.ImplicitBindings [mkVar n]);
-		  tac]);
-	     ])
-	in
-	let newt = mkApp (Lazy.force ex_ind, [| t; t'; |]) in
-	  aux (tac', newt) tl
-    | [] -> tac, typ
-  in 
-    match l with 
-	(_, hd) :: tl -> aux (intros, hd) tl
-      | [] -> raise (Invalid_argument "build_dependent_sum")
-
 let id x = x
 
 let build_dependent_sum l =
@@ -438,3 +423,32 @@ let rewrite_cases env c =
   let c' = rewrite_cases c in
   let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in
     c'
+
+let id_of_name = function
+    Name n -> n
+  | Anonymous -> raise (Invalid_argument "id_of_name")
+
+let definition_message id =
+  Options.if_verbose message ((string_of_id id) ^ " is defined")
+
+let recursive_message v =
+  match Array.length v with
+    | 0 -> error "no recursive definition"
+    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
+    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+		    spc () ++ str "are recursively defined")
+
+(* Solve an obligation using tactics, return the corresponding proof term *)
+let solve_by_tac ev t =
+  debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev);
+  let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in
+  let ts = Tacmach.mk_pftreestate goal in
+  let solved_state = Tacmach.solve_pftreestate t ts in
+  let c = Tacmach.extract_pftreestate solved_state in
+    debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c);
+    c
+
+let rec string_of_list sep f = function
+    [] -> ""
+  | x :: [] -> f x
+  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli
index 4a7e8177..ebfc5123 100644
--- a/contrib/subtac/subtac_utils.mli
+++ b/contrib/subtac/subtac_utils.mli
@@ -10,6 +10,7 @@ open Rawterm
 open Util
 open Evarutil
 open Names
+open Sign
 
 val contrib_name : string
 val subtac_dir : string list
@@ -51,6 +52,7 @@ val my_print_constr : env -> constr -> std_ppcmds
 val my_print_constr_expr : constr_expr -> std_ppcmds
 val my_print_evardefs : evar_defs -> std_ppcmds
 val my_print_context : env -> std_ppcmds
+val my_print_named_context : env -> std_ppcmds
 val my_print_env : env -> std_ppcmds
 val my_print_rawconstr : env -> rawconstr -> std_ppcmds
 val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
@@ -88,3 +90,11 @@ val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->
 val destruct_ex : constr -> constr -> constr list
 
 val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr
+val id_of_name : name -> identifier
+
+val definition_message : identifier -> unit
+val recursive_message : global_reference array -> std_ppcmds
+
+val solve_by_tac : evar_info -> Tacmach.tactic -> constr
+
+val string_of_list : string -> ('a -> string) -> 'a list -> string
diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v
new file mode 100644
index 00000000..7ab720f6
--- /dev/null
+++ b/contrib/subtac/test/ListDep.v
@@ -0,0 +1,86 @@
+Require Import List.
+Require Import Coq.subtac.Utils.
+
+Set Implicit Arguments.
+
+Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
+
+Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
+Proof.
+  intros.
+  inversion H.
+  split.
+  intros.
+  apply H0.
+  auto with datatypes.
+  auto with arith.
+Qed.
+
+Section Map_DependentRecursor.
+  Variable U V : Set.
+  Variable l : list U.
+  Variable f : { x : U | In x l } -> V.
+
+  Program Fixpoint map_rec ( l' : list U | sub_list l' l )
+    { measure l' length } : { r : list V | length r = length l' } :=
+    match l' with
+    nil => nil
+    | cons x tl => let tl' := map_rec tl in
+	f x :: tl'
+    end.
+    
+    Obligation 1.
+    intros.
+    destruct tl' ; simpl ; simpl in e.
+    subst x0 tl0.
+    rewrite <- Heql'.
+    rewrite e.
+    auto.
+    Qed.
+
+    Obligation 2.
+    simpl.
+    intros.
+    destruct l'.
+    simpl in Heql'.
+    destruct x0 ; simpl ; try discriminate.
+    inversion Heql'.
+    inversion s.
+    apply H.
+    auto with datatypes.
+    Qed.
+
+
+    Obligation 3 of map_rec.
+    simpl.
+    intros.
+    rewrite <- Heql'.
+    simpl ; auto with arith.
+    Qed.
+
+    Obligation 4.
+    simpl.
+    intros.
+    destruct l'.
+    simpl in Heql'.
+    destruct x0 ; simpl ; try discriminate.
+    inversion Heql'.
+    subst x tl.
+    apply sub_list_tl with u ; auto.
+    Qed.
+  
+    Obligation 5.
+    intros.
+    rewrite <- Heql' ; auto.
+    Qed.
+    
+    Program Definition map : list V := map_rec l.
+    Obligation 1.
+      split ; auto.
+    Qed.
+    
+End Map_DependentRecursor.
+
+Extraction map.
+Extraction map_rec.
+
diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
index f217b037..ff07c3c4 100644
--- a/contrib/xml/cic2acic.ml
+++ b/contrib/xml/cic2acic.ml
@@ -241,7 +241,7 @@ let typeur sigma metamap =
           Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
     | T.Const c ->
         let cb = Environ.lookup_constant c env in
-        T.body_of_type cb.Declarations.const_type
+        Typeops.type_of_constant_type env (cb.Declarations.const_type)
     | T.Evar ev -> Evd.existential_type sigma ev
     | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind)
     | T.Construct cstr ->
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
index a3336817..c7d3b4ff 100644
--- a/contrib/xml/doubleTypeInference.ml
+++ b/contrib/xml/doubleTypeInference.ml
@@ -122,7 +122,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
         Typeops.judge_of_variable env id
 	  
      | T.Const c ->
-        E.make_judge cstr (E.constant_type env c)
+        E.make_judge cstr (Typeops.type_of_constant env c)
 	  
      | T.Ind ind ->
         E.make_judge cstr (Inductiveops.type_of_inductive env ind)
diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml
index 678b650c..92cbf6df 100644
--- a/contrib/xml/proof2aproof.ml
+++ b/contrib/xml/proof2aproof.ml
@@ -63,21 +63,24 @@ let nf_evar sigma ~preserve =
 (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
 let rec unshare_proof_tree =
  let module PT = Proof_type in
-  function {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = ref} ->
+  function {PT.open_subgoals = status ; 
+	    PT.goal = goal ; 
+	    PT.ref = ref} ->
    let unshared_ref =
     match ref with
        None -> None
      | Some (rule,pfs) ->
         let unshared_rule =
          match rule with
-            PT.Prim prim -> PT.Prim prim
-          | PT.Change_evars -> PT.Change_evars
-          | PT.Tactic (tactic_expr, pf) ->
-             PT.Tactic (tactic_expr, unshare_proof_tree pf)
-        in
+             PT.Nested (cmpd, pf) ->
+               PT.Nested (cmpd, unshare_proof_tree pf)
+	   | other -> other
+	in
          Some (unshared_rule, List.map unshare_proof_tree pfs)
    in
-    {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = unshared_ref}
+    {PT.open_subgoals = status ; 
+     PT.goal = goal ; 
+     PT.ref = unshared_ref}
 ;;
 
 module ProofTreeHash =
@@ -103,7 +106,7 @@ let extract_open_proof sigma pf =
        {PT.ref=Some(PT.Prim _,_)} as pf ->
         L.prim_extractor proof_extractor vl pf
 	  
-     | {PT.ref=Some(PT.Tactic (_,hidden_proof),spfl)} ->
+     | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
 	 let sgl,v = Refiner.frontier hidden_proof in
 	 let flat_proof = v spfl in
          ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4
index 578c1ed2..dbdc79a8 100644
--- a/contrib/xml/proofTree2Xml.ml4
+++ b/contrib/xml/proofTree2Xml.ml4
@@ -141,7 +141,7 @@ Pp.ppnl (Pp.(++) (Pp.str
               (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
 
      | {PT.goal=goal;
-        PT.ref=Some(PT.Tactic (tactic_expr,hidden_proof),nodes)} ->
+        PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
          (* [hidden_proof] is the proof of the tactic;                     *)
          (* [nodes] are the proof of the subgoals generated by the tactic; *)
          (* [flat_proof] if the proof-tree obtained substituting [nodes]   *)
@@ -194,6 +194,12 @@ Pp.ppnl (Pp.(++) (Pp.str
           (List.fold_left
             (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
 
+     | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
+         Util.anomaly "Not Implemented" 
+
+     | {PT.ref=Some(PT.Daimon,_)} ->
+         X.xml_empty "Hidden_open_goal" of_attribute
+
      | {PT.ref=None;PT.goal=goal} ->
          X.xml_empty "Open_goal" of_attribute
   in
diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
index b6b1c7b6..f286d2c8 100644
--- a/contrib/xml/xmlcommand.ml
+++ b/contrib/xml/xmlcommand.ml
@@ -408,7 +408,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite =
        let {D.mind_consnames=consnames ;
             D.mind_typename=typename } = p
        in
-        let arity = Inductive.type_of_inductive (mib,p) in
+        let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
         let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
         let cons =
          (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
@@ -522,6 +522,7 @@ let print internal glob_ref kind xml_library_root =
        let id = N.id_of_label (N.con_label kn) in
        let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} =
         G.lookup_constant kn in
+       let typ = Typeops.type_of_constant_type (Global.env()) typ in
         Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
     | Ln.IndRef (kn,_) ->
        let mib = G.lookup_mind kn in
@@ -531,7 +532,7 @@ let print internal glob_ref kind xml_library_root =
             D.mind_finite=finite} = mib in
           Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
     | Ln.ConstructRef _ ->
-       Util.anomaly ("print: this should not happen")
+       Util.error ("a single constructor cannot be printed in XML")
   in
   let fn = filename_of_path xml_library_root tag in
   let uri = Cic2acic.uri_of_kernel_name tag in
@@ -547,14 +548,12 @@ let print_ref qid fn =
 (*  where dest is either None (for stdout) or (Some filename) *)
 (* pretty prints via Xml.pp the proof in progress on dest     *)
 let show_pftreestate internal fn (kind,pftst) id =
- let str = Names.string_of_id id in
  let pf = Tacmach.proof_of_pftreestate pftst in
  let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in
  let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree,
      unshared_pf
  =
   Proof2aproof.extract_open_pftreestate pftst in
- let kn = Lib.make_kn id in
  let env = Global.env () in
  let obj =
   mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in