Imported Upstream version 8.1+dfsgupstream/8.1+dfsg

50 files changed, 5696 insertions, 2422 deletions

diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml
index af684e6e..131dd029 100644
--- a/contrib/dp/dp.ml
+++ b/contrib/dp/dp.ml
@@ -639,8 +639,8 @@ let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
 let sprintf = Format.sprintf
 
 let call_simplify fwhy =
-  if Sys.command (sprintf "why --simplify %s" fwhy) <> 0 then
-    anomaly ("call to why --simplify " ^ fwhy ^ " failed; please report");
+  let cmd = sprintf "why --simplify %s" fwhy in
+  if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed");
   let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
   let cmd = 
     sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" fsx
@@ -652,8 +652,7 @@ let call_simplify fwhy =
 
 let call_zenon fwhy =
   let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in
-  if Sys.command cmd <> 0 then
-    anomaly ("call to " ^ cmd ^ " failed; please report");
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
   let cmd = 
     sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn
@@ -669,8 +668,8 @@ let call_zenon fwhy =
   r
 
 let call_cvcl fwhy =
-  if Sys.command (sprintf "why --cvcl %s" fwhy) <> 0 then
-    anomaly ("call to why --cvcl " ^ fwhy ^ " failed; please report");
+  let cmd = sprintf "why --cvcl %s" fwhy in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
   let cmd = 
     sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" fcvc
@@ -681,8 +680,8 @@ let call_cvcl fwhy =
   r
 
 let call_harvey fwhy =
-  if Sys.command (sprintf "why --harvey %s" fwhy) <> 0 then
-    anomaly ("call to why --harvey " ^ fwhy ^ " failed; please report");
+  let cmd = sprintf "why --harvey %s" fwhy in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
   let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
   if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
index 2d425e9f..e31b701c 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 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: extract_env.ml 9486 2007-01-15 19:11:28Z letouzey $ i*)
 
 open Term
 open Declarations
@@ -53,23 +53,55 @@ let environment_until dir_opt =
 	  | _ -> assert false
   in parse (Library.loaded_libraries ())
 
-type visit =
- { mutable kn : KNset.t; mutable ref : Refset.t; mutable mp : MPset.t }
 
-let in_kn v kn = KNset.mem kn v.kn
-let in_ref v ref = Refset.mem ref v.ref
-let in_mp v mp = MPset.mem mp v.mp
-
-let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp
-let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn)
-let visit_ref v r =
- let r =
-  (* if we meet a constructor we must export the inductive definition *)
-  match r with
-     ConstructRef (r,_) -> IndRef r
-   | _ -> r
- in
-  v.ref <- Refset.add r v.ref; visit_mp v (modpath_of_r r) 
+(*s Visit: 
+  a structure recording the needed dependencies for the current extraction *)
+
+module type VISIT = sig 
+  (* Reset the dependencies by emptying the visit lists *)
+  val reset : unit -> unit
+    
+  (* Add the module_path and all its prefixes to the mp visit list *)  
+  val add_mp : module_path -> unit
+    
+  (* Add kernel_name / constant / reference / ... in the visit lists. 
+     These functions silently add the mp of their arg in the mp list *)
+  val add_kn : kernel_name -> unit
+  val add_con : constant -> unit
+  val add_ref : global_reference -> unit
+  val add_decl_deps : ml_decl -> unit
+  val add_spec_deps : ml_spec -> unit
+
+  (* Test functions: 
+     is a particular object a needed dependency for the current extraction ? *)
+  val needed_kn : kernel_name -> bool 
+  val needed_con : constant -> bool
+  val needed_mp : module_path -> bool
+end
+  
+module Visit : VISIT = struct 
+  (* Thanks to C.S.C, what used to be in a single KNset should now be split 
+     into a KNset (for inductives and modules names) and a Cset for constants 
+     (and still the remaining MPset) *)
+  type must_visit = 
+      { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t }
+  (* the imperative internal visit lists *)
+  let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } 
+  (* the accessor functions *)
+  let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
+  let needed_kn kn = KNset.mem kn v.kn
+  let needed_con c = Cset.mem c v.con
+  let needed_mp mp = MPset.mem mp v.mp
+  let add_mp mp = v.mp <- MPset.union (prefixes_mp mp) v.mp
+  let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn)
+  let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c)
+  let add_ref = function 
+    | ConstRef c -> add_con c
+    | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn
+    | VarRef _ -> assert false
+  let add_decl_deps = decl_iter_references add_ref add_ref add_ref 
+  let add_spec_deps = spec_iter_references add_ref add_ref add_ref
+end
 
 exception Impossible
 
@@ -104,115 +136,108 @@ let factor_fix env l cb msb =
     labels, recd, msb''
   end
 
-let get_decl_references v d = 
-  let f = visit_ref v in decl_iter_references f f f d
-
-let get_spec_references v s = 
-  let f = visit_ref v in spec_iter_references f f f s
-
-let rec extract_msig env v mp = function 
+let rec extract_msig env mp = function 
   | [] -> [] 
   | (l,SPBconst cb) :: msig -> 
       let kn = make_con mp empty_dirpath l in 
       let s = extract_constant_spec env kn cb in 
-      if logical_spec s then extract_msig env v mp msig
+      if logical_spec s then extract_msig env mp msig
       else begin
-	get_spec_references v s; 
-	(l,Spec s) :: (extract_msig env v mp msig)
+	Visit.add_spec_deps s;
+	(l,Spec s) :: (extract_msig env mp msig)
       end
   | (l,SPBmind cb) :: msig -> 
       let kn = make_kn mp empty_dirpath l in 
       let s = Sind (kn, extract_inductive env kn) in 
-      if logical_spec s then extract_msig env v mp msig
+      if logical_spec s then extract_msig env mp msig
       else begin 
-	get_spec_references v s; 
-	(l,Spec s) :: (extract_msig env v mp msig)
+	Visit.add_spec_deps s;
+	(l,Spec s) :: (extract_msig env mp msig)
       end
   | (l,SPBmodule {msb_modtype=mtb}) :: msig -> 
-(*i      let mpo = Some (MPdot (mp,l)) in  i*)
-      (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig)
+      (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig)
   | (l,SPBmodtype mtb) :: msig -> 
-      (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig)
+      (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig)
 
-and extract_mtb env v mpo = function 
-  | MTBident kn -> visit_kn v kn; MTident kn 
+and extract_mtb env mpo = function 
+  | MTBident kn -> Visit.add_kn kn; MTident kn 
   | MTBfunsig (mbid, mtb, mtb') -> 
       let mp = MPbound mbid in 
       let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
-      MTfunsig (mbid, extract_mtb env v None mtb, 
-		extract_mtb env' v None mtb') 
+      MTfunsig (mbid, extract_mtb env None mtb, 
+		extract_mtb env' None mtb') 
   | MTBsig (msid, msig) -> 
       let mp, msig = match mpo with 
 	| None -> MPself msid, msig
 	| Some mp -> mp, Modops.subst_signature_msid msid mp msig
       in
       let env' = Modops.add_signature mp msig env in 
-      MTsig (msid, extract_msig env' v mp msig) 
+      MTsig (msid, extract_msig env' mp msig) 
 
-let rec extract_msb env v mp all = function 
+let rec extract_msb env mp all = function 
   | [] -> [] 
   | (l,SEBconst cb) :: msb -> 
       (try 
 	 let vl,recd,msb = factor_fix env l cb msb in 
-	 let vkn = Array.map (fun id -> make_con mp empty_dirpath id) vl in
-	 let ms = extract_msb env v mp all msb in 
-	 let b = array_exists (fun con -> in_ref v (ConstRef con)) vkn in 
+	 let vc = Array.map (make_con mp empty_dirpath) vl in
+	 let ms = extract_msb env mp all msb in 
+	 let b = array_exists Visit.needed_con vc in 
 	 if all || b then 
-	   let d = extract_fixpoint env vkn recd in 
+	   let d = extract_fixpoint env vc recd in
 	   if (not b) && (logical_decl d) then ms 
-	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_msb env v mp all msb in 
-	 let kn = make_con mp empty_dirpath l in 
-	 let b = in_ref v (ConstRef kn) in 
+	 let ms = extract_msb env mp all msb in 
+	 let c = make_con mp empty_dirpath l in 
+	 let b = Visit.needed_con c in 
 	 if all || b then 
-	   let d = extract_constant env kn cb in
+	   let d = extract_constant env c cb in
 	   if (not b) && (logical_decl d) then ms 
-	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
   | (l,SEBmind mib) :: msb ->
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let kn = make_kn mp empty_dirpath l in 
-      let b = in_ref v (IndRef (kn,0)) in  (* 0 is dummy *)
+      let b = Visit.needed_kn kn in
       if all || b then 
 	let d = Dind (kn, extract_inductive env kn) in 
 	if (not b) && (logical_decl d) then ms 
-	else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
   | (l,SEBmodule mb) :: msb -> 
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let mp = MPdot (mp,l) in 
-      if all || in_mp v mp then 
-	(l,SEmodule (extract_module env v mp true mb)) :: ms
+      if all || Visit.needed_mp mp then 
+	(l,SEmodule (extract_module env mp true mb)) :: ms
       else ms
   | (l,SEBmodtype mtb) :: msb ->
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let kn = make_kn mp empty_dirpath l in
-      if all || in_kn v kn then 
-	(l,SEmodtype (extract_mtb env v None mtb)) :: ms
+      if all || Visit.needed_kn kn then 
+	(l,SEmodtype (extract_mtb env None mtb)) :: ms
       else ms
 
-and extract_meb env v mpo all = function 
+and extract_meb env mpo all = function 
   | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
-  | MEBident mp -> visit_mp v mp; MEident mp 
+  | MEBident mp -> Visit.add_mp mp; MEident mp 
   | MEBapply (meb, meb',_) -> 
-      MEapply (extract_meb env v None true meb, 
-	       extract_meb env v None true meb')
+      MEapply (extract_meb env None true meb, 
+	       extract_meb env None true meb')
   | MEBfunctor (mbid, mtb, meb) -> 
       let mp = MPbound mbid in 
       let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
-      MEfunctor (mbid, extract_mtb env v None mtb, 
-		 extract_meb env' v None true meb)
+      MEfunctor (mbid, extract_mtb env None mtb, 
+		 extract_meb env' None true meb)
   | MEBstruct (msid, msb) -> 
       let mp,msb = match mpo with 
 	| None -> MPself msid, msb 
 	| Some mp -> mp, subst_msb (map_msid msid mp) msb
       in 
       let env' = add_structure mp msb env in 
-      MEstruct (msid, extract_msb env' v mp all msb) 
+      MEstruct (msid, extract_msb env' mp all msb) 
 
-and extract_module env v mp all mb = 
+and extract_module env mp all mb = 
   (* [mb.mod_expr <> None ], since we look at modules from outside. *)
   (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *)
   let meb = out_some mb.mod_expr in
@@ -220,25 +245,21 @@ and extract_module env v mp all mb =
   (* Because of the "with" construct, the module type can be [MTBsig] with *)
   (* a msid different from the one of the module. Here is the patch. *)
   let mtb = replicate_msid meb mtb in
-  { ml_mod_expr = extract_meb env v (Some mp) all meb;
-    ml_mod_type = extract_mtb env v None mtb }
+  { ml_mod_expr = extract_meb env (Some mp) all meb;
+    ml_mod_type = extract_mtb env None mtb }
 
 let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
 
 let mono_environment refs mpl = 
-  let l = environment_until None in 
-  let v = 
-    let add_ref r = Refset.add r in 
-    let refs = List.fold_right add_ref refs Refset.empty in 
-    let add_mp mp = MPset.union (prefixes_mp mp) in
-    let mps = List.fold_right add_mp mpl MPset.empty in 
-    let mps = Refset.fold (fun k -> add_mp (modpath_of_r k)) refs mps in 
-    { kn = KNset.empty; ref = refs; mp = mps }
-  in 
+  Visit.reset ();
+  List.iter Visit.add_ref refs; 
+  List.iter Visit.add_mp mpl; 
   let env = Global.env () in 
-  List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) 
-    (List.rev l)
+  let l = List.rev (environment_until None) in 
+  List.rev_map 
+    (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l
 
+    
 (*s Recursive extraction in the Coq toplevel. The vernacular command is
     \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env]
     to get the saturated environment to extract. *)
@@ -259,6 +280,7 @@ let mono_extraction (f,m) qualids =
   let prm = {modular=false; mod_name = m; to_appear= refs} in
   let struc = optimize_struct prm None (mono_environment refs mps) in 
   print_structure_to_file f prm struc; 
+  Visit.reset ();
   reset_tables ()
 
 let extraction_rec = mono_extraction (None,id_of_string "Main")
@@ -277,15 +299,15 @@ let extraction qid =
     let r = Nametab.global qid in 
     if is_custom r then
       msgnl (str "User defined extraction:" ++ spc () ++ 
-	     str (find_custom r) ++ fnl ()) 
-    else begin 
+	       str (find_custom r) ++ fnl ()) 
+    else
       let prm = 
-	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in 
+	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in
       let struc = optimize_struct prm None (mono_environment [r] []) in 
       let d = get_decl_in_structure r struc in 
       print_one_decl struc (modpath_of_r r) d;
-      reset_tables ()
-    end
+      Visit.reset (); 
+      reset_tables () 
 
 (*s Extraction to a file (necessarily recursive). 
     The vernacular command is 
@@ -313,32 +335,33 @@ let extraction_file f vl =
 let extraction_module m = 
   check_inside_section (); 
   check_inside_module ();
-  match lang () with 
+  begin match lang () with 
     | Toplevel -> error_toplevel ()
     | Scheme -> error_scheme ()
-    | _ -> 
-	let q = snd (qualid_of_reference m) in 
-	let mp = 
-	  try Nametab.locate_module q
-	  with Not_found -> error_unknown_module q
-	in 
-	let b = is_modfile mp in 
-	let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
-	let l = environment_until None in 
-	let v={ kn = KNset.empty ; ref = Refset.empty; mp = prefixes_mp mp } in
-	let env = Global.env () in 
-	let struc = 
-	  List.rev_map
-	    (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) 
-	    (List.rev l)
-	in 
-	let struc = optimize_struct prm None struc in 
-	let struc = 
-	  let bmp = base_mp mp in 
-	  try [bmp, List.assoc bmp struc] with Not_found -> assert false
-	in
-	print_structure_to_file None prm struc; 
-	reset_tables ()
+    | _ -> ()
+  end; 
+  let q = snd (qualid_of_reference m) in 
+  let mp = 
+    try Nametab.locate_module q with Not_found -> error_unknown_module q
+  in 
+  let b = is_modfile mp in 
+  let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
+  Visit.reset ();
+  Visit.add_mp mp; 
+  let env = Global.env () in 
+  let l = List.rev (environment_until None) in 
+  let struc = 
+    List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) b m)) l
+  in
+  let struc = optimize_struct prm None struc in 
+  let struc = 
+    let bmp = base_mp mp in 
+    try [bmp, List.assoc bmp struc] with Not_found -> assert false
+  in
+  print_structure_to_file None prm struc; 
+  Visit.reset (); 
+  reset_tables ()
+
 
 (*s (Recursive) Extraction of a library. The vernacular command is 
   \verb!(Recursive) Extraction Library! [M]. *) 
@@ -355,38 +378,38 @@ let dir_module_of_id m =
 let extraction_library is_rec m =
   check_inside_section (); 
   check_inside_module ();  
-  match lang () with 
+  begin match lang () with 
     | Toplevel -> error_toplevel ()
     | Scheme -> error_scheme ()
-    | _ -> 
-	let dir_m = dir_module_of_id m in 
-	let v =
-         { kn = KNset.empty; ref = Refset.empty;
-           mp = MPset.singleton (MPfile dir_m) } in 
-	let l = environment_until (Some dir_m) in 
-	let struc = 
-	  let env = Global.env () in
-	  let select l (mp,meb) = 
-	    if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *)
-	    then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l 
-	    else l
-	  in 
-	  List.fold_left select [] (List.rev l)
-	in 
-	let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
-	let struc = optimize_struct dummy_prm None struc in 
-	let rec print = function 
-	  | [] -> () 
-	  | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l 
-	  | (MPfile dir, sel) as e :: l -> 
-	      let short_m = snd (split_dirpath dir) in
-	      let f = module_file_name short_m in 
-	      let prm = {modular=true;mod_name=short_m;to_appear=[]} in
-	      print_structure_to_file (Some f) prm [e]; 
-	      print l 
-	  | _ -> assert false
-	in print struc; 
-	reset_tables ()
+    | _ -> () 
+  end; 
+  let dir_m = dir_module_of_id m in 
+  Visit.reset (); 
+  Visit.add_mp (MPfile dir_m); 
+  let env = Global.env () in	
+  let l = List.rev (environment_until (Some dir_m)) in 
+  let select l (mp,meb) = 
+    if Visit.needed_mp mp 
+    then (mp, unpack (extract_meb env (Some mp) true meb)) :: l 
+    else l
+  in 
+  let struc = List.fold_left select [] l in 
+  let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
+  let struc = optimize_struct dummy_prm None struc in 
+  let rec print = function 
+    | [] -> () 
+    | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l 
+    | (MPfile dir, sel) as e :: l -> 
+	let short_m = snd (split_dirpath dir) in
+	let f = module_file_name short_m in 
+	let prm = {modular=true;mod_name=short_m;to_appear=[]} in
+	print_structure_to_file (Some f) prm [e]; 
+	print l 
+    | _ -> assert false
+  in 
+  print struc; 
+  Visit.reset ();
+  reset_tables ()
 
 
 
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 52e7f1dd..6fd4a3cc 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 9310 2006-10-28 19:35:09Z herbelin $ i*)
+(*i $Id: extraction.ml 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 (*i*)
 open Util
@@ -310,6 +310,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
   with Not_found -> 
     internal_call := KNset.add kn !internal_call;
     let mib = Environ.lookup_mind kn env in 
+    (* First, if this inductive is aliased via a Module, *)
+    (* we process the original inductive. *)
+    option_iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; 
     (* Everything concerning parameters. *)
     (* We do that first, since they are common to all the [mib]. *)
     let mip0 = mib.mind_packets.(0) in 
@@ -332,7 +335,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	     ip_types = t }) 
 	mib.mind_packets 
     in 
-    add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets};
+    add_ind kn 
+      {ind_info = Standard; 
+       ind_nparams = npar; 
+       ind_packets = packets; 
+       ind_equiv = mib.mind_equiv };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
       let p = packets.(i) in 
@@ -413,7 +420,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	Record field_glob
       with (I info) -> info
     in
-    let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in
+    let i = {ind_info = ind_info; 
+	     ind_nparams = npar; 
+	     ind_packets = packets; 
+	     ind_equiv = mib.mind_equiv}
+    in
     add_ind kn i; 
     internal_call := KNset.remove kn !internal_call;
     i
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
index e34abe02..3b4146f8 100644
--- a/contrib/extraction/miniml.mli
+++ b/contrib/extraction/miniml.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: miniml.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
+(*i $Id: miniml.mli 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 (*s Target language for extraction: a core ML called MiniML. *)
 
@@ -79,7 +79,9 @@ type ml_ind_packet = {
 type ml_ind = {
   ind_info : inductive_info;
   ind_nparams : int; 	       
-  ind_packets : ml_ind_packet array }
+  ind_packets : ml_ind_packet array;
+  ind_equiv : kernel_name option
+}
 
 (*s ML terms. *)
 
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
index 46d4a5a6..c9d4e237 100644
--- a/contrib/extraction/modutil.ml
+++ b/contrib/extraction/modutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.ml 8724 2006-04-20 09:57:01Z letouzey $ i*)
+(*i $Id: modutil.ml 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 open Names
 open Declarations
@@ -195,7 +195,10 @@ let ind_iter_references do_term do_cons do_type kn ind =
   let type_iter = type_iter_references do_type in
   let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in 
   let packet_iter ip p = 
-    do_type (IndRef ip); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
+    do_type (IndRef ip); 
+    if lang () = Ocaml then 
+      option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; 
+    Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
   in
   if lang () = Ocaml then record_iter_references do_term ind.ind_info; 
   Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
index 483da236..35f9a83c 100644
--- a/contrib/extraction/ocaml.ml
+++ b/contrib/extraction/ocaml.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
+(*i $Id: ocaml.ml 9472 2007-01-05 15:49:32Z letouzey $ i*)
 
 (*s Production of Ocaml syntax. *)
 
@@ -392,7 +392,14 @@ let rec pp_Dfix init i ((rv,c,t) as fix) =
 	
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_one_ind prefix ip pl cv =
+let pp_equiv param_list = function 
+  | None -> mt ()
+  | Some ip_equiv -> 
+      str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv)
+
+let pp_comment s = str "(* " ++ s ++ str " *)"
+
+let pp_one_ind prefix ip ip_equiv pl cv =
   let pl = rename_tvars keywords pl in
   let pp_constructor (r,l) =
     hov 2 (str "  | " ++ pp_global r ++
@@ -402,13 +409,12 @@ let pp_one_ind prefix ip pl cv =
 		      prlist_with_sep 
 			(fun () -> spc () ++ str "* ") (pp_type true pl) l))
   in
-  pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ 
+  pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++
+  pp_equiv pl ip_equiv ++ str " =" ++
   if Array.length cv = 0 then str " unit (* empty inductive *)" 
   else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor
 			(Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv))
 
-let pp_comment s = str "(* " ++ s ++ str " *)"
-
 let pp_logical_ind packet = 
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ 
   fnl () ++ pp_comment (str "with constructors : " ++ 
@@ -422,10 +428,11 @@ let pp_singleton kn packet =
 	 pp_comment (str "singleton inductive, whose constructor was " ++ 
 		     pr_id packet.ip_consnames.(0)))
 
-let pp_record kn projs packet = 
+let pp_record kn projs ip_equiv packet = 
   let l = List.combine projs packet.ip_types.(0) in 
   let pl = rename_tvars keywords packet.ip_vars in 
-  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++
+  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ 
+  pp_equiv pl ip_equiv ++ str " = { "++
   hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
 	   (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) 
   ++ str " }"
@@ -434,17 +441,20 @@ let pp_coind ip pl =
   let r = IndRef ip in 
   let pl = rename_tvars keywords pl in
   pp_parameters pl ++ pp_global r ++ str " = " ++ 
-  pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t"
+  pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" ++ 
+  fnl() ++ str "and "
 
 let pp_ind co kn ind =
+  let prefix = if co then "__" else "" in 
   let some = ref false in 
   let init= ref (str "type ") in 
   let rec pp i =  
     if i >= Array.length ind.ind_packets then mt () 
     else 
       let ip = (kn,i) in 
+      let ip_equiv = option_map (fun kn -> (kn,i)) ind.ind_equiv in 
       let p = ind.ind_packets.(i) in 
-      if is_custom (IndRef (kn,i)) then pp (i+1)
+      if is_custom (IndRef ip) then pp (i+1)
       else begin 
 	some := true; 
 	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
@@ -453,8 +463,8 @@ let pp_ind co kn ind =
 	  begin 
 	    init := (fnl () ++ str "and "); 
 	    s ++
-	    (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ())
-	    ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++
+	    (if co then pp_coind ip p.ip_vars else mt ())
+	    ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++
 	    pp (i+1)
 	  end
       end
@@ -468,7 +478,9 @@ let pp_mind kn i =
   match i.ind_info with 
     | Singleton -> pp_singleton kn i.ind_packets.(0)
     | Coinductive -> pp_ind true kn i
-    | Record projs -> pp_record kn projs i.ind_packets.(0)
+    | Record projs -> 
+	let ip_equiv = option_map (fun kn -> (kn,0)) i.ind_equiv in 
+	pp_record kn projs ip_equiv i.ind_packets.(0)
     | Standard -> pp_ind false kn i
 
 let pp_decl mpl = 
@@ -574,7 +586,7 @@ let rec pp_structure_elem mpl = function
   | (l,SEmodule m) ->
       hov 1 
 	(str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ 
-	 (* if you want signatures everywhere: *)
+	 (*i if you want signatures everywhere: i*)
 	 (*i str " :" ++ fnl () ++ i*)
 	 (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
 	 str " = " ++
diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v
deleted file mode 100644
index 0745f62d..00000000
--- a/contrib/extraction/test_extraction.v
+++ /dev/null
@@ -1,552 +0,0 @@
-(************************************************************************)
-(*  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 Arith.
-Require Import List.
-
-(*** STANDARD EXAMPLES *)
-
-(** Functions. *)
-
-Definition idnat (x:nat) := x.
-Extraction idnat.
-(* let idnat x = x *)
-
-Definition id (X:Type) (x:X) := x.      
-Extraction id. (* let id x = x *)
-Definition id' := id Set nat.
-Extraction id'. (* type id' = nat *)
-
-Definition test2 (f:nat -> nat) (x:nat) := f x.
-Extraction test2.
-(* let test2 f x = f x *)
-
-Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat.
-Extraction test3.
-(* let test3 f x = f x __ *)
-
-Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g.
-Extraction test4.
-(* let test4 f x g = f g *)
-
-Definition test5 := (1, 0).
-Extraction test5.
-(* let test5 = Pair ((S O), O) *)
-
-Definition cf (x:nat) (_:x <= 0) := S x.
-Extraction NoInline cf.
-Definition test6 := cf 0 (le_n 0).
-Extraction test6.  
-(* let test6 = cf O *)
-
-Definition test7 := (fun (X:Set) (x:X) => x) nat.
-Extraction test7.
-(* let test7 x = x *)
-
-Definition d (X:Type) := X.
-Extraction d. (* type 'x d = 'x *)
-Definition d2 := d Set.
-Extraction d2. (* type d2 = __ d *)
-Definition d3 (x:d Set) := 0.
-Extraction d3. (* let d3 _ = O *)
-Definition d4 := d nat. 
-Extraction d4. (* type d4 = nat d *)
-Definition d5 := (fun x:d Type => 0) Type.  
-Extraction d5.  (* let d5 = O *)
-Definition d6 (x:d Type) := x.
-Extraction d6.  (* type 'x d6 = 'x *)
-
-Definition test8 := (fun (X:Type) (x:X) => x) Set nat.
-Extraction test8. (* type test8 = nat *)
-
-Definition test9 := let t := nat in id Set t.
-Extraction test9.  (* type test9 = nat *)
-
-Definition test10 := (fun (X:Type) (x:X) => 0) Type Type.
-Extraction test10. (* let test10 = O *)
-
-Definition test11 := let n := 0 in let p := S n in S p.
-Extraction test11. (* let test11 = S (S O) *)
-
-Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
-Extraction test12. 
-(* type test12 = (__ -> __ -> __) -> __ *)
-
-
-Definition test13 := match left True I with
-                     | left x => 1
-                     | right x => 0
-                     end.
-Extraction test13. (* let test13 = S O *)
-
-
-(** example with more arguments that given by the type *)
-
-Definition test19 :=
-  nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0)
-    (fun (n:nat) (f:nat -> nat) => f) 0 0.
-Extraction test19.
-(* let test19 =
-  let rec f = function
-    | O -> (fun n0 -> O)
-    | S n0 -> f n0
-  in f O O
-*)
-
-
-(** casts *)
-
-Definition test20 := True:Type.
-Extraction test20.
-(* type test20 = __ *)
-
-
-(** Simple inductive type and recursor. *)
-
-Extraction nat.
-(* 
-type nat = 
-  | O 
-  | S of nat 
-*)
-
-Extraction sumbool_rect.
-(* 
-let sumbool_rect f f0 = function
-  |  Left -> f __
-  | Right -> f0 __
-*)
-
-(** Less simple inductive type. *)
-
-Inductive c (x:nat) : nat -> Set :=
-  | refl : c x x
-  | trans : forall y z:nat, c x y -> y <= z -> c x z.
-Extraction c.
-(* 
-type c =
-  | Refl
-  | Trans of nat * nat * c
-*)
-
-Definition Ensemble (U:Type) := U -> Prop.
-Definition Empty_set (U:Type) (x:U) := False.
-Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y.
-
-Inductive Finite (U:Type) : Ensemble U -> Set :=
-  | Empty_is_finite : Finite U (Empty_set U)
-  | Union_is_finite :
-      forall A:Ensemble U,
-        Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x).
-Extraction Finite.
-(* 
-type 'u finite =
-  | Empty_is_finite
-  | Union_is_finite of 'u finite * 'u
-*)
-
-
-(** Mutual Inductive *)
-
-Inductive tree : Set :=
-    Node : nat -> forest -> tree
-with forest : Set :=
-  | Leaf : nat -> forest
-  | Cons : tree -> forest -> forest.
-
-Extraction tree.
-(* 
-type tree =
-  | Node of nat * forest
-and forest =
-  | Leaf of nat
-  | Cons of tree * forest
-*)
-
-Fixpoint tree_size (t:tree) : nat :=
-  match t with
-  | Node a f => S (forest_size f)
-  end
- 
- with forest_size (f:forest) : nat :=
-  match f with
-  | Leaf b => 1
-  | Cons t f' => tree_size t + forest_size f'
-  end.
-
-Extraction tree_size.
-(* 
-let rec tree_size = function
-  | Node (a, f) -> S (forest_size f)
-and forest_size = function
-  | Leaf b -> S O
-  | Cons (t, f') -> plus (tree_size t) (forest_size f')
-*)
-
-
-(** Eta-expansions of inductive constructor *)
-
-Inductive titi : Set :=
-    tata : nat -> nat -> nat -> nat -> titi.
-Definition test14 := tata 0.
-Extraction test14.
-(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
-Definition test15 := tata 0 1.
-Extraction test15. 
-(* let test15 x x0 = Tata (O, (S O), x, x0) *)
-
-Inductive eta : Set :=
-    eta_c : nat -> Prop -> nat -> Prop -> eta.
-Extraction eta_c.
-(* 
-type eta =
-  | Eta_c of nat * nat
-*)
-Definition test16 := eta_c 0.
-Extraction test16.
-(* let test16 x = Eta_c (O, x) *)
-Definition test17 := eta_c 0 True.
-Extraction test17.
-(* let test17 x = Eta_c (O, x) *)
-Definition test18 := eta_c 0 True 0.
-Extraction test18. 
-(* let test18 _ = Eta_c (O, O) *)
-
-
-(** Example of singleton inductive type *)
-
-Inductive bidon (A:Prop) (B:Type) : Set :=
-    tb : forall (x:A) (y:B), bidon A B. 
-Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) 
-  (x:A) (y:B) := f x y.
-Extraction bidon.
-(* type 'b bidon = 'b *)
-Extraction tb.
-(* tb : singleton inductive constructor *)
-Extraction fbidon.
-(* let fbidon f x y =
-  f x y
-*)
-
-Definition fbidon2 := fbidon True nat (tb True nat).
-Extraction fbidon2. (* let fbidon2 y = y *)
-Extraction NoInline fbidon.
-Extraction fbidon2.
-(* let fbidon2 y = fbidon (fun _ x -> x) __ y *)
-
-(* NB: first argument of fbidon2 has type [True], so it disappears. *)
-
-(** mutual inductive on many sorts *)
-
-Inductive test_0 : Prop :=
-    ctest0 : test_0
-with test_1 : Set :=
-    ctest1 : test_0 -> test_1.  
-Extraction test_0.
-(* test0 : logical inductive *)
-Extraction test_1. 
-(* 
-type test1 =
-  | Ctest1
-*)
-
-(** logical singleton *)
-
-Extraction eq.
-(* eq : logical inductive *)
-Extraction eq_rect.
-(* let eq_rect x f y =
-  f
-*)
-
-(** No more propagation of type parameters. Obj.t instead. *)
-
-Inductive tp1 : Set :=
-    T : forall (C:Set) (c:C), tp2 -> tp1
-with tp2 : Set :=
-    T' : tp1 -> tp2.
-Extraction tp1.
-(* 
-type tp1 =
-  | T of __ * tp2
-and tp2 =
-  | T' of tp1
-*) 
-
-Inductive tp1bis : Set :=
-    Tbis : tp2bis -> tp1bis
-with tp2bis : Set :=
-    T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
-Extraction tp1bis.
-(* 
-type tp1bis =
-  | Tbis of tp2bis
-and tp2bis =
-  | T'bis of __ * tp1bis
-*)
-
-
-(** Strange inductive type. *)
-
-Inductive Truc : Set -> Set :=
-  | chose : forall A:Set, Truc A
-  | machin : forall A:Set, A -> Truc bool -> Truc A.
-Extraction Truc.
-(*
-type 'x truc =
-  | Chose
-  | Machin of 'x * bool truc
-*)
-
-
-(** Dependant type over Type *)
-
-Definition test24 := sigT (fun a:Set => option a).
-Extraction test24.
-(* type test24 = (__, __ option) sigT *)
-
-
-(** Coq term non strongly-normalizable after extraction *)
-
-Require Import Gt.
-Definition loop (Ax:Acc gt 0) :=
-  (fix F (a:nat) (b:Acc gt a) {struct b} : nat :=
-     F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax.
-Extraction loop.
-(* let loop _ =
-  let rec f a =
-    f (S a)
-  in f O
-*)
-
-(*** EXAMPLES NEEDING OBJ.MAGIC *)
-
-(** False conversion of type: *)
-
-Lemma oups : forall H:nat = list nat, nat -> nat.
-intros.
-generalize H0; intros.
-rewrite H in H1.
-case H1.
-exact H0.
-intros.
-exact n.
-Qed.
-Extraction oups.
-(* 
-let oups h0 = 
-  match Obj.magic h0 with
-    | Nil -> h0
-    | Cons0 (n, l) -> n
-*)
-
-
-(** hybrids *)
-
-Definition horibilis (b:bool) :=
-  if b as b return (if b then Type else nat) then Set else 0.
-Extraction horibilis.
-(* 
-let horibilis = function
-  | True -> Obj.magic __
-  | False -> Obj.magic O
-*)
-
-Definition PropSet (b:bool) := if b then Prop else Set.
-Extraction PropSet. (* type propSet = __ *)
-
-Definition natbool (b:bool) := if b then nat else bool.
-Extraction natbool. (* type natbool = __ *)
-
-Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true.
-Extraction zerotrue. 
-(* 
-let zerotrue = function
-  | True -> Obj.magic O
-  | False -> Obj.magic True
-*)
-
-Definition natProp (b:bool) := if b return Type then nat else Prop.
-
-Definition natTrue (b:bool) := if b return Type then nat else True.
-
-Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
-Extraction zeroTrue.
-(* 
-let zeroTrue = function
-  | True -> Obj.magic O
-  | False -> Obj.magic __
-*)
-
-Definition natTrue2 (b:bool) := if b return Type then nat else True.
-
-Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
-Extraction zeroprop.
-(* 
-let zeroprop = function
-  | True -> Obj.magic O
-  | False -> Obj.magic __
-*)
-
-(** polymorphic f applied several times *)
-
-Definition test21 := (id nat 0, id bool true).
-Extraction test21.
-(* let test21 = Pair ((id O), (id True)) *)
-
-(** ok *)
-
-Definition test22 :=
-  (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
-    (fun (X:Type) (x:X) => x).
-Extraction test22. 
-(* let test22 = 
-  let f = fun x -> x in Pair ((f O), (f True)) *)
-
-(* still ok via optim beta -> let *)
-
-Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true).
-Extraction test23.
-(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *)
-
-(* problem: fun f -> (f 0, f true) not legal in ocaml *)
-(* solution: magic ... *)
-
-
-(** Dummy constant __ can be applied.... *)
-
-Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0).
-Extraction f.
-(* let f x y =
-  y (x O)
-*)
-
-Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true).
-Extraction NoInline f.
-Extraction f_prop.
-(* let f_prop =
-  f (Obj.magic __) (fun _ -> True)
-*)
-
-Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true).
-Extraction f_arity.
-(* let f_arity =
-  f (Obj.magic __) (fun _ -> True)
-*)
-
-Definition f_normal :=
-  f nat (fun x => x) (fun x => match x with
-                               | O => true
-                               | _ => false
-                               end).
-Extraction f_normal.
-(* let f_normal =
-  f (fun x -> x) (fun x -> match x with
-                             | O -> True
-                             | S n -> False)
-*)
-
-
-(* inductive with magic needed *)
-
-Inductive Boite : Set :=
-    boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. 
-Extraction Boite. 
-(*
-type boite =
-  | Boite of bool * __
-*)
-
-
-Definition boite1 := boite true 0.
-Extraction boite1.
-(* let boite1 = Boite (True, (Obj.magic O)) *)
-
-Definition boite2 := boite false (0, 0).
-Extraction boite2.
-(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)
-
-Definition test_boite (B:Boite) :=
-  match B return nat with
-  | boite true n => n
-  | boite false n => fst n + snd n
-  end.
-Extraction test_boite. 
-(* 
-let test_boite = function
-  | Boite (b0, n) ->
-      (match b0 with
-         | True -> Obj.magic n
-         | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n)))
-*)
-
-(* singleton inductive with magic needed *)
-
-Inductive Box : Set :=
-    box : forall A:Set, A -> Box. 
-Extraction Box.
-(* type box = __ *)
-
-Definition box1 := box nat 0. 
-Extraction box1. (* let box1 = Obj.magic O *)
-
-(* applied constant, magic needed *)
-
-Definition idzarb (b:bool) (x:if b then nat else bool) := x.
-Definition zarb := idzarb true 0.
-Extraction NoInline idzarb. 
-Extraction zarb. 
-(* let zarb = Obj.magic idzarb True (Obj.magic O) *)
-
-(** function of variable arity. *)
-(** Fun n = nat -> nat -> ... -> nat *)  
-
-Fixpoint Fun (n:nat) : Set :=
-  match n with
-  | O => nat
-  | S n => nat -> Fun n
-  end.
-
-Fixpoint Const (k n:nat) {struct n} : Fun n :=
-  match n as x return Fun x with
-  | O => k
-  | S n => fun p:nat => Const k n
-  end.
-
-Fixpoint proj (k n:nat) {struct n} : Fun n :=
-  match n as x return Fun x with
-  | O => 0 (* ou assert false ....*)
-  | S n =>
-      match k with
-      | O => fun x => Const x n
-      | S k => fun x => proj k n
-      end
-  end. 
-
-Definition test_proj := proj 2 4 0 1 2 3.
-
-Eval compute in test_proj. 
-
-Recursive Extraction test_proj. 
-
-
-
-(*** TO SUM UP: ***) 
-
-
-Extraction
- "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2
-                     d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
-                     test13 test19 test20 nat sumbool_rect c Finite tree
-                     tree_size test14 test15 eta_c test16 test17 test18 bidon
-                     tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
-                     tp1bis Truc oups test24 loop horibilis PropSet natbool
-                     zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
-                     f_arity f_normal Boite boite1 boite2 test_boite Box box1
-                     zarb test_proj.
-
diff --git a/contrib/first-order/ground.ml b/contrib/first-order/ground.ml
index bb096308..bccac6df 100644
--- a/contrib/first-order/ground.ml
+++ b/contrib/first-order/ground.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.ml 7909 2006-01-21 11:09:18Z herbelin $ *)
+(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *)
 
 open Formula
 open Sequent
@@ -81,7 +81,7 @@ let ground_tac solver startseq gl=
 			      tclFAIL 0 (Pp.str "reversible in 1st order mode")
 			    else
 			      backtrack in
-			    forall_tac backtrack continue (re_add seq1)
+			    forall_tac backtrack1 continue (re_add seq1)
 		      | Rarrow->
 			  arrow_tac backtrack continue (re_add seq1)
 		      | Ror->
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
index 14e2233f..ff4f7499 100644
--- a/contrib/funind/functional_principles_proofs.ml
+++ b/contrib/funind/functional_principles_proofs.ml
@@ -1380,219 +1380,6 @@ let is_valid_hypothesis predicates_name =
 	| _ -> false 
   in
   is_valid_hypothesis 
-(*
-let fresh_id avoid na = 
-  let id =  
-    match na with 
-      | Name id -> id 
-      | Anonymous -> h_id 
-  in 
-  next_global_ident_away true id avoid
-
-
-let prove_principle_for_gen
-    (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
-    rec_arg_num rec_arg_type relation = 
-  fun g -> 
-    let type_of_goal = pf_concl g in 
-    let goal_ids = pf_ids_of_hyps g in 
-    let goal_elim_infos = compute_elim_sig type_of_goal in 
-    let params_names,ids = List.fold_left 
-      (fun (params_names,avoid) (na,_,_) -> 
-	 let new_id = fresh_id avoid na in 
-	 (new_id::params_names,new_id::avoid)
-      )
-      ([],goal_ids)
-      goal_elim_infos.params
-    in
-    let predicates_names,ids = 
-      List.fold_left 
-	(fun (predicates_names,avoid) (na,_,_) -> 
-	   let new_id = fresh_id avoid na in 
-	   (new_id::predicates_names,new_id::avoid)
-	)
-	([],ids)
-	goal_elim_infos.predicates
-    in
-    let branches_names,ids = 
-      List.fold_left 
-	(fun (branches_names,avoid) (na,_,_) -> 
-	   let new_id = fresh_id avoid na in 
-	   (new_id::branches_names,new_id::avoid)
-	)
-	([],ids)
-	goal_elim_infos.branches
-    in
-    let to_intro = params_names@predicates_names@branches_names in 
-    let nparams = List.length params_names in 
-    let rec_arg_num = rec_arg_num - nparams in 
-    let tac_intro_static = h_intros to_intro in 
-    let args_info = ref None in 
-    let arg_tac g =  (* introducing args *)
-      let ids = pf_ids_of_hyps g in 
-      let func_body = def_of_const (mkConst functional_ref) in
-      (* 	      let _ = Pp.msgnl (Printer.pr_lconstr func_body) in  *)
-      let (f_name, _, body1) = destLambda func_body in
-      let f_id =
-	match f_name with
-	  | Name f_id -> next_global_ident_away true f_id ids
-	  | Anonymous -> anomaly "anonymous function"
-      in
-      let n_names_types,_ = decompose_lam body1 in 
-      let n_ids,ids = 
-	List.fold_left 
-	  (fun (n_ids,ids) (n_name,_) -> 
-	     match n_name with 
-	       | Name id -> 
-		   let n_id = next_global_ident_away true id ids in 
-		   n_id::n_ids,n_id::ids
-	       | _ -> anomaly "anonymous argument"
-	  )
-	  ([],(f_id::ids))
-	  n_names_types
-      in
-      let rec_arg_id = List.nth n_ids (rec_arg_num - 1 ) in
-      let args_ids = snd (list_chop nparams n_ids) in
-      args_info := Some (ids,args_ids,rec_arg_id);
-      h_intros args_ids g
-    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 start_tac g = 
-      let ids,args_ids,rec_arg_id = out_some !args_info in
-      let nargs = List.length args_ids in 
-      let pre_rec_arg = 
-	List.rev_map 
-	  mkVar 
-	  (fst (list_chop (rec_arg_num - 1) args_ids))
-      in
-      let args_before_rec = pre_rec_arg@(List.map mkVar params_names) in
-      let relation = substl args_before_rec relation in 
-      let input_type = substl args_before_rec rec_arg_type in 
-      let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in 
-      let wf_rec_arg = 
-	next_global_ident_away true 
-	  (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 acc_inv = 
-	lazy (
-	  mkApp (
-	    delayed_force acc_inv_id,
-	    [|input_type;relation;mkVar rec_arg_id|]
-	  )
-	)
-      in
-      (tclTHENS
-	   (observe_tac 
-	      "first assert" 
-	      (assert_tac 
-		 true (* the assert thm is in first subgoal *)
-		 (Name wf_rec_arg) 
-		 (mkApp (delayed_force acc_rel,
-			 [|input_type;relation;mkVar rec_arg_id|])
-		 )
-	      )
-	   )
-	   [
-	     (* accesibility proof *) 
-	     tclTHENS 
-	       (observe_tac 
-		  "second assert" 
-		  (assert_tac 
-		     true 
-		     (Name wf_thm)
-		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  )
-	       )
-	       [ 
-		 (* interactive proof of the well_foundness of the relation *) 
-		 wf_tac is_mes;
-		 (* well_foundness -> Acc for any element *)
-		 observe_tac 
-		   "apply wf_thm" 
-		   (h_apply ((mkApp(mkVar wf_thm,
-				    [|mkVar rec_arg_id |])),Rawterm.NoBindings)
-		   )
-	       ]
-	     ;
-	     (* rest of the proof *)
-	     tclTHENSEQ
-	       [
-		 observe_tac "generalize" (fun g -> 
-		    let to_thin = 
-		      fst (list_chop ( nargs + 1) (pf_ids_of_hyps g))
-		    in
-		    let to_thin_c = List.rev_map mkVar to_thin in 
-		    tclTHEN (generalize to_thin_c) (observe_tac "thin" (h_clear false to_thin)) g
-		 );
-		 observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
-		h_intros args_ids;
-		h_intro wf_rec_arg;
-		Equality.rewriteLR (mkConst eq_ref);
-		(fun g' -> 
-		   let body = 
-		     let _,args = destApp (pf_concl g') 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(Lazy.force acc_inv, [|mkVar  wf_rec_arg|]) )  in
-		   let pte_info = 
-		     { proving_tac =
-			 (fun eqs -> 
-			    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 
-		     }
-		   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
-		   instanciate_hyps_with_args 
-		     make_proof
-		     branches_names
-		     args_ids
-		     g'
-		     
-		) 
-	       ]
-	   ]
-	   g
-      )
-      in
-      tclTHENSEQ 
-	[tac_intro_static;
-	 arg_tac;
-	 start_tac
-	] g
-*)
 
 let prove_principle_for_gen
     (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
@@ -1627,14 +1414,22 @@ let prove_principle_for_gen
   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 
+  observe (
+    str "princ_type := " ++ pr_lconstr  princ_type ++ fnl () ++
+    str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ 
+      str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ 
+    str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ 
+	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++
+	     str "npost_rec_arg := " ++ int npost_rec_arg );
   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 
+    match List.rev post_rec_arg with 
       | (Name id,_,_)::_ -> id 
       | _ -> assert false 
   in
+  observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id));
   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 
@@ -1679,7 +1474,7 @@ let prove_principle_for_gen
  	 (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)); 
+      observe_tac "h_fix" (h_fix (Some fix_id) (npost_rec_arg + 1)); 
       h_intros (List.rev (acc_rec_arg_id::args_ids));
       Equality.rewriteLR (mkConst eq_ref);
       observe_tac "finish" (fun gl' -> 
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
index 89ebb75a..8ad2e72b 100644
--- a/contrib/funind/functional_principles_types.ml
+++ b/contrib/funind/functional_principles_types.ml
@@ -405,11 +405,26 @@ let generate_functional_principle
   let (id,(entry,g_kind,hook)) =
     build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook 
   in
+  (* Pr  1278 :
+     Don't forget to close the goal if an error is raised !!!!
+  *) 
   save false new_princ_name entry g_kind hook
-  with 
-    | Defining_principle _ as e -> raise e
-    | e -> raise (Defining_principle e)
-
+  with e -> 
+    begin
+      begin 
+	try 
+	  let id = Pfedit.get_current_proof_name () in 
+	  let s = string_of_id id in 
+	  let n = String.length "___________princ_________" in
+	  if String.length s >= n 
+	  then if String.sub s 0 n = "___________princ_________" 
+	  then Pfedit.delete_current_proof ()
+	  else ()
+	  else ()
+	with _ -> ()
+      end;
+      raise (Defining_principle e)
+    end
 (*   defined  () *)
 
 
diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
index 82bb2869..6e2af224 100644
--- a/contrib/funind/indfun.ml
+++ b/contrib/funind/indfun.ml
@@ -266,7 +266,7 @@ let derive_inversion fix_names =
 	)
     with e -> 
       msg_warning 
-	(str "Cannot built inversion information" ++ 
+	(str "Cannot build functional inversion principle" ++ 
 	   if do_observe () then Cerrors.explain_exn e else mt ())
   with _ -> ()
 
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
index ed46ec72..ba5c2bbd 100644
--- a/contrib/funind/rawtermops.ml
+++ b/contrib/funind/rawtermops.ml
@@ -561,7 +561,7 @@ let ids_of_rawterm c =
       | 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 -> []
+      | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
   in
   (* build the set *)
   List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
index b6cc55f6..ef1d095e 100644
--- a/contrib/interface/ascent.mli
+++ b/contrib/interface/ascent.mli
@@ -642,6 +642,7 @@ and ct_TACTIC_COM =
   | CT_elim_type of ct_FORMULA
   | CT_exact of ct_FORMULA
   | CT_exact_no_check of ct_FORMULA
+  | CT_vm_cast_no_check of ct_FORMULA
   | CT_exists of ct_SPEC_LIST
   | CT_fail of ct_ID_OR_INT * ct_STRING_OPT
   | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list
diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml
index 4d4df59f..8cca7614 100644
--- a/contrib/interface/parse.ml
+++ b/contrib/interface/parse.ml
@@ -315,21 +315,21 @@ let parse_file_action reqid file_name =
 		   fnl () ++ Cerrors.explain_exn e));;
 
 let add_rec_path_action reqid string_arg ident_arg =
-  let directory_name = glob string_arg in
+  let directory_name = expand_path_macros string_arg in
     begin
       add_rec_path directory_name (Libnames.dirpath_of_string ident_arg)
     end;;
 	
 
 let add_path_action reqid string_arg =
-  let directory_name = glob string_arg in
+  let directory_name = expand_path_macros string_arg in
     begin
       add_path directory_name Names.empty_dirpath
     end;;
 
 let print_version_action () =
   msgnl (mt ());
-  msgnl (str "$Id: parse.ml 7844 2006-01-11 16:36:14Z bertot $");;
+  msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");;
 
 let load_syntax_action reqid module_name =
  msg (str "loading " ++ str module_name ++ str "... ");
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
index fe227f99..166a0cbf 100644
--- a/contrib/interface/vtp.ml
+++ b/contrib/interface/vtp.ml
@@ -1549,6 +1549,9 @@ and fTACTIC_COM = function
 | CT_exact_no_check(x1) ->
    fFORMULA x1;
    fNODE "exact_no_check" 1
+| CT_vm_cast_no_check(x1) ->
+   fFORMULA x1;
+   fNODE "vm_cast_no_check" 1
 | CT_exists(x1) ->
    fSPEC_LIST x1;
    fNODE "exists" 1
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
index 6c9e8239..60195229 100644
--- a/contrib/interface/xlate.ml
+++ b/contrib/interface/xlate.ml
@@ -1060,6 +1060,7 @@ and xlate_tac =
     | TacAssumption -> CT_assumption
     | TacExact c -> CT_exact (xlate_formula c)
     | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c)
+    | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c)
     | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id)
     | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id)
     | TacDestructConcl -> CT_dconcl
@@ -1978,7 +1979,7 @@ let rec xlate_vernac =
    | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s)
    | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s)
    | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s)
-   | VernacArgumentsScope(qid, l) -> 
+   | VernacArgumentsScope(true, qid, l) -> 
        CT_arguments_scope(loc_qualid_to_ct_ID qid,
 		       CT_id_opt_list
 		       (List.map
@@ -1986,6 +1987,8 @@ let rec xlate_vernac =
 				  match x with
 				      None -> ctv_ID_OPT_NONE
 				    | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l))
+   | VernacArgumentsScope(false, qid, l) -> 
+       xlate_error "TODO: Arguments Scope Global"
    | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2)
    | VernacBindScope(id, a::l) -> 
        let xlate_class_rawexpr = function
@@ -2060,7 +2063,7 @@ let rec xlate_vernac =
   | VernacNop -> CT_proof_no_op
   | VernacComments l -> 
       CT_scomments(CT_scomment_content_list (List.map xlate_comment l))
-  | VernacDeclareImplicits(id, opt_positions) ->
+  | VernacDeclareImplicits(true, id, opt_positions) ->
       CT_implicits
 	(reference_to_ct_ID id,
 	 match opt_positions with
@@ -2073,6 +2076,8 @@ let rec xlate_vernac =
 		       -> xlate_error
 			   "explication argument by rank is obsolete"
 		     | ExplByName id -> CT_ident (string_of_id id)) l)))
+  | VernacDeclareImplicits(false, id, opt_positions) ->
+      xlate_error "TODO: Implicit Arguments Global"
   | VernacReserve((_,a)::l, f) ->
       CT_reserve(CT_id_ne_list(xlate_ident a, 
 			       List.map (fun (_,x) -> xlate_ident x) l),
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
index 5060bc69..074f6ef7 100644
--- a/contrib/setoid_ring/ArithRing.v
+++ b/contrib/setoid_ring/ArithRing.v
@@ -7,20 +7,32 @@
 (************************************************************************)
 
 Require Import Mult.
+Require Import BinNat.
+Require Import Nnat.
 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.
+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.
+
+Lemma nat_morph_N : 
+   semi_morph 0 1 plus mult (eq (A:=nat)) 
+          0%N 1%N Nplus Nmult Neq_bool nat_of_N.
+Proof.
+  constructor;trivial.
+  exact nat_of_Nplus.
+  exact nat_of_Nmult.
+  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+Qed.
+
 Ltac natcst t :=
   match isnatcst t with
-    true => t
-  | _ => NotConstant
+    true => constr:(N_of_nat t)
+  | _ => InitialRing.NotConstant
   end.
 
 Ltac Ss_to_add f acc :=
@@ -43,28 +55,6 @@ Ltac natprering :=
   | _ => 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]).
+  (morphism nat_morph_N, constants [natcst], preprocess [natprering]).
+
diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v
index 0d0fe5a4..50902004 100644
--- a/contrib/setoid_ring/BinList.v
+++ b/contrib/setoid_ring/BinList.v
@@ -10,7 +10,7 @@ Set Implicit Arguments.
 Require Import BinPos.
 Require Export List.
 Require Export ListTactics.
-Open Scope positive_scope.
+Open Local Scope positive_scope.
 
 Section MakeBinList.
  Variable A : Type.
@@ -89,3 +89,5 @@ Section MakeBinList.
  Qed.
 
 End MakeBinList.
+
+
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
index 786654ab..aad3a580 100644
--- a/contrib/setoid_ring/Field_tac.v
+++ b/contrib/setoid_ring/Field_tac.v
@@ -10,10 +10,10 @@ 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 := 
+ Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := 
  let rec mkP t :=
     match Cst t with
-    | Ring_tac.NotConstant =>
+    | InitialRing.NotConstant =>
         match t with 
         | (radd ?t1 ?t2) => 
           let e1 := mkP t1 in
@@ -31,6 +31,13 @@ Require Export Field_theory.
           let e2 := mkP t2 in constr:(FEdiv e1 e2)
         | (rinv ?t1) =>
           let e1 := mkP t1 in constr:(FEinv e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant => 
+            let p := Find_at t fv in constr:(@FEX C p)
+          | ?c => let e1 := mkP t1 in constr:(FEpow e1 c)
+          end
+  
         | _ =>
           let p := Find_at t fv in constr:(@FEX C p)
         end
@@ -38,10 +45,10 @@ Require Export Field_theory.
     end
  in mkP t.
 
-Ltac FFV Cst add mul sub opp div inv t fv :=
+Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
  let rec TFV t fv :=
   match Cst t with
-  | Ring_tac.NotConstant =>
+  | InitialRing.NotConstant =>
       match t with
       | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
@@ -49,16 +56,24 @@ Ltac FFV Cst add mul sub opp div inv t fv :=
       | (opp ?t1) => TFV t1 fv
       | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (inv ?t1) => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => AddFvTail t fv
+        | _ => TFV t1 fv
+        end
       | _ => AddFvTail t fv
       end
   | _ => fv
   end 
  in TFV t fv.
 
-Ltac ParseFieldComponents lemma req :=
+Ltac ParseFieldComponents lemma :=
   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)
+  | context [
+     (*   PCond _ _ _  _ _ _ _  _ _  _ _ -> *)
+        (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv 
+                 ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] =>
+      (fun f => f radd rmul rsub ropp rdiv rinv rpow C)
   | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
   end.
 
@@ -78,91 +93,244 @@ Ltac fold_field_cond req :=
 
 Ltac simpl_PCond req :=
   protect_fv "field_cond";
-  try (exact I);
+  (try exact I);
+  fold_field_cond req.
+
+Ltac simpl_PCond_BEURK req :=
+  protect_fv "field_cond";
   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.
+Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
+  let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let mkFE := 
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let simpl_field H := (protect_fv "field" in H;f H) in
+    let lemma_tac fv RW_tac :=
+      let rr_lemma := fresh "f_rw_lemma" in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let vlpe := fresh "list_hyp" in
+      let vlmp := fresh "list_hyp_norm" in
+      let vlmp_eq := fresh "list_hyp_norm_eq" in
+      let prh := proofHyp_tac lH in
+      pose (vlpe := lpe);
+      match type of lemma with
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
+        compute_assertion vlmp_eq vlmp 
+            (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+         (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq)
+          || fail "type error when build the rewriting lemma");
+         RW_tac rr_lemma;
+        try clear rr_lemma vlmp_eq vlmp vlpe
+      | _ => fail 1 "field_simplify anomaly: bad correctness lemma"
+      end in
+    ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl;
+    try (apply Cond_lemma; simpl_PCond req) in
+  ParseFieldComponents lemma Main.
+
+Ltac Field_simplify_gen f := 
+     fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req 
+                  ring_subst_niter lH rl; 
+      post().
+
+Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) 
+  "field_simplify" constr_list(rl) :=
+  match goal with [|- ?G] => field_lookup Field_simplify [] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  match goal with [|- ?G] => field_lookup Field_simplify [lH] rl [G] end.
+
+Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=   
+   let G := getGoal in
+   let t := type of H in   
+   let g := fresh "goal" in
+   set (g:= G);
+   generalize H;clear H;
+   field_lookup Field_simplify [] rl [t];
+   intro H;
+   unfold g;clear g.
+
+Tactic Notation "field_simplify" "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=   
+   let G := getGoal in
+   let t := type of H in   
+   let g := fresh "goal" in
+   set (g:= G);
+   generalize H;clear H;
+   field_lookup Field_simplify [lH] rl [t];
+   intro H;
+   unfold g;clear g.
+
+(*
+Ltac Field_simplify_in hyp:= 
+   Field_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0) 
+  "field_simplify" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [] rl [t].
+
+Tactic Notation (at level 0) 
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [lH] rl [t].
+*)
+
+(** Generic tactic for solving equations *)
+
+Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
+  let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let mkFE := 
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow 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_eq t1 t2 :=
+      let fv := FV_hypo_tac mkFV req lH in
+      let fv := mkFFV t1 fv in
+      let fv := mkFFV t2 fv in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let prh := proofHyp_tac lH in
+      let vlpe := fresh "list_hyp" in
+      let fe1 := mkFE t1 fv in
+      let fe2 := mkFE t2 fv in
+      pose (vlpe := lpe);
+      let nlemma := fresh "field_lemma" in
+      (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
+       || fail "field anomaly:failed to build lemma"); 
+      ParseExpr nlemma
+         ltac:(fun ilemma =>
+                  apply ilemma 
+                  || fail "field anomaly: failed in applying lemma";
+                  [ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
+      clear vlpe nlemma in
+    OnEquation req Main_eq in
+  ParseFieldComponents lemma 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.
 
+Ltac FIELD :=
+   let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
+   fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req 
+         Ring_tac.ring_subst_niter lH;
+       try exact I;
+       post().
+ 
 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()).
+  let G := getGoal in field_lookup FIELD [] [G].
+
+Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
+  let G := getGoal in field_lookup FIELD [lH] [G].
 
 (* 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()).
 
+Ltac FIELD_SIMPL  :=
+  let Simpl := (protect_fv "field") in
+  fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok 
+          req Ring_tac.ring_subst_niter lH;
+       post().
+
+Tactic Notation (at level 0) "field_simplify_eq" :=  
+  let G := getGoal in field_lookup FIELD_SIMPL [] [G].
+
+Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=  
+  let G := getGoal in field_lookup FIELD_SIMPL [lH] [G].
+
+(* Same as FIELD_SIMPL but in hypothesis *)
+
+Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
+   let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let hyp := fresh "hyp" in
+    intro hyp;
+    match type of hyp with
+    | req ?t1 ?t2 =>
+      let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+      let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+      let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+      let mkFE := 
+        mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow 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 H x)
+        | _ => (fun t => t ilemma)
+        end in
+      let fv := FV_hypo_tac mkFV req lH in
+      let fv := mkFFV t1 fv in
+      let fv := mkFFV t2 fv in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let prh := proofHyp_tac lH in
+      let fe1 := mkFE t1 fv in
+      let fe2 := mkFE t2 fv in
+      let vlpe := fresh "vlpe" in
+      ParseExpr (lemma n fv lpe fe1 fe2 prh)
+         ltac:(fun ilemma =>
+             match type of ilemma with
+             | req _ _ ->  _ -> ?EQ => 
+               let tmp := fresh "tmp" in
+               assert (tmp : EQ);
+               [ apply ilemma; 
+                 [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req]
+               | protect_fv "field" in tmp;
+                 generalize tmp;clear tmp ];
+               clear hyp  
+             end)
+     end in
+  ParseFieldComponents lemma Main.
+
+Ltac FIELD_SIMPL_EQ :=
+ fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
+       pre(); 
+       Field_simplify_eq cst_tac pow_tac lemma cond_ok req
+         Ring_tac.ring_subst_niter lH;
+       post().
+
+Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
+  let t := type of H in
+  generalize H;
+  field_lookup FIELD_SIMPL_EQ [] [t];
+  [ try exact I
+  | clear H;intro H].
+
+
+Tactic Notation (at level 0) 
+  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=  
+  let t := type of H in
+  generalize H;
+  field_lookup FIELD_SIMPL_EQ [lH] [t];
+  [ try exact I
+  |clear H;intro H].
+ 
 (* Adding a new field *)
 
 Ltac ring_of_field f :=
@@ -179,22 +347,59 @@ Ltac coerce_to_almost_field set ext f :=
   | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
   end.
 
-Ltac field_elements set ext fspec rk :=
+Ltac field_elements set ext fspec pspec sspec 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)).
+  ring_elements set ext rspec pspec sspec rk
+  ltac:(fun arth ext_r morph p_spec s_spec f => f afth ext_r morph p_spec s_spec).
+
+Ltac field_lemmas set ext inv_m fspec pspec sspec rk :=
+  let simpl_eq_lemma := 
+     match pspec with
+     | None => constr:(Field_simplify_eq_correct)
+     | Some _ => constr:(Field_simplify_eq_pow_correct)
+     end in
+  let simpl_eq_in_lemma :=
+     match pspec with
+     | None => constr:(Field_simplify_eq_in_correct)
+     | Some _ => constr:(Field_simplify_eq_pow_in_correct)
+     end in
+  let rw_lemma :=
+     match pspec with
+     | None => constr:(Field_rw_correct)
+     | Some _ => constr:(Field_rw_pow_correct)
+     end in
+  field_elements set ext fspec pspec sspec rk
+   ltac:(fun afth ext_r morph p_spec s_spec =>
+     match p_spec with
+     | mkhypo ?pp_spec => match s_spec with
+     | mkhypo ?ss_spec =>
+       let field_simpl_eq_ok :=
+         constr:(simpl_eq_lemma _ _ _  _ _ _  _ _ _ _ 
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in 
+       let field_simpl_ok :=
+         constr:(rw_lemma _ _ _  _ _ _  _ _ _ _
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in
+       let field_simpl_eq_in :=
+         constr:(simpl_eq_in_lemma _ _ _  _ _ _  _ _ _ _
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in
+       let field_ok := 
+         constr:(Field_correct set ext_r inv_m afth morph pp_spec ss_spec) in
+       let cond1_ok := 
+         constr:(Pcond_simpl_gen set ext_r afth morph pp_spec) in
+       let cond2_ok := 
+         constr:(Pcond_simpl_complete set ext_r afth morph pp_spec) in
+       (fun f => 
+         f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
+                cond1_ok cond2_ok)
+     | _ => fail 2 "bad sign specification"
+     end 
+     | _ => fail 1 "bad power specification" 
+     end).
+
diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v
index f810859c..ea8421cf 100644
--- a/contrib/setoid_ring/Field_theory.v
+++ b/contrib/setoid_ring/Field_theory.v
@@ -9,6 +9,7 @@
 Require Ring.
 Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
 Require Import ZArith_base.
+(*Require Import Omega.*)
 Set Implicit Arguments.
 
 Section MakeFieldPol.
@@ -29,7 +30,7 @@ Section MakeFieldPol.
  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;
@@ -94,9 +95,20 @@ Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc 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).
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R. 
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+ (* sign function *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory ropp req phi get_sign.
+
+Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
+Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb).
+
+Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
+Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
 
 (* add abstract semi-ring to help with some proofs *)
 Add Ring Rring : (ARth_SRth ARth).
@@ -105,7 +117,7 @@ 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.
+intros; rewrite (ARsub_def ARth) in |- *;ring.
 Qed.
 
 Lemma rsub_0_r : forall r, r - 0 == r.
@@ -352,6 +364,20 @@ intros H1; apply f_equal with ( f := xO ); auto.
 intros H1 H2; case H1; injection H2; auto.
 Qed.
  
+Definition N_eq n1 n2 := 
+  match n1, n2 with
+  | N0, N0 => true
+  | Npos p1, Npos p2 => positive_eq p1 p2
+  | _, _ => false
+  end.
+
+Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2.
+Proof.
+  intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail).
+  assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2);
+     [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial].
+Qed.
+
 (* equality test *)
 Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
  match e1, e2 with
@@ -361,9 +387,25 @@ Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
   | 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
+  | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false
   | _, _ => false
  end.
  
+Add Morphism (pow_pos rmul) : pow_morph.
+intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
+Qed.
+
+Add Morphism (pow_N rI rmul) : pow_N_morph.
+intros x y H [|p];simpl;auto. apply pow_morph;trivial.
+Qed.
+(*
+Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n).
+Proof.
+  intros; repeat rewrite pow_th.(rpow_pow_N).
+  destruct n;simpl. apply eq_refl.
+  induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl.
+Qed.
+*)
 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.
@@ -387,6 +429,10 @@ intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
 intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
 intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
  (try (intros; discriminate)); auto.
+intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
+intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4);
+intros;try discriminate.
+repeat rewrite  pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto.
 Qed.
 
 (* add *)
@@ -395,6 +441,7 @@ Definition NPEadd e1 e2 :=
     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
+    (* Peut t'on factoriser ici ??? *)
   | _, _ => PEadd e1 e2
   end.
 
@@ -403,32 +450,68 @@ Theorem NPEadd_correct:
 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).
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl;
+ try ring [(morph0 CRmorph)].
+ apply (morph_add CRmorph).
+Qed.
+
+Definition NPEpow x n :=
+  match n with
+  | N0 => PEc cI
+  | Npos p =>
+    if positive_eq p xH then x else
+    match x with 
+    | PEc c => 
+      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)  
+    | _ => PEpow x n         
+    end
+  end.
+
+Theorem NPEpow_correct : forall l e n,
+  NPEeval l (NPEpow e n) == NPEeval l (PEpow e n).
+Proof.
+ destruct n;simpl.
+ rewrite pow_th.(rpow_pow_N);simpl;auto.
+ generalize (positive_eq_correct p xH).
+ destruct (positive_eq p 1);intros.
+ rewrite H;rewrite  pow_th.(rpow_pow_N). trivial.
+ clear H;destruct e;simpl;auto.
+ repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
+ symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
+ symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
+ induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
 Qed.
 
 (* mul *) 
-Definition NPEmul x y :=
+Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
   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
+  | PEpow e1 n1, PEpow e2 n2 =>
+      if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
+  | _, _ => PEmul x y
   end.
-             
+
+Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
+induction p;simpl;auto;try ring [IHp].
+Qed.
+          
 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;
+induction 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).
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity;
+ try ring [(morph0 CRmorph) (morph1 CRmorph)].
+ apply (morph_mul CRmorph).
+assert (H:=N_eq_correct n n0);destruct (N_eq n n0).
+rewrite NPEpow_correct. simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite IHe1;rewrite <- H;destruct n;simpl;try ring.
+apply pow_pos_mul.
+simpl;auto.
 Qed.
 
 (* sub *)
@@ -437,6 +520,7 @@ Definition NPEsub e1 e2 :=
     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
+     (* Peut-on factoriser ici *)
   | _, _ => PEsub e1 e2
   end.
 
@@ -467,6 +551,7 @@ Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
   | 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)
+  | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
   | _ => e
  end.
  
@@ -489,6 +574,10 @@ intros e1 He1.
 transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
 apply NPEopp_correct.
 simpl; auto.
+intros e1 He1 n;simpl.
+rewrite NPEpow_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1;auto.
 Qed.
 
 
@@ -508,8 +597,9 @@ Inductive FExpr : Type :=
  | FEmul: FExpr -> FExpr ->  FExpr
  | FEopp: FExpr ->  FExpr
  | FEinv: FExpr ->  FExpr
- | FEdiv: FExpr -> FExpr ->  FExpr .
-
+ | FEdiv: FExpr -> FExpr ->  FExpr
+ | FEpow: FExpr -> N -> FExpr .
+ 
 Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   match pe with
   | FEc c     => phi c
@@ -520,6 +610,7 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   | FEopp x   => - FEeval l x
   | FEinv x   => / FEeval l x
   | FEdiv x y => FEeval l x / FEeval l y
+  | FEpow x n => rpow (FEeval l x) (Cp_phi n)
   end.
 
 (* The result of the normalisation *)
@@ -538,8 +629,8 @@ Record linear : Type := mk_linear {
 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
+  | e1 :: nil => ~ req (NPEeval l e1) rO
+  | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
   end.
 
 Theorem PCond_cons_inv_l :
@@ -584,66 +675,170 @@ Qed.
                                                                           
   ***************************************************************************)
 
-
-Fixpoint isIn (e1 e2: PExpr C) {struct e2}: option (PExpr C) :=
+Fixpoint isIn (e1:PExpr C)  (p1:positive)
+                      (e2:PExpr C)  (p2:positive) {struct e2}: option (N * 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
+       match isIn e1 p1 e3 p2 with
+       | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
+       | Some (Npos p, e5) => 
+          match isIn e1 p e4 p2 with
+          | Some (n, e6) => Some (n, NPEmul e5 e6)
+          | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
+          end
+       | None => 
+         match isIn e1 p1 e4 p2 with
+         | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
+         | None => None
+         end
        end
+  | PEpow e3 N0 => None 
+  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
   | _ =>
-       if PExpr_eq e1 e2 then Some (PEc cI) else None
+     if  PExpr_eq e1 e2 then
+         match Zminus (Zpos p1) (Zpos p2) with
+          | Zpos p => Some (Npos p, PEc cI)
+          | Z0 => Some (N0, PEc cI)
+          | Zneg p => Some (N0, NPEpow e2 (Npos p))
+          end
+     else None 
    end.
+ 
+ Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
+ Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
+
+ Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) 
+                        ARth.(ARmul_comm) ARth.(ARmul_assoc)).
+
+ Lemma isIn_correct_aux : forall l e1 e2 p1 p2, 
+  match 
+      (if  PExpr_eq e1 e2 then
+         match Zminus (Zpos p1) (Zpos p2) with
+          | Zpos p => Some (Npos p, PEc cI)
+          | Z0 => Some (N0, PEc cI)
+          | Zneg p => Some (N0, NPEpow e2 (Npos p))
+          end
+     else None) 
+   with
+   | Some(n, e3) => 
+       NPEeval l (PEpow e2 (Npos p2)) == 
+       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+       (Zpos p1 > NtoZ n)%Z
+   |  _ => True
+  end.
+Proof.
+  intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
+   case (PExpr_eq e1 e2); simpl; auto; intros H.
+  case_eq ((p1 ?= p2)%positive Eq);intros;simpl. 
+  repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
+  rewrite (Pcompare_Eq_eq _ _ H0).  
+  rewrite H;[trivial | ring [ (morph1 CRmorph)]].
+  fold (NPEpow e2 (Npos (p2 - p1))).
+  rewrite NPEpow_correct;simpl.
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite H;trivial. split. 2:refine (refl_equal _).
+  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. 
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite H;trivial.
+   change (ZtoN
+     match (p1 ?= p1 - p2)%positive Eq with
+     | Eq => 0
+     | Lt => Zneg (p1 - p2 - p1)
+     | Gt => Zpos (p1 - (p1 - p2))
+     end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))).
+  replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z.
+  split.
+  repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
+  rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
+  ring [ (morph1 CRmorph)].
+ assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). 
+ apply Zplus_gt_reg_l with (Zpos p2).
+ rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z.
+ apply Zplus_gt_compat_r. refine (refl_equal _).
+ simpl;rewrite H0;trivial.
+Qed.
+
+Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
+induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl.
+ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
+Qed.
+
 
-Theorem isIn_correct: forall l e1 e2,
-  match isIn e1 e2 with 
-    (Some e3) => NPEeval l e2 == NPEeval l (NPEmul e1 e3)
-  |  _ => True
+Theorem isIn_correct: forall l e1 p1 e2 p2,
+  match isIn e1 p1 e2 p2 with 
+   | Some(n, e3) => 
+       NPEeval l (PEpow e2 (Npos p2)) == 
+       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+        (Zpos p1 > NtoZ n)%Z
+   |  _ => 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.
+Opaque NPEpow.
+intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
+  try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
+generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
+destruct n. 
+  simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
+  generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
+  destruct n;simpl.
+    rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl.
+    intros (H1,H2) (H3,H4).
+    unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
+    rewrite pow_pos_mul. rewrite H1;rewrite H3.
+    assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == 
+        pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
+        NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
+   rewrite <- pow_pos_plus. rewrite Pplus_minus.
+   split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
+   repeat rewrite pow_th.(rpow_pow_N);simpl. 
+   intros (H1,H2) (H3,H4).
+   unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
+   rewrite H2 in H1;simpl in H1.
+   assert (Zpos p1 > Zpos p6)%Z.
+     apply Zgt_trans with (Zpos p4). exact H4. exact H2.
+  unfold Zgt in H;simpl in H;rewrite H.
+  split. 2:exact H.
+  rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
+  assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+                (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
+             pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
+                NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
+  rewrite <- pow_pos_plus.
+  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. 
+ rewrite NPEmul_correct. simpl;ring.
+  assert 
+     (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
+ change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
+ rewrite <- Zplus_assoc. rewrite (Zplus_assoc  (- Zpos p4)).
+ simpl. rewrite Pcompare_refl. reflexivity.
+ unfold Zminus, Zopp in H0. simpl in H0.
+  rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial.
+ simpl. repeat rewrite pow_th.(rpow_pow_N). 
+ intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3.
+ rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
+ rewrite pow_pos_mul. split. ring [H2]. exact H3.
+ generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
+ destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
+ rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
+ intros (H1, H2);rewrite H1;split.
+   unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1.
+   simpl in H1;ring [H1]. trivial. 
+ trivial. 
+ destruct n. trivial.
+ generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
+ destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
+ repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split;trivial.
+ rewrite pow_pos_pow_pos;trivial.
+ trivial.
 Qed.
 
 Record rsplit : Type := mk_rsplit {
@@ -652,90 +847,94 @@ Record rsplit : Type := mk_rsplit {
    rsplit_right : PExpr C}.
 
 (* Stupid name clash *)
-Let left := rsplit_left.
-Let right := rsplit_right.
-Let common := rsplit_common.
+Notation left := rsplit_left.
+Notation right := rsplit_right.
+Notation common := rsplit_common.
 
-Fixpoint split (e1 e2: PExpr C) {struct e1}: rsplit :=
+Fixpoint split_aux (e1: PExpr C) (p:positive) (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
+      let r1 := split_aux e3 p e2 in
+      let r2 := split_aux e4 p (right r1) in
           mk_rsplit (NPEmul (left r1) (left r2))
                     (NPEmul (common r1) (common r2))
                     (right r2)
+  | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
+  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2      
   | _ => 
-       match isIn e1 e2 with
-         Some e3 => mk_rsplit (PEc cI) e1 e3
-       | None => mk_rsplit e1 (PEc cI) e2
+       match isIn e1 p e2 xH with
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+       | None => mk_rsplit (NPEpow e1 (Npos p)) (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))).
+Lemma split_aux_correct_1 : forall l e1 p e2,
+  let res :=  match isIn e1 p e2 xH with
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+       | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
+       end in
+       NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
+   /\
+       NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
 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.
+ intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
+ destruct (isIn e1 p e2 1). destruct p0.
+ Opaque NPEpow NPEmul.
+  destruct n;simpl; 
+    (repeat rewrite NPEmul_correct;simpl;
+     repeat rewrite NPEpow_correct;simpl;
+     repeat rewrite pow_th.(rpow_pow_N);simpl).
+  intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
+  intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H.
+  simpl in H;split;try ring [H].
+  rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
+  simpl;intros. repeat rewrite NPEmul_correct;simpl.
+  rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
 Qed.
 
+Theorem split_aux_correct: forall l e1 p e2,
+  NPEeval l (PEpow e1 (Npos p)) == 
+       NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
+/\
+  NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
+                                   (common (split_aux e1 p e2))).
+Proof.
+intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
+generalize (IHe1_1 k e2); clear IHe1_1.
+generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. 
+simpl. repeat (rewrite NPEmul_correct;simpl).
+repeat rewrite pow_th.(rpow_pow_N);simpl. 
+intros (H1,H2) (H3,H4);split.
+rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
+rewrite H4;rewrite H2;ring.
+destruct n;simpl.
+split. repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite NPEmul_correct. simpl.
+ induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
+ rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
+generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
+repeat rewrite NPEmul_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
+Qed.
 
+Definition split e1 e2 := split_aux e1 xH e2.
+ 
 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.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
+rewrite pow_th.(rpow_pow_N);simpl;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.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
 Qed.
 
 Fixpoint Fnorm (e : FExpr) : linear := 
@@ -777,6 +976,9 @@ Fixpoint Fnorm (e : FExpr) : linear :=
       mk_linear (NPEmul (num x) (denum y))
         (NPEmul (denum x) (num y))
         (num y :: condition x ++ condition y)
+  | FEpow e1 n =>
+      let x := Fnorm e1 in
+      mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
   end.
 
 
@@ -789,6 +991,17 @@ Eval compute
           (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
 *)
 
+ Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
+Proof.
+ induction p;simpl.
+  intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
+  apply IHp.
+  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp). rewrite H1. rewrite Hp;ring. ring.
+  reflexivity. 
+  intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
+  rewrite Hp;ring. reflexivity. trivial.
+Qed.
+ 
 Theorem Pcond_Fnorm:
  forall l e,
  PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
@@ -849,6 +1062,11 @@ intros l e; elim e.
     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).
+ simpl;intros e1 Hrec1 n Hcond.
+  rewrite NPEpow_correct.
+  simpl;rewrite pow_th.(rpow_pow_N).
+  destruct n;simpl;intros.
+  apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
 Qed.
 Hint Resolve Pcond_Fnorm.
 
@@ -928,6 +1146,23 @@ rewrite (He1 HH1); rewrite (He2 HH2).
 repeat rewrite NPEmul_correct;simpl.
 apply rdiv7; auto.
 apply PCond_cons_inv_l with ( 1 := HH ).
+
+intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
+repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1';clear He1'.
+destruct n;simpl. apply rdiv1.
+generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
+  (Pcond_Fnorm _ _ Hcond).
+intros r r0 Hdiff;induction p;simpl.
+repeat (rewrite <- rdiv4;trivial).
+intro Hp;apply (pow_pos_not_0 Hdiff  p). 
+rewrite  (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p)  0).
+ apply pow_pos_not_0;trivial. ring [Hp]. reflexivity.
+apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+rewrite IHp;reflexivity.
+rewrite <- rdiv4;trivial. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+rewrite IHp;reflexivity.
+reflexivity.
 Qed.
 
 Theorem Fnorm_crossproduct:
@@ -951,17 +1186,22 @@ rewrite Fnorm_FEeval_PEeval in |- *.
 Qed.
 
 (* Correctness lemmas of reflexive tactics *)
+Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow).
+Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb).
 
 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;
+ forall n l lpe fe,
+  Ninterp_PElist l lpe ->
+  Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
+  PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
+intros n l lpe fe Hlpe 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.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th n l lpe);auto.
+change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)).
+apply (Peq_ok Rsth Reqe CRmorph);auto.
+simpl. apply (morph0 CRmorph); auto.
 Qed.
 
 (* simplify a field expression into a fraction *)
@@ -969,31 +1209,50 @@ Qed.
 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)).
+Definition display_pow_linear l num den :=
+  NPphi_pow l num / NPphi_pow l den.
+
+Theorem Field_rw_correct :
+ forall n lpe l,
+   Ninterp_PElist l lpe ->
+   forall lmp, Nmk_monpol_list lpe = lmp ->
+   forall fe nfe, Fnorm fe = nfe ->
+   PCond l (condition nfe) ->
+   FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
 Proof.
-  intros l fe nfe eq_nfe H; subst nfe.
+  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
   apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
   unfold display_linear; apply SRdiv_ext;
-  apply (Pphi_dev_ok Rsth Reqe ARth CRmorph); reflexivity.
+  eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
+Qed.
+
+Theorem Field_rw_pow_correct :
+ forall n lpe l,
+   Ninterp_PElist l lpe ->
+   forall lmp, Nmk_monpol_list lpe = lmp ->
+   forall fe nfe, Fnorm fe = nfe ->
+   PCond l (condition nfe) ->
+   FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+Proof.
+  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+  unfold display_pow_linear; apply SRdiv_ext;
+  eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
 Qed.
 
-(* solving a field equation *)
 Theorem Field_correct :
- forall l fe1 fe2,
+ forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
  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 ->
+ Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
+          (Nnorm n lmp (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.
+intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
 apply Fnorm_crossproduct; trivial.
-apply (ring_correct Rsth Reqe ARth CRmorph); trivial.
+eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
 Qed.
 
 (* simplify a field equation : generate the crossproduct and simplify
@@ -1002,47 +1261,204 @@ 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))) ->
+ NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
+ NPphi_dev l (Nnorm O nil (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 |- *.
+match goal with 
+ [ |- NPEeval l ?x == NPEeval l ?y] =>
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec
+       O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x)));
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec
+       O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
+ end.
 trivial.
 Qed.
 
 Theorem Field_simplify_eq_correct :
- forall l fe1 fe2,
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
  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))) ->
+ NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_dev l (Nnorm n lmp (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.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+  subst nfe1 nfe2 den lmp.
 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 (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
 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.
+rewrite <-(
+  let x := PEmul (num (Fnorm fe1))
+                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+  let x := (PEmul (num (Fnorm fe2))
+                     (rsplit_left
+                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+    ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
 simpl in Hcrossprod.
 rewrite Hcrossprod in |- *.
 reflexivity.
 Qed.
 
+Theorem Field_simplify_eq_pow_correct :
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+  subst nfe1 nfe2 den lmp.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <-(
+  let x := PEmul (num (Fnorm fe1))
+                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+  let x := (PEmul (num (Fnorm fe2))
+                     (rsplit_left
+                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Theorem Field_simplify_eq_pow_in_correct :
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+  PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_pow l np1 ==
+ NPphi_pow l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
+ apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+Qed.
+
+Theorem Field_simplify_eq_in_correct :
+forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+  PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_dev l np1 ==
+ NPphi_dev l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
+ apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+Qed.
+
+
 Section Fcons_impl.
 
 Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
@@ -1100,7 +1516,7 @@ 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)
+     if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1)
  end.
  
 Theorem PFcons0_fcons_inv:
@@ -1108,8 +1524,8 @@ Theorem PFcons0_fcons_inv:
 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)).
+generalize (ring_correct Rsth Reqe ARth CRmorph pow_th O l nil a a0). simpl.
+  case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)).
 intros H H0 H1; split; auto.
 rewrite H; auto.
 generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
@@ -1125,6 +1541,7 @@ 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)
+ | PEpow e1 _ => Fcons00 e1 l
  | _ => Fcons0 e l
  end.
 
@@ -1137,9 +1554,12 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
    case (H0 _ H3); intros H4 H5; split; auto.
    simpl in |- *.
    apply field_is_integral_domain; trivial.
+   simpl;intros. rewrite pow_th.(rpow_pow_N).
+   destruct (H _ H0);split;auto.
+   destruct n;simpl. apply AFth.(AF_1_neq_0).
+   apply pow_pos_not_0;trivial.
 Qed.
 
-
 Definition Pcond_simpl_gen := 
   fcons_correct _ PFcons00_fcons_inv.
 
@@ -1167,6 +1587,7 @@ 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)
+ | PEpow e _ => Fcons1 e 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
@@ -1196,6 +1617,9 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
     rewrite (morph1 CRmorph) in H0.
     rewrite (morph0 CRmorph) in H0.
     trivial.
+ intros;simpl. destruct (H _ H0);split;trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n;simpl.
+ apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
 Qed.
 
 Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
@@ -1214,30 +1638,6 @@ Definition Pcond_simpl_complete :=
 
 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.
@@ -1457,4 +1857,3 @@ Qed.
 End Field.
 
 End Complete.
-
diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v
index 7df68cc0..bbdcd443 100644
--- a/contrib/setoid_ring/InitialRing.v
+++ b/contrib/setoid_ring/InitialRing.v
@@ -7,16 +7,21 @@
 (************************************************************************)
 
 Require Import ZArith_base.
+Require Import Zpow_def.
 Require Import BinInt.
 Require Import BinNat.
 Require Import Setoid.
 Require Import Ring_theory.
-Require Import Ring_tac.
 Require Import Ring_polynom.
+
 Set Implicit Arguments.
 
 Import RingSyntax.
 
+
+(* An object to return when an expression is not recognized as a constant *)
+Definition NotConstant := false.
+
 (** Z is a ring and a setoid*)
 
 Lemma Zsth : Setoid_Theory Z (@eq Z).
@@ -88,6 +93,21 @@ Section ZMORPHISM.
   | Zneg p => -(gen_phiPOS p)
   end.
  Notation "[ x ]" := (gen_phiZ x).   
+
+ Definition get_signZ z :=
+  match z with
+  | Zneg p => Some (Zpos p) 
+  | _ => None
+  end.
+
+ Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ.
+ Proof.
+  constructor.
+  destruct c;intros;try discriminate.
+  injection H;clear H;intros H1;subst c'.
+  simpl;rrefl.
+ Qed.
+
  
  Section ALMOST_RING.
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
@@ -346,7 +366,8 @@ Section NMORPHISM.
 End NMORPHISM.
 
  (* syntaxification of constants in an abstract ring:
-    the inverse of gen_phiPOS *)
+    the inverse of gen_phiPOS 
+    Why we do not reconnize only rI ?????? *)
  Ltac inv_gen_phi_pos rI add mul t :=
    let rec inv_cst t :=
    match t with
@@ -396,65 +417,8 @@ End NMORPHISM.
      end
    end.
 
-(* coefs = Z (abstract ring) *)
-Module Zpol.
-
-Definition ring_gen_correct
-  R rO rI radd rmul rsub ropp req rSet req_th Rth :=
-  @ring_correct 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 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 rSet req_th Rth).
-
-Definition ring_gen_eq_correct R rO rI radd rmul rsub ropp Rth :=
-  @ring_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) *)
-Module Npol.
-
-Definition ring_gen_correct
-  R rO rI radd rmul req rSet req_th SRth :=
-  @ring_correct 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 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 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.
-
-End Npol.
+(* A simpl tactic reconninzing nothing *)
+ Ltac inv_morph_nothing t := constr:(NotConstant).
 
 
 Ltac coerce_to_almost_ring set ext rspec :=
@@ -481,7 +445,47 @@ Ltac abstract_ring_morphism set ext rspec :=
   | _ => fail 1 "bad ring structure"
   end.
 
-Ltac ring_elements set ext rspec rk :=
+Record hypo : Type := mkhypo {
+   hypo_type : Type;
+   hypo_proof : hypo_type
+ }.
+
+Ltac gen_ring_pow set arth pspec :=
+ match pspec with
+ | None =>
+   match type of arth with
+   | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
+     constr:(mkhypo (@pow_N_th R rI rmul req set))
+   | _ => fail 1 "gen_ring_pow"
+   end
+ | Some ?t => constr:(t)
+ end.
+
+Ltac default_sign_spec morph :=
+ match type of morph with
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+               ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
+      constr:(mkhypo (@get_sign_None_th R ropp req C phi))
+ | _ => fail 1 "ring anomaly : default_sign_spec" 
+ end.
+
+Ltac gen_ring_sign set rspec morph sspec rk :=
+ match sspec with
+ | None =>
+   match rk with
+   | Abstract =>
+     match type of rspec with
+     | @ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
+       constr:(mkhypo (@get_signZ_th R rO rI radd rmul ropp req set))
+     | _ => default_sign_spec morph 
+     end
+   | _ => default_sign_spec morph 
+   end
+ | Some ?t => constr:(t)
+ end.
+
+
+Ltac ring_elements set ext rspec pspec sspec rk :=
   let arth := coerce_to_almost_ring set ext rspec in
   let ext_r := coerce_to_ring_ext ext in
   let morph :=
@@ -493,19 +497,85 @@ Ltac ring_elements set ext rspec rk :=
             constr:(IDmorph rO rI add mul sub opp set _ reqb_ok)
         | _ => fail 2 "ring anomaly"
         end
-    | @Morphism ?m => m
+    | @Morphism ?m =>
+       match type of m with 
+       | ring_morph _ _ _ _ _ _ _  _ _ _ _ _ _  _ _ => m 
+       | @semi_morph _ _ _ _ _ _  _ _ _ _ _  _ _   => 
+           constr:(SRmorph_Rmorph set m) 
+       | _ => fail 2 " ici"
+       end
     | _ => fail 1 "ill-formed ring kind"
     end in
-  fun f => f arth ext_r morph.
+  let p_spec := gen_ring_pow set arth pspec in
+  let s_spec := gen_ring_sign set rspec morph sspec rk in
+  fun f => f arth ext_r morph p_spec s_spec.
 
 (* 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 pspec sspec rk :=
+  let gen_lemma2 :=
+    match pspec with
+    | None => constr:(ring_rw_correct) 
+    | Some _ => constr:(ring_rw_pow_correct)
+    end in
+  ring_elements set ext rspec pspec sspec rk
+    ltac:(fun arth ext_r morph p_spec s_spec =>
+        match p_spec with
+        | mkhypo ?pp_spec =>
+        match s_spec with
+        | mkhypo ?ps_spec =>
+          let lemma1 := 
+            constr:(ring_correct set ext_r arth morph pp_spec) in
+          let lemma2 := 
+            constr:(gen_lemma2 _  _ _  _ _ _  _  _ set ext_r arth 
+                           _  _ _  _ _ _  _  _  _ morph 
+                           _ _ _ pp_spec
+                           _ ps_spec) in 
+          fun f => f arth ext_r morph lemma1 lemma2
+        | _ => fail 2 "bad sign specification"
+       end
+       | _ => fail 1 "bad power specification" 
+       end).
+ 
+(* Tactic for constant *)
+Ltac isnatcst t :=
+  match t with
+    O => true
+  | S ?p => isnatcst p
+  | _ => false
+  end.
+
+Ltac isPcst t :=
+  match t with
+  | xI ?p => isPcst p
+  | xO ?p => isPcst p
+  | xH => constr:true
+  (* nat -> positive *)
+  | P_of_succ_nat ?n => isnatcst n 
+  | _ => false
+  end.
+
+Ltac isNcst t :=
+  match t with
+    N0 => constr:true
+  | Npos ?p => isPcst p
+  | _ => constr:false
+  end.
+
+Ltac isZcst t :=
+  match t with
+    Z0 => true
+  | Zpos ?p => isPcst p
+  | Zneg ?p => isPcst p
+  (* injection nat -> Z *)
+  | Z_of_nat ?n => isnatcst n
+  (* injection N -> Z *)
+  | Z_of_N ?n => isNcst n
+  (* *)
+  | _ => false
+  end.
+
+
 
-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).
 
 
diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v
index 33e3cb4e..ae067a8a 100644
--- a/contrib/setoid_ring/NArithRing.v
+++ b/contrib/setoid_ring/NArithRing.v
@@ -12,16 +12,6 @@ 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
diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v
index 13896123..d0512dff 100644
--- a/contrib/setoid_ring/RealField.v
+++ b/contrib/setoid_ring/RealField.v
@@ -1,6 +1,9 @@
-Require Import Raxioms.
-Require Import Rdefinitions.
+Require Import Nnat.
+Require Import ArithRing. 
 Require Export Ring Field.
+Require Import Rdefinitions.
+Require Import Rpow_def.
+Require Import Raxioms.
 
 Open Local Scope R_scope.
 
@@ -102,4 +105,29 @@ Lemma Zeq_bool_complete : forall x 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).
+Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x  (n + m) = pow x n * pow x m.
+Proof.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros n0 H' m; rewrite H'; auto with real.
+Qed.
+
+Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R))  nat_of_N pow.
+Proof.
+ constructor. destruct n. reflexivity.
+ simpl. induction p;simpl. 
+ rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
+ unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
+ rewrite Rmult_comm;apply Rmult_1_l.
+Qed.
+
+Ltac Rpow_tac t := 
+  match isnatcst t with
+  | false => constr:(InitialRing.NotConstant)
+  | _ => constr:(N_of_nat t)
+  end. 
+
+Add Field RField : Rfield  
+   (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
+
+
+ 
diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v
index 167e026f..1a4e1cc7 100644
--- a/contrib/setoid_ring/Ring.v
+++ b/contrib/setoid_ring/Ring.v
@@ -9,6 +9,7 @@
 Require Import Bool.
 Require Export Ring_theory.
 Require Export Ring_base.
+Require Export InitialRing.
 Require Export Ring_tac.
 
 Lemma BoolTheory :
@@ -25,7 +26,7 @@ reflexivity.
 destruct x; reflexivity.
 Qed.
 
-Unboxed Definition bool_eq (b1 b2:bool) :=
+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.
diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v
index 7317ab21..b79f2fe2 100644
--- a/contrib/setoid_ring/Ring_polynom.v
+++ b/contrib/setoid_ring/Ring_polynom.v
@@ -1,5 +1,5 @@
 (************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(*  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       *)
@@ -10,9 +10,11 @@ Set Implicit Arguments.
 Require Import Setoid.
 Require Import BinList.
 Require Import BinPos.
+Require Import BinNat.
 Require Import BinInt.
 Require Export Ring_theory.
 
+Open Local Scope positive_scope.
 Import RingSyntax.
 
 Section MakeRingPol.
@@ -35,6 +37,12 @@ Section MakeRingPol.
  Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
                                 cO cI cadd cmul csub copp ceqb phi.
 
+  (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R. 
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
 
  (* R notations *)
  Notation "0" := rO. Notation "1" := rI.
@@ -113,12 +121,23 @@ Section MakeRingPol.
   | _ => Pinj j P
   end.
 
+ Definition mkPinj_pred j P:=
+  match j with
+  | xH => P
+  | xO j => Pinj (Pdouble_minus_one j) P
+  | xI j => Pinj (xO j) P
+  end.
+
  Definition mkPX P i Q := 
   match P with
   | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
   | Pinj _ _ => PX P i Q
   | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
   end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
  
  (** Opposite of addition *)
  
@@ -305,7 +324,34 @@ Section MakeRingPol.
    end.
  
  End PmulI.
+(* A symmetric version of the multiplication *)
 
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+   match P'' with
+   | Pc c => PmulC P c
+   | Pinj j' Q' => PmulI Pmul Q' j' P
+   | PX P' i' Q' =>
+     match P with
+     | Pc c => PmulC P'' c
+     | Pinj j Q =>
+       let QQ' := 
+         match j with
+         | xH => Pmul Q Q'
+         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' 
+         | xI j => Pmul (Pinj (xO j) Q) Q'
+         end in
+       mkPX (Pmul P P') i' QQ'
+     | PX P i Q=>
+       let QQ' := Pmul Q Q' in
+       let PQ' := PmulI Pmul Q' xH P in
+       let QP' := Pmul (mkPinj xH Q) P' in
+       let PP' := Pmul P P' in
+       (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+     end
+  end.    
+
+(* Non symmetric *)
+(*       
  Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
   match P' with
   | Pc c' => PmulC P c'
@@ -319,10 +365,21 @@ Section MakeRingPol.
   | Pc c => PmulC P' c
   | Pinj j Q => PmulI Pmul_aux Q j P'
   | PX P i Q => 
-    Padd (mkPX (Pmul_aux P P') i P0) (PmulI Pmul_aux Q xH P')
+    (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
   end.
+*)
  Notation "P ** P'" := (Pmul P P').
- 
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+   match P with
+   | Pc c => Pc (c *! c)
+   | Pinj j Q => Pinj j (Psquare Q)
+   | PX P i Q => 
+     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+     let Q2 := Psquare Q in
+     let P2 := Psquare P in
+     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+   end.
 
  (** Monomial **)
      
@@ -331,29 +388,29 @@ Section MakeRingPol.
   | zmon: positive -> Mon -> Mon 
   | vmon: positive -> Mon -> Mon.
 
- Fixpoint pow (x:R) (i:positive) {struct i}: R :=
-  match i with
-  | xH => x
-  | xO i => let p := pow x i in p * p
-  | 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
+     let xi := pow_pos rmul 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.
 
+ Definition zmon_pred j M :=
+   match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+   match M with 
+   | mon0 => vmon i mon0 
+   | zmon j m => vmon i (zmon_pred j m)
+   | vmon i' m => vmon (i+i') m
+   end.
+
  Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
    match P, M with
         _, mon0 => (Pc cO, P)
@@ -434,7 +491,7 @@ Section MakeRingPol.
   | Pinj j Q => Pphi (jump j l) Q
   | PX P i Q => 
      let x := hd 0 l in
-     let xi := pow x i in
+     let xi := pow_pos rmul x i in
     (Pphi l P) * xi + (Pphi (tail l) Q)      
   end.
 
@@ -469,26 +526,6 @@ Section MakeRingPol.
   rewrite Psucc_o_double_minus_one_eq_xO;trivial.
   simpl;trivial.
  Qed.
-
- Lemma pow_Psucc : forall x j, pow x (Psucc j) == x * pow x j.
- Proof.
-  induction j;simpl;rsimpl.
-  rewrite IHj;rsimpl;mul_push x;rrefl.
- Qed.
-
- Lemma pow_Pplus : forall x i j, pow x (i + j) == pow x i * pow x j.
- Proof.
-  intro x;induction i;intros.
-  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_Psucc.
-  simpl;rsimpl.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi;rsimpl.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_Psucc;
-   simpl;rsimpl.
- Qed.
   
  Lemma Peq_ok : forall P P', 
     (P ?== P') = true -> forall l, P@l == P'@ l.
@@ -523,8 +560,11 @@ Section MakeRingPol.
   rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl.
  Qed.
 
+ Let pow_pos_Pplus := 
+    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
  Lemma mkPX_ok : forall l P i Q, 
-  (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tail l).
+  (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
  Proof.
   intros l P i Q;unfold mkPX.
   destruct P;try (simpl;rrefl).
@@ -533,7 +573,7 @@ Section MakeRingPol.
   rewrite mkPinj_ok;rsimpl;simpl;rrefl.
   assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
   rewrite (H (refl_equal true));trivial.
-  rewrite Pphi0;rewrite pow_Pplus;rsimpl.
+  rewrite Pphi0.  rewrite pow_pos_Pplus;rsimpl.
  Qed.
 
  Ltac Esimpl :=
@@ -622,19 +662,19 @@ Section MakeRingPol.
   Esimpl2;add_push [c];rrefl.
   destruct p0;simpl;Esimpl2.
   rewrite IHP'2;simpl.
-  rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl.
+  rsimpl;add_push (P'1@l * (pow_pos rmul (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 jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));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 @ (tail l));rewrite H;rrefl.
   rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
   rewrite H;rewrite Pplus_comm.
-  rewrite pow_Pplus;rsimpl.
+  rewrite pow_pos_Pplus;rsimpl.
   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).
+           (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
    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).
@@ -642,15 +682,15 @@ Section MakeRingPol.
     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.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
     add_push (P5 @ (tail l0));rrefl.
     rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_Pplus;simpl;rsimpl.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
     add_push (P5 @ (tail l0));rrefl.
   rewrite H0;rsimpl.
   add_push (P3 @ (tail l)).
   rewrite H;rewrite Pplus_comm.
-  rewrite IHP'2;rewrite pow_Pplus;rsimpl.
+  rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
   add_push (P3 @ (tail l));rrefl.
  Qed.
 
@@ -674,20 +714,20 @@ Section MakeRingPol.
   destruct P;simpl. 
   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.
+  rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
   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.
+  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));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 @ (tail l));rewrite H;rrefl.
    rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
   rewrite H;rewrite Pplus_comm.
-  rewrite pow_Pplus;rsimpl.
+  rewrite pow_pos_Pplus;rsimpl.
   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).
+           (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
    induction P;simpl;intros.
    rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
    destruct p2;simpl;rewrite Popp_ok;rsimpl.
@@ -697,17 +737,44 @@ Section MakeRingPol.
     assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
     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.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
     add_push (P5 @ (tail l0));rrefl.
     rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_Pplus;simpl;rsimpl.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
     add_push (P5 @ (tail l0));rrefl.
   rewrite H0;rsimpl.
   rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
   rewrite H;rewrite Pplus_comm.
-  rewrite pow_Pplus;rsimpl.
+  rewrite pow_pos_Pplus;rsimpl.
  Qed.
- 
+(* Proof for the symmetriv version *)
+
+ Lemma PmulI_ok : 
+  forall P', 
+   (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : list R),
+    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  induction P;simpl;intros.
+  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.
+  rewrite Pplus_comm.
+  rewrite jump_Pplus;simpl;rrefl.
+  rewrite H1;rewrite Pplus_comm.
+  rewrite jump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+  rewrite IHP1;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p).
+  rewrite H;rrefl.
+ Qed.
+
+(*
  Lemma PmulI_ok : 
   forall P', 
    (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
@@ -725,11 +792,11 @@ Section MakeRingPol.
   rewrite jump_Pplus;rewrite IHP;rrefl.
   destruct p0;Esimpl2.
   rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow (hd 0 l) p);rrefl.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
   rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
   rewrite IHP1;simpl;rsimpl.
-  mul_push (pow (hd 0 l) p).
+  mul_push (pow_pos rmul (hd 0 l) p).
   rewrite H;rrefl.
  Qed.
 
@@ -741,9 +808,33 @@ Section MakeRingPol.
   rewrite Padd_ok;Esimpl2.
   rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
  Qed.
+*)
 
+(* Proof for the symmetric version *)
  Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
  Proof.
+  intros P P';generalize P;clear P;induction P';simpl;intros.
+  apply PmulC_ok. apply PmulI_ok;trivial.
+  destruct P.
+  rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+  Esimpl2. rewrite IHP'1;Esimpl2.
+   assert (match p0 with
+           | xI j => Pinj (xO j) P ** P'2
+           | xO j => Pinj (Pdouble_minus_one j) P ** P'2 
+           | 1 => P ** P'2
+           end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+   destruct p0;simpl;rewrite IHP'2;Esimpl.
+   rewrite jump_Pdouble_minus_one;Esimpl.
+   rewrite H;Esimpl.
+   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+   rewrite PmulI_ok;trivial.
+   mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
   destruct P;simpl;intros.
   Esimpl2;apply (ARmul_comm ARth).
   rewrite (PmulI_ok P (Pmul_aux_ok P)).
@@ -753,12 +844,38 @@ Section MakeRingPol.
   rewrite Pmul_aux_ok;mul_push (P' @ l).
   rewrite (ARmul_comm ARth (P' @ l));rrefl.
  Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+  induction P;simpl;intros;Esimpl2.
+  apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+  rewrite IHP1;rewrite IHP2.
+  mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@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 zmon_pred_ok : forall M j l, 
+    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+   destruct j; simpl;intros auto; rsimpl.
+   rewrite mkZmon_ok;rsimpl.
+   rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+  destruct M;simpl;intros;rsimpl.
+   rewrite zmon_pred_ok;simpl;rsimpl.
+  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
 
  Lemma Mphi_ok: forall P M l, 
     let (Q,R) := MFactor P M in
@@ -798,8 +915,7 @@ Section MakeRingPol.
      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.
+     rewrite zmon_pred_ok;rsimpl.
    intros j M1.
      case_eq ((i ?= j) Eq); intros He; simpl.
        rewrite (Pcompare_Eq_eq _ _ He).
@@ -827,7 +943,7 @@ Section MakeRingPol.
        apply rmul_ext; rsimpl.
        rewrite (ARmul_comm ARth); rsimpl.
        apply rmul_ext; rsimpl.
-       rewrite <- pow_Pplus.
+       rewrite <- pow_pos_Pplus.
        rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
        generalize (Hrec1 (mkZmon 1 M1) l); 
              case (MFactor P2 (mkZmon 1 M1));
@@ -847,13 +963,15 @@ Section MakeRingPol.
        repeat (rewrite <-(ARmul_assoc ARth)).
        rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
        apply rmul_ext; rsimpl.
-       rewrite <- pow_Pplus.
+       rewrite <- pow_pos_Pplus.
        rewrite (Pplus_minus _ _ He); rsimpl.
  Qed.
 
+(* Proof for the symmetric version *)
 
  Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
     POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
  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.
@@ -864,16 +982,40 @@ Section MakeRingPol.
    discriminate.
    intros _ H1 H2; injection H1; intros; subst.
    rewrite H2; rsimpl.
-   rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ (* new version *)
+   rewrite Padd_ok; rewrite PmulC_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.
+   rewrite Padd_ok; rewrite PmulI_ok. intros;apply 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.
+   assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+   injection H2; intros; subst;trivial.
+  rewrite H;rewrite Padd_ok;rewrite Pmul_ok;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.
+Proof.
+ 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.
@@ -947,47 +1089,28 @@ Section MakeRingPol.
   | PEadd : PExpr -> PExpr -> PExpr
   | PEsub : PExpr -> PExpr -> PExpr
   | PEmul : PExpr -> PExpr -> PExpr
-  | PEopp : PExpr -> PExpr.
-
- (** normalisation towards polynomials *)
- 
- Definition X := (PX P1 xH P0).
-
- Definition mkX j :=
-  match j with
-  | xH => X
-  | xO j => Pinj (Pdouble_minus_one j) X
-  | xI j => Pinj (xO j) X
-  end.
+  | PEopp : PExpr -> PExpr
+  | PEpow : PExpr -> N -> PExpr.
 
- Fixpoint norm (pe:PExpr) : Pol :=
-  match pe with
-  | PEc c => Pc c
-  | PEX j => mkX j
-  | PEadd pe1 (PEopp pe2) => Psub (norm pe1) (norm pe2)
-  | PEadd (PEopp pe1) pe2 => Psub (norm pe2) (norm pe1)
-  | PEadd pe1 pe2 => Padd (norm pe1) (norm pe2)
-  | PEsub pe1 pe2 => Psub (norm pe1) (norm pe2)
-  | PEmul pe1 pe2 => Pmul (norm pe1) (norm pe2)
-  | PEopp pe1 => Popp (norm pe1)
-  end.
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
 
  (** evaluation of polynomial expressions towards R *)
- 
+
  Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R :=
-  match pe with
-  | PEc c => phi c
-  | PEX j => nth 0 j l
-  | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
-  | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
-  | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
-  | PEopp pe1 => - (PEeval l pe1)
-  end.
+   match pe with
+   | PEc c => phi c
+   | PEX j => nth 0 j l
+   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
+   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
+   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
+   | PEopp pe1 => - (PEeval l pe1)
+   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
+   end.
 
  (** Correctness proofs *)
  
-
- Lemma mkX_ok : forall p l, nth 0 p l == (mkX p) @ l.
+ Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
  Proof.
   destruct p;simpl;intros;Esimpl;trivial.
   rewrite <-jump_tl;rewrite nth_jump;rrefl.
@@ -995,238 +1118,579 @@ Section MakeRingPol.
   rewrite nth_Pdouble_minus_one;rrefl.
  Qed.
 
- Lemma norm_PEopp : forall l pe,  (norm (PEopp pe))@l == -(norm pe)@l.
- Proof.
-  intros;simpl;apply Popp_ok.
- Qed.
-
  Ltac Esimpl3 := 
   repeat match goal with
   | |- 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_comm ARth).
+  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). 
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => P
+   | xO p => subst_l (Psquare (Ppow_pos P p))
+   | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+   end.
+ 
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P p
+   end.
+ 
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok P.
+   induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+  Qed.
+ 
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
+    
+ End POWER. *)
+
+Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => subst_l (Pmul res P) 
+   | xO p => Ppow_pos (Ppow_pos res P p) P p
+   | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
+   end.
+ 
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P1 P p
+   end.
+ 
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok res P p. generalize res;clear res.
+   induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+   rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+  Qed.
+ 
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl.  Qed.
+    
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+  Variable n : nat.
+  Variable lmp:list (Mon*Pol).
+  Let subst_l P := PNSubstL P lmp n n.
+  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Ppow_subst := Ppow_N subst_l.
+
+  Fixpoint norm_aux (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => mk_X j  
+   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+   | PEadd pe1 (PEopp pe2) => 
+     Psub (norm_aux pe1) (norm_aux pe2)
+   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
+   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) 
+   | PEopp pe1 => Popp (norm_aux pe1)
+   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+   end.
 
- Lemma norm_ok : forall l pe,  PEeval l pe == (norm pe)@l.
- Proof.
-  induction pe;simpl;Esimpl3.
-  apply mkX_ok.
-  rewrite IHpe1;rewrite IHpe2; destruct pe1;destruct pe2;Esimpl3.
-  rewrite IHpe1;rewrite IHpe2;rrefl.
-  rewrite Pmul_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
-  rewrite IHpe;rrefl.
- Qed.
+  Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (* 
+  Fixpoint norm_subst (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => subst_l (mk_X j)  
+   | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+   | PEadd pe1 (PEopp pe2) => 
+     Psub (norm_subst pe1) (norm_subst pe2)
+   | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
+   | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) 
+   | PEopp pe1 => Popp (norm_subst pe1)
+   | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+   end.
 
- Lemma ring_correct : forall l pe1 pe2, 
-  ((norm pe1) ?== (norm pe2)) = true -> (PEeval l pe1) == (PEeval l pe2).
+  Lemma norm_subst_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_subst pe)@l. 
+  Proof.
+   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). 
+      unfold subst_l;intros.
+      rewrite <- PNSubstL_ok;trivial. rrefl.
+   assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+    intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+   induction pe;simpl;Esimpl3.
+   rewrite subst_l_ok;apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe;rrefl.
+   unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+*)
+ Lemma norm_aux_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_aux pe)@l. 
+  Proof.
+   intros.
+   induction pe;simpl;Esimpl3.
+   apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+   rewrite IHpe;rrefl.
+   rewrite Ppow_N_ok. intros;rrefl.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+
+ Lemma norm_subst_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_subst pe)@l.
  Proof.
-  intros l pe1 pe2 H.
-  repeat rewrite norm_ok.
-  apply  (Peq_ok (norm pe1) (norm pe2) H l).
- Qed.
-
-(** Evaluation function avoiding parentheses *)
- Fixpoint mkmult (r:R) (lm:list R) {struct lm}: R :=
-  match lm with
-  | nil => r
-  | cons h t => mkmult (r*h) t
-  end.
- 		       
- Definition mkadd_mult rP lm :=
-  match lm with
-  | nil => rP + 1
-  | cons h t => rP + mkmult h t
+  intros;unfold norm_subst.
+  unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
+ Qed. 
+ 
+ End NORM_SUBST_REC.
+  
+ Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop :=
+   match lpe with
+   | nil => True
+   | (me,pe)::lpe => 
+     match lpe with
+     | nil => PEeval l me == PEeval l pe
+     | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
+     end
   end.
 
- Fixpoint powl (i:positive) (x:R) (l:list R) {struct i}: list R :=
-  match i with
-  | xH => cons x l
-  | xO i => powl i x (powl i x l)
-  | xI i => powl i x (powl i x (cons x l))
-  end.
-			       
- Fixpoint add_mult_dev (rP:R) (P:Pol) (fv lm:list R) {struct P} : R :=
-  (* rP + P@l * lm *)
+  Fixpoint mon_of_pol (P:Pol) : option Mon :=
   match P with
-  | 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 (tail fv) lm
+  | Pc c => if (c ?=! cI) then Some mon0 else None
+  | Pinj j P =>
+    match mon_of_pol P with 
+    | None => None
+    | Some m =>  Some (mkZmon j m) 
+    end
+  | PX P i Q =>
+    if Peq Q P0 then
+      match mon_of_pol P with
+      | None => None
+      | Some m => Some (mkVmon i m)
+      end
+    else None
   end.
- 
- Definition mkmult1 lm :=
-  match lm with
-  | nil => rI
-  | cons h t => mkmult h t
+
+ Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) :=
+  match lpe with
+  | nil => nil
+  | (me,pe)::lpe =>
+    match mon_of_pol (norm_subst 0 nil me) with
+    | None => mk_monpol_list lpe 
+    | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe 
+    end
   end.
+
+  Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
+              forall l, Mphi l m == P@l.
+  Proof.
+    induction P;simpl;intros;Esimpl.  
+    assert (H1 := (morph_eq CRmorph) c cI).
+    destruct (c ?=! cI).
+    inversion H;rewrite H1;trivial;Esimpl.
+    discriminate.
+    generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate.
+    inversion H0.
+    rewrite mkZmon_ok;simpl;auto.
+    generalize H;clear H;change match P3 with
+        | Pc c => c ?=! cO
+        | Pinj _ _ => false
+        | PX _ _ _ => false
+        end with (P3 ?== P0).
+    assert (H := Peq_ok P3 P0).
+    destruct (P3 ?== P0).
+    case_eq (mon_of_pol P2);intros.
+    inversion H1.
+    rewrite mkVmon_ok;simpl.
+    rewrite H;trivial;Esimpl.  rewrite IHP1;trivial;Esimpl. discriminate.
+    intros;discriminate.
+   Qed.
+ 
+ Lemma interp_PElist_ok : forall l lpe, 
+         interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l.
+ Proof.
+   induction lpe;simpl. trivial.
+   destruct a;simpl;intros.
+   assert (HH:=mon_of_pol_ok (norm_subst 0 nil  p));
+     destruct  (mon_of_pol (norm_subst 0 nil p)).  
+   split.
+   rewrite <- norm_subst_spec. exact I.
+   destruct lpe;try destruct H;rewrite <- H;
+   rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial.
+   apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+   apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+ Qed.
+
+ Lemma norm_subst_ok : forall n l lpe pe,
+   interp_PElist l lpe ->
+   PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l.
+ Proof.
+   intros;apply norm_subst_spec. apply interp_PElist_ok;trivial.
+  Qed.
+ 
+ Lemma ring_correct : forall n l lpe pe1 pe2,
+   interp_PElist l lpe ->
+   (let lmp := mk_monpol_list lpe in
+   norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true ->
+   PEeval l pe1 == PEeval l pe2.
+ Proof.
+  simpl;intros.
+  do 2 (rewrite (norm_subst_ok n l lpe);trivial). 
+  apply Peq_ok;trivial.
+ Qed.  
+
+
+
+  (** Generic evaluation of polynomial towards R avoiding parenthesis *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory ropp req phi get_sign.
+
+
+ Section EVALUATION.
+
+  (* [mkpow x p] = x^p *)
+  Variable mkpow : R -> positive -> R.
+  (* [mkpow x p] = -(x^p) *)
+  Variable mkopp_pow : R -> positive -> R.
+  (* [mkmult_pow r x p] = r * x^p *)
+  Variable mkmult_pow : R -> R -> positive -> R.
     
- Fixpoint mult_dev (P:Pol) (fv lm : list R) {struct P} : R :=
-  (* P@l * lm *)							      
+  Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R :=
+   match lm with
+   | nil => r
+   | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t 
+   end.
+
+  Definition mkmult1 lm :=
+   match lm with
+   | nil => 1
+   | cons (x,p) t => mkmult_rec (mkpow x p) t 
+   end.
+
+  Definition mkmultm1 lm :=
+   match lm with
+   | nil => ropp rI
+   | cons (x,p) t => mkmult_rec (mkopp_pow x p) t 
+   end.
+
+  Definition mkmult_c_pos c lm :=
+   if c ?=! cI then mkmult1 (rev' lm)
+   else mkmult_rec [c] (rev' lm).
+
+  Definition mkmult_c c lm :=
+   match get_sign c with
+   | None => mkmult_c_pos c lm
+   | Some c' => 
+     if c' ?=! cI then mkmultm1 (rev' lm)
+     else mkmult_rec [c] (rev' lm)
+   end.
+      
+  Definition mkadd_mult rP c lm :=
+   match get_sign c with
+   | None => rP + mkmult_c_pos c lm
+   | Some c' => rP - mkmult_c_pos c' lm
+   end.
+
+  Definition add_pow_list (r:R) n l :=
+   match n with 
+   | N0 => l
+   | Npos p => (r,p)::l
+   end.
+
+  Fixpoint add_mult_dev 
+      (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
+   match P with
+   | Pc c => 
+     let lm := add_pow_list (hd 0 fv) n lm in
+     mkadd_mult rP c lm
+   | Pinj j Q => 
+     add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+   | PX P i Q => 
+     let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
+     if Q ?== P0 then rP 
+     else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
+   end.
+
+  Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) 
+                     (lm:list (R*positive)) {struct P} : R :=
+  (* P@l * (hd 0 l)^n * lm *)						      
   match P with
-  | Pc c => if c ?=! cI then mkmult1 (rev' lm) else mkmult [c] (rev' lm)
-  | Pinj j Q => mult_dev Q (jump j fv) lm
+  | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
+  | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n 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 (tail fv) lm
+     let rP := mult_dev P fv (Nplus (Npos i) n) lm in
+     if Q ?== P0 then rP 
+     else 
+       let lmq := add_pow_list (hd 0 fv) n lm in
+       add_mult_dev rP Q (tail fv) N0 lmq
   end. 
 
- Definition Pphi_dev fv P := mult_dev P fv nil.
+ Definition Pphi_avoid fv P := mult_dev P fv N0 nil.
+ 
+ Fixpoint r_list_pow (l:list (R*positive)) : R :=
+  match l with
+  | nil => rI
+  | cons (r,p) l => pow_pos rmul r p * r_list_pow l 
+  end.
 
- Add Morphism mkmult : mkmult_ext.
-  intros r r0 eqr l;generalize l r r0 eqr;clear l r r0 eqr;
-   induction l;simpl;intros.
-  trivial. apply IHl; rewrite eqr;rrefl.
- Qed.
+  Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p.
+  Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). 
+  Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p.
 
- Lemma mul_mkmult : forall lm r1 r2, r1 * mkmult r2 lm == mkmult (r1*r2) lm.
+ Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm.
  Proof.
-  induction lm;simpl;intros;try rrefl.
-  rewrite IHlm.
-  setoid_replace (r1 * (r2 * a)) with (r1 * r2 * a);Esimpl.
- Qed.
+   induction lm;intros;simpl;Esimpl.
+   destruct a as (x,p);Esimpl.
+   rewrite IHlm. rewrite mkmult_pow_spec. Esimpl.
+  Qed.
 
- Lemma mkmult1_mkmult : forall lm r, r * mkmult1 lm == mkmult r lm.
+ Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm.
  Proof.
-  destruct lm;simpl;intros. Esimpl.
-  apply mul_mkmult.
+   destruct lm;simpl;Esimpl.
+   destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl.
  Qed.
- 
- Lemma mkmult1_mkmult_1 : forall lm, mkmult1 lm == mkmult 1 lm.
+
+ Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm.
  Proof.
-  intros;rewrite <- mkmult1_mkmult;Esimpl.
+  destruct lm;simpl;Esimpl.
+  destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl.
  Qed.
 
- Lemma mkmult_rev_append : forall lm l r,
-  mkmult r (rev_append lm l) == mkmult (mkmult r l) lm.
+ Lemma r_list_pow_rev :  forall l, r_list_pow (rev' l) == r_list_pow l.
+ Proof.
+   assert 
+    (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
+   induction l;intros;simpl;Esimpl.
+   destruct a;rewrite IHl;Esimpl.
+   rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl.
+  intros;unfold rev'. rewrite H;simpl;Esimpl.
+  Qed.
+
+ Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm.
  Proof.
- induction lm; simpl in |- *; intros.
- rrefl.
- rewrite IHlm; simpl in |- *.
-   repeat rewrite <- (ARmul_comm ARth a); rewrite <- mul_mkmult.
-   rrefl.
+  intros;unfold mkmult_c_pos;simpl.
+   assert (H := (morph_eq CRmorph) c cI).
+   rewrite <- r_list_pow_rev; destruct (c ?=! cI). 
+  rewrite H;trivial;Esimpl.
+  apply mkmult1_ok.  apply mkmult_rec_ok.
  Qed.
 
- Lemma powl_mkmult_rev : forall p r x lm,
-  mkmult r (rev' (powl p x lm)) == mkmult (pow x p * r) (rev' lm).
+ Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm.
+ Proof.
+  intros;unfold mkmult_c;simpl.
+  case_eq (get_sign c);intros.
+  assert (H1 := (morph_eq CRmorph) c0  cI).
+  destruct (c0 ?=! cI).
+   rewrite (get_sign_spec.(sign_spec) _ H). rewrite H1;trivial.
+   rewrite <- r_list_pow_rev;trivial;Esimpl.
+  apply mkmultm1_ok.
+ rewrite <- r_list_pow_rev; apply mkmult_rec_ok.
+ apply mkmult_c_pos_ok.
+Qed.
+
+ Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm.
  Proof.
-  induction p;simpl;intros.
-  repeat rewrite IHp.
-  unfold rev';simpl.
-  repeat rewrite mkmult_rev_append.
-  simpl.
-  setoid_replace (pow x p * (pow x p * r) * x) 
-    with (x * pow x p * pow x p * r);Esimpl.
-  mul_push x;rrefl.
-  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_comm ARth);rrefl.
+  intros;unfold mkadd_mult.
+  case_eq (get_sign c);intros.
+  rewrite (get_sign_spec.(sign_spec) _ H).
+  rewrite mkmult_c_pos_ok;Esimpl.
+  rewrite mkmult_c_pos_ok;Esimpl.
  Qed.
 
- Lemma Pphi_add_mult_dev : forall P rP fv lm, 
-    rP + P@fv * mkmult1 (rev' lm) == add_mult_dev rP P fv lm.
+ Lemma add_pow_list_ok : 
+      forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l.
  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.
-    rewrite mkmult1_mkmult;rrefl.
-   apply IHP.
-   replace (match P3 with
+   destruct n;simpl;intros;Esimpl.
+ Qed.
+
+ Lemma add_mult_dev_ok : forall P rP fv n lm, 
+    add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+  Proof.
+    induction P;simpl;intros.  
+    rewrite mkadd_mult_ok. rewrite  add_pow_list_ok; Esimpl.
+    rewrite IHP. simpl. rewrite  add_pow_list_ok; Esimpl.
+    change (match P3 with
        | Pc c => c ?=! cO
        | Pinj _ _ => false
        | PX _ _ _ => false
-       end) with (Peq P3 P0);trivial.
+       end) with (Peq P3 P0).
+   change match n with
+    | N0 => Npos p
+    | Npos q => Npos (p + q)
+    end with (Nplus (Npos p) n);trivial.
    assert (H := Peq_ok P3 P0).
     destruct (P3 ?== P0).
-    rewrite (H (refl_equal true));simpl;Esimpl.
-   rewrite <- IHP1.
-     repeat rewrite mkmult1_mkmult_1.
-     rewrite powl_mkmult_rev.
-     rewrite <- mul_mkmult;Esimpl.
-   rewrite <- IHP2.
-   rewrite <- IHP1.
-     repeat rewrite mkmult1_mkmult_1.
-     rewrite powl_mkmult_rev.
-     rewrite <- mul_mkmult;Esimpl.
+    rewrite (H (refl_equal true)).
+   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+   rewrite  IHP2.
+   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
  Qed.
-                                     
- Lemma Pphi_mult_dev : forall P fv lm,
-	 P@fv * mkmult1 (rev' lm) == mult_dev P fv lm.
+
+ Lemma mult_dev_ok : forall P fv n lm,    
+    mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow 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.
-    apply  mkmult1_mkmult.
-   apply IHP.
-   replace (match P3 with
+   induction P;simpl;intros;Esimpl.
+   rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl.
+   rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl.
+  change (match P3 with
        | Pc c => c ?=! cO
        | Pinj _ _ => false
        | PX _ _ _ => false
-       end) with (Peq P3 P0);trivial.
+       end) with (Peq P3 P0).
+   change match n with
+    | N0 => Npos p
+    | Npos q => Npos (p + q)
+    end with (Nplus (Npos p) n);trivial.
    assert (H := Peq_ok P3 P0).
-   destruct (P3 ?== P0).
-   rewrite (H (refl_equal true));simpl;Esimpl.
-   rewrite <- IHP1.
-     repeat rewrite mkmult1_mkmult_1.
-     rewrite powl_mkmult_rev.
-     rewrite <- mul_mkmult;Esimpl.
-   rewrite <- Pphi_add_mult_dev.
-   rewrite <- IHP1.
-     repeat rewrite mkmult1_mkmult_1.
-     rewrite powl_mkmult_rev.
-     rewrite <- mul_mkmult;Esimpl.
- Qed.
+    destruct (P3 ?== P0).
+    rewrite (H (refl_equal true)).
+   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+   rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok.
+   destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+  Qed.
 
- Lemma Pphi_Pphi_dev :  forall P l,  P@l == Pphi_dev l P.
- Proof. 		
-  unfold Pphi_dev;intros.
-  rewrite <- Pphi_mult_dev;simpl;Esimpl.
+ Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P  == P@fv.
+ Proof.
+   unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl.
  Qed.
 
- Lemma Pphi_dev_gen_ok :  forall l pe,  PEeval l pe == Pphi_dev l (norm pe).
+ End EVALUATION.
+
+  Definition Pphi_pow := 
+   let mkpow x p := 
+      match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in
+   let mkopp_pow x p := ropp (mkpow x p)  in
+   let mkmult_pow r x p := rmul r (mkpow x p) in
+    Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+ Lemma local_mkpow_ok : 
+   forall (r : R) (p : positive),
+    match p with
+    | xI _ => rpow r (Cp_phi (Npos p))
+    | xO _ => rpow r (Cp_phi (Npos p))
+    | 1 => r
+    end == pow_pos rmul r p.
+ Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
+ 
+ Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P  == P@fv.
  Proof.
-  intros l pe;rewrite <- Pphi_Pphi_dev;apply norm_ok.
+  unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
  Qed.
 
- Lemma Pphi_dev_ok :
-   forall l pe npe, norm pe = npe -> PEeval l pe == Pphi_dev l npe.
+ Lemma ring_rw_pow_correct : forall n lH l,  
+      interp_PElist l lH ->
+      forall lmp, mk_monpol_list lH = lmp ->
+      forall pe npe, norm_subst n lmp pe = npe ->
+      PEeval l pe == Pphi_pow l npe.
  Proof.
-  intros l pe npe npe_eq; subst npe; apply Pphi_dev_gen_ok.
- Qed. 
+  intros n lH l H1 lmp Heq1 pe npe Heq2.
+  rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1.
+  apply norm_subst_ok. trivial.
+ 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
+ Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := 
+   match p with
+   | xH => r*x 
+   | xO p => mkmult_pow (mkmult_pow r x p) x p
+   | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p
+   end.
+ 
+  Definition mkpow x p :=
+    match p with 
+    | xH => x
+    | xO p => mkmult_pow x x (Pdouble_minus_one p)
+    | xI p => mkmult_pow x x (xO p)
     end.
-
- 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
+ 
+  Definition mkopp_pow x p :=
+    match p with 
+    | xH => -x
+    | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
+    | xI p => mkmult_pow (-x) x (xO p)
     end.
 
- Lemma MP_cond_dev_imp_MP_cond: forall LM1 l,
-     MPcond_dev LM1 l -> MPcond LM1 l.
+  Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+  Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
+  Proof.
+    induction p;intros;simpl;Esimpl.   
+    repeat rewrite IHp;Esimpl.
+    repeat rewrite IHp;Esimpl.
+  Qed.
+  
+ Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
+  Proof.
+    destruct p;simpl;intros;Esimpl.
+    repeat rewrite mkmult_pow_ok;Esimpl.
+    rewrite mkmult_pow_ok;Esimpl.
+    pattern x at 1;replace x with (pow_pos rmul x 1). 
+    rewrite <- pow_pos_Pplus. 
+    rewrite <- Pplus_one_succ_l.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    simpl;Esimpl.
+    trivial.
+  Qed.
+ 
+  Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
+  Proof.
+    destruct p;simpl;intros;Esimpl.
+    repeat rewrite mkmult_pow_ok;Esimpl.
+    rewrite mkmult_pow_ok;Esimpl.
+    pattern x at 1;replace x with (pow_pos rmul x 1). 
+    rewrite <- pow_pos_Pplus. 
+    rewrite <- Pplus_one_succ_l.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    simpl;Esimpl.
+    trivial.
+  Qed.
+
+ Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv.
+  Proof.
+   unfold Pphi_dev;intros;apply Pphi_avoid_ok.
+   intros;apply mkpow_ok.
+   intros;apply mkopp_pow_ok.
+   intros;apply mkmult_pow_ok.
+  Qed.
+
+ Lemma ring_rw_correct : forall n lH l,  
+      interp_PElist l lH ->
+      forall lmp, mk_monpol_list lH = lmp ->
+      forall pe npe, norm_subst n lmp pe = npe ->
+      PEeval l pe == Pphi_dev l npe.
  Proof.
- intros LM1; elim LM1; simpl; auto.
- intros (M2,P2) LM2 Hrec l [H1 H2]; split; auto.
- rewrite H1; rewrite Pphi_Pphi_dev; rsimpl. 
+  intros n lH l H1 lmp Heq1 pe npe Heq2.
+  rewrite  Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1.
+  apply norm_subst_ok. trivial.
  Qed.
 
- 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.
 
-End MakeRingPol. 
+End MakeRingPol.
+
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
index 95efde7f..7419f184 100644
--- a/contrib/setoid_ring/Ring_tac.v
+++ b/contrib/setoid_ring/Ring_tac.v
@@ -3,16 +3,23 @@ Require Import Setoid.
 Require Import BinPos.
 Require Import Ring_polynom.
 Require Import BinList.
+Require Import InitialRing.
 Declare ML Module "newring".
-
+  
 
 (* 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]).
+  pose (id' := t');
+  assert (id : t = id');
+  [vm_cast_no_check (refl_equal id')|idtac].
+(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *)
+
+Ltac getGoal :=
+  match goal with 
+  | |- ?G => G
+  end.
 
 (********************************************************************)
 (* Tacticals to build reflexive tactics *)
@@ -23,7 +30,6 @@ Ltac OnEquation req :=
   | _ => fail 1 "Goal is not an equation (of expected equality)"
   end.
 
-
 Ltac OnMainSubgoal H ty :=
   match ty with
   | _ -> ?ty' =>
@@ -32,43 +38,54 @@ Ltac OnMainSubgoal H ty :=
   | _ => (fun tac => tac)
   end.
 
-Ltac ApplyLemmaAndSimpl tac lemma pe:=
-  let npe := fresh "ast_nf" in
+Ltac ApplyLemmaThen lemma expr tac :=
+  let nexpr := fresh "expr_nf" in
+  let H := fresh "eq_nf" in
+  let Heq := fresh "thm" in
+  let nf_spec :=
+    match type of (lemma expr) with
+      forall x, ?nf_spec = x -> _ => nf_spec
+    | _ => fail 1 "ApplyLemmaThen: cannot find norm expression"
+    end in
+  (compute_assertion H nexpr nf_spec;
+   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
+   clear H;
+   OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr)).
+
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
+  let npe := fresh "expr_nf" in
   let H := fresh "eq_nf" in
   let Heq := fresh "thm" in
   let npe_spec :=
-    match type of (lemma pe) with
+    match type of (lemma expr) with
       forall npe, ?npe_spec = npe -> _ => npe_spec
-    | _ => fail 1 "ApplyLemmaAndSimpl: cannot find norm expression"
+    | _ => fail 1 "ApplyLemmaThenAndCont: 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)).
+     ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)).
 
 (* 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).
+
+Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms :=
+  (* extend the atom list *)
+  let fv := list_fold_left FV_tac fv terms in
+  let RW_tac lemma := 
+     let fcons term CONT_tac cont_arg := 
+      let expr := SYN_tac term fv in
+      (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in
+     (* rewrite steps *)
+     lazy_list_fold_right fcons ltac:(idtac) terms in
+  LEMMA_tac fv RW_tac.
 
 (********************************************************)
 
-(* An object to return when an expression is not recognized as a constant *)
-Definition NotConstant := false.
-		      
+
 (* Building the atom list of a ring expression *)
-Ltac FV Cst add mul sub opp t fv :=
+Ltac FV Cst CstPow add mul sub opp pow t fv :=
  let rec TFV t fv :=
   match Cst t with
   | NotConstant =>
@@ -77,6 +94,11 @@ 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
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => AddFvTail t fv
+        | _ => TFV t1 fv
+        end
       | _ => AddFvTail t fv
       end
   | _ => fv
@@ -84,10 +106,10 @@ Ltac FV Cst add mul sub opp t fv :=
  in TFV t fv.
 
  (* syntaxification of ring expressions *)
- Ltac mkPolexpr C Cst radd rmul rsub ropp t fv := 
+Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := 
  let rec mkP t :=
     match Cst t with
-    | NotConstant =>
+    | InitialRing.NotConstant =>
         match t with 
         | (radd ?t1 ?t2) => 
           let e1 := mkP t1 in
@@ -100,6 +122,12 @@ Ltac FV Cst add mul sub opp t fv :=
           let e2 := mkP t2 in constr:(PEsub e1 e2)
         | (ropp ?t1) =>
           let e1 := mkP t1 in constr:(PEopp e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant => 
+            let p := Find_at t fv in constr:(PEX C p)
+          | ?c => let e1 := mkP t1 in constr:(PEpow e1 c)
+          end
         | _ =>
           let p := Find_at t fv in constr:(PEX C p)
         end
@@ -107,54 +135,222 @@ Ltac FV Cst add mul sub opp t fv :=
     end
  in mkP t.
 
+Ltac ParseRingComponents lemma :=
+  match type of lemma with
+  | context
+     [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+      (fun f => f R add mul sub opp pow C)
+  | _ => fail 1 "ring anomaly: bad correctness lemma (parse)"
+  end.
+
+
 (* ring tactics *)
 
- 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"
+Ltac FV_hypo_tac mkFV req lH :=
+  let R := match type of req with ?R -> _ => R end in
+  let FV_hypo_l_tac h :=
+    match h with @mkhypo (req ?pe _) _ => mkFV pe end in
+  let FV_hypo_r_tac h :=
+    match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
+  let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
+  list_fold_right FV_hypo_r_tac fv lH.
+
+Ltac mkHyp_tac C req mkPE lH :=
+  let mkHyp h res := 
+   match h with 
+   | @mkhypo (req ?r1 ?r2) _ =>
+     let pe1 := mkPE r1 in
+     let pe2 := mkPE r2 in
+     constr:(cons (pe1,pe2) res)
+   | _ => fail "hypothesis is not a ring equality"
+   end in
+  list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
+     
+Ltac proofHyp_tac lH :=
+  let get_proof h :=
+    match h with
+    | @mkhypo _ ?p => p
     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"
+  let rec bh l :=
+    match l with
+    | nil => constr:(I)
+    | cons ?h nil => get_proof h
+    | cons ?h ?tl => 
+      let l := get_proof h in
+      let r := bh tl in  
+      constr:(conj l r)
     end in
-  Make_tac ReflexiveRewriteTactic.
+  bh lH.
+
+Definition ring_subst_niter := (10*10*10)%nat.
+ 
+Ltac Ring Cst_tac CstPow_tac lemma1 req n lH :=
+  let Main lhs rhs R radd rmul rsub ropp rpow C :=
+    let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let fv := mkFV lhs fv in
+    let fv := mkFV rhs fv in
+    check_fv fv;
+    let pe1 := mkPol lhs fv in
+    let pe2 := mkPol rhs fv in
+    let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+    let vlpe := fresh "hyp_list" in
+    let vfv := fresh "fv_list" in
+    pose (vlpe := lpe);
+    pose (vfv := fv);
+    (apply (lemma1 n vfv vlpe pe1 pe2)
+      || fail "typing error while applying ring");
+    [ ((let prh := proofHyp_tac lH in exact prh)
+        || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") 
+    | vm_compute;
+      (exact (refl_equal true) || fail "not a valid ring equation")] in
+  ParseRingComponents lemma1 ltac:(OnEquation req Main).
+
+Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
+  let Main R add mul sub opp pow C :=
+    let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in
+    let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let simpl_ring H := (protect_fv "ring" in H; f H) in
+    let Coeffs :=
+      match type of lemma2 with
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
+        (fun f => f cO cI cadd cmul csub copp ceqb)
+      | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
+      end in
+    let lemma_tac fv RW_tac := 
+      let rr_lemma := fresh "r_rw_lemma" in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let vlpe := fresh "list_hyp" in
+      let vlmp := fresh "list_hyp_norm" in
+      let vlmp_eq := fresh "list_hyp_norm_eq" in
+      let prh := proofHyp_tac lH in
+      pose (vlpe := lpe);
+      Coeffs ltac:(fun cO cI cadd cmul csub copp ceqb =>
+        compute_assertion vlmp_eq vlmp 
+            (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+        assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
+         || fail "type error when build the rewriting lemma";
+        RW_tac rr_lemma;
+        try clear rr_lemma vlmp_eq vlmp vlpe) in
+    ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in
+  ParseRingComponents lemma2 Main.
 
+Ltac Ring_gen
+  req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl :=
+  pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH.
 
 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).
+  let G := getGoal in ring_lookup Ring_gen [] [G].
+
+Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
+  let G := getGoal in ring_lookup Ring_gen [lH] [G].
+
+(* Simplification *)
+
+Ltac Ring_simplify_gen f :=
+  fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     let l := fresh "to_rewrite" in
+     pose (l:= rl);
+     generalize (refl_equal l);
+     unfold l at 2;
+     pre(); 
+     match goal with
+     | [|- l = ?RL -> _ ] =>
+       let Heq := fresh "Heq" in
+       intros Heq;clear Heq l;
+       Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; 
+       post()
+     | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+     end.
+
+Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
+
+Ltac Ring_nf Cst_tac lemma2 req rl f :=
+  let on_rhs H :=
+   match type of H with
+   | req _ ?rhs => clear H; f rhs
+   end in
+  Ring_norm_gen on_rhs Cst_tac lemma2 req rl.
+
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  let G := getGoal in ring_lookup Ring_simplify [lH] rl [G].
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) := 
+  let G := getGoal in ring_lookup Ring_simplify [] rl [G].
+
+
+Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=   
+ let G := getGoal in
+ let t := type of H in   
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup Ring_simplify [] rl [t];
+ intro H;
+ unfold g;clear g.
+
+Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):=   
+ let G := getGoal in
+ let t := type of H in   
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup Ring_simplify [lH] rl [t];
+ intro H;
+ unfold g;clear g.
+
+
+(*
+
+Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := 
+  match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) := 
+  match goal with [|- ?G] => ring_lookup Ring_simplify [] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= 
+  let t := type of h in
+  ring_lookup 
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post()) 
+  [lH] rl [t]. 
+(*  ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *)
+
+Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) "in" constr(h):= 
+  let t := type of h in
+  ring_lookup   
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post())
+ [] rl [t].
+
+Ltac rw_in H Heq := rewrite Heq in H.
+
+Ltac simpl_in H := 
+  let t := type of H in
+   ring_lookup 
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post()) 
+   [] [t].
 
-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_theory.v b/contrib/setoid_ring/Ring_theory.v
index 2f7378eb..5498911d 100644
--- a/contrib/setoid_ring/Ring_theory.v
+++ b/contrib/setoid_ring/Ring_theory.v
@@ -7,6 +7,9 @@
 (************************************************************************)
 
 Require Import Setoid.
+Require Import BinPos.
+Require Import BinNat.
+
 Set Implicit Arguments.
 
 Module RingSyntax.
@@ -27,6 +30,71 @@ Reserved Notation "x == y" (at level 70, no associativity).
 End RingSyntax.
 Import RingSyntax.
 
+Section Power.
+ Variable R:Type.
+ Variable rI : R.
+ Variable rmul : R -> R -> R.
+ Variable req : R -> R -> Prop.
+ Variable Rsth : Setoid_Theory R req.
+ Notation "x * y " := (rmul x y).
+ Notation "x == y" := (req x y).
+
+ Hypothesis mul_ext : 
+   forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
+ Hypothesis mul_comm : forall x y, x * y == y * x.
+ Hypothesis mul_assoc  : forall x y z, x * (y * z) == (x * y) * z.
+ Add Setoid R req Rsth as R_set_Power.
+ Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed.
+
+
+ Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+  match i with
+  | xH => x
+  | xO i => let p := pow_pos x i in rmul p p
+  | xI i => let p := pow_pos x i in rmul x (rmul p p)
+  end.
+
+ Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
+ Proof.
+  induction j;simpl.
+  rewrite IHj.
+  rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
+  set (w:= x*pow_pos x j);unfold w at 2.
+  rewrite (mul_comm x (pow_pos x j));unfold w.
+  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  apply (Seq_refl _ _ Rsth).
+ Qed.
+
+ Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j.
+ Proof.
+  intro x;induction i;intros.
+  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc.
+  simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc;
+   simpl. apply (Seq_refl _ _ Rsth).
+ Qed.
+
+ Definition pow_N (x:R) (p:N) := 
+  match p with
+  | N0 => rI
+  | Npos p => pow_pos x p
+  end. 
+
+ Definition id_phi_N (x:N) : N := x.
+
+ Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n.
+ Proof.
+  intros; apply (Seq_refl _ _ Rsth).
+ Qed.
+
+End Power.
+
 Section DEFINITIONS.
  Variable R : Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
@@ -126,6 +194,19 @@ Section DEFINITIONS.
     morph_opp : forall x, [-!x] == -[x];
     morph_eq  : forall x y, x?=!y = true -> [x] == [y] 
   }.
+
+ Section SIGN.
+  Variable get_sign : C -> option C.
+  Record sign_theory : Prop := mksign_th {
+    sign_spec : forall c c', get_sign c = Some c' -> [c] == - [c']
+  }.
+ End SIGN.
+
+ Definition get_sign_None (c:C) := @None C.
+
+ Lemma get_sign_None_th : sign_theory get_sign_None.
+ Proof. constructor;intros;discriminate. Qed.
+
  End MORPHISM. 
 
  (** Identity is a morphism *)
@@ -140,6 +221,20 @@ Section DEFINITIONS.
   try apply (Seq_refl _ _ Rsth);auto.
  Qed.
 
+ (** Specification of the power function *)
+ Section POWER.
+  Variable Cpow : Set.
+  Variable Cp_phi : N -> Cpow.
+  Variable rpow : R -> Cpow -> R. 
+  
+  Record power_theory : Prop := mkpow_th {
+    rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n)
+  }.
+
+ End POWER.
+
+ Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
+
 End DEFINITIONS.
 
 
@@ -437,11 +532,12 @@ Qed.
 
 End ALMOST_RING.
 
+
 Section AddRing.
 
- Variable R : Type.
+(* Variable R : Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
+ Variable req : R -> R -> Prop. *)
 
 Inductive ring_kind : Type :=
 | Abstract
@@ -461,6 +557,7 @@ Inductive ring_kind : Type :=
     (_ : ring_morph rO rI radd rmul rsub ropp req
                     cO cI cadd cmul csub copp ceqb phi).
 
+
 End AddRing.
 
 
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
index 4f47fff0..8de7021e 100644
--- a/contrib/setoid_ring/ZArithRing.v
+++ b/contrib/setoid_ring/ZArithRing.v
@@ -8,26 +8,49 @@
 
 Require Export Ring.
 Require Import ZArith_base.
+Require Import Zpow_def.
+
 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.
 
+Ltac isZpow_coef t :=
+  match t with 
+  | Zpos ?p => isPcst p
+  | Z0 => true
+  | _ => false
+  end.
+
+Definition N_of_Z x :=
+ match x with
+ | Zpos p => Npos p
+ | _ => N0
+ end.
+
+Ltac Zpow_tac t :=
+ match isZpow_coef t with
+ | true => constr:(N_of_Z t)
+ | _ => constr:(NotConstant)
+ end.
+
+Ltac Zpower_neg :=
+  repeat match goal with
+  | [|- ?G] => 
+    match G with 
+    | context c [Zpower _ (Zneg _)] =>
+      let t := context c [Z0] in
+      change t
+    end
+  end.   
+
+
 Add Ring Zr : Zth
-  (decidable Zeqb_ok, constants [Zcst], preprocess [unfold Zsucc]).
+  (decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
+   power_tac Zpower_theory [Zpow_tac]).
+
diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4
index daa2fedb..8b2ce26b 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 9302 2006-10-27 21:21:17Z barras $ i*)
+(*i $Id: newring.ml4 9603 2007-02-07 00:41:16Z barras $ i*)
 
 open Pp
 open Util
@@ -127,6 +127,12 @@ TACTIC EXTEND closed_term
     [ closed_term t l ]
 END
 ;;
+
+TACTIC EXTEND echo 
+| [ "echo" constr(t) ] -> 
+  [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
+END;;
+
 (*
 let closed_term_ast l =
   TacFun([Some(id_of_string"t")],
@@ -196,7 +202,8 @@ let constr_of = function
 
 let stdlib_modules =
   [["Coq";"Setoids";"Setoid"];
-   ["Coq";"Lists";"List"]
+   ["Coq";"Lists";"List"];
+   ["Coq";"Init";"Datatypes"]
   ]
 
 let coq_constant c =
@@ -205,18 +212,24 @@ let coq_constant c =
 let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
 let coq_cons = coq_constant "cons"
 let coq_nil = coq_constant "nil"
+let coq_None = coq_constant "None"
+let coq_Some = coq_constant "Some"
 
 let lapp f args = mkApp(Lazy.force f,args)
 
+let dest_rel0 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)"
+  | _ -> error "ring: cannot find relation"
+
 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"
+  | Prod(_,_,c) -> dest_rel c
+  | _ -> dest_rel0 t
 
 (****************************************************************************)
 (* Library linking *)
@@ -265,11 +278,18 @@ 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"
 
+(* power function *)
+let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
+let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
+
+(* hypothesis *)
+let coq_mkhypo = my_constant "mkhypo"
+let coq_hypo = my_constant "hypo"
+
 (* Equality: do not evaluate but make recursive call on both sides *)
 let map_with_eq arg_map c =
   let (req,_,_) = dest_rel c in
@@ -283,10 +303,12 @@ let _ = add_map "ring"
     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);
+    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+    pol_cst "Pphi_pow", 
+          (function -1|8|9|10|11|13|15|17->Eval|16->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)])
+    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
 
 (****************************************************************************)
 (* Ring database *)
@@ -299,6 +321,7 @@ type ring_info =
       ring_morph : constr;
       ring_th : constr;
       ring_cst_tac : glob_tactic_expr;
+      ring_pow_tac : glob_tactic_expr;
       ring_lemma1 : constr;
       ring_lemma2 : constr;
       ring_pre_tac : glob_tactic_expr;
@@ -316,7 +339,7 @@ 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 =
+let find_ring_structure env sigma l oname =
   match oname, l with
       Some rf, _ ->
         (try ring_lookup_by_name rf
@@ -337,13 +360,14 @@ let find_ring_structure env sigma l cl oname =
           errorlabstrm "ring"
             (str"cannot find a declared ring structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] ->
+    | None, [] -> assert false
+(*
         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"\""))
+             spc()++str"\""++pr_constr req++str"\"")) *)
 
 let _ = 
   Summary.declare_summary "tactic-new-ring-table"
@@ -378,6 +402,7 @@ let subst_th (_,subst,th) =
   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 pow_tac'= subst_tactic subst th.ring_pow_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 &&
@@ -389,6 +414,7 @@ let subst_th (_,subst,th) =
      thm1' == th.ring_lemma1 &&
      thm2' == th.ring_lemma2 &&
      tac' == th.ring_cst_tac &&
+     pow_tac' == th.ring_pow_tac &&
      pretac' == th.ring_pre_tac &&
      posttac' == th.ring_post_tac then th
   else
@@ -399,6 +425,7 @@ let subst_th (_,subst,th) =
       ring_morph = morph';
       ring_th = th';
       ring_cst_tac = tac';
+      ring_pow_tac = pow_tac';
       ring_lemma1 = thm1';
       ring_lemma2 = thm2';
       ring_pre_tac = pretac';
@@ -532,14 +559,50 @@ let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac =
               TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
           | _ -> error"a tactic must be specified for an almost_ring")
 
-let add_theory name rth eqth morphth cst_tac (pre,post) =
+let make_hyp env c =
+  let t = (Typeops.typing env c).uj_type in
+  lapp coq_mkhypo [|t;c|]
+
+let make_hyp_list env lH =
+  let carrier = Lazy.force coq_hypo in
+  List.fold_right 
+    (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
+    (lapp coq_nil [|carrier|])
+
+let interp_power env pow =  
+  let carrier = Lazy.force coq_hypo in
+  match pow with
+  | None -> 
+      let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
+      (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+  | Some (tac, spec) -> 
+      let tac = 
+        match tac with
+        | CstTac t -> Tacinterp.glob_tactic t
+        | Closed lc -> closed_term_ast (List.map Nametab.global lc) in
+      let spec = make_hyp env (ic spec) in
+      (tac, lapp coq_Some [|carrier; spec|])
+
+let interp_sign env sign =
+  let carrier = Lazy.force coq_hypo in
+  match sign with
+  | None -> lapp coq_None [|carrier|] 
+  | Some spec -> 
+      let spec = make_hyp env (ic spec) in
+      lapp coq_Some [|carrier;spec|]
+       (* Same remark on ill-typed terms ... *)
+
+let add_theory name rth eqth morphth cst_tac (pre,post) power sign =
   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 (pow_tac, pspec) = interp_power env power in 
+  let sspec = interp_sign env sign in
   let rk = reflect_coeff morphth in
   let params =
-    exec_tactic env 5 (zltac"ring_lemmas") (List.map carg[sth;ext;rth;rk]) in
+    exec_tactic env 5 (zltac "ring_lemmas") 
+      (List.map carg[sth;ext;rth;pspec;sspec;rk]) in
   let lemma1 = constr_of params.(3) in
   let lemma2 = constr_of params.(4) in
 
@@ -564,6 +627,7 @@ let add_theory name rth eqth morphth cst_tac (pre,post) =
           ring_morph = constr_of params.(2);
           ring_th = constr_of params.(0);
           ring_cst_tac = cst_tac;
+	  ring_pow_tac = pow_tac;
           ring_lemma1 = lemma1;
           ring_lemma2 = lemma2;
           ring_pre_tac = pretac;
@@ -576,6 +640,10 @@ type ring_mod =
   | Pre_tac of raw_tactic_expr
   | Post_tac of raw_tactic_expr
   | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
+  | Pow_spec of cst_tac_spec * Topconstr.constr_expr
+           (* Syntaxification tactic , correctness lemma *)
+  | Sign_spec of Topconstr.constr_expr
+
 
 VERNAC ARGUMENT EXTEND ring_mod
   | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
@@ -586,6 +654,11 @@ VERNAC ARGUMENT EXTEND ring_mod
   | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
   | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
   | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+  | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+  | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+           [ Pow_spec (Closed l, pow_spec) ]   
+  | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+           [ Pow_spec (CstTac cst_tac, pow_spec) ]
 END
 
 let set_once s r v =
@@ -597,45 +670,54 @@ let process_ring_mods l =
   let cst_tac = ref None in
   let pre = ref None in
   let post = ref None in
+  let sign = ref None in
+  let power = 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;
+    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) 
+    | Pow_spec(t,spec) -> set_once "power" power (t,spec)
+    | Sign_spec t -> set_once "sign" sign t) l;
   let k = match !kind with Some k -> k | None -> Abstract in
-  (k, !set, !cst_tac, !pre, !post)
+  (k, !set, !cst_tac, !pre, !post, !power, !sign)
 
 VERNAC COMMAND EXTEND AddSetoidRing
   | [ "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) ]
+    [ let (k,set,cst,pre,post,power,sign) = process_ring_mods l in
+      add_theory id (ic t) set k cst (pre,post) power sign ]
 END
 
 (*****************************************************************************)
 (* The tactics consist then only in a lookup in the ring database and
    call the appropriate ltac. *)
 
-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
+let make_args_list rl t = 
+  match rl with
+  | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
+  | _ -> rl
+
+let make_term_list carrier rl =
   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 ring_lookup (f:glob_tactic_expr) lH rl t 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 rl = make_args_list rl t in
+  let e = find_ring_structure env sigma rl None in
+  let rl = carg (make_term_list e.ring_carrier rl) in
+  let lH = carg (make_hyp_list env lH) 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 pow_tac = Tacexp e.ring_pow_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
@@ -644,12 +726,17 @@ let ring_lookup (f:glob_tactic_expr) rl gl =
     (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
+         [req;sth;ext;morph;th;cst_tac;pow_tac;
+          lemma1;lemma2;pretac;posttac;lH;rl])) gl
 
 TACTIC EXTEND ring_lookup
-| [ "ring_lookup" tactic(f) constr_list(l) ] -> [ ring_lookup (fst f) l ]
+| [ "ring_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(lr)
+      "[" constr(t) "]" ] ->
+          [ring_lookup (fst f) lH lr t]
 END
 
+
+ 
 (***********************************************************************)
 
 let new_field_path =
@@ -666,14 +753,20 @@ let _ = add_map "field"
     (* 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
+      (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
+    my_constant "display_pow_linear",
+     (function -1|9|10|11|12|13|14|16|18|19->Eval|17->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);
+    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+    pol_cst "Pphi_pow", 
+          (function -1|8|9|10|11|13|15|17->Eval|16->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)]);;
-
+    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+    (* FEeval: evaluate morphism, protect field 
+       operations and make recursive call on the var map *)
+    my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
 
 let _ = add_map "field_cond"
   (map_with_eq
@@ -681,7 +774,8 @@ let _ = add_map "field_cond"
      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)]);;
+     my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
+(*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
 
 
 let afield_theory = my_constant "almost_field_theory"
@@ -715,9 +809,11 @@ type field_info =
     { field_carrier : types;
       field_req : constr;
       field_cst_tac : glob_tactic_expr;
+      field_pow_tac : glob_tactic_expr;
       field_ok : constr;
       field_simpl_eq_ok : constr;
       field_simpl_ok : constr;
+      field_simpl_eq_in_ok : constr;
       field_cond : constr;
       field_pre_tac : glob_tactic_expr;
       field_post_tac : glob_tactic_expr }
@@ -734,7 +830,7 @@ let field_lookup_by_name ref =
     !field_from_name
 
 
-let find_field_structure env sigma l cl oname =
+let find_field_structure env sigma l oname =
   check_required_library (cdir@["Field_tac"]);
   match oname, l with
       Some rf, _ ->
@@ -756,13 +852,13 @@ let find_field_structure env sigma l cl oname =
           errorlabstrm "field"
             (str"cannot find a declared field structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] ->
-        let (req,_,_) = dest_rel cl in
+    | None, [] -> assert false
+(*        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"\""))
+             spc()++str"\""++pr_constr req++str"\"")) *)
 
 let _ = 
   Summary.declare_summary "tactic-new-field-table"
@@ -796,8 +892,10 @@ let subst_th (_,subst,th) =
   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 thm4' = subst_mps subst th.field_simpl_eq_in_ok in
+  let thm5' = subst_mps subst th.field_cond in
   let tac'= subst_tactic subst th.field_cst_tac in
+  let pow_tac' = subst_tactic subst th.field_pow_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 &&
@@ -805,18 +903,22 @@ let subst_th (_,subst,th) =
      thm1' == th.field_ok &&
      thm2' == th.field_simpl_eq_ok &&
      thm3' == th.field_simpl_ok &&
-     thm4' == th.field_cond &&
+     thm4' == th.field_simpl_eq_in_ok &&
+     thm5' == th.field_cond &&
      tac' == th.field_cst_tac &&
+     pow_tac' == th.field_pow_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_pow_tac = pow_tac';
       field_ok = thm1';
       field_simpl_eq_ok = thm2';
       field_simpl_ok = thm3';
-      field_cond = thm4';
+      field_simpl_eq_in_ok = thm4';
+      field_cond = thm5';
       field_pre_tac = pretac';
       field_post_tac = posttac' }
 
@@ -850,30 +952,34 @@ let default_field_equality r inv req =
             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 add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign =
   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 _ = add_theory name rth eqth morphth cst_tac (None,None) power sign in
+  let (pow_tac, pspec) = interp_power env power in 
+  let sspec = interp_sign env sign 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
+    exec_tactic env 9 (field_ltac"field_lemmas")
+      (List.map carg[sth;ext;inv_m;fth;pspec;sspec;rk]) in
   let lemma1 = constr_of params.(3) in
   let lemma2 = constr_of params.(4) in
   let lemma3 = constr_of params.(5) in
+  let lemma4 = constr_of params.(6) in
   let cond_lemma =
     match inj with
-      | Some thm -> mkApp(constr_of params.(7),[|thm|])
-      | None -> constr_of params.(6) in
+      | Some thm -> mkApp(constr_of params.(8),[|thm|])
+      | None -> constr_of params.(7) 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 lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
+  let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
   let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in
   let pretac =
     match pre with
@@ -889,9 +995,11 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) =
         { field_carrier = r;
           field_req = req;
           field_cst_tac = cst_tac;
+          field_pow_tac = pow_tac;
           field_ok = lemma1;
           field_simpl_eq_ok = lemma2;
           field_simpl_ok = lemma3;
+          field_simpl_eq_in_ok = lemma4;
           field_cond = cond_lemma;
           field_pre_tac = pretac;
           field_post_tac = posttac }) in  ()
@@ -902,7 +1010,7 @@ type field_mod =
 
 VERNAC ARGUMENT EXTEND field_mod
   | [ ring_mod(m) ] -> [ Ring_mod m ]
-  | [ "infinite" constr(inj) ] -> [ Inject inj ]
+  | [ "completeness" constr(inj) ] -> [ Inject inj ]
 END
 
 let process_field_mods l =
@@ -911,7 +1019,9 @@ let process_field_mods l =
   let cst_tac = ref None in
   let pre = ref None in
   let post = ref None in
-  let inj = ref None in
+  let inj = ref None in  
+  let sign = ref None in
+  let power = ref None in
   List.iter(function
       Ring_mod(Ring_kind k) -> set_once "field kind" kind k
     | Ring_mod(Const_tac t) ->
@@ -919,26 +1029,32 @@ let process_field_mods l =
     | 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)
+    | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
+    | Ring_mod(Sign_spec t) -> set_once "sign" sign t
     | 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)
+  (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign)
 
 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) ]
+  [ let (k,set,inj,cst_tac,pre,post,power,sign) = process_field_mods l in
+    add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign]
 END
 
-let field_lookup (f:glob_tactic_expr) rl gl =
+let field_lookup (f:glob_tactic_expr) lH rl t 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 rl = make_args_list rl t in
+  let e = find_field_structure env sigma rl None in
+  let rl = carg (make_term_list e.field_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
   let req = carg e.field_req in
   let cst_tac = Tacexp e.field_cst_tac in
+  let pow_tac = Tacexp e.field_pow_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 field_simpl_eq_in_ok = carg e.field_simpl_eq_in_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
@@ -946,9 +1062,11 @@ let field_lookup (f:glob_tactic_expr) rl gl =
     (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
+        [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+         field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl
 
 TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic(f) constr_list(l) ] -> [ field_lookup (fst f) l ]
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(l) 
+     "[" constr(t) "]" ] -> 
+      [ field_lookup (fst f) lH l t ]
 END
diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v
index ded069bf..46121ff1 100644
--- a/contrib/subtac/FixSub.v
+++ b/contrib/subtac/FixSub.v
@@ -1,37 +1,87 @@
 Require Import Wf.
+Require Import Coq.subtac.Utils.
 
 Section Well_founded.
-Variable A : Set.
-Variable R : A -> A -> Prop.
-Hypothesis Rwf : well_founded R.
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
+  Hypothesis Rwf : well_founded R.
+  
+  Section Acc.
+    
+    Variable P : A -> Type.
+    
+    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
+    
+    Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
+      F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y) 
+        (Acc_inv r (proj1_sig y) (proj2_sig y))).
+    
+    Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
+  End Acc.
+  
+  Section FixPoint.
+    Variable P : A -> Type.
+    
+    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
+    
+    Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *)
+    
+    Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x).
+    
+    Hypothesis
+      F_ext :
+      forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
+        (forall y:{ y:A | R y x}, f y = g y) -> F_sub x f = F_sub x g.
 
-Section FixPoint.
-
-Variable P : A -> Set.
+    Lemma Fix_F_eq :
+      forall (x:A) (r:Acc R x),
+        F_sub x (fun (y:{y:A|R y x}) => Fix_F (`y) (Acc_inv r (proj1_sig y) (proj2_sig y))) = Fix_F x r.
+    Proof. 
+      destruct r using Acc_inv_dep; auto.
+    Qed.
+    
+    Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s.
+    Proof.
+      intro x; induction (Rwf x); intros.
+      rewrite <- (Fix_F_eq x r); rewrite <- (Fix_F_eq x s); intros.
+      apply F_ext; auto.
+      intros.
+      rewrite (proof_irrelevance (Acc R x) r s) ; auto.
+    Qed.
 
-Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
- 
-Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
-   F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y) 
-   (Acc_inv r (proj1_sig y) (proj2_sig y))).
+    Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:{y:A|R y x}) => Fix (proj1_sig y)).
+    Proof.
+      intro x; unfold Fix in |- *.
+      rewrite <- (Fix_F_eq ).
+      apply F_ext; intros.
+      apply Fix_F_inv.
+    Qed.
 
-Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
+    Lemma fix_sub_eq :
+        forall x : A,
+          Fix_sub P F_sub x =
+          let f_sub := F_sub in
+            f_sub x (fun  {y : A | R y x}=> Fix (`y)).
+      exact Fix_eq.
+    Qed.
 
-End FixPoint.
+ End FixPoint.
 
 End Well_founded.
 
+Extraction Inline Fix_F_sub Fix_sub.
+
 Require Import Wf_nat.
 Require Import Lt.
 
 Section Well_founded_measure.
-Variable A : Set.
+Variable A : Type.
 Variable f : A -> nat.
 Definition R := fun x y => f x < f y.
 
 Section FixPoint.
 
-Variable P : A -> Set.
+Variable P : A -> Type.
 
 Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x.
  
@@ -44,3 +94,5 @@ Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)).
 End FixPoint.
 
 End Well_founded_measure.
+
+Extraction Inline Fix_measure_F_sub Fix_measure_sub.
diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v
new file mode 100644
index 00000000..1a12ac82
--- /dev/null
+++ b/contrib/subtac/FunctionalExtensionality.v
@@ -0,0 +1,25 @@
+Axiom fun_extensionality : forall A B (f g : A -> B), 
+  (forall x, f x = g x) -> f = g.
+
+Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), forall (f g : forall x : A, B x), 
+  (forall x, f x = g x) -> f = g.
+
+Hint Resolve fun_extensionality fun_extensionality_dep : subtac.
+
+Require Import Coq.subtac.Utils.
+Require Import Coq.subtac.FixSub.
+
+Lemma fix_sub_eq_ext :
+  forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R)
+    (P : A -> Set)
+    (F_sub : forall x : A, (forall  {y : A | R y x}, P (`y)) -> P x),
+    forall x : A,
+      Fix_sub A R Rwf P F_sub x =
+        F_sub x (fun {y : A | R y x}=> Fix A R Rwf P F_sub (`y)).
+Proof.
+  intros ; apply Fix_eq ; auto.
+  intros.
+  assert(f = g).
+  apply (fun_extensionality_dep _ _ _ _ H).
+  rewrite H0 ; auto.
+Qed.
diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v
new file mode 100644
index 00000000..9912cd24
--- /dev/null
+++ b/contrib/subtac/Subtac.v
@@ -0,0 +1,2 @@
+Require Export Coq.subtac.Utils.
+Require Export Coq.subtac.FixSub.
\ No newline at end of file
diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v
index 219cd75b..4a2208ce 100644
--- a/contrib/subtac/Utils.v
+++ b/contrib/subtac/Utils.v
@@ -6,6 +6,8 @@ Notation "'fun' { x : A | P } => Q" :=
 
 Notation "( x & ? )" := (@exist _ _ x _) : core_scope.
 
+Notation " ! " := (False_rect _ _).
+
 Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A.
 intros.
 induction t.
@@ -44,4 +46,30 @@ end.
 
 Ltac destruct_exists := repeat (destruct_one_pair) .
 
+Ltac subtac_simpl := simpl ; intros ; destruct_exists ; simpl in * ; try subst ; auto with arith.  
+
+(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *)
+Ltac destruct_call f :=
+  match goal with
+    | H : ?T |- _  =>
+      match T with
+         context [f ?x ?y ?z] => destruct (f x y z)
+       | context [f ?x ?y] => destruct (f x y)
+       | context [f ?x] => destruct (f x)        
+      end
+    | |- ?T  =>
+      match T with
+        context [f ?x ?y ?z] => let n := fresh "H" in set (n:=f x y z); destruct n
+        | context [f ?x ?y] => let n := fresh "H" in set (n:=f x y); destruct n
+        | context [f ?x] => let n := fresh "H" in set (n:=f x); destruct n
+      end
+    end.
+
 Extraction Inline proj1_sig.
+Extract Inductive unit => "unit" [ "()" ].
+Extract Inductive bool => "bool" [ "true" "false" ].
+Extract Inductive sumbool => "bool" [ "true" "false" ].
+Extract Inductive prod => "pair" [ "" ].
+Extract Inductive sigT => "pair" [ "" ].
+
+Require Export ProofIrrelevance.
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
index 790e61a0..1844fea5 100644
--- a/contrib/subtac/eterm.ml
+++ b/contrib/subtac/eterm.ml
@@ -52,8 +52,8 @@ let subst_evar_constr evs n t =
 	    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 _ -> () );
+(* 	  (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)
 	  *)
@@ -126,7 +126,6 @@ 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");
   let evn = 
     let i = ref (-1) in
       List.rev_map (fun (id, ev) -> incr i; 
@@ -136,12 +135,9 @@ let eterm_obligations name nclen evm t tycon =
     (* Remove existential variables in types and build the corresponding products *)
     fold_right 
       (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 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) 
       evn []
@@ -152,17 +148,17 @@ let eterm_obligations name nclen evm t tycon =
   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);
-       trace (str "Term constructed in eterm" ++ spc () ++
-		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 _ -> ());
+(*     (try  *)
+(*        trace (str "Term given to eterm" ++ spc () ++ *)
+(* 		Termops.print_constr_env (Global.env ()) t); *)
+(*        trace (str "Term constructed in eterm" ++ spc () ++ *)
+(* 		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 _ -> ()); *)
     Array.of_list (List.rev evars), t'
 
 let mkMetas n = 
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
index 243cb191..e31326e9 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 9326 2006-10-31 12:57:26Z msozeau $ *)
+(* $Id: g_subtac.ml4 9588 2007-02-02 16:17:13Z herbelin $ *)
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
@@ -37,6 +37,8 @@ struct
   let gec s = Gram.Entry.create ("Subtac."^s)
 		(* types *)
   let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
+
+  let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
 end
 
 open SubtacGram 
@@ -46,12 +48,17 @@ open Pcoq
 let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
 
 GEXTEND Gram
-  GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder;
+  GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder subtac_nameopt;
  
   subtac_gallina_loc:
     [ [ g = Vernac.gallina -> loc, g ] ]
     ;
 
+  subtac_nameopt:
+    [ [ "ofb"; id=Prim.ident -> Some (id) 
+      | -> None ] ]
+    ;
+
   Constr.binder_let:
     [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> 
 	  let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in
@@ -60,8 +67,12 @@ GEXTEND Gram
 
   Constr.binder:
     [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
-	  let typ = mkAppC (sigref, [mkLambdaC ([id], c, p)]) in
-	    ([id], typ) ] ];
+          ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)]))
+      | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
+          ([id],c)
+      | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
+          (id::lid,c)
+    ] ];
 
   END
 
@@ -69,16 +80,42 @@ GEXTEND Gram
 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),
-  (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr) gallina_loc_argtype),
+  (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr ) gallina_loc_argtype),
   (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) =
   Genarg.create_arg "subtac_gallina_loc"
 
+type 'a nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type
+
+let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
+  (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
+  (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) =
+  Genarg.create_arg "subtac_nameopt"
+
 VERNAC COMMAND EXTEND Subtac
 [ "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) ]      
+  END
+
+VERNAC COMMAND EXTEND Subtac_Obligations
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ]
+| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ]
+| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ]      
+| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ]
+| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ]
+| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligations
 | [ "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) ]
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] 
+| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] 
+    END
+
+VERNAC COMMAND EXTEND Subtac_Set_Solver
+| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.interp t) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Obligations
 | [ "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 26e8f715..5e46bead 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 9284 2006-10-26 12:06:57Z msozeau $ *)
+(* $Id: subtac.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
 
 open Global
 open Pp
@@ -120,6 +120,8 @@ let subtac_end_proof = function
 open Pp
 open Ppconstr
 open Decl_kinds
+open Tacinterp
+open Tacexpr
 
 let start_proof_com env isevars sopt kind (bl,t) hook =
   let id = match sopt with
@@ -140,14 +142,27 @@ let start_proof_com env isevars sopt kind (bl,t) hook =
       
 let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
 
+let subtac_utils_path =
+  make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"])
+let utils_tac s =
+  lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s))
+
+let utils_call tac args =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args))
+
 let start_proof_and_print env isevars idopt k t hook =
   start_proof_com env isevars idopt k t hook;
   print_subgoals ()
   (*if !pcoq <> None then (out_some !pcoq).start_proof ()*)
 
+let _ = Subtac_obligations.set_default_tactic 
+    (Tacinterp.eval_tactic (utils_call "subtac_simpl" []))
+
+
 let subtac (loc, command) =
   check_required_library ["Coq";"Init";"Datatypes"];
   check_required_library ["Coq";"Init";"Specif"];
+  (* check_required_library ["Coq";"Logic";"JMeq"]; *)
   require_library "Coq.subtac.FixSub";
   require_library "Coq.subtac.Utils";
   let env = Global.env () in
diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml
new file mode 100644
index 00000000..fbe1ac37
--- /dev/null
+++ b/contrib/subtac/subtac_cases.ml
@@ -0,0 +1,1925 @@
+(************************************************************************)
+(*  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: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductiveops
+open Environ
+open Sign
+open Reductionops
+open Typeops
+open Type_errors
+
+open Rawterm
+open Retyping
+open Pretype_errors
+open Evarutil
+open Evarconv
+
+open Subtac_utils
+
+(* Pattern-matching errors *)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+let raise_pattern_matching_error (loc,ctx,te) =
+  Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te))
+
+let error_bad_pattern_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind))
+
+let error_bad_constructor_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
+
+let error_wrong_numarg_constructor_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n))
+
+let error_wrong_numarg_inductive_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n))
+
+let error_wrong_predicate_arity_loc loc env c n1 n2 =
+  raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
+
+let error_needs_inversion env x t =
+  raise (PatternMatchingError (env, NeedsInversion (x,t)))
+
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) *
+      Evd.evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    unsafe_judgment
+end
+
+(************************************************************************)
+(*            Pattern-matching compilation (Cases)                      *)
+(************************************************************************)
+
+(************************************************************************)
+(* Configuration, errors and warnings *)
+
+open Pp
+
+let mssg_may_need_inversion () =
+  str "Found a matching with no clauses on a term unknown to have an empty inductive type"
+
+(* Utils *)
+let make_anonymous_patvars =
+  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
+
+(* Environment management *)
+let push_rels vars env = List.fold_right push_rel vars env
+
+let push_rel_defs =
+  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
+
+(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
+   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
+
+let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
+
+let rec regeneralize_index i k t = match kind_of_term t with
+  | Rel j when j = i+k -> mkRel (k+1)
+  | Rel j when j < i+k -> t
+  | Rel j when j > i+k -> t
+  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
+
+type alias_constr =
+  | DepAlias
+  | NonDepAlias
+
+let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
+  { uj_val =
+      (match d with
+	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
+	| NonDepAlias ->
+	    if (not (dependent (mkRel 1) j.uj_type))
+	      or (* A leaf: *) isRel deppat
+	    then 
+	      (* The body of pat is not needed to type j - see *)
+	      (* insert_aliases - and both deppat and nondeppat have the *)
+	      (* same type, then one can freely substitute one by the other *)
+	      subst1 nondeppat j.uj_val
+	    else
+	      (* The body of pat is not needed to type j but its value *)
+	      (* is dependent in the type of j; our choice is to *)
+	      (* enforce this dependency *)
+	      mkLetIn (na,deppat,t,j.uj_val));
+    uj_type = subst1 deppat j.uj_type }
+
+(**********************************************************************)
+(* Structures used in compiling pattern-matching *)
+
+type rhs =
+    { rhs_env    : env;
+      avoid_ids  : identifier list;
+      it         : rawconstr;
+    }
+
+type equation =
+    { patterns     : cases_pattern list; 
+      rhs          : rhs;
+      alias_stack  : name list;
+      eqn_loc      : loc;
+      used         : bool ref;
+      tag          : pattern_source }
+
+type matrix = equation list
+
+(* 1st argument of IsInd is the original ind before extracting the summary *)
+type tomatch_type =
+  | IsInd of types * inductive_type
+  | NotInd of constr option * types
+
+type tomatch_status =
+  | Pushed of ((constr * tomatch_type) * int list)
+  | Alias of (constr * constr * alias_constr * constr)
+  | Abstract of rel_declaration
+
+type tomatch_stack = tomatch_status list
+
+(* The type [predicate_signature] types the terms to match and the rhs:
+
+   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
+     if dep<>Anonymous, the term is dependent, let n=|names|, if
+     n<>0 then the type of the pushed term is necessarily an
+     inductive with n real arguments. Otherwise, it may be
+     non inductive, or inductive without real arguments, or inductive
+     originating from a subterm in which case real args are not dependent;
+     it accounts for n+1 binders if dep or n binders if not dep
+   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
+   - [PrCcl] types the right-hand-side
+   - Aliases [Alias] have no trace in [predicate_signature]
+*)
+
+type predicate_signature =
+  | PrLetIn of (name list * name) * predicate_signature
+  | PrProd of predicate_signature
+  | PrCcl of constr
+
+(* We keep a constr for aliases and a cases_pattern for error message *)
+
+type alias_builder =
+  | AliasLeaf
+  | AliasConstructor of constructor
+
+type pattern_history =
+  | Top
+  | MakeAlias of alias_builder * pattern_continuation
+
+and pattern_continuation =
+  | Continuation of int * cases_pattern list * pattern_history
+  | Result of cases_pattern list
+
+let start_history n = Continuation (n, [], Top)
+
+let initial_history = function Continuation (_,[],Top) -> true | _ -> false
+
+let feed_history arg = function
+  | Continuation (n, l, h) when n>=1 ->
+      Continuation (n-1, arg :: l, h)
+  | Continuation (n, _, _) ->
+      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
+  | Result _ -> 
+      anomaly "Exhausted pattern history"
+
+(* This is for non exhaustive error message *)
+
+let rec rawpattern_of_partial_history args2 = function
+  | Continuation (n, args1, h) ->
+      let args3 = make_anonymous_patvars (n - (List.length args2)) in
+      build_rawpattern (List.rev_append args1 (args2@args3)) h
+  | Result pl -> pl
+
+and build_rawpattern args = function
+  | Top -> args
+  | MakeAlias (AliasLeaf, rh) ->
+      assert (args = []);
+      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+  | MakeAlias (AliasConstructor pci, rh) ->
+      rawpattern_of_partial_history
+	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
+
+let complete_history = rawpattern_of_partial_history []
+
+(* This is to build glued pattern-matching history and alias bodies *)
+
+let rec simplify_history = function
+  | Continuation (0, l, Top) -> Result (List.rev l)
+  | Continuation (0, l, MakeAlias (f, rh)) ->
+      let pargs = List.rev l in
+      let pat = match f with
+	| AliasConstructor pci ->
+	    PatCstr (dummy_loc,pci,pargs,Anonymous)
+	| AliasLeaf -> 
+	    assert (l = []);
+	    PatVar (dummy_loc, Anonymous) in
+      feed_history pat rh
+  | h -> h
+
+(* Builds a continuation expecting [n] arguments and building [ci] applied
+   to this [n] arguments *)
+
+let push_history_pattern n current cont =
+  Continuation (n, [], MakeAlias (current, cont))
+
+(* A pattern-matching problem has the following form:
+
+   env, isevars |- <pred> Cases tomatch of mat end
+
+  where tomatch is some sequence of "instructions" (t1  ... tn)
+
+  and mat is some matrix 
+   (p11 ... p1n -> rhs1)
+   (    ...            )
+   (pm1 ... pmn -> rhsm)
+
+  Terms to match: there are 3 kinds of instructions
+
+  - "Pushed" terms to match are typed in [env]; these are usually just
+    Rel(n) except for the initial terms given by user and typed in [env]
+  - "Abstract" instructions means an abstraction has to be inserted in the
+    current branch to build (this means a pattern has been detected dependent
+    in another one and generalisation is necessary to ensure well-typing)
+  - "Alias" instructions means an alias has to be inserted (this alias
+    is usually removed at the end, except when its type is not the
+    same as the type of the matched term from which it comes -
+    typically because the inductive types are "real" parameters)
+
+  Right-hand-sides:
+
+  They consist of a raw term to type in an environment specific to the
+  clause they belong to: the names of declarations are those of the
+  variables present in the patterns. Therefore, they come with their
+  own [rhs_env] (actually it is the same as [env] except for the names
+  of variables).
+
+*)
+type pattern_matching_problem =
+    { env      : env;
+      isevars  : Evd.evar_defs ref;
+      pred     : predicate_signature option;
+      tomatch  : tomatch_stack;
+      history  : pattern_continuation;
+      mat      : matrix;
+      caseloc  : loc;
+      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+
+(*--------------------------------------------------------------------------*
+ * A few functions to infer the inductive type from the patterns instead of *
+ * checking that the patterns correspond to the ind. type of the            *
+ * destructurated object. Allows type inference of examples like            *
+ *  match n with O => true | _ => false end                                 *
+ *  match x in I with C => true | _ => false end                            *
+ *--------------------------------------------------------------------------*)
+
+(* Computing the inductive type from the matrix of patterns *)
+
+(* We use the "in I" clause to coerce the terms to match and otherwise
+   use the constructor to know in which type is the matching problem
+
+   Note that insertion of coercions inside nested patterns is done
+   each time the matrix is expanded *)
+
+let rec find_row_ind = function
+    [] -> None
+  | PatVar _ :: l -> find_row_ind l
+  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
+
+let inductive_template isevars env tmloc ind =
+  let arsign = get_full_arity_sign env ind in
+  let hole_source = match tmloc with 
+    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
+    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
+   let (_,evarl,_) =
+    List.fold_right
+      (fun (na,b,ty) (subst,evarl,n) ->
+	match b with
+        | None ->
+	    let ty' = substl subst ty in
+	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
+	    (e::subst,e::evarl,n+1) 
+	| Some b ->
+	    (b::subst,evarl,n+1))
+      arsign ([],[],1) in
+   applist (mkInd ind,List.rev evarl)
+
+
+(************************************************************************)
+(* Utils *)
+
+let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
+  e_new_evar isevars env ~src:src (new_Type ())
+
+let evd_comb2 f isevars x y =
+  let (evd',y) = f !isevars x y in
+  isevars := evd';
+  y
+
+
+module Cases_F(Coercion : Coercion.S) : S = struct
+
+let inh_coerce_to_ind isevars env ty tyi =
+  let expected_typ = inductive_template isevars env None tyi in
+     (* devrait être indifférent d'exiger leq ou pas puisque pour 
+        un inductif cela doit être égal *)
+  let _ = e_cumul env isevars expected_typ ty in ()
+
+let unify_tomatch_with_patterns isevars env loc typ pats =
+  match find_row_ind pats with
+    | None -> NotInd (None,typ)
+    | Some (_,(ind,_)) ->
+	inh_coerce_to_ind isevars env typ ind;
+	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+	with Not_found -> NotInd (None,typ)
+
+let find_tomatch_tycon isevars env loc = function
+  (* Try if some 'in I ...' is present and can be used as a constraint *)
+  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
+  | None -> empty_tycon
+
+let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
+  let loc = Some (loc_of_rawconstr tomatch) in
+  let tycon = find_tomatch_tycon isevars env loc indopt in
+  let j = typing_fun tycon env tomatch in
+  let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in
+  isevars := evd;
+  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+  let t =
+    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+    with Not_found ->
+      unify_tomatch_with_patterns isevars env loc typ pats in
+  (j.uj_val,t)
+
+let coerce_to_indtype typing_fun isevars env matx tomatchl =
+  let pats = List.map (fun r ->  r.patterns) matx in
+  let matx' = match matrix_transpose pats with
+    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
+    | m -> m in
+  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+
+
+
+let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+  (* Ideally, we could find a common inductive type to which both the
+     term to match and the patterns coerce *)
+  (* In practice, we coerce the term to match if it is not already an
+     inductive type and it is not dependent; moreover, we use only 
+     the first pattern type and forget about the others *)
+  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+  let typ =
+    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+    with Not_found -> NotInd (None,typ) in
+  let tomatch = ((current,typ),deps) in
+  match typ with
+  | NotInd (None,typ) ->
+      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+      (match find_row_ind tm1 with
+	| None -> tomatch
+	| Some (_,(ind,_)) ->
+	    let indt = inductive_template pb.isevars pb.env None ind in
+	    let current =
+	      if deps = [] & isEvar typ then
+	      (* Don't insert coercions if dependent; only solve evars *)
+		let _ = e_cumul pb.env pb.isevars indt typ in
+		current
+	      else
+		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
+		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
+	    let sigma = Evd.evars_of !(pb.isevars) in
+	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
+	    ((current,typ),deps))
+  | _ -> tomatch
+
+   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
+let to_mutind env isevars tm c t =
+(*  match c with
+    | Some body -> *) NotInd (c,t)
+(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
+
+let type_of_tomatch = function
+  | IsInd (t,_) -> t
+  | NotInd (_,t) -> t
+
+let mkDeclTomatch na = function
+  | IsInd (t,_) -> (na,None,t)
+  | NotInd (c,t) -> (na,c,t)
+
+let map_tomatch_type f = function
+  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
+  | NotInd (c,t) -> NotInd (option_map f c, f t)
+
+let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
+let lift_tomatch_type n = liftn_tomatch_type n 1
+
+let lift_tomatch n ((current,typ),info) =
+  ((lift n current,lift_tomatch_type n typ),info)
+
+(**********************************************************************)
+(* Utilities on patterns *)
+
+let current_pattern eqn =
+  match eqn.patterns with
+    | pat::_ -> pat
+    | [] -> anomaly "Empty list of patterns"
+
+let alias_of_pat = function
+  | PatVar (_,name) -> name
+  | PatCstr(_,_,_,name) -> name
+
+let unalias_pat = function
+  | PatVar (c,name) as p ->
+      if name = Anonymous then p else PatVar (c,Anonymous)
+  | PatCstr(a,b,c,name) as p ->
+      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
+
+let remove_current_pattern eqn =
+  match eqn.patterns with
+    | pat::pats ->
+	{ eqn with
+	    patterns = pats;
+	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
+    | [] -> anomaly "Empty list of patterns"
+
+let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
+
+(**********************************************************************)
+(* Dealing with regular and default patterns *)
+let is_regular eqn = eqn.tag = RegularPat
+
+let lower_pattern_status = function
+  | RegularPat -> DefaultPat 0
+  | DefaultPat n -> DefaultPat (n+1)
+
+let pattern_status pats =
+  if array_exists ((=) RegularPat) pats then RegularPat
+  else 
+    let min =
+      Array.fold_right
+	(fun pat n -> match pat with
+	   | DefaultPat i when i<n -> i
+	   | _ -> n)
+	pats 0 in
+    DefaultPat min
+
+(**********************************************************************)
+(* Well-formedness tests *)
+(* Partial check on patterns *)
+
+exception NotAdjustable
+
+let rec adjust_local_defs loc = function
+  | (pat :: pats, (_,None,_) :: decls) ->
+      pat :: adjust_local_defs loc (pats,decls)
+  | (pats, (_,Some _,_) :: decls) ->
+      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
+  | [], [] -> []
+  | _ -> raise NotAdjustable
+
+let check_and_adjust_constructor env ind cstrs = function 
+  | PatVar _ as pat -> pat
+  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
+      (* Check it is constructor of the right type *)
+      let ind' = inductive_of_constructor cstr in
+      if Closure.mind_equiv env ind' ind then
+	(* Check the constructor has the right number of args *)
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	if List.length args = nb_args_constr then pat
+	else
+	  try 
+	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
+	    in PatCstr (loc, cstr, args', alias)
+	  with NotAdjustable ->
+	    error_wrong_numarg_constructor_loc loc (Global.env())
+	      cstr nb_args_constr
+      else
+	(* Try to insert a coercion *)
+	try
+	  Coercion.inh_pattern_coerce_to loc pat ind' ind
+	with Not_found -> 
+	  error_bad_constructor_loc loc cstr ind
+
+let check_all_variables typ mat =
+  List.iter
+    (fun eqn -> match current_pattern eqn with
+       | PatVar (_,id) -> ()
+       | PatCstr (loc,cstr_sp,_,_) ->
+	   error_bad_pattern_loc loc cstr_sp typ)
+    mat
+
+let check_unused_pattern env eqn =
+  if not !(eqn.used) then 
+    raise_pattern_matching_error
+      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
+
+let set_used_pattern eqn = eqn.used := true
+
+let extract_rhs pb =
+  match pb.mat with 
+    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
+    | eqn::_ ->
+	set_used_pattern eqn;
+	eqn.tag, eqn.rhs
+
+(**********************************************************************)
+(* Functions to deal with matrix factorization *)
+
+let occur_in_rhs na rhs =
+  match na with
+    | Anonymous -> false
+    | Name id -> occur_rawconstr id rhs.it
+
+let is_dep_patt eqn = function
+  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
+  | PatCstr _ -> true
+
+let dependencies_in_rhs nargs eqns =
+  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
+  else
+  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
+  let columns = matrix_transpose deps in
+  List.map (List.exists ((=) true)) columns
+
+let dependent_decl a = function
+  | (na,None,t) -> dependent a t
+  | (na,Some c,t) -> dependent a t || dependent a c
+
+(* Computing the matrix of dependencies *)
+
+(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
+   computes for declaration [k+1] in which of declarations in
+   [nextlist] (which corresponds to d(k+2)...dn) it depends;
+   declarations are expressed by index, e.g. in dependency list
+   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
+
+let rec find_dependency_list k n = function
+  | [] -> []
+  | (used,tdeps,d)::rest -> 
+      let deps = find_dependency_list k (n+1) rest in
+      if used && dependent_decl (mkRel n) d
+      then list_add_set (List.length rest + 1) (list_union deps tdeps)
+      else deps
+
+let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
+  let deps = find_dependency_list k 1 nextlist in
+  if is_dep_or_cstr_in_rhs || deps <> []
+  then (k-1,(true ,deps,d)::nextlist)
+  else (k-1,(false,[]  ,d)::nextlist)
+
+let find_dependencies_signature deps_in_rhs typs =
+  let k = List.length deps_in_rhs in
+  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
+  List.map (fun (_,deps,_) -> deps) l
+
+(******)
+
+(* A Pushed term to match has just been substituted by some
+   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
+   match 
+
+   - all terms to match and to push (dependent on t by definition)
+     must have (Rel depth) substituted by t and Rel's>depth lifted by n
+   - all pushed terms to match (non dependent on t by definition) must
+     be lifted by n
+
+  We start with depth=1
+*)
+
+let regeneralize_index_tomatch n =
+  let rec genrec depth = function
+  | [] -> []
+  | Pushed ((c,tm),l)::rest ->
+      let c = regeneralize_index n depth c in
+      let tm = map_tomatch_type (regeneralize_index n depth) tm in
+      let l = List.map (regeneralize_rel n depth) l in
+      Pushed ((c,tm),l)::(genrec depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (regeneralize_index n depth) d)
+      ::(genrec (depth+1) rest) in
+  genrec 0
+
+let rec replace_term n c k t = 
+  if t = mkRel (n+k) then lift k c
+  else map_constr_with_binders succ (replace_term n c) k t
+
+let replace_tomatch n c =
+  let rec replrec depth = function
+  | [] -> []
+  | Pushed ((b,tm),l)::rest ->
+      let b = replace_term n c depth b in
+      let tm = map_tomatch_type (replace_term n c depth) tm in
+      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
+      Pushed ((b,tm),l)::(replrec depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (replace_term n c depth) d)
+      ::(replrec (depth+1) rest) in
+  replrec 0
+
+let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
+let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
+
+let rec liftn_tomatch_stack n depth = function
+  | [] -> []
+  | Pushed ((c,tm),l)::rest ->
+      let c = liftn n depth c in
+      let tm = liftn_tomatch_type n depth tm in
+      let l = List.map (fun i -> if i<depth then i else i+n) l in
+      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
+      ::(liftn_tomatch_stack n depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (liftn n depth) d)
+      ::(liftn_tomatch_stack n (depth+1) rest)
+
+
+let lift_tomatch_stack n = liftn_tomatch_stack n 1
+
+(* if [current] has type [I(p1...pn u1...um)] and we consider the case
+   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
+   default variable [name] is expected to have which type?
+   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
+
+(************************************************************************)
+(* Some heuristics to get names for variables pushed in pb environment *)
+(* Typical requirement:
+
+   [match y with (S (S x)) => x | x => x end] should be compiled into
+   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
+
+   and [match y with (S (S n)) => n | n => n end] into 
+   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
+
+  i.e. user names should be preserved and created names should not
+  interfere with user names *)
+
+let merge_name get_name obj = function
+  | Anonymous -> get_name obj
+  | na -> na
+
+let merge_names get_name = List.map2 (merge_name get_name)
+
+let get_names env sign eqns =
+  let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
+  (* If any, we prefer names used in pats, from top to bottom *)
+  let names2 = 
+    List.fold_right
+      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
+      eqns names1 in
+  (* Otherwise, we take names from the parameters of the constructor but
+     avoiding conflicts with user ids *)
+  let allvars =
+    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
+  let names4,_ =
+    List.fold_left2
+      (fun (l,avoid) d na ->
+	 let na =
+	   merge_name
+	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+	     d na 
+	 in
+         (na::l,(out_name na)::avoid))
+      ([],allvars) (List.rev sign) names2 in
+  names4
+
+(************************************************************************)
+(* Recovering names for variables pushed to the rhs' environment *)
+
+let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
+
+let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
+				(n, b, t)) sign
+
+let push_rels_eqn sign eqn =
+  let sign = all_name sign in
+(*    trace (str "push_rels_eqn: " ++ my_print_rel_context eqn.rhs.rhs_env sign ++ str "end");   *)
+(* 	str " branch is " ++ my_print_constr (fst eqn.rhs.c_orig) (snd eqn.rhs.c_orig)); *)
+(*   let rhs = eqn.rhs in *)
+(*   let l, c, s, e = *)
+(*     List.fold_right *)
+(*       (fun (na, c, t) (itlift, it, sign, env) -> *)
+(* 	 (try trace (str "Pushing decl: " ++ pr_rel_decl env (na, c, t) ++ *)
+(* 		  str " lift is " ++ int itlift); *)
+(* 	 with _ -> trace (str "error in push_rels_eqn")); *)
+(* 	 let env' = push_rel (na, c, t) env in *)
+(* 	   match sign with  *)
+(* 	       [] -> (itlift, lift 1 it, sign, env') *)
+(* 	     | (na', c, t) :: sign' ->  *)
+(* 		 if na' = na then  *)
+(* 		   (pred itlift, it, sign', env') *)
+(* 		 else ( *)
+(* 		   trace (str "skipping it"); *)
+(* 		   (itlift, liftn 1 itlift it, sign, env'))) *)
+(*       sign (rhs.rhs_lift, rhs.c_it, eqn.rhs.rhs_sign, eqn.rhs.rhs_env) *)
+(*   in *)
+    {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
+
+let push_rels_eqn_with_names sign eqn =
+  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+  let sign = recover_alias_names alias_of_pat pats sign in
+  push_rels_eqn sign eqn
+
+let build_aliases_context env sigma names allpats pats =
+  (* pats is the list of bodies to push as an alias *)
+  (* They all are defined in env and we turn them into a sign *)
+  (* cuts in sign need to be done in allpats *)
+  let rec insert env sign1 sign2 n newallpats oldallpats = function
+    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
+        (* Anonymous leaves must be considered named and treated in the *)
+        (* next clause because they may occur in implicit arguments *)
+	insert env sign1 sign2
+	  n newallpats (List.map List.tl oldallpats) (pats,names)
+    | (deppat,nondeppat,d,t)::pats, na::names ->
+	let nondeppat = lift n nondeppat in
+	let deppat = lift n deppat in
+	let newallpats =
+	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
+	let oldallpats = List.map List.tl oldallpats in
+	let decl = (na,Some deppat,t) in
+	let a = (deppat,nondeppat,d,t) in
+	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
+	  newallpats oldallpats (pats,names)
+    | [], [] -> newallpats, sign1, sign2, env
+    | _ -> anomaly "Inconsistent alias and name lists" in
+  let allpats = List.map (fun x -> [x]) allpats
+  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
+
+let insert_aliases_eqn sign eqnnames alias_rest eqn =
+  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
+    push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
+	    
+
+let insert_aliases env sigma alias eqns =
+  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
+  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
+  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
+  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
+  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
+  (* names2 takes the meet of all needed aliases *)
+  let names2 = 
+    List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
+  (* Only needed aliases are kept by build_aliases_context *)
+  let eqnsnames, sign1, sign2, env =
+    build_aliases_context env sigma [names2] eqnsnames [alias] in
+  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
+  sign2, env, eqns
+
+(**********************************************************************)
+(* Functions to deal with elimination predicate *)
+
+exception Occur
+let noccur_between_without_evar n m term = 
+  let rec occur_rec n c = match kind_of_term c with
+    | Rel p       -> if n<=p && p<n+m then raise Occur
+    | Evar (_,cl) -> ()
+    | _             -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with Occur -> false
+
+(* Inferring the predicate *)
+let prepare_unif_pb typ cs =
+  let n = List.length (assums_of_rel_context cs.cs_args) in
+
+  (* We may need to invert ci if its parameters occur in typ *)
+  let typ' =
+    if noccur_between_without_evar 1 n typ then lift (-n) typ
+    else (* TODO4-1 *)
+      error "Unable to infer return clause of this pattern-matching problem" in
+  let args = extended_rel_list (-n) cs.cs_args in
+  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
+
+  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
+  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
+
+
+(* Infering the predicate *)
+(*
+The problem to solve is the following:
+
+We match Gamma |- t : I(u01..u0q) against the following constructors:
+
+  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
+   ...
+  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
+
+Assume the types in the branches are the following
+
+  Gamma, x11...x1p1 |- branch1 : T1
+   ...
+  Gamma, xn1...xnpn |- branchn : Tn
+
+Assume the type of the global case expression is Gamma |- T
+
+The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
+the following n+1 equations:
+
+  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
+   ...
+  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
+  Gamma             |- (phi u01..u0q t)               =  T
+
+Some hints:
+
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
+  should be inserted somewhere in Ti.
+
+- If T is undefined, an easy solution is to insert a "match z with (Ci
+  xi1..xipi) => ..." in front of each Ti
+
+- Otherwise, T1..Tn and T must be step by step unified, if some of them
+  diverge, then try to replace the diverging subterm by one of y1..yq or z.
+
+- The main problem is what to do when an existential variables is encountered
+
+let prepare_unif_pb typ cs =
+  let n = cs.cs_nargs in
+  let _,p = decompose_prod_n n typ in
+  let ci = build_dependent_constructor cs in
+  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
+  (n, cs.cs_concl_realargs, ci, p)
+
+let eq_operator_lift k (n,n') = function
+  | OpRel p, OpRel p' when p > k & p' > k ->
+      if p < k+n or p' < k+n' then false else p - n = p' - n'
+  | op, op' -> op = op'
+
+let rec transpose_args n =
+  if n=0 then []
+  else
+    (Array.map (fun l -> List.hd l) lv)::
+    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
+
+let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
+
+let reloc_operator (k,n) = function OpRel p when p > k -> 
+let rec unify_clauses k pv =
+  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
+  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
+  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
+  then
+    let argvl = transpose_args (List.length args1) pv' in
+    let k' = shift_operator k op1 in
+    let argl = List.map (unify_clauses k') argvl in
+    gather_constr (reloc_operator (k,n1) op1) argl
+*)
+
+let abstract_conclusion typ cs =
+  let n = List.length (assums_of_rel_context cs.cs_args) in
+  let (sign,p) = decompose_prod_n n typ in
+  lam_it p sign
+
+let infer_predicate loc env isevars typs cstrs indf =
+  (* Il faudra substituer les isevars a un certain moment *)
+  if Array.length cstrs = 0 then (* "TODO4-3" *)
+    error "Inference of annotation for empty inductive types not implemented"
+  else
+    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
+    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
+    let typs =
+      Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs
+    in
+    let eqns = array_map2 prepare_unif_pb typs cstrs in
+    (* First strategy: no dependencies at all *)
+(*
+    let (mis,_) = dest_ind_family indf in
+    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
+*)
+    let (sign,_) = get_arity env indf in
+    let mtyp =
+      if array_exists is_Type typs then
+	(* Heuristic to avoid comparison between non-variables algebric univs*)
+	new_Type ()
+      else
+	mkExistential env ~src:(loc, Evd.CasesType) isevars
+    in
+    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
+    then
+      (* Non dependent case -> turn it into a (dummy) dependent one *)
+      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
+      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+      (true,pred) (* true = dependent -- par défaut *)
+    else
+(*
+      let s = get_sort_of env (evars_of isevars) typs.(0) in
+      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
+      let caseinfo = make_default_case_info mis in
+      let brs = array_map2 abstract_conclusion typs cstrs in
+      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
+      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+*)
+      (* "TODO4-2" *)
+      (* We skip parameters *)
+      let cis = 
+	Array.map
+	  (fun cs ->
+	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
+	  cstrs in
+      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
+      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
+(*
+      (true,pred)
+*)
+
+(* Propagation of user-provided predicate through compilation steps *)
+
+let rec map_predicate f k = function
+  | PrCcl ccl -> PrCcl (f k ccl)
+  | PrProd pred ->
+      PrProd (map_predicate f (k+1) pred)
+  | PrLetIn ((names,dep as tm),pred) ->
+      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+      PrLetIn (tm, map_predicate f (k+k') pred)
+
+let rec noccurn_predicate k = function
+  | PrCcl ccl -> noccurn k ccl
+  | PrProd pred -> noccurn_predicate (k+1) pred
+  | PrLetIn ((names,dep),pred) ->
+      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+      noccurn_predicate (k+k') pred
+
+let liftn_predicate n = map_predicate (liftn n)
+
+let lift_predicate n = liftn_predicate n 1
+
+let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
+
+let substnl_predicate sigma = map_predicate (substnl sigma)
+
+(* This is parallel bindings *)
+let subst_predicate (args,copt) pred =
+  let sigma = match copt with
+    | None -> List.rev args
+    | Some c -> c::(List.rev args) in
+  substnl_predicate sigma 0 pred
+
+let specialize_predicate_var (cur,typ) = function
+  | PrProd _ | PrCcl _ ->
+     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
+  | PrLetIn (([],dep),pred) ->
+      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
+  | PrLetIn ((_,dep),pred) ->
+      (match typ with
+        | IsInd (_,IndType (_,realargs)) ->
+           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
+        | _ -> anomaly "specialize_predicate_var")
+
+let ungeneralize_predicate = function
+  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
+  | PrProd pred -> pred
+
+(*****************************************************************************)
+(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
+(* and we want to abstract P over y:t(x) typed in the same context to get    *)
+(*                                                                           *)
+(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
+(*                                                                           *)
+(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
+(* then we have to replace x by x' in t(x) and y by y' in P                  *)
+(*****************************************************************************)
+let generalize_predicate ny d = function
+  | PrLetIn ((names,dep as tm),pred) ->
+      if dep=Anonymous then anomaly "Undetected dependency";
+      let p = List.length names + 1 in
+      let pred = lift_predicate 1 pred in
+      let pred = regeneralize_index_predicate (ny+p+1) pred in
+      PrLetIn (tm, PrProd pred)
+  | PrProd _ | PrCcl _ ->
+      anomaly "generalize_predicate: expects a non trivial pattern"
+
+let rec extract_predicate l = function
+  | pred, Alias (deppat,nondeppat,_,_)::tms ->
+      let tms' = match kind_of_term nondeppat with
+        | Rel i -> replace_tomatch i deppat tms
+        | _ -> (* initial terms are not dependent *) tms in
+      extract_predicate l (pred,tms')
+  | PrProd pred, Abstract d'::tms ->
+      let d' = map_rel_declaration (lift (List.length l)) d' in
+      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
+  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
+      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
+      let l = List.rev realargs@l in
+      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+  | PrCcl ccl, [] ->
+      substl l ccl
+  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
+
+let abstract_predicate env sigma indf cur tms = function
+  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
+  | PrLetIn ((names,dep),pred) ->
+      let sign = make_arity_signature env true indf in
+      (* n is the number of real args + 1 *)
+      let n = List.length sign in
+      let tms = lift_tomatch_stack n tms in
+      let tms =
+        match kind_of_term cur with
+          | Rel i -> regeneralize_index_tomatch (i+n) tms
+          | _ -> (* Initial case *) tms in
+      (* Depending on whether the predicate is dependent or not, and has real
+         args or not, we lift it to make room for [sign] *)
+      (* Even if not intrinsically dep, we move the predicate into a dep one *)
+      let sign,k =
+        if names = [] & n <> 1 then
+          (* Real args were not considered *)
+          (if dep<>Anonymous then
+            ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
+          else
+            (sign,n))
+        else
+          (* Real args are OK *)
+          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
+           if dep<>Anonymous then 0 else 1) in
+      let pred = lift_predicate k pred in
+      let pred = extract_predicate [] (pred,tms) in
+      (true, it_mkLambda_or_LetIn_name env pred sign)
+
+let rec known_dependent = function
+  | None -> false
+  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
+  | Some (PrCcl _) -> false
+  | Some (PrProd _) ->
+      anomaly "known_dependent: can only be used when patterns remain"
+
+(* [expand_arg] is used by [specialize_predicate]
+   it replaces gamma, x1...xn, x1...xk |- pred
+   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
+   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
+
+let expand_arg n alreadydep (na,t) deps (k,pred) =
+  (* current can occur in pred even if the original problem is not dependent *)
+  let dep =
+    if alreadydep<>Anonymous then alreadydep
+    else if deps = [] && noccurn_predicate 1 pred then Anonymous
+    else Name (id_of_string "x") in
+  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
+  (* There is no dependency in realargs for subpattern *)
+  (k-1, PrLetIn (([],dep), pred))
+
+
+(*****************************************************************************)
+(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
+(*                                                                           *)
+(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
+(*                                                                           *)
+(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
+(* is considered. Assume each Ti is some Ii(argsi).                          *)
+(* We let e=Ci(x1,...,xn) and replace pred by                                *)
+(*                                                                           *)
+(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
+(*                                                                           *)
+(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
+(*                                                                           *)
+(*****************************************************************************)
+let specialize_predicate tomatchs deps cs = function
+  | (PrProd _ | PrCcl _) ->
+      anomaly "specialize_predicate: a matched pattern must be pushed"
+  | PrLetIn ((names,isdep),pred) ->
+      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
+      let nrealargs = List.length names in
+      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
+      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
+      let n = cs.cs_nargs in
+      let pred' = liftn_predicate n (k+1) pred in
+      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
+      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
+      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
+      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
+      let pred'' = subst_predicate (argsi, copti) pred' in
+      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
+      let pred''' = liftn_predicate n (n+1) pred'' in
+      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
+      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
+
+let find_predicate loc env isevars p typs cstrs current
+  (IndType (indf,realargs)) tms =
+  let (dep,pred) =
+    match p with
+      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
+      | None -> infer_predicate loc env isevars typs cstrs indf in
+  let typ = whd_beta (applist (pred, realargs)) in
+  if dep then
+    (pred, whd_beta (applist (typ, [current])), new_Type ())
+  else
+    (pred, typ, new_Type ())
+
+(************************************************************************)
+(* Sorting equations by constructor *)
+
+type inversion_problem =
+  (* the discriminating arg in some Ind and its order in Ind *)
+  | Incompatible of int * (int * int)
+  | Constraints of (int * constr) list
+
+let solve_constraints constr_info indt =
+  (* TODO *)
+  Constraints []
+
+let rec irrefutable env = function
+  | PatVar (_,name) -> true
+  | PatCstr (_,cstr,args,_) ->
+      let ind = inductive_of_constructor cstr in
+      let (_,mip) = Inductive.lookup_mind_specif env ind in
+      let one_constr = Array.length mip.mind_user_lc = 1 in
+      one_constr & List.for_all (irrefutable env) args
+
+let first_clause_irrefutable env = function
+  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
+  | _ -> false
+
+let group_equations pb ind current cstrs mat =
+  let mat =
+    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
+  let brs = Array.create (Array.length cstrs) [] in
+  let only_default = ref true in
+  let _ =
+    List.fold_right (* To be sure it's from bottom to top *)
+      (fun eqn () ->
+	 let rest = remove_current_pattern eqn in
+	 let pat = current_pattern eqn in
+	 match check_and_adjust_constructor pb.env ind cstrs pat with 
+	   | PatVar (_,name) -> 
+	       (* This is a default clause that we expand *)
+	       for i=1 to Array.length cstrs do
+		 let n = cstrs.(i-1).cs_nargs in
+		 let args = make_anonymous_patvars n in
+		 let rest = {rest with tag = lower_pattern_status rest.tag } in
+		 brs.(i-1) <- (args, rest) :: brs.(i-1)
+	       done
+	   | PatCstr (loc,((_,i)),args,_) ->
+	       (* This is a regular clause *)
+	       only_default := false;
+	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
+  (brs,!only_default)
+
+(************************************************************************)
+(* Here starts the pattern-matching compilation algorithm *)
+
+(* Abstracting over dependent subterms to match *)
+let rec generalize_problem pb = function
+  | [] -> pb
+  | i::l ->
+      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let pb' = generalize_problem pb l in
+      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
+      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
+      { pb with
+	  tomatch = Abstract d :: tomatch;
+          pred = option_map (generalize_predicate i d) pb'.pred }
+
+(* No more patterns: typing the right-hand-side of equations *)
+let build_leaf pb =
+  let tag, rhs = extract_rhs pb in
+  let tycon = match pb.pred with
+    | None -> anomaly "Predicate not found"
+    | Some (PrCcl typ) -> mk_tycon typ
+    | Some _ -> anomaly "not all parameters of pred have been consumed" in
+    tag, pb.typing_function tycon rhs.rhs_env rhs.it
+
+(* Building the sub-problem when all patterns are variables *)
+let shift_problem (current,t) pb =
+  {pb with
+     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
+     pred = option_map (specialize_predicate_var (current,t)) pb.pred;
+     history = push_history_pattern 0 AliasLeaf pb.history;
+     mat = List.map remove_current_pattern pb.mat }
+
+(* Building the sub-pattern-matching problem for a given branch *)
+let build_branch current deps pb eqns const_info =
+  (* We remember that we descend through a constructor *)
+  let alias_type =
+    if Array.length const_info.cs_concl_realargs = 0
+      & not (known_dependent pb.pred) & deps = []
+    then
+      NonDepAlias
+    else 
+      DepAlias
+  in
+  let history = 
+    push_history_pattern const_info.cs_nargs
+      (AliasConstructor const_info.cs_cstr)
+      pb.history in
+
+  (* We find matching clauses *)
+  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
+  let names = get_names pb.env cs_args eqns in
+  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
+  if submat = [] then
+    raise_pattern_matching_error
+      (dummy_loc, pb.env, NonExhaustive (complete_history history));
+  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+  let _,typs',_ =
+    List.fold_right
+      (fun (na,c,t as d) (env,typs,tms) ->
+	 let tm1 = List.map List.hd tms in
+	 let tms = List.map List.tl tms in
+ 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
+      typs (pb.env,[],List.map fst eqns) in
+
+  let dep_sign =
+    find_dependencies_signature
+      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
+
+  (* The dependent term to subst in the types of the remaining UnPushed 
+     terms is relative to the current context enriched by topushs *)
+  let ci = build_dependent_constructor const_info in
+
+  (* We replace [(mkRel 1)] by its expansion [ci] *)
+  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
+  (* This is done in two steps : first from "Gamma |- tms" *)
+  (* into  "Gamma; typs; curalias |- tms" *)
+  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
+
+  let currents =
+    list_map2_i
+      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
+      1 typs' (List.rev dep_sign) in
+
+  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
+  let ind =
+    appvect (
+      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+      List.map (lift const_info.cs_nargs) const_info.cs_params),
+      const_info.cs_concl_realargs) in
+
+  let cur_alias = lift (List.length sign) current in
+  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
+  let env' = push_rels sign pb.env in
+  let pred' = option_map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
+    sign,
+  { pb with
+      env = env';
+      tomatch = List.rev_append currents tomatch;
+      pred = pred';
+      history = history;
+      mat = List.map (push_rels_eqn_with_names sign) submat }
+
+(**********************************************************************
+ INVARIANT:
+
+  pb = { env, subst, tomatch, mat, ...}
+  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
+
+  "Pushed" terms and types are relative to env
+  "Abstract" types are relative to env enriched by the previous terms to match
+
+*)
+
+(**********************************************************************)
+(* Main compiling descent *)
+let rec compile pb =
+  match pb.tomatch with
+    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
+    | (Alias x)::rest -> compile_alias pb x rest
+    | (Abstract d)::rest -> compile_generalization pb d rest
+    | [] -> build_leaf pb
+
+and match_current pb tomatch =
+  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
+  match typ with
+    | NotInd (_,typ) ->
+	check_all_variables typ pb.mat;
+	compile (shift_problem ct pb)
+    | IsInd (_,(IndType(indf,realargs) as indt)) ->
+	let mind,_ = dest_ind_family indf in
+	let cstrs = get_constructors pb.env indf in
+	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
+	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
+	  compile (shift_problem ct pb)
+	else
+          let _constraints = Array.map (solve_constraints indt) cstrs in
+
+	  (* We generalize over terms depending on current term to match *)
+	  let pb = generalize_problem pb deps in
+
+	  (* We compile branches *)
+	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
+
+	  (* We build the (elementary) case analysis *)
+	  let tags   = Array.map (fun (t,_,_) -> t) brs in
+	  let brvals = Array.map (fun (_,v,_) -> v) brs in
+	  let brtyps = Array.map (fun (_,_,t) -> t) brs in
+	  let (pred,typ,s) =
+	    find_predicate pb.caseloc pb.env pb.isevars 
+	      pb.pred brtyps cstrs current indt pb.tomatch in
+	  let ci = make_case_info pb.env mind RegularStyle tags in
+	  let case = mkCase (ci,nf_betaiota pred,current,brvals) in
+	  let inst = List.map mkRel deps in
+	  pattern_status tags,
+	  { uj_val = applist (case, inst);
+	    uj_type = substl inst typ }
+
+and compile_branch current deps pb eqn cstr =
+  let sign, pb = build_branch current deps pb eqn cstr in
+  let tag, j = compile pb in
+  (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+
+and compile_generalization pb d rest =
+  let pb =
+    { pb with
+       env = push_rel d pb.env;
+       tomatch = rest;
+       pred = option_map ungeneralize_predicate pb.pred;
+       mat = List.map (push_rels_eqn [d]) pb.mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  { uj_val = mkLambda_or_LetIn d j.uj_val;
+    uj_type = mkProd_or_LetIn d j.uj_type }
+
+and compile_alias pb (deppat,nondeppat,d,t) rest =
+  let history = simplify_history pb.history in
+  let sign, newenv, mat =
+    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
+  let n = List.length sign in
+
+  (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
+  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
+  let tomatch = lift_tomatch_stack n rest in
+  let tomatch = match kind_of_term nondeppat with
+    | Rel i ->
+	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
+	else replace_tomatch i deppat tomatch
+    | _ -> (* initial terms are not dependent *) tomatch in
+
+  let pb =
+    {pb with
+       env = newenv;
+       tomatch = tomatch;
+       pred = option_map (lift_predicate n) pb.pred;
+       history = history;
+       mat = mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  List.fold_left mkSpecialLetInJudge j sign
+
+(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
+substituer après par les initiaux *)
+
+(**************************************************************************)
+(* Preparation of the pattern-matching problem                            *)
+
+(* builds the matrix of equations testing that each eqn has n patterns
+ * and linearizing the _ patterns.
+ * Syntactic correctness has already been done in astterm *)
+let matx_of_eqns env eqns =
+  let build_eqn (loc,ids,lpat,rhs) =
+    let rhs =
+      { rhs_env = env;
+	avoid_ids = ids@(ids_of_named_context (named_context env));
+	it = rhs;
+      } in
+    { patterns = lpat;
+      tag = RegularPat;
+      alias_stack = [];
+      eqn_loc = loc;
+      used = ref false;
+      rhs = rhs }
+  in List.map build_eqn eqns
+
+(************************************************************************)
+(* preparing the elimination predicate if any                          *)
+
+let build_expected_arity env isevars isdep tomatchl =
+  let cook n = function
+    | _,IsInd (_,IndType(indf,_)) ->
+        let indf' = lift_inductive_family n indf in
+	Some (build_dependent_inductive env indf', fst (get_arity env indf'))
+    | _,NotInd _ -> None
+  in
+  let rec buildrec n env = function
+    | [] -> new_Type ()
+    | tm::ltm ->
+	match cook n tm with
+	  | None -> buildrec n env ltm
+	  | Some (ty1,aritysign) ->
+	      let rec follow n env = function
+		| d::sign ->
+		    mkProd_or_LetIn_name env
+		      (follow (n+1) (push_rel d env) sign) d
+		| [] ->
+		    if isdep then
+		      mkProd (Anonymous, ty1, 
+			      buildrec (n+1)
+				(push_rel_assum (Anonymous, ty1) env)
+				ltm)
+		    else buildrec n env ltm
+	      in follow n env (List.rev aritysign)
+  in buildrec 0 env tomatchl
+
+let extract_predicate_conclusion isdep tomatchl pred =
+  let cook = function
+    | _,IsInd (_,IndType(_,args)) -> Some (List.length args)
+    | _,NotInd _ -> None in
+  let rec decomp_lam_force n l p =
+    if n=0 then (l,p) else
+    match kind_of_term p with
+      | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c
+      | _ -> (* eta-expansion *)
+          let na = Name (id_of_string "x") in
+          decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in
+  let rec buildrec allnames p = function
+    | [] -> (List.rev allnames,p)
+    | tm::ltm ->
+	match cook tm with
+	  | None -> 
+              let p = 
+                (* adjust to a sign containing the NotInd's *)
+                if isdep then lift 1 p else p in
+              let names = if isdep then [Anonymous] else [] in
+              buildrec (names::allnames) p ltm
+	  | Some n ->
+              let n = if isdep then n+1 else n in
+              let names,p = decomp_lam_force n [] p in
+              buildrec (names::allnames) p ltm
+  in buildrec [] pred tomatchl
+
+let set_arity_signature dep n arsign tomatchl pred x =
+  (* avoid is not exhaustive ! *)
+  let rec decomp_lam_force n avoid l p =
+    if n = 0 then (List.rev l,p,avoid) else
+    match p with
+      | RLambda (_,(Name id as na),_,c) -> 
+          decomp_lam_force (n-1) (id::avoid) (na::l) c
+      | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c
+      | _ ->
+          let x = next_ident_away (id_of_string "x") avoid in
+          decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+          (* eta-expansion *)
+            (let a = RVar (dummy_loc,x) in
+             match p with
+               | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+               | _ -> (RApp (dummy_loc,p,[a]))) in
+  let rec decomp_block avoid p = function
+    | ([], _) -> x := Some p
+    | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l')  ->
+	let (ind,params) = dest_ind_family indf in
+        let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p 
+        in
+        let na,p,avoid' = 
+          if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid'
+        in 
+        y :=
+        (List.hd na,
+         if List.for_all ((=) Anonymous) nal then
+           None
+         else
+           Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal));
+        decomp_block avoid' p (l,l')
+    | (_::l),(y::l') ->
+        y := (Anonymous,None);
+        decomp_block avoid p (l,l')
+    | _ -> anomaly "set_arity_signature"
+  in
+  decomp_block [] pred (tomatchl,arsign)
+
+let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
+  let cook (n, l, env, signs) = function
+    | c,IsInd (_,IndType(indf,realargs)) ->
+	let indf' = lift_inductive_family n indf in
+	let sign = make_arity_signature env dep indf' in
+	let p = List.length realargs in
+	if dep then
+	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
+	else
+	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
+    | c,NotInd _ ->
+	(n, l, env, []::signs) in
+  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+  let names = List.rev (List.map (List.map pi1) signs) in
+  let allargs =
+    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
+  let rec build_skeleton env c =
+    (* Don't put into normal form, it has effects on the synthesis of evars *)
+ (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
+    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
+    if isEvar c or List.exists (eq_constr c) allargs then
+      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
+        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
+    else
+      map_constr_with_full_binders push_rel build_skeleton env c 
+  in
+    names, build_skeleton env (lift n c)
+  
+(* Here, [pred] is assumed to be in the context built from all *)
+(* realargs and terms to match *)
+let build_initial_predicate isdep allnames pred =
+  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+  let rec buildrec n pred = function
+    | [] -> PrCcl pred
+    | names::lnames ->
+        let names' = if isdep then List.tl names else names in
+        let n' = n + List.length names' in
+        let pred, p, user_p =
+          if isdep then 
+            if dependent (mkRel (nar-n')) pred then pred, 1, 1
+            else liftn (-1) (nar-n') pred, 0, 1
+          else pred, 0, 0 in
+        let na =
+          if p=1 then
+            let na = List.hd names in
+            if na = Anonymous then
+              (* peut arriver en raison des evars *)
+              Name (id_of_string "x") (*Hum*)
+            else na
+          else Anonymous in
+        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
+  in buildrec 0 pred allnames
+
+let extract_arity_signature env0 tomatchl tmsign =
+  let get_one_sign n tm (na,t) =
+    match tm with
+      | NotInd (bo,typ) -> 
+	  (match t with
+	    | None -> [na,option_map (lift n) bo,lift n typ]
+	    | Some (loc,_,_,_) -> 
+ 	    user_err_loc (loc,"",
+	    str "Unexpected type annotation for a term of non inductive type"))
+      | IsInd (_,IndType(indf,realargs)) ->
+          let indf' = lift_inductive_family n indf in
+	  let (ind,params) = dest_ind_family indf' in
+	  let nrealargs = List.length realargs in
+	  let realnal =
+	    match t with
+	      | Some (loc,ind',nparams,realnal) ->
+		  if ind <> ind' then
+		    user_err_loc (loc,"",str "Wrong inductive type");
+		  if List.length params <> nparams
+		    or nrealargs <> List.length realnal then
+		      anomaly "Ill-formed 'in' clause in cases";
+		  List.rev realnal
+	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+	  let arsign = fst (get_arity env0 indf') in
+	  (na,None,build_dependent_inductive env0 indf')
+	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+  let rec buildrec n = function
+    | [],[] -> []
+    | (_,tm)::ltm, x::tmsign ->
+	let l = get_one_sign n tm x in
+	l :: buildrec (n + List.length l) (ltm,tmsign)
+    | _ -> assert false
+  in List.rev (buildrec 0 (tomatchl,tmsign))
+
+let inh_conv_coerce_to_tycon loc env isevars j tycon =
+  match tycon with
+    | Some p ->
+	let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
+          isevars := evd';
+          j
+    | None -> j
+
+let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
+  
+let list_mapi f l = 
+  let rec aux n = function
+      [] -> []
+    | hd :: tl -> f n hd :: aux (succ n) tl
+  in aux 0 l
+
+let constr_of_pat env isevars ty pat idents = 
+  let rec typ env ty pat idents = 
+    trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++
+	     print_env env ++ str" should have type: " ++ my_print_constr env ty);
+    match pat with
+    | PatVar (l,name) -> 
+	let name, idents' = match name with
+	    Name n -> name, idents
+	  | Anonymous -> 
+	      let n' = next_ident_away_from (id_of_string "wildcard") idents in
+		Name n', n' :: idents
+	in
+(* 	  trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); *)
+	  PatVar (l, name), [name, None, ty], mkRel 1, 1, idents'
+    | PatCstr (l,((_, i) as cstr),args,alias) ->
+	let _ind = inductive_of_constructor cstr in
+	let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) ty in
+	let ind, params = dest_ind_family indf in
+	let cstrs = get_constructors env indf in
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	assert(nb_args_constr = List.length args);
+	let idents' = idents in
+	let patargs, args, sign, env, n, m, idents' = 
+	  List.fold_right2
+	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, idents)  ->
+	       let pat', sign', arg', n', idents' = typ env (lift (n - m) t) ua idents in
+	       let args' = arg' :: List.map (lift n') args in
+	       let env' = push_rels sign' env in
+		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, idents'))
+	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, idents')
+	in
+	let args = List.rev args in
+	let patargs = List.rev patargs in
+	let pat' = PatCstr (l, cstr, patargs, alias) in
+	let cstr = mkConstruct ci.cs_cstr in
+	let app = applistc cstr (List.map (lift (List.length sign)) params) in
+	let app = applistc app args in
+(* 	  trace (str "New pattern: " ++ Printer.pr_cases_pattern pat'); *)
+(* 	let alname = if alias <> Anonymous then alias else Name (id_of_string "anon") in *)
+(* 	let al = alname, Some (mkRel 1), lift 1 ty in *)
+	  if alias <> Anonymous then
+	    pat', (alias, Some app, ty) :: sign, lift 1 app, n + 1, idents'
+	  else pat', sign, app, n, idents'
+  in 
+  let pat', sign, y, z, idents = typ env ty pat idents in 
+  let c = it_mkProd_or_LetIn y sign in
+    trace (str "Constr_of_pat gives: " ++ my_print_constr env c);
+    pat', (sign, y), idents
+
+let mk_refl typ a = mkApp (Lazy.force eq_refl, [| typ; a |])
+
+let vars_of_ctx = 
+  List.rev_map (fun (na, _, t) -> 
+	      match na with
+		  Anonymous -> raise (Invalid_argument "vars_of_ctx")
+		| Name n -> RVar (dummy_loc, n))
+
+(*let build_ineqs eqns pats = 
+  List.fold_left 
+    (fun (sign, c) eqn -> 
+       let acc = fold_left3
+	 (fun acc prevpat (ppat_sign, ppat_c, ppat_ty) (pat, pat_c) ->
+	    match acc with
+		None -> None
+	      | Some (sign,len, c) ->
+		  if is_included pat prevpat then
+		    let lens = List.length ppat_sign in
+		    let acc = 
+		      (lift_rels lens ppat_sign @ sign, 
+		       lens + len,
+		       mkApp (Lazy.force eq_ind,
+			      [| ppat_ty ; ppat_c ; 
+				 lift (lens + len) pat_c |]) :: c)
+		    in Some acc
+		  else None)
+	 (sign, c) eqn.patterns eqn.c_patterns pats
+       in match acc with 
+	   None -> (sign, c)
+	 | Some (sign, len, c) ->
+	     it_mkProd_or_LetIn c sign
+	     
+    )
+    ([], []) eqns*)
+
+let constrs_of_pats typing_fun tycon env isevars eqns tomatchs =
+  let i = ref 0 in
+  List.fold_left
+    (fun (branches, eqns) eqn ->
+       let _, newpatterns, pats = 
+	 List.fold_right2 (fun pat (_, ty) (idents, newpatterns, pats) -> 
+			    let x, y, z = constr_of_pat env isevars (type_of_tomatch ty) pat idents in
+			      (z, x :: newpatterns, y :: pats)) 
+	   eqn.patterns tomatchs ([], [], [])
+       in
+       let rhs_rels, signlen = 
+	 List.fold_left (fun (renv, n) (sign,_) -> 
+			   ((lift_rel_context n sign) @ renv, List.length sign + n)) 
+	   ([], 0) pats in
+       let eqs, _, _ = List.fold_left2 
+	 (fun (eqs, n, slen) (sign, c) (tm, ty) -> 
+	    let len = n + signlen in (* Number of already defined equations + signature *)
+	    let csignlen = List.length sign in
+	    let slen' = slen - csignlen in (* Lift to get pattern variables signature *)	      
+	    let c = liftn (signlen - slen) signlen c in (* Lift to jump over previous ind signatures for pattern variables outside sign 
+							in c (e.g. type arguments of constructors instanciated by variables ) *)
+	    let cstr = lift (slen' + n) c in
+(* 	      trace (str "lift " ++ my_print_constr (push_rels sign env) c ++ *)
+(* 		       str " by " ++ int  ++ str " to get " ++ *)
+(* 		       my_print_constr (push_rels sign env) cstr); *)
+	    let app = 
+	      mkApp (Lazy.force eq_ind, 
+		     [| lift len (type_of_tomatch ty); cstr; lift len tm |])
+	    in app :: eqs, succ n, slen')
+	 ([], 0, signlen) pats tomatchs
+       in
+       let eqs_rels = List.map (fun eq -> Name (id_of_string "H"), None, eq) eqs in
+(*        let ineqs = build_ineqs eqns newpatterns in *)
+       let rhs_rels' = eqs_rels @ rhs_rels in
+       let rhs_env = push_rels rhs_rels' env in
+(*        (try trace (str "branch env: " ++ print_env rhs_env) *)
+(* 	with _ -> trace (str "error in print branch env")); *)
+       let tycon = lift_tycon (List.length eqs + signlen) tycon in
+	 
+       let j = typing_fun tycon rhs_env eqn.rhs.it in
+(* 	 (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *)
+(* 		       str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *)
+(* 	  with _ -> *)
+(* 	    trace (str "Error in typed branch pretty printing")); *)
+	 let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
+	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
+	 let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in
+	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+(* 	 (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *)
+(* 	  with _ -> trace (str "Error in branch decl pp")); *)
+	 let branch = 
+	   let bref = RVar (dummy_loc, branch_name) in
+	   match vars_of_ctx rhs_rels with
+	       [] -> bref
+	     | l -> RApp (dummy_loc, bref, l)
+	 in
+(* 	 let branch =  *)
+(* 	   List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *)
+(* 	 in *)
+(* 	 (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *)
+(* 	  with _ -> trace (str "Error in new branch pp")); *)
+	 incr i;
+	 let rhs = { eqn.rhs with it = branch } in
+	   (branch_decl :: branches,
+	    { eqn with patterns = newpatterns; rhs = rhs } :: eqns))
+    ([], []) eqns
+    
+
+(* 		   liftn_rel_declaration *)
+
+
+(* Builds the predicate. If the predicate is dependent, its context is
+ * made of 1+nrealargs assumptions for each matched term in an inductive
+ * type and 1 assumption for each term not _syntactically_ in an
+ * inductive type.
+
+ * Each matched terms are independently considered dependent or not.
+
+ * A type constraint but no annotation case: it is assumed non dependent.
+ *)
+
+let prepare_predicate_from_tycon loc typing_fun isevars env tomatchs arsign tycon = 
+  (* We extract the signature of the arity *)
+(*   List.iter *)
+(*       (fun arsign ->  *)
+(* 	 trace (str "arity signature: " ++ my_print_rel_context env arsign)) *)
+(*     arsign; *)
+(*   let env = List.fold_right push_rels arsign env in *)
+  let allnames = List.rev (List.map (List.map pi1) arsign) in
+  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+  let pred = out_some (valcon_of_tycon tycon) in
+  let predcclj, pred, neqs = 
+    let _, _, eqs = 
+      List.fold_left2
+	(fun (neqs, slift, eqs) ctx (tm,ty) ->
+	   let len = List.length ctx in
+	   let _name, _, _typ' = List.hd ctx in (* FixMe: Ignoring dependent inductives *)
+	   let eq = mkApp (Lazy.force eq_ind, 
+			   [| lift (neqs + nar) (type_of_tomatch ty); 
+			      mkRel (neqs + slift);
+			      lift (neqs + nar) tm|]) 
+	   in
+	     (succ neqs, slift - len, (Anonymous, None, eq) :: eqs))
+	(0, nar, []) (List.rev arsign) tomatchs
+    in
+    let len = List.length eqs in
+      it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len
+  in
+  let predccl = nf_isevar !isevars predcclj in
+(*   let env' = List.fold_right push_rel_context arsign env in *)
+(*     trace (str " Env:" ++ my_print_env env' ++ str" Predicate: " ++ my_print_constr env' predccl); *)
+    build_initial_predicate true allnames predccl, pred
+    
+let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
+  (* We extract the signature of the arity *)
+  let arsign = extract_arity_signature env tomatchs sign in
+  let env = List.fold_right push_rels arsign env in
+  let allnames = List.rev (List.map (List.map pi1) arsign) in
+  let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in
+(*   let _ =  *)
+(*     option_map (fun tycon ->  *)
+(* 		  isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val  *)
+(* 		    (lift_tycon_type (List.length arsign) tycon)) *)
+(*       tycon *)
+(*   in *)
+  let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
+    Some (build_initial_predicate true allnames predccl)
+  
+let lift_ctx n ctx = 
+  let ctx', _ =
+    List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
+  in ctx'
+
+(* Turn matched terms into variables. *)
+let abstract_tomatch env tomatchs =
+  let prev, ctx, names = 
+    List.fold_left
+      (fun (prev, ctx, names) (c, t) ->
+	 let lenctx =  List.length ctx in
+	 match kind_of_term c with
+	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names
+	   | _ -> 
+	       let name = next_ident_away_from (id_of_string "filtered_var") names in
+		 (mkRel 1, lift_tomatch_type 1 t) :: lift_ctx 1 prev, 
+	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, 
+	       name :: names)
+      ([], [], []) tomatchs
+  in List.rev prev, ctx
+    
+(**************************************************************************)
+(* Main entry of the matching compilation                                 *)
+  
+let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)=
+  let tycon0 = tycon in
+  (* We build the matrix of patterns and right-hand-side *)
+  let matx = matx_of_eqns env eqns in
+     
+  (* We build the vector of terms to match consistently with the *)
+  (* constructors found in patterns *)
+  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
+  let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
+  let tomatchs_len = List.length tomatchs_lets in
+  let tycon = lift_tycon tomatchs_len tycon in
+  let env = push_rel_context tomatchs_lets env in
+    match predopt with
+	None ->	  
+	  let lets, matx = constrs_of_pats typing_fun tycon env isevars matx tomatchs in
+	  let matx = List.rev matx in
+	  let len = List.length lets in
+	  let sign = 
+	    let arsign = extract_arity_signature env tomatchs (List.map snd tomatchl) in
+	      List.map (lift_rel_context len) arsign
+	  in
+	  let env = push_rels lets env in	      
+	  let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
+	  let tycon = lift_tycon len tycon in
+	  let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
+	  let args = List.map (fun (tm,ty) -> mk_refl (type_of_tomatch ty) tm) tomatchs in
+	    
+	  (* We build the elimination predicate if any and check its consistency *)
+	  (* with the type of arguments to match *)
+	  let pred, opred = prepare_predicate_from_tycon loc typing_fun isevars env tomatchs sign tycon in
+	  (* We push the initial terms to match and push their alias to rhs' envs *)
+	  (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+	  let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+	    
+	  let pb =
+	    { env      = env;
+	      isevars  = isevars;
+	      pred     = Some pred;
+	      tomatch  = initial_pushed;
+	      history  = start_history (List.length initial_pushed);
+	      mat      = matx;
+	      caseloc  = loc;
+	      typing_function = typing_fun } in
+	    
+	  let _, j = compile pb in
+	    (* We check for unused patterns *)
+	    List.iter (check_unused_pattern env) matx;
+	    let ty = out_some (valcon_of_tycon tycon0) in
+	    let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
+	    let j = 
+	      { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
+		uj_type = ty; }
+	    in
+	      inh_conv_coerce_to_tycon loc env isevars j tycon0
+
+      | Some rtntyp ->
+	  (* We build the elimination predicate if any and check its consistency *)
+	  (* with the type of arguments to match *)
+	  let tmsign = List.map snd tomatchl in
+	  let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon rtntyp in
+	    
+	  (* We push the initial terms to match and push their alias to rhs' envs *)
+	  (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+	  let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+	    
+	  let pb =
+	    { env      = env;
+	      isevars  = isevars;
+	      pred     = pred;
+	      tomatch  = initial_pushed;
+	      history  = start_history (List.length initial_pushed);
+	      mat      = matx;
+	      caseloc  = loc;
+	      typing_function = typing_fun } in
+	    
+	  let _, j = compile pb in
+	  (* We check for unused patterns *)
+	  List.iter (check_unused_pattern env) matx;
+	  let j = { j with uj_val = it_mkLambda_or_LetIn j.uj_val tomatchs_lets } in
+	    inh_conv_coerce_to_tycon loc env isevars j tycon	  
+
+end
+  
diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli
new file mode 100644
index 00000000..9e902126
--- /dev/null
+++ b/contrib/subtac/subtac_cases.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Evd
+open Environ
+open Inductiveops
+open Rawterm
+open Evarutil
+(*i*)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a
+
+val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a
+
+(*s Compilation of pattern-matching. *)
+
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    unsafe_judgment
+end
+
+module Cases_F(C : Coercion.S) : S
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
index da5c497c..3613ec4f 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 9284 2006-10-26 12:06:57Z msozeau $ *)
+(* $Id: subtac_coercion.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
 
 open Util
 open Names
@@ -53,8 +53,6 @@ module Coercion = struct
       | _ -> None
 	  
   and disc_exist env x =
-    (try trace (str "Disc_exist: " ++ my_print_constr env x)
-     with _ -> ());
     match kind_of_term x with
       | App (c, l) ->
 	  (match kind_of_term c with
@@ -67,8 +65,6 @@ module Coercion = struct
 
 
   let disc_proj_exist env x =
-    (try trace (str "disc_proj_exist: " ++ my_print_constr env x);
-     with _ -> ());
     match kind_of_term x with
       | App (c, l) ->
 	  (if Term.eq_constr c (Lazy.force sig_).proj1 
@@ -108,27 +104,27 @@ module Coercion = struct
       : (Term.constr -> Term.constr) option 
       =
     let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in
-      (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++ 
-		  str " and "++ my_print_constr env y ++ 
-		  str " with evars: " ++ spc () ++
-		  my_print_evardefs !isevars);
-       with _ -> ());
+(*       (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++  *)
+(* 		  str " and "++ my_print_constr env y ++  *)
+(* 		  str " with evars: " ++ spc () ++ *)
+(* 		  my_print_evardefs !isevars); *)
+(*        with _ -> ()); *)
     let rec coerce_unify env x y =
-      (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ 
-		  str " to "++ my_print_constr env y)
-       with _ -> ());
+(*       (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++  *)
+(* 		  str " to "++ my_print_constr env y) *)
+(*        with _ -> ()); *)
       try 
 	isevars := the_conv_x_leq env x y !isevars;
-	(try debug 1 (str "Unified " ++ (my_print_constr env x) ++ 
-			str " and "++ my_print_constr env y);
-	 with _ -> ());
+(* 	(try debug 1 (str "Unified " ++ (my_print_constr env x) ++  *)
+(* 			str " and "++ my_print_constr env y); *)
+(* 	 with _ -> ()); *)
 	None
       with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y)
     and coerce' env x y : (Term.constr -> Term.constr) option =
       let subco () = subset_coerce env isevars x y in
-	(try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ 
-		    str " to "++ my_print_constr env y);
-	 with _ -> ());
+(* 	(try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++  *)
+(* 		    str " to "++ my_print_constr env y); *)
+(* 	 with _ -> ()); *)
 	match (kind_of_term x, kind_of_term y) with
 	  | Sort s, Sort s' -> 
 	      (match s, s' with
@@ -158,11 +154,11 @@ module Coercion = struct
 		     let existS = Lazy.force existS in
 		     let prod = Lazy.force prod in
 		       if len = Array.length l' && len = 2 && i = i'
+			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
 		       then 
 			 if i = Term.destInd existS.typ 
 			 then
 			   begin 
-			     trace (str "In coerce sigma types");
 			     let (a, pb), (a', pb') = 
 			       pair_of_array l, pair_of_array l' 
 			     in
@@ -185,7 +181,6 @@ module Coercion = struct
 			     let c2 = coerce_unify env' b b' in
 			       match c1, c2 with
 				   None, None -> 
-				     trace (str "No coercion needed");
 				     None
 				 | _, _ ->
 				     Some 
@@ -198,9 +193,8 @@ module Coercion = struct
 					  in
 					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
 			   end
-			 else if i = Term.destInd prod.typ then
+			 else 
 			   begin 
-			     debug 1 (str "In coerce prod types");
 			     let (a, b), (a', b') = 
 			       pair_of_array l, pair_of_array l' 
 			     in
@@ -219,14 +213,48 @@ module Coercion = struct
 					  in
 					    mkApp (prod.intro, [| a'; b'; x ; y |]))
 			   end
-			 else subco ()
-		       else subco ()
-		 | _ ->  subco ())
+		       else
+			 (* if len = 1 && len = Array.length l' && i = i' then *)
+(* 			   let argx, argy = l.(0), l'.(0) in *)
+(* 			   let indtyp = Inductiveops.type_of_inductive env i in *)
+(* 			   let argname, argtype, _ = destProd indtyp in *)
+(* 			   let eq = *)
+(* 			     mkApp (Lazy.force eqind, [| argtype; argx; argy |]) *)
+(* 			   in *)
+(* 			   let pred = mkLambda (argname, argtype,  *)
+(* 						mkApp (mkInd i, [| mkRel 1 |])) *)
+(* 			   in *)
+(* 			   let evar = make_existential dummy_loc env isevars eq in *)
+(* 			     Some (fun x -> *)
+(* 				     mkApp (Lazy.force eqrec,  *)
+(* 					    [| argtype; argx; pred; x; argy; evar |])) *)
+(* 			 else  *)subco ()
+		 | x, y when x = y ->
+		     let lam_type = Typing.type_of env (evars_of !isevars) c in
+		     let rec coerce typ i co =
+		       if i < Array.length l then
+			 let hdx = l.(i) and hdy = l'.(i) in
+			 let (n, eqT, restT) = destProd typ in
+			 let pred = mkLambda (n, eqT, mkApp (lift 1 c, [| mkRel 1 |])) in
+			 let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
+			 let evar = make_existential dummy_loc env isevars eq in
+			 let eq_app x = mkApp (Lazy.force eq_rect,
+					       [| eqT; hdx; pred; x; hdy; evar|])
+			 in 
+			   coerce (subst1 hdy restT) (succ i) (fun x -> eq_app (co x))
+		       else co
+		     in
+		       if Array.length l = Array.length l' then (
+			 trace (str"Inserting coercion at application");
+			 Some (coerce lam_type 0 (fun x -> x))
+		       ) else subco ()
+		 | _ -> subco ())
 	  | _, _ ->  subco ()
 
     and subset_coerce env isevars x y =
       match disc_subset x with
 	  Some (u, p) -> 
+	    (* trace (str "Inserting projection ");	     *)
 	    let c = coerce_unify env u y in
 	    let f x = 
 	      app_opt c (mkApp ((Lazy.force sig_).proj1, 
@@ -372,13 +400,13 @@ module Coercion = struct
       with Reduction.NotConvertible -> raise NoCoercion
 
   let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
-    (try
-       debug 1 (str "inh_conv_coerce_to_fail called for " ++
-	      Termops.print_constr_env env t ++ str " and "++ spc () ++
-	      Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++
-	      Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
-	      Termops.print_env env);
-     with _ -> ());
+(*     (try *)
+(*        debug 1 (str "inh_conv_coerce_to_fail called for " ++ *)
+(* 	      Termops.print_constr_env env t ++ str " and "++ spc () ++ *)
+(* 	      Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ *)
+(* 	      Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
     try (the_conv_x_leq env t c1 isevars, v, t)
     with Reduction.NotConvertible ->
       (try 
@@ -437,14 +465,14 @@ module Coercion = struct
 
 	
   (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-  let inh_conv_coerce_to loc env isevars cj ((n, t) as tycon) =
-    (try 
-       debug 1 (str "Subtac_coercion.inh_conv_coerce_to called for " ++
-	      Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ 
-	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++
-	      Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
-	      Termops.print_env env);
-     with _ -> ());
+  let inh_conv_coerce_to loc env isevars cj ((n, t) as _tycon) =
+(*     (try *)
+(*        trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ *)
+(* 	      Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ *)
+(* 	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
+(* 	      Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
     match n with
 	None ->
 	  let (evd', val', type') = 
@@ -462,40 +490,38 @@ module Coercion = struct
       | Some (init, cur) ->
 	  (isevars, cj)
 
-  let inh_conv_coerces_to loc env isevars t ((abs, t') as tycon) =
-    (try 
-       debug 1 (str "Subtac_coercion.inh_conv_coerces_to called for " ++
-	      Termops.print_constr_env env t ++ str " and "++ spc () ++ 
-	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++
-	      Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
-	      Termops.print_env env);
-     with _ -> ());
+  let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) =
+(*     (try  *)
+(*        trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ *)
+(* 	      Termops.print_constr_env env t ++ str " and "++ spc () ++  *)
+(* 	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
+(* 	      Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
     let nabsinit, nabs = 
       match abs with
 	  None -> 0, 0
 	| Some (init, cur) -> init, cur
     in
-    let (rels, rng) = 
       (* a little more effort to get products is needed *) 
-      try decompose_prod_n nabs t
-      with _ -> 
-	trace (str "decompose_prod_n failed");
-	raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to")
-    in
-      (* The final range free variables must have been replaced by evars, we accept only that evars
-	 in rng are applied to free vars. *)
-      if noccur_with_meta 0 (succ nabsinit) rng then (
-	trace (str "No occur between 0 and " ++ int (succ nabsinit));
-	let env', t, t' = 
-	  let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
-	    env', rng, lift nabs t'
-	in
-	  try 
-	    pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t'
-		 with NoCoercion ->
-		   coerce_itf loc env' isevars None t t') 
-	  with NoSubtacCoercion ->
-	    let sigma = evars_of isevars in
-	      error_cannot_coerce env' sigma (t, t'))
-      else isevars 
+      try let rels, rng = decompose_prod_n nabs t in
+	(* The final range free variables must have been replaced by evars, we accept only that evars
+	   in rng are applied to free vars. *)
+	if noccur_with_meta 0 (succ nabsinit) rng then (
+(* 	  trace (str "No occur between 0 and " ++ int (succ nabsinit)); *)
+	  let env', t, t' = 
+	    let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
+	      env', rng, lift nabs t'
+	  in
+	    try 
+	      pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t'
+		   with NoCoercion ->
+		     coerce_itf loc env' isevars None t t') 
+	    with NoSubtacCoercion ->
+	      let sigma = evars_of isevars in
+		error_cannot_coerce env' sigma (t, t'))
+	else isevars 
+      with _ -> isevars
+ (* 	trace (str "decompose_prod_n failed"); *)
+ (* 	raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *)
 end
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
index b433af2c..68ab8c46 100644
--- a/contrib/subtac/subtac_command.ml
+++ b/contrib/subtac/subtac_command.ml
@@ -57,7 +57,7 @@ let interp_gen kind isevars env
                c =
   let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in
   let c' = Subtac_utils.rewrite_cases env c' in
-    (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ());
+(*     (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *)
   let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in
     evar_nf isevars c'
     
@@ -150,14 +150,6 @@ let collect_non_rec env =
   in 
   searchrec [] 
 
-
-let filter_map f l = 
-  let rec aux acc = function
-      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
-		     | None -> aux acc tl)
-    | [] -> List.rev acc
-  in aux [] l
-
 let list_of_local_binders l = 
   let rec aux acc = function
       Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
@@ -176,25 +168,29 @@ let rec gen_rels = function
     0 -> []
   | n -> mkRel n :: gen_rels (pred n)
 
+let split_args n rel = match list_chop ((List.length rel) - n) rel with
+    (l1, x :: l2) -> l1, x, l2
+  | _ -> assert(false)
+
 let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   let sigma = Evd.empty in
   let isevars = ref (Evd.create_evar_defs sigma) in
   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 "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)
-    with _ -> ()
-  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 _ =  *)
+(*     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) *)
+(*     with _ -> () *)
+    (*   in *)
   let env', binders_rel = interp_context isevars env bl in
-  let after, ((argname, _, argtyp) as arg), before = list_chop_hd (succ n) binders_rel in
+  let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in
   let before_length, after_length = List.length before, List.length after in
   let argid = match argname with Name n -> n | _ -> assert(false) in
   let _liftafter = lift_binders 1 after_length after in
@@ -226,15 +222,14 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   in
   let argid' = id_of_string (string_of_id argid ^ "'") in
   let wfarg len = (Name argid', None, 
-  		   mkSubset (Name argid') argtyp 
+  		   mkSubset (Name argid') (lift len 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
   let top_env = push_rel_context top_bl env in
-  let intern_env = push_rel_context intern_bl env in
+  let _intern_env = push_rel_context intern_bl env in
   let top_arity = interp_type isevars top_env arityc in
-  (try debug 2 (str "Intern bl: " ++ prr intern_bl) with _ -> ());
   let proj = (Lazy.force sig_).Coqlib.proj1 in
   let projection = 
     mkApp (proj, [| argtyp ;
@@ -243,32 +238,32 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
 		    mkRel 1
 		 |])
   in
-  (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ());
+    (*   (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); *)
   let intern_arity = substnl [projection] after_length top_arity in 
-  (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ());
+(*   (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); *)
   let intern_before_env = push_rel_context before env in
   let intern_fun_bl = after @ [wfarg 1]  in
-  (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ());
+(*   (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *)
   let intern_fun_arity = intern_arity in
-  (try debug 2 (str "Intern fun arity: " ++ 
-		  my_print_constr intern_env intern_fun_arity) with _ -> ());
+(*   (try debug 2 (str "Intern fun arity: " ++  *)
+(* 		  my_print_constr intern_env intern_fun_arity) with _ -> ()); *)
   let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in
   let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
   let fun_bl = after @ (intern_fun_binder :: [arg]) in
-  (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ());
+(*   (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *)
   let fun_env = push_rel_context fun_bl intern_before_env in
   let fun_arity = interp_type isevars fun_env arityc in
   let intern_body = interp_casted_constr isevars fun_env body fun_arity in
   let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in
-  let _ = 
-      try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++
-		   str "Intern bl" ++ prr intern_bl ++ spc () ++
-		   str "Top bl" ++ prr top_bl ++ spc () ++
-		   str "Intern arity: " ++ pr intern_arity ++
-		   str "Top arity: " ++ pr top_arity ++ spc () ++
-		   str "Intern body " ++ pr intern_body_lam)
-      with _ -> ()
-  in
+(*   let _ =  *)
+(*       try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ *)
+(* 		   str "Intern bl" ++ prr intern_bl ++ spc () ++ *)
+(* 		   str "Top bl" ++ prr top_bl ++ spc () ++ *)
+(* 		   str "Intern arity: " ++ pr intern_arity ++ *)
+(* 		   str "Top arity: " ++ pr top_arity ++ spc () ++ *)
+(* 		   str "Intern body " ++ pr intern_body_lam) *)
+(*       with _ -> () *)
+(*   in *)
   let _impl = 
     if Impargs.is_implicit_args()
     then Impargs.compute_implicits top_env top_arity
@@ -292,53 +287,48 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
   let def_appl = applist (fix_def, gen_rels (after_length + 1)) in
   let def = it_mkLambda_or_LetIn def_appl binders_rel in
   let typ = it_mkProd_or_LetIn top_arity binders_rel in
-    debug 2 (str "Constructed def");
-    debug 2 (my_print_constr intern_before_env def);
-    debug 2 (str "Type: " ++ my_print_constr env typ);
   let fullcoqc = Evarutil.nf_isevar !isevars def in
   let fullctyp = Evarutil.nf_isevar !isevars typ in
-  let _ = try trace (str "After evar normalization: " ++ spc () ++
-		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc ()
-		     ++ str "Coq type: " ++ my_print_constr env fullctyp) 
-     with _ -> () 
-  in
+(*   let _ = try trace (str "After evar normalization: " ++ spc () ++ *)
+(* 		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *)
+(* 		     ++ str "Coq type: " ++ my_print_constr env fullctyp)  *)
+(*      with _ -> ()  *)
+(*   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 _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in *)
   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")
-(*
+    (*     (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 _ -> ());     *)
+    Subtac_obligations.add_definition recname evars_def fullctyp evars
+    
 let build_mutrec l boxed = 
-  let sigma = Evd.empty
-  and env0 = Global.env()
-  in 
+  let sigma = Evd.empty and env = Global.env () in 
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
   let lnameargsardef =
-    (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env0 protos (f, d))*)
+    (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env protos (f, d))*)
     l
   in
   let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef 
   and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef
   in
     (* Build the recursive context and notations for the recursive types *)
-  let (rec_sign,rec_impls,arityl) = 
+  let (rec_sign,rec_env,rec_impls,arityl) = 
     List.fold_left 
-      (fun (env,impls,arl) ((recname, n, bl,arityc,body),_) -> 
+      (fun (sign,env,impls,arl) ((recname, n, bl,arityc,body),_) -> 
 	 let isevars = ref (Evd.create_evar_defs sigma) in	  
 	 let arityc = Command.generalize_constr_expr arityc bl in
-	 let arity = interp_type isevars env0 arityc in
+	 let arity = interp_type isevars env arityc in
 	 let impl = 
 	   if Impargs.is_implicit_args()
-	   then Impargs.compute_implicits env0 arity
+	   then Impargs.compute_implicits env arity
 	   else [] in
 	 let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
-	   (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl))
-      (env0,[],[]) lnameargsardef in
+	   ((recname,None,arity) :: sign, Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl))
+      ([],env,[],[]) lnameargsardef in
   let arityl = List.rev arityl in
   let notations = 
     List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) 
@@ -357,11 +347,11 @@ let build_mutrec l boxed =
 	     match info with
 		 None ->
 		   let def = abstract_constr_expr def bl in
-		     isevars, info, interp_casted_constr isevars rec_sign ~impls:([],rec_impls)
+		     isevars, info, interp_casted_constr isevars rec_env ~impls:([],rec_impls)
 		       def arity
 	       | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) ->
-		   let rec_sign = push_rel_context fun_bl rec_sign in
-		   let cstr = interp_casted_constr isevars rec_sign ~impls:([],rec_impls)
+		   let rec_env = push_rel_context fun_bl rec_env in
+		   let cstr = interp_casted_constr isevars rec_env ~impls:([],rec_impls)
 				def intern_arity
 		   in isevars, info, it_mkLambda_or_LetIn cstr fun_bl)
           lnameargsardef arityl
@@ -369,162 +359,33 @@ let build_mutrec l boxed =
 	States.unfreeze fs; raise e in
     States.unfreeze fs; def 
   in
-
   let (lnonrec,(namerec,defrec,arrec,nvrec)) = 
-    collect_non_rec env0 lrecnames recdef arityl nv in
-  let declare arrec defrec =
-    let recvec = 
-      Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
-    let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
-    let rec declare i fi =
-      (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++
-		  my_print_constr env0 (recvec.(i)));
-       with _ -> ());
-      let ce = 
-	{ const_entry_body = mkFix ((nvrec,i),recdecls); 
-          const_entry_type = Some arrec.(i);
-          const_entry_opaque = false;
-          const_entry_boxed = boxed} in
-      let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint)
-      in (ConstRef kn)
-    in 
-      (* declare the recursive definitions *)
-    let lrefrec = Array.mapi declare namerec in
-      Options.if_verbose ppnl (recursive_message lrefrec);
-
-
-      (*(* The others are declared as normal definitions *)
-      let var_subst id = (id, Constrintern.global_reference id) in
-      let _ = 
-	List.fold_left
-	  (fun subst (f,def,t) ->
-	     let ce = { const_entry_body = replace_vars subst def;
-			const_entry_type = Some t;
-			const_entry_opaque = false;
-			const_entry_boxed = boxed } in
-	     let _ =
-	       Declare.declare_constant f (DefinitionEntry ce,IsDefinition Definition)
-	     in
-      	       warning ((string_of_id f)^" is non-recursively defined");
-      	       (var_subst f) :: subst)
-	  (List.map var_subst (Array.to_list namerec))
-	  lnonrec 
-      in*)
-      List.iter (fun (df,c,scope) ->
-		   Metasyntax.add_notation_interpretation df [] c scope) notations
-  in 
-  let declare l = 
-    let recvec = Array.of_list l
-    and arrec = Array.map pi3 arrec
-    in declare arrec recvec
-  in
+    collect_non_rec env lrecnames recdef arityl nv in
   let recdefs = Array.length defrec in
-    trace (int recdefs ++ str " recursive definitions");
     (* Solve remaining evars *)
   let rec collect_evars i acc = 
     if i < recdefs then
       let (isevars, info, def) = defrec.(i) in
-      let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in
+	(*       let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *)
       let def = evar_nf isevars def in
       let isevars = Evd.undefined_evars !isevars in
-      let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in
+	(*       let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *)
       let evm = Evd.evars_of isevars in
       let _, _, typ = arrec.(i) in
       let id = namerec.(i) in
-      (* Generalize by the recursive prototypes  *)
+	(* Generalize by the recursive prototypes  *)
       let def = 
-	Termops.it_mkNamedLambda_or_LetIn def (Environ.named_context rec_sign)
+	Termops.it_mkNamedLambda_or_LetIn def rec_sign
       and typ = 
-	Termops.it_mkNamedProd_or_LetIn typ (Environ.named_context rec_sign) 
+	Termops.it_mkNamedProd_or_LetIn typ rec_sign
       in
-      let evars_def, evars_typ, evars = Eterm.eterm_term evm def (Some typ) in 	
-      (*let evars_typ = match evars_typ with Some t -> t | None -> assert(false) in*)
-      (*let fi = id_of_string (string_of_id id ^ "_evars") in*)
-      (*let ce = 
-	{ const_entry_body = evars_def; 
-	  const_entry_type = Some evars_typ;
-	  const_entry_opaque = false;
-	  const_entry_boxed = boxed} in
-      let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Definition) in
-	definition_message fi;
-	trace (str (string_of_id fi) ++ str " is defined");*)
-	let evar_sum =
-	  if evars = [] then None
-	  else (
-	    (try trace (str "Building evars sum for : ");
-	       List.iter
-		 (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env0 t))
-		 evars;
-	     with _ -> ());
-	    let sum = Subtac_utils.build_dependent_sum evars in
-	      (try trace (str "Evars sum: " ++ my_print_constr env0 (snd sum));
-	       with _ -> ());
-	      Some sum)
-	in
-	  collect_evars (succ i) ((id, evars_def, evar_sum) :: acc)
+      let evars, def = Eterm.eterm_obligations id nc_len evm def (Some typ) in
+	collect_evars (succ i) ((id, def, typ, evars) :: acc)
     else acc
   in 
   let defs = collect_evars 0 [] in
-
-  (* Solve evars then create the definitions *)
-  let real_evars = 
-    filter_map (fun (id, kn, sum) ->
-		  match sum with Some (sumtac, sumg) -> Some (id, kn, sumg, sumtac) | None -> None)
-      defs
-  in
-    match real_evars with
-	[] -> declare (List.rev_map (fun (id, c, _) ->
-				   snd (decompose_lam_n recdefs c)) defs)
-      | l ->
-
-    Subtac_utils.and_tac real_evars
-      (fun f _ gr ->
-	 let _ = trace (str "Got a proof of: " ++ pr_global gr ++
-			str "type: " ++ my_print_constr (Global.env ()) (Global.type_of_global gr)) in
-	 let constant = match gr with Libnames.ConstRef c -> c
-	   | _ -> assert(false)
-	 in
-	   try
-	     (*let value = Environ.constant_value (Global.env ()) constant in*)
-	     let pis = f (mkConst constant) in
-	       (try (trace (str "Accessors: " ++
-			   List.fold_right (fun (_, _, _, c) acc -> my_print_constr env0 c ++ spc () ++ acc)
-			     pis (mt()));
-		    trace (str "Applied existentials: " ++
-			   (List.fold_right
-			      (fun (id, kn, sumg, pi) acc ->
-				 let args = Subtac_utils.destruct_ex pi sumg in
-				   my_print_constr env0 (mkApp (kn, Array.of_list args)))
-			      pis (mt ()))))
-	       with _ -> ());
-	       let rec aux pis acc = function
-		   (id, kn, sum) :: tl ->
-		     (match sum with 
-			  None -> aux pis (kn :: acc) tl
-			| Some (_, sumg) -> 
-			    let (id, kn, sumg, pi), pis = List.hd pis, List.tl pis in
-			    let args = Subtac_utils.destruct_ex pi sumg in
-			    let args = 
-			      List.map (fun c -> 
-					  try Reductionops.whd_betadeltaiota (Global.env ()) Evd.empty c
-					  with Not_found ->
-					    trace (str "Not_found while reducing " ++
-						   my_print_constr (Global.env ()) c);
-					    c
-				       ) args 				  
-			    in
-			    let _, newdef = decompose_lam_n (recdefs + List.length args) kn in
-			    let constr = Term.substl (mkRel 1 :: List.rev args) newdef in
-			      aux pis (constr :: acc) tl)
-		 | [] -> List.rev acc
-	       in
-		 declare (aux pis [] defs)
-	   with Environ.NotEvaluableConst cer ->
-	     match cer with
-		 Environ.NoBody -> trace (str "Constant has no body")
-	       | Environ.Opaque -> trace (str "Constant is opaque")
-      )
-*)
+    Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec
+      
 let out_n = function
     Some n -> n
   | None -> 0
@@ -544,8 +405,7 @@ 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 assert(false)
-	     (*build_mutrec lnameargsardef boxed*)
+	in build_mutrec lnameargsardef boxed
 	  
       
       
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
index 7b13b402..d6c1772f 100644
--- a/contrib/subtac/subtac_obligations.ml
+++ b/contrib/subtac/subtac_obligations.ml
@@ -12,6 +12,8 @@ open Decl_kinds
 open Util
 open Evd
 
+type obligation_info = (Names.identifier * Term.types * Intset.t) array
+
 type obligation =
     { obl_name : identifier;
       obl_type : types;
@@ -24,15 +26,42 @@ type obligations = (obligation array * int)
 type program_info = {
   prg_name: identifier;
   prg_body: constr;
-  prg_type: types;
+  prg_type: constr;
   prg_obligations: obligations;
+  prg_deps : identifier list;
+  prg_nvrec : int array;
 }
 
-let evar_of_obligation o = { evar_hyps = Environ.empty_named_context_val ; 
+let assumption_message id =
+  Options.if_verbose message ((string_of_id id) ^ " is assumed")
+
+let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC
+
+let set_default_tactic t = default_tactic := t
+
+let evar_of_obligation o = { evar_hyps = Global.named_context_val () ;
 			     evar_concl = o.obl_type ; 
 			     evar_body = Evar_empty ;
 			     evar_extra = None }
 
+let subst_deps obls deps t =
+  Intset.fold
+    (fun x acc ->
+       let xobl = obls.(x) in
+	 debug 3 (str "Trying to get body of obligation " ++ int x);
+       let oblb = 
+	 try out_some xobl.obl_body
+	 with _ ->
+	   debug 3 (str "Couldn't get body of obligation " ++ int x);
+	   assert(false)
+       in
+	 Term.subst1 oblb (Term.subst_var xobl.obl_name acc))
+    deps t
+
+let subst_deps_obl obls obl =
+  let t' = subst_deps obls obl.obl_deps obl.obl_type in
+    { obl with obl_type = t' }
+
 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)
@@ -62,21 +91,6 @@ let _ =
       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 = 
@@ -88,14 +102,72 @@ let terms_of_evar ev =
 	  body, typ
     | _ -> assert(false)
 	  
+let rec intset_to = function
+    -1 -> Intset.empty
+  | n -> Intset.add n (intset_to (pred n))
+  
+let subst_body prg = 
+  let obls, _ = prg.prg_obligations in
+    subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body
+
+let declare_definition prg =
+  let body = subst_body prg in
+    (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++
+		  my_print_constr (Global.env()) body);
+     with _ -> ());
+  let ce = 
+    { const_entry_body = 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 Pp
+open Ppconstr
+
+let declare_mutual_definition l =
+  let len = List.length l in
+  let namerec = Array.of_list (List.map (fun x -> x.prg_name) l) in
+  let arrec = 
+    Array.of_list (List.map (fun x -> snd (decompose_prod_n len x.prg_type)) l)
+  in
+  let recvec = 
+    Array.of_list 
+      (List.map (fun x -> 
+		   let subs = (subst_body x) in
+		     snd (decompose_lam_n len subs)) l)
+  in
+  let nvrec = (List.hd l).prg_nvrec in
+  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
+  let rec declare i fi =
+    (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++
+		  my_print_constr (Global.env()) (recvec.(i)));
+     with _ -> ());
+    let ce = 
+      { const_entry_body = mkFix ((nvrec,i),recdecls); 
+        const_entry_type = Some arrec.(i);
+        const_entry_opaque = false;
+        const_entry_boxed = true} in
+    let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint)
+    in
+      ConstRef kn
+  in
+  let lrefrec = Array.mapi declare namerec in
+    Options.if_verbose ppnl (recursive_message lrefrec)
+         
 let declare_obligation obl body =
   let ce = 
     { const_entry_body = body;
       const_entry_type = Some obl.obl_type;
-      const_entry_opaque = true;
+      const_entry_opaque = false;
       const_entry_boxed = false} 
   in
-  let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property)
+  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) }
@@ -113,36 +185,30 @@ let try_tactics obls =
 	 | _ -> 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
+let red = Reductionops.nf_betaiota
+
+let init_prog_info n b t deps nvrec obls =
+  let obls' = 
+    Array.mapi
+      (fun i (n, t, d) ->
+	 debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d));
+         { obl_name = n ; obl_body = None; 
+	   obl_type = red t; 
+	   obl_deps = d })
+      obls
   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
+    { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
+      prg_deps = deps; prg_nvrec = nvrec; }
+    
+let pperror cmd = Util.errorlabstrm "Subtac" cmd
+let error s = pperror (str s)
 
 let get_prog name =
   let prg_infos = !from_prg in
     match name with
-	Some n -> ProgMap.find n prg_infos
+	Some n -> 
+	  (try ProgMap.find n prg_infos
+	   with Not_found -> error ("No obligations for program " ^ string_of_id n))
       | None -> 
 	  (let n = map_cardinal prg_infos in
 	     match n with 
@@ -150,57 +216,67 @@ let get_prog name =
 	       | 1 -> map_first prg_infos
 	       | _ -> error "More than one program with unsolved obligations")
 
+let obligations_solved prg = (snd prg.prg_obligations) = 0
+
 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)
+    from_prg := map_replace prg.prg_name prg' !from_prg;
+    if rem > 0 then (
+      Options.if_verbose msgnl (int rem ++ str " obligation(s) remaining");
+    )
     else (
-      declare_definition prg';
-      from_prg := ProgMap.remove prg.prg_name !from_prg
-    )		 
+      Options.if_verbose msgnl (str "No more obligations remaining");
+      match prg'.prg_deps with
+	  [] ->
+	    declare_definition prg';
+	    from_prg := ProgMap.remove prg.prg_name !from_prg
+	| l ->
+	    let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
+	      if List.for_all (fun x -> obligations_solved x) progs then 
+		(declare_mutual_definition progs;
+		 from_prg := List.fold_left
+		   (fun acc x -> ProgMap.remove x.prg_name acc) !from_prg progs))
 	    
 let is_defined obls x = obls.(x).obl_body <> None
 
-let deps_remaining obls x = 
-  let deps = obls.(x).obl_deps in
+let deps_remaining obls deps = 
     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 solve_obligation prg num =
+  let user_num = succ num in
+  let obls, rem = prg.prg_obligations in
+  let obl = obls.(num) in
+    if obl.obl_body <> None then
+      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")    
+    else
+      match deps_remaining obls obl.obl_deps with
+	  [] ->
+	    let obl = subst_deps_obl 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: " ++
+		       Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
+	      Pfedit.by !default_tactic
+	| l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
+			++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
+
+let subtac_obligation (user_num, name, typ) =
   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)))
+	    None -> solve_obligation prg num
 	  | Some r -> error "Obligation already solved"
     else error (sprintf "Unknown obligation number %i" (succ num))
       
@@ -217,33 +293,102 @@ let obligations_of_evars evars =
 	    }) evars)
   in arr, Array.length arr
 
+let solve_obligation_by_tac prg obls i tac =
+  let obl = obls.(i) in
+  match obl.obl_body with 
+      Some _ -> false
+    | None -> 
+	(try
+	   if deps_remaining obls obl.obl_deps = [] then
+	     let obl = subst_deps_obl obls obl in
+	     let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
+	       obls.(i) <- { obl with obl_body = Some t };
+	       true		 
+	   else false
+	 with _ -> false)  
+
 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.copy obls in
+  let _ = 
+    Array.iteri (fun i x -> 
+		   if solve_obligation_by_tac prg obls' i tac then
+		     decr rem)
+      obls'
+  in
+    update_obls prg obls' !rem
+
+let add_definition n b t obls =
+  Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
+  let prg = init_prog_info n b t [] (Array.make 0 0) obls in
+  let obls,_ = prg.prg_obligations in
+  if Array.length obls = 0 then (
+    Options.if_verbose ppnl (str ".");    
+    declare_definition prg;
+    from_prg := ProgMap.remove prg.prg_name !from_prg)
+  else (
+    let len = Array.length obls in
+    let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
+      from_prg := ProgMap.add n prg !from_prg; 
+      solve_obligations (Some n) !default_tactic)
+	
+let add_mutual_definitions l nvrec =
+  let deps = List.map (fun (n, b, t, obls) -> n) l in
+  let upd = List.fold_left
+      (fun acc (n, b, t, obls) ->
+	 let prg = init_prog_info n b t deps nvrec obls in
+	   ProgMap.add n prg acc)
+      !from_prg l
+  in
+    from_prg := upd;
+    List.iter (fun x -> solve_obligations (Some x) !default_tactic) deps
+
+let admit_obligations n =
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
   let obls' = 
-    Array.map (fun x -> 
+    Array.mapi (fun i 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)
+		     None -> 
+			 let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in
+			   assumption_message x.obl_name;
+			   { x with obl_body = Some (mkConst kn) }
+		   | Some _ -> x)
       obls
   in
-    update_obls prg obls' !rem
+    update_obls prg obls' 0
 
+exception Found of int
+
+let array_find f arr = 
+  try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
+    raise Not_found
+  with Found i -> i
+
+let rec next_obligation n =
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+  let i = 
+    array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = [])
+      obls
+  in
+    if solve_obligation_by_tac prg obls i !default_tactic then (
+      update_obls prg obls (pred rem);
+      next_obligation n
+    ) else solve_obligation prg i
+      
 open Pp
 let show_obligations n =
   let prg = get_prog n in
+  let n = prg.prg_name 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)
+		       None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ 
+					my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())
 		    | Some _ -> ())
       obls
 			
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
index 7d93d57b..3981d4c6 100644
--- a/contrib/subtac/subtac_obligations.mli
+++ b/contrib/subtac/subtac_obligations.mli
@@ -1,10 +1,21 @@
 open Util
 
-val add_entry : Names.identifier -> Term.constr -> Term.types ->
-  (Names.identifier * Term.types * Intset.t) array -> unit
+type obligation_info = (Names.identifier * Term.types * Intset.t) array
 
-val subtac_obligation : int * Names.identifier option -> unit
+val set_default_tactic : Proof_type.tactic -> unit
+
+val add_definition : Names.identifier ->  Term.constr -> Term.types -> 
+  obligation_info -> unit
+
+val add_mutual_definitions : 
+  (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit
+
+val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit
+
+val next_obligation : Names.identifier option -> unit
 
 val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit
 
 val show_obligations : Names.identifier option -> unit
+
+val admit_obligations : Names.identifier option -> unit
diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml
index a243ba34..4d1ac731 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 9326 2006-10-31 12:57:26Z msozeau $ *)
+(* $Id: subtac_pretyping.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
 
 open Global
 open Pp
@@ -113,29 +113,23 @@ let env_with_binders env isevars l =
   in aux (env, []) l
 
 let subtac_process env isevars id l c tycon =
-  let evars () = evars_of !isevars in
-  let _ = trace (str "Creating env with binders") in
   let env_binders, binders_rel = env_with_binders env isevars l in
-  let _ = try (trace (str "New env created:" ++ my_print_context env_binders)) with _ -> () in
   let tycon = 
     match tycon with
 	None -> empty_tycon
       | Some t -> 
 	  let t = coqintern !isevars env_binders t in
-	  let _ = try trace (str "Internalized specification: " ++ my_print_rawconstr env_binders t) with _ -> () in
 	  let coqt, ttyp = interp env_binders isevars t empty_tycon in
-	  let _ = try trace (str "Interpreted type: " ++ my_print_constr env_binders coqt) with _ -> () in
 	    mk_tycon coqt
   in    
   let c = coqintern !isevars env_binders c in
   let c = Subtac_utils.rewrite_cases env c in
-  let _ = try trace (str "Internalized term: " ++ my_print_rawconstr env c)  with _ -> () in
   let coqc, ctyp = interp env_binders isevars c tycon in
-  let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++
-		 str "Coq type: " ++ my_print_constr env_binders ctyp)
-  with _ -> () 
-  in
-  let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ()))  with _ -> () in
+(*   let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ *)
+(* 		 str "Coq type: " ++ my_print_constr env_binders ctyp) *)
+(*   with _ -> ()  *)
+(*   in *)
+(*   let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ()))  with _ -> () in *)
     
   let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel 
   and fullctyp = it_mkProd_or_LetIn ctyp binders_rel
@@ -143,13 +137,13 @@ let subtac_process env isevars id l c tycon =
   let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in
   let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in
 
-  let _ = try trace (str "After evar normalization: " ++ spc () ++
-		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc ()
-		 ++ str "Coq type: " ++ my_print_constr env fullctyp) 
-     with _ -> () 
-  in
+(*   let _ = try trace (str "After evar normalization: " ++ spc () ++ *)
+(* 		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *)
+(* 		 ++ str "Coq type: " ++ my_print_constr env fullctyp)  *)
+(*      with _ -> ()  *)
+(*   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 _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in *)
     evm, fullcoqc, fullctyp
 
 open Subtac_obligations
@@ -159,5 +153,4 @@ let subtac_proof env isevars id l c tycon =
   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
+    add_definition id def coqt evars
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml
index 46af5886..6244aef3 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 9316 2006-10-29 22:49:11Z herbelin $ *)
+(* $Id: subtac_pretyping_F.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
 
 open Pp
 open Util
@@ -40,7 +40,7 @@ open Inductiveops
 
 module SubtacPretyping_F (Coercion : Coercion.S) = struct
 
-  module Cases = Cases.Cases_F(Coercion)
+  module Cases = Subtac_cases.Cases_F(Coercion)
 
   (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
   let allow_anonymous_refs = ref true
@@ -161,7 +161,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
   (* in environment [env], with existential variables [(evars_of isevars)] and *)
   (* the type constraint tycon *)
-  let rec pretype (tycon : type_constraint) env isevars lvar = function
+  let rec pretype (tycon : type_constraint) env isevars lvar c = 
+(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
+(* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
+(*     with _ -> () *)
+(*     in *)
+    match c with
     | RRef (loc,ref) ->
 	inh_conv_coerce_to_tycon loc env isevars
 	  (pretype_ref isevars env ref)
@@ -321,7 +326,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	      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
+	  inh_conv_coerce_to_tycon loc env isevars resj tycon
 
     | RLambda(loc,name,c1,c2)      ->
 	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
index 7b96758a..01dee3e9 100644
--- a/contrib/subtac/subtac_utils.ml
+++ b/contrib/subtac/subtac_utils.ml
@@ -5,6 +5,8 @@ open Term
 open Names
 open Util
 
+let ($) f x = f x
+
 (****************************************************************************)
 (* Library linking *)
 
@@ -45,10 +47,23 @@ let build_sig () =
 
 let sig_ = lazy (build_sig ())
 
-let eqind = lazy (init_constant ["Init"; "Logic"] "eq")
-let eqind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
+let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
+let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
+let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
+let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal")
+let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
 let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal")
 
+let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
+let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
+
+let jmeq_ind = lazy (init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_ind_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq")
+let jmeq_refl_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq_refl")
+
 let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
 let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
 
@@ -79,6 +94,7 @@ open Pp
 
 let my_print_constr = Termops.print_constr_env
 let my_print_constr_expr = Ppconstr.pr_constr_expr
+let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
 let my_print_context = Termops.print_rel_context
 let my_print_named_context = Termops.print_named_context
 let my_print_env = Termops.print_env
@@ -87,7 +103,7 @@ let my_print_evardefs = Evd.pr_evar_defs
 
 let my_print_tycon_type = Evarutil.pr_tycon_type
 
-let debug_level = 1
+let debug_level = 2
 
 let debug_on = true
 
@@ -132,8 +148,9 @@ let print_args env args =
 let make_existential loc env isevars c =
   let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) c in
   let (key, args) = destEvar evar in
-    (try debug 2 (str "Constructed evar " ++ int key ++ str " applied to args: " ++
-		  print_args env args) with _ -> ());
+    (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
+		  print_args env args ++ str " for type: "++ 
+		  my_print_constr env c) with _ -> ());
     evar
 
 let make_existential_expr loc env c =
@@ -177,6 +194,12 @@ open Tactics
 open Tacticals
 
 let id x = x
+let filter_map f l = 
+  let rec aux acc = function
+      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
+		     | None -> aux acc tl)
+    | [] -> List.rev acc
+  in aux [] l
 
 let build_dependent_sum l =
   let rec aux names conttac conttype = function
@@ -279,45 +302,137 @@ let destruct_ex ext ex =
 
 open Rawterm
 
-
+let rec concatMap f l = 
+  match l with
+      hd :: tl -> f hd @ concatMap f tl      
+    | [] -> []
+	
 let list_mapi f = 
   let rec aux i = function 
       hd :: tl -> f i hd :: aux (succ i) tl 
     | [] -> []
   in aux 0
 
-let rewrite_cases_aux (loc, po, tml, eqns) =
-  let tml = list_mapi (fun i (c, (n, opt)) -> c, 
-		       ((match n with
-			    Name id -> (match c with
-					  | RVar (_, id') when id = id' ->
-					      Name (id_of_string (string_of_id id ^ "'"))
-					  | _ -> n)
-			  | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))),
-			opt)) tml 
-  in
+(*
+let make_discr (loc, po, tml, eqns) =
   let mkHole = RHole (dummy_loc, InternalHole) in
-  let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)),
-		       [mkHole; c; n])
+  
+  let rec vars_of_pat = function
+      RPatVar (loc, n) -> (match n with Anonymous -> [] | Name n -> [n])
+    | RPatCstr (loc, csrt, pats, _) -> 
+	concatMap vars_of_pat pats
   in
-  let eqs_types = 
-    List.map
-      (fun (c, (n, _)) ->
-	 let id = match n with Name id -> id | _ -> assert false in
-	 let heqid = id_of_string ("Heq" ^ string_of_id id) in
-	   Name heqid, mkeq c (RVar (dummy_loc, id)))
-      tml
+  let rec constr_of_pat l = function 
+      RPatVar (loc, n) -> 
+	(match n with 
+	     Anonymous -> 
+	       let n = next_name_away_from "x" l in
+		 RVar n, (n :: l)
+	   | Name n -> RVar n, l)
+    | RPatCstr (loc, csrt, pats, _) -> 
+	let (args, vars) =
+	  List.fold_left
+	    (fun (args, vars) x ->
+	       let c, vars = constr_of_pat vars x in
+		 c :: args, vars)
+	    ([], l) pats
+	in		 
+	  RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars
   in
-  let po = 
-    List.fold_right
-      (fun (n,t) acc ->
-	 RProd (dummy_loc, Anonymous, t, acc))
-      eqs_types (match po with 
-		     Some e -> e
-		   | None -> mkHole)
+  let rec constr_of_pat l = function 
+      RPatVar (loc, n) -> 
+	(match n with 
+	     Anonymous -> 
+	       let n = next_name_away_from "x" l in
+		 RVar n, (n :: l)
+	   | Name n -> RVar n, l)
+    | RPatCstr (loc, csrt, pats, _) -> 
+	let (args, vars) =
+	  List.fold_left
+	    (fun (args, vars) x ->
+	       let c, vars = constr_of_pat vars x in
+		 c :: args, vars)
+	    ([], l) pats
+	in		 
+	  RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars
   in
-  let eqns =   
-    List.map (fun (loc, idl, cpl, c) ->
+  let constrs_of_pats v l =
+    List.fold_left 
+      (fun (v, acc) x -> 
+	 let x', v' = constr_of_pat v x in
+	   (l', v' :: acc))
+      (v, []) l
+  in
+  let rec pat_of_pat l = function
+      RPatVar (loc, n) -> 
+	let n', l = match n with
+	    Anonymous -> 
+	      let n = next_name_away_from "x" l in
+		n, n :: l
+	  | Name n -> n, n :: l 
+	in
+	  RPatVar (loc, Name n'), l
+    | RPatCstr (loc, cstr, pats, (loc, alias)) ->
+	let args, vars, s = 
+	  List.fold_left (fun (args, vars) x -> 
+			    let pat', vars = pat_of_pat vars pat in
+			      pat' :: args, vars)
+	    ([], alias :: l) pats
+	in RPatCstr (loc, cstr, args, (loc, alias)), vars
+  in
+  let pats_of_pats l =
+    List.fold_left 
+      (fun (v, acc) x -> 
+	 let x', v' = pat_of_pat v x in
+	   (v', x' :: acc))
+      ([], []) l
+  in
+  let eq_of_pat p used c = 
+    let constr, vars' = constr_of_pat used p in
+    let eq = RApp (dummy_loc, RRef (dummy_loc, Lazy.force eqind_ref), [mkHole; constr; c]) in
+      vars', eq
+  in
+  let eqs_of_pats ps used cstrs =
+    List.fold_left2 
+      (fun (vars, eqs) pat c ->
+	 let (vars', eq) = eq_of_pat pat c in
+	   match eqs with 
+	       None -> Some eq 
+	     | Some eqs ->
+		 Some (RApp (dummy_loc, RRef (dummy_loc, Lazy.force and_ref), [eq, eqs])))
+      (used, None) ps cstrs
+  in
+  let quantify c l =
+    List.fold_left
+      (fun acc name -> RProd (dummy_loc, name, mkHole, acc))
+      c l
+  in
+  let quantpats = 
+    List.fold_left
+      (fun (acc, pats) ((loc, idl, cpl, c) as x) ->
+	 let vars, cpl = pats_of_pats cpl in
+	 let l', constrs = constrs_of_pats vars cpl in	   
+	 let discrs = 
+	   List.map (fun (_, _, cpl', _) -> 
+		       let qvars, eqs = eqs_of_pats cpl' l' constrs in
+		       let neg = RApp (dummy_loc, RRef (dummy_loc, Lazy.force not_ref), [out_some eqs]) in
+		       let pat_ineq = quantify qvars neg in
+			 
+		    )
+	     pats in
+	   
+			 
+
+
+	   
+	   
+
+	   (x, pat_ineq))
+  in
+    List.fold_left 
+      (fun acc ((loc, idl, cpl, c0) pat) -> 
+    
+		
 		let c' = 
 		  List.fold_left 
 		    (fun acc (n, t) ->
@@ -325,27 +440,74 @@ let rewrite_cases_aux (loc, po, tml, eqns) =
 		    c eqs_types
 		in (loc, idl, cpl, c'))
       eqns
-  in
-  let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref),
-			      [mkHole; c])
-  in
-  let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in
-  let case = RCases (loc,Some po,tml,eqns) in
-  let app = RApp (dummy_loc, case, refls) in
-    app
-
-let rec rewrite_cases c = 
-  match c with 
-      RCases _ -> let c' = map_rawconstr rewrite_cases c in
-	(match c' with 
-	   | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w)
-	   | _ -> assert(false))
-    | _ -> map_rawconstr rewrite_cases c
+  i
+*)
+(* let rewrite_cases_aux (loc, po, tml, eqns) = *)
+(*   let tml = list_mapi (fun i (c, (n, opt)) -> c,  *)
+(* 		       ((match n with *)
+(* 			    Name id -> (match c with *)
+(* 					  | RVar (_, id') when id = id' -> *)
+(* 					      Name (id_of_string (string_of_id id ^ "'")) *)
+(* 					  | _ -> n) *)
+(* 			  | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), *)
+(* 			opt)) tml  *)
+(*   in *)
+(*   let mkHole = RHole (dummy_loc, InternalHole) in *)
+(*   (\* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), *\) *)
+(* (\* 		       [mkHole; c; n]) *\) *)
+(* (\*   in *\) *)
+(*   let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqdep_ind_ref)), *)
+(* 		       [mkHole; c; mkHole; n]) *)
+(*   in *)
+(*   let eqs_types =  *)
+(*     List.map *)
+(*       (fun (c, (n, _)) -> *)
+(* 	 let id = match n with Name id -> id | _ -> assert false in *)
+(* 	 let heqid = id_of_string ("Heq" ^ string_of_id id) in *)
+(* 	   Name heqid, mkeq c (RVar (dummy_loc, id))) *)
+(*       tml *)
+(*   in *)
+(*   let po =  *)
+(*     List.fold_right *)
+(*       (fun (n,t) acc -> *)
+(* 	 RProd (dummy_loc, Anonymous, t, acc)) *)
+(*       eqs_types (match po with  *)
+(* 		     Some e -> e *)
+(* 		   | None -> mkHole) *)
+(*   in *)
+(*   let eqns =    *)
+(*     List.map (fun (loc, idl, cpl, c) -> *)
+(* 		let c' =  *)
+(* 		  List.fold_left  *)
+(* 		    (fun acc (n, t) -> *)
+(* 		       RLambda (dummy_loc, n, mkHole, acc)) *)
+(* 		    c eqs_types *)
+(* 		in (loc, idl, cpl, c')) *)
+(*       eqns *)
+(*   in *)
+(*   let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *)
+(* 			      [mkHole; c]) *)
+(*   in *)
+(*   (\*let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *)
+(* 			      [mkHole; c]) *)
+(*   in*\) *)
+(*   let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in *)
+(*   let case = RCases (loc,Some po,tml,eqns) in *)
+(*   let app = RApp (dummy_loc, case, refls) in *)
+(*     app *)
+
+(* let rec rewrite_cases c =  *)
+(*   match c with  *)
+(*       RCases _ -> let c' = map_rawconstr rewrite_cases c in *)
+(* 	(match c' with  *)
+(* 	   | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) *)
+(* 	   | _ -> assert(false)) *)
+(*     | _ -> map_rawconstr rewrite_cases c *)
 	  
-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 rewrite_cases env c = *)
+(*   let c' = rewrite_cases c in *)
+(*   let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *)
+(*     c' *)
 
 let list_mapi f = 
   let rec aux i = function 
@@ -371,7 +533,7 @@ let rewrite_cases_aux (loc, po, tml, eqns) =
   in
   let mkHole = RHole (dummy_loc, InternalHole) in
   let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in
-  let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)),
+  let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eq_ind_ref)),
 		       [mkHole; c; n])
   in
   let eqs_types = 
@@ -419,10 +581,10 @@ let rec rewrite_cases c =
 	   | _ -> assert(false))
     | _ -> map_rawconstr rewrite_cases c
 	  
-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 rewrite_cases env c = 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
@@ -439,16 +601,107 @@ let recursive_message 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
+  debug 1 (str "Goal created");
   let ts = Tacmach.mk_pftreestate goal in
+  debug 1 (str "Got pftreestate");
   let solved_state = Tacmach.solve_pftreestate t ts in
-  let c = Tacmach.extract_pftreestate solved_state in
+  debug 1 (str "Solved goal");
+    let _, l = Tacmach.extract_open_pftreestate solved_state in
+      List.iter (fun (_, x) -> debug 1 (str "left hole of type " ++ my_print_constr (Global.env()) x)) l;
+    let c = Tacmach.extract_pftreestate solved_state in
+    debug 1 (str "Extracted term");
     debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c);
     c
+    *)
+
+let solve_by_tac evi t =
+  debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi);
+  let id = id_of_string "H" in
+  try 
+    Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
+    (fun _ _ -> ());
+    debug 2 (str "Started proof");
+    Pfedit.by (tclCOMPLETE t);
+    let _,(const,_,_) = Pfedit.cook_proof () in 
+      Pfedit.delete_current_proof (); const.Entries.const_entry_body
+  with e -> 
+    Pfedit.delete_current_proof();
+    raise Exit
 
 let rec string_of_list sep f = function
     [] -> ""
   | x :: [] -> f x
   | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
+
+let string_of_intset d = 
+  string_of_list "," string_of_int (Intset.elements d)
+
+(**********************************************************)
+(* Pretty-printing *)
+open Printer
+open Ppconstr
+open Nameops
+open Termops
+open Evd
+
+let pr_meta_map evd =
+  let ml = meta_list evd in
+  let pr_name = function
+      Name id -> str"[" ++ pr_id id ++ str"]"
+    | _ -> mt() in
+  let pr_meta_binding = function
+    | (mv,Cltyp (na,b)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " : " ++
+           print_constr b.rebus ++ fnl ())
+    | (mv,Clval(na,b,_)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " := " ++
+             print_constr b.rebus ++ fnl ())
+  in
+  prlist pr_meta_binding ml    
+
+let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+
+let pr_evar_info evi =
+  let phyps = 
+    (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
+    Printer.pr_named_context (Global.env()) (evar_context evi)
+  in
+  let pty = print_constr evi.evar_concl in
+  let pb =
+    match evi.evar_body with
+      | Evar_empty -> mt ()
+      | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
+  in
+  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
+
+let pr_evar_map sigma =
+  h 0 
+    (prlist_with_sep pr_fnl
+      (fun (ev,evi) ->
+        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+      (to_list sigma))
+
+let pr_constraints pbs =
+  h 0
+    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
+      print_constr t1 ++ spc() ++
+      str (match pbty with
+	| Reduction.CONV -> "=="
+	| Reduction.CUMUL -> "<=") ++ 
+      spc() ++ print_constr t2) pbs)
+
+let pr_evar_defs evd =
+  let pp_evm =
+    let evars = evars_of evd in
+    if evars = empty then mt() else
+      str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
+  let pp_met =
+    if meta_list evd = [] then mt() else
+      str"METAS:"++brk(0,1)++pr_meta_map evd in
+  v 0 (pp_evm ++ pp_met)
diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli
index ebfc5123..482640f9 100644
--- a/contrib/subtac/subtac_utils.mli
+++ b/contrib/subtac/subtac_utils.mli
@@ -12,6 +12,7 @@ open Evarutil
 open Names
 open Sign
 
+val ($) : ('a -> 'b) -> 'a -> 'b
 val contrib_name : string
 val subtac_dir : string list
 val fix_sub_module : string
@@ -31,9 +32,19 @@ val proj1_sig_ref : reference
 val proj2_sig_ref : reference
 val build_sig : unit -> coq_sigma_data
 val sig_ : coq_sigma_data lazy_t
-val eqind : constr lazy_t
-val eqind_ref : global_reference lazy_t
+
+val eq_ind : constr lazy_t
+val eq_rec : constr lazy_t
+val eq_rect : constr lazy_t
+val eq_refl : constr lazy_t
+val eq_ind_ref : global_reference lazy_t
 val refl_equal_ref : global_reference lazy_t
+
+val eqdep_ind : constr lazy_t
+val eqdep_rec : constr lazy_t
+val eqdep_ind_ref : global_reference lazy_t
+val eqdep_intro_ref : global_reference lazy_t
+
 val boolind : constr lazy_t
 val sumboolind : constr lazy_t
 val natind : constr lazy_t
@@ -48,10 +59,12 @@ val acc : constr lazy_t
 val acc_inv : constr lazy_t
 val extconstr : constr -> constr_expr
 val extsort : sorts -> constr_expr
+
 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_rel_context : env -> rel_context -> 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
@@ -98,3 +111,6 @@ 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
+val string_of_intset : Intset.t -> string
+
+val pr_evar_defs : evar_defs -> Pp.std_ppcmds
diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v
index 8429c267..b8d13fe6 100644
--- a/contrib/subtac/test/ListsTest.v
+++ b/contrib/subtac/test/ListsTest.v
@@ -1,95 +1,76 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
 Require Import Coq.subtac.Utils.
 Require Import List.
 
-Variable A : Set.
-
-Program Definition myhd : forall { l : list A | length l <> 0 }, A :=  
-  fun l =>
-    match `l with
-    | nil => _
-    | hd :: tl => hd
-    end.
-Proof.
-  destruct l ; simpl ; intro H.
-  rewrite H in n ; intuition.
-Defined.
+Set Implicit Arguments.
 
+Section Accessors.
+  Variable A : Set.
 
-Extraction myhd.
-Extraction Inline proj1_sig.
+  Program Definition myhd : forall { l : list A | length l <> 0 }, A :=  
+    fun l =>
+      match l with
+        | nil => !
+        | hd :: tl => hd
+      end.
 
-Program Definition mytail : forall { l : list A | length l <> 0 }, list A :=
-  fun l => 
+  Program Definition mytail (l : list A | length l <> 0) : list A :=
     match l with
-    | nil => _
-    | hd :: tl => tl
+      | nil => !
+      | hd :: tl => tl
     end.
-Proof.
-destruct l ; simpl ; intro H ; rewrite H in n ; intuition.
-Defined.
-
-Extraction mytail.
-
-Variable a : A.
+End Accessors.
 
-Program Definition test_hd : A := myhd (cons a nil).
-Proof.
-simpl ; auto.
-Defined.
-
-Extraction test_hd.
+Program Definition test_hd : nat := myhd (cons 1 nil).
 
+(*Eval compute in test_hd*)
 (*Program Definition test_tail : list A := mytail nil.*)
 
+Section app.
+  Variable A : Set.
 
+  Program Fixpoint app (l : list A) (l' : list A) { struct l } :
+    { r : list A | length r = length l + length l' } :=
+    match l with
+      | nil => l'
+      | hd :: tl => hd :: (tl ++ l')
+    end 
+    where "x ++ y" := (app x y).
+
+  Next Obligation.
+    intros.
+    destruct_call app ; subtac_simpl.
+  Defined.
+  
+  Program Lemma app_id_l : forall l : list A, l = nil ++ l.
+  Proof.
+    simpl ; auto.
+  Qed.
+  
+  Program Lemma app_id_r : forall l : list A, l = l ++ nil.
+  Proof.
+    induction l ; simpl ; auto.
+    rewrite <- IHl ; auto.
+  Qed.
+
+End app.
+
+Extraction app.
+
+Section Nth.
+
+  Variable A : Set.
+
+  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := 
+    match n, l with
+      | 0, hd :: _ => hd
+      | S n', _ :: tl => nth tl n'
+      | _, nil => !
+    end.
 
-
-
-Program Fixpoint append (l : list A) (l' : list A) { struct l } :
- { r : list A | length r = length l + length l' } :=
- match l with
- | nil => l'
- | hd :: tl => hd :: (append tl l')
- end.
-subst ; auto.
-simpl ; rewrite (subset_simpl (append tl0 l')).
-simpl ; subst.
-simpl ; auto.
-Defined.
-
-Extraction append.
-
-
-Program Lemma append_app' : forall l : list A, l = append nil l.
-Proof.
-simpl ; auto.
-Qed.
-
-Program Lemma append_app : forall l : list A, l = append l nil.
-Proof.
-intros.
-induction l ; simpl ; auto.
-simpl in IHl.
-rewrite <- IHl.
-reflexivity.
-Qed.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+  Next Obligation.
+  Proof.
+    inversion l0.
+  Defined.
+End Nth.
 
diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v
index ba5bdf23..a5a8b85f 100644
--- a/contrib/subtac/test/euclid.v
+++ b/contrib/subtac/test/euclid.v
@@ -1,66 +1,27 @@
-
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-
-Definition t := fun (Evar46 : forall a : nat, (fun y : nat => @eq nat a y) a) (a : nat) =>
-@existS nat (fun x : nat => @sig nat (fun y : nat => @eq nat x y)) a
-  (@exist nat (fun y : nat => @eq nat a y) a (Evar46 a)).
-
-Program Definition testsig (a : nat) : { x : nat & { y : nat | x = y } } :=
-  (a & a).
-reflexivity.
-Defined.
-
-Extraction testsig.
-Extraction sig.
-Extract Inductive sig => "" [ "" ].
-Extraction testsig.
-
+Require Import Coq.subtac.Utils.
 Require Import Coq.Arith.Compare_dec.
-
-Require Import Omega.
-
-Lemma minus_eq_add : forall x y z w, y <= x -> x - y = y * z + w -> x = y * S z + w.
-intros.
-assert(y * S z = y * z + y).
-auto.
-rewrite H1.
-omega.
-Qed.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
+Notation "( x & y )" := (existS _ x y) : core_scope.
+  
+Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
   { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
   if le_lt_dec b a then let (q', r) := euclid (a - b) b in 
   (S q' & r)
   else (O & a).
-intro euclid.
-simpl ; intros.
-Print euclid_evars.
-eapply euclid_evars with euclid.
-refine (euclid_evars _ _ _ euclid a Acc_a b).
-; simpl ; intros.
-Show Existentials.
 
-induction b0 ; induction r.
-simpl in H.
-simpl.
-simpl in p0.
-destruct p0.
-split.
+Require Import Omega.
+
+Obligations.
+Solve Obligations using subtac_simpl ; omega.
+
+Next Obligation.
+  assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega.
+Defined.
 
-apply minus_eq_add.
-omega.
-auto with arith.
-auto.
-simpl.
-induction b0 ; simpl.
-split ; auto.
-omega.
-exact (euclid a0 Acc_a0 b0).
+Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
 
-exact (Acc_a).
-auto.
-auto.
-Focus 1.
+Eval lazy beta zeta delta iota in test_euclid.
 
+Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
+  (a & S a).
 
+Check testsig.
diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml
index 92cbf6df..30dc7b71 100644
--- a/contrib/xml/proof2aproof.ml
+++ b/contrib/xml/proof2aproof.ml
@@ -112,8 +112,6 @@ let extract_open_proof sigma pf =
          ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
 	 proof_extractor vl flat_proof
 	  
-     | {PT.ref=Some(PT.Change_evars,[pf])} -> (proof_extractor vl) pf
-	  
      | {PT.ref=None;PT.goal=goal} ->
 	 let visible_rels =
            Util.map_succeed
diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4
index dbdc79a8..9afd07a6 100644
--- a/contrib/xml/proofTree2Xml.ml4
+++ b/contrib/xml/proofTree2Xml.ml4
@@ -93,7 +93,7 @@ let string_of_prim_rule x = match x with
   | Proof_type.ThinBody _-> "ThinBody"
   | Proof_type.Move (_,_,_) -> "Move"
   | Proof_type.Rename (_,_) -> "Rename"
-
+  | Proof_type.Change_evars -> "Change_evars"
 
 let
  print_proof_tree curi sigma pf proof_tree_to_constr
@@ -189,11 +189,6 @@ Pp.ppnl (Pp.(++) (Pp.str
           [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
         end
 
-     | {PT.ref=Some(PT.Change_evars,nodes)} ->
-         X.xml_nempty "Change_evars" of_attribute
-          (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"