Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

263 files changed, 24083 insertions, 16756 deletions

diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
index 8bdae54b..e67797e4 100644
--- a/contrib/cc/ccalgo.ml
+++ b/contrib/cc/ccalgo.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *)
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
@@ -16,13 +16,16 @@ open Pp
 open Goptions
 open Names
 open Term
+open Tacmach
+open Evd
+open Proof_type
 
 let init_size=5
 
 let cc_verbose=ref false 
 
-let debug msg (stdpp:std_ppcmds) = 
-  if !cc_verbose then msg stdpp
+let debug f x = 
+  if !cc_verbose then f x
 
 let _=
   let gdopt=
@@ -97,7 +100,8 @@ type cinfo=
 
 type term=
     Symb of constr
-  | Eps
+  | Product of sorts_family * sorts_family
+  | Eps of identifier
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
@@ -122,14 +126,19 @@ type equality = rule eq
 
 type disequality = from eq
 
+type patt_kind =
+    Normal 
+  | Trivial of types
+  | Creates_variables
+
 type quant_eq =
     {qe_hyp_id: identifier;
      qe_pol: bool;
      qe_nvars:int;
      qe_lhs: ccpattern;
-     qe_lhs_valid:bool;
+     qe_lhs_valid:patt_kind;
      qe_rhs: ccpattern;
-     qe_rhs_valid:bool}
+     qe_rhs_valid:patt_kind}
 
 let swap eq : equality =
   let swap_rule=match eq.rule with
@@ -145,10 +154,11 @@ type inductive_status =
   | Total of (int * pa_constructor)
 
 type representative=
-    {mutable nfathers:int;
+    {mutable weight:int;
      mutable lfathers:Intset.t;
      mutable fathers:Intset.t;
      mutable inductive_status: inductive_status;
+     class_type : Term.types;
      mutable functions: Intset.t PafMap.t;
      mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
 
@@ -179,9 +189,11 @@ type state =
      mutable diseq: disequality list;
      mutable quant: quant_eq list;
      mutable pa_classes: Intset.t;
-     q_history: (constr,unit) Hashtbl.t;
+     q_history: (identifier,int array) Hashtbl.t;
      mutable rew_depth:int;
-     mutable changed:bool}
+     mutable changed:bool;
+     by_type: (types,Intset.t) Hashtbl.t;
+     mutable gls:Proof_type.goal Tacmach.sigma}
 
 let dummy_node =
   {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
@@ -189,7 +201,7 @@ let dummy_node =
    vertex=Leaf;
    term=Symb (mkRel min_int)}
 
-let empty depth:state =
+let empty depth gls:state =
   {uf=
      {max_size=init_size;
       size=0;
@@ -206,7 +218,9 @@ let empty depth:state =
   pa_classes=Intset.empty;
   q_history=Hashtbl.create init_size;
   rew_depth=depth;
-  changed=false}
+  by_type=Hashtbl.create init_size;
+  changed=false;
+  gls=gls}
 
 let forest state = state.uf 
        
@@ -233,7 +247,7 @@ let get_constructor_info uf i=
     | _ -> anomaly "get_constructor: not a constructor"
 	
 let size uf i=
-  (get_representative uf i).nfathers
+  (get_representative uf i).weight
 
 let axioms uf = uf.axioms
 
@@ -241,13 +255,13 @@ let epsilons uf = uf.epsilons
 
 let add_lfather uf i t=
   let r=get_representative uf i in
-    r.nfathers<-r.nfathers+1;
+    r.weight<-r.weight+1;
     r.lfathers<-Intset.add t r.lfathers;
     r.fathers <-Intset.add t r.fathers
 
 let add_rfather uf i t=
   let r=get_representative uf i in
-    r.nfathers<-r.nfathers+1;
+    r.weight<-r.weight+1;
     r.fathers <-Intset.add t r.fathers
 
 exception Discriminable of int * pa_constructor * int * pa_constructor 
@@ -295,19 +309,29 @@ let next uf=
     uf.size<-nsize; 
     size
 	
-let new_representative ()=
-  {nfathers=0;
+let new_representative typ =
+  {weight=0;
    lfathers=Intset.empty;
    fathers=Intset.empty;
    inductive_status=Unknown;
+   class_type=typ;
    functions=PafMap.empty;
    constructors=PacMap.empty}
     
 (* rebuild a constr from an applicative term *)
     
+let _A_ = Name (id_of_string "A")
+let _B_ = Name (id_of_string "A")
+let _body_ =  mkProd(Anonymous,mkRel 2,mkRel 2)
+
+let cc_product s1 s2 = 
+  mkLambda(_A_,mkSort(Termops.new_sort_in_family s1),
+	   mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_))
+
 let rec constr_of_term = function
     Symb s->s
-  | Eps -> anomaly "epsilon constant has no value" 
+  | Product(s1,s2) -> cc_product s1 s2
+  | Eps id -> mkVar id
   | Constructor cinfo -> mkConstruct cinfo.ci_constr 
   | Appli (s1,s2)->
       make_app [(constr_of_term s2)] s1
@@ -330,24 +354,31 @@ let rec inst_pattern subst = function
 	(fun spat f -> Appli (f,inst_pattern subst spat))
 	   args t  
 
+let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
+  Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]"
+
+let pr_term t = str "[" ++
+  Termops.print_constr (constr_of_term t) ++ str "]"
+
 let rec add_term state t= 
   let uf=state.uf in
     try Hashtbl.find uf.syms t with 
 	Not_found ->
 	  let b=next uf in
+	  let typ = pf_type_of state.gls (constr_of_term t) in
 	  let new_node=
 	    match t with
-		Symb _ ->
+		Symb _ | Product (_,_) ->
 		  let paf =
 		    {fsym=b;
 		     fnargs=0} in
 		    Queue.add (b,Fmark paf) state.marks;
-		    {clas= Rep (new_representative ());
+		    {clas= Rep (new_representative typ);
 		     cpath= -1;
 		     vertex= Leaf;
 		     term= t}
-	      | Eps -> 
-		  {clas= Rep (new_representative ());
+	      | Eps id -> 
+		  {clas= Rep (new_representative typ);
 		   cpath= -1;
 		   vertex= Leaf;
 		   term= t}
@@ -356,7 +387,7 @@ let rec add_term state t=
 		    add_lfather uf (find uf i1) b;
 		    add_rfather uf (find uf i2) b;
 		    state.terms<-Intset.add b state.terms;
-		    {clas= Rep (new_representative ());
+		    {clas= Rep (new_representative typ);
 		     cpath= -1;
 		     vertex= Node(i1,i2);
 		     term= t}
@@ -370,13 +401,17 @@ let rec add_term state t=
 		     arity= cinfo.ci_arity;
 		     args=[]} in
 		    Queue.add (b,Cmark pac) state.marks;
-		    {clas=Rep (new_representative ());
+		    {clas=Rep (new_representative typ);
 		     cpath= -1;
 		     vertex=Leaf;
 		     term=t}
 	  in
 	    uf.map.(b)<-new_node;
 	    Hashtbl.add uf.syms t b;
+	    Hashtbl.replace state.by_type typ 
+	      (Intset.add b 
+		 (try Hashtbl.find state.by_type typ with 
+		      Not_found -> Intset.empty));
 	    b
 
 let add_equality state c s t=
@@ -400,32 +435,53 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
      qe_rhs= patt2;
      qe_rhs_valid=valid2}::state.quant
 
+let is_redundant state id args =
+  try  
+    let norm_args = Array.map (find state.uf) args in
+    let prev_args = Hashtbl.find_all state.q_history id in
+    List.exists 
+      (fun old_args -> 
+	 Util.array_for_all2 (fun i j -> i = find state.uf j) 
+         norm_args old_args) 
+      prev_args
+    with Not_found -> false
+
 let add_inst state (inst,int_subst) = 
-  if state.rew_depth > 0 then 
-  let subst = build_subst (forest state) int_subst in
-  let prfhead= mkVar inst.qe_hyp_id in
-  let args = Array.map constr_of_term subst in
-  let _ = array_rev args in (* highest deBruijn index first *)
-  let prf= mkApp(prfhead,args) in
-    try Hashtbl.find state.q_history prf
-    with Not_found ->
-      (* this instance is new, we can go on *)
-      let s = inst_pattern subst inst.qe_lhs 
-      and t = inst_pattern subst inst.qe_rhs in
-	state.changed<-true;
-	state.rew_depth<-pred state.rew_depth;
-	if inst.qe_pol then
-	  begin
-	    debug msgnl 
-	      (str "adding new equality, depth="++ int state.rew_depth);
-	    add_equality state prf s t
-	  end
-	else
-	  begin
-	    debug msgnl (str "adding new disequality, depth="++ 
-			   int state.rew_depth);
-	    add_disequality state (Hyp prf) s t 
-	  end
+  check_for_interrupt ();
+  if state.rew_depth > 0 then
+  if is_redundant state inst.qe_hyp_id int_subst then
+    debug msgnl (str "discarding redundant (dis)equality")
+  else   
+    begin
+      Hashtbl.add state.q_history inst.qe_hyp_id int_subst;
+      let subst = build_subst (forest state) int_subst in
+      let prfhead= mkVar inst.qe_hyp_id in
+      let args = Array.map constr_of_term subst in
+      let _ = array_rev args in (* highest deBruijn index first *)
+      let prf= mkApp(prfhead,args) in
+	  let s = inst_pattern subst inst.qe_lhs 
+	  and t = inst_pattern subst inst.qe_rhs in
+	    state.changed<-true;
+	    state.rew_depth<-pred state.rew_depth;
+	    if inst.qe_pol then
+	      begin
+		debug (fun () -> 
+		  msgnl 
+		   (str "Adding new equality, depth="++ int state.rew_depth);
+	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++ 
+			   pr_term s ++ str " == " ++ pr_term t ++ str "]")) ();
+		add_equality state prf s t
+	      end
+	    else
+	      begin
+		debug (fun () -> 
+		  msgnl 
+		   (str "Adding new disequality, depth="++ int state.rew_depth);
+	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++ 
+			   pr_term s ++ str " <> " ++ pr_term t ++ str "]")) ();
+		add_disequality state (Hyp prf) s t 
+	      end
+  end
 
 let link uf i j eq = (* links i -> j *)
   let node=uf.map.(i) in 
@@ -448,12 +504,17 @@ let join_path uf i j=
   min_path (down_path uf i [],down_path uf j [])
 
 let union state i1 i2 eq=
-  debug msgnl (str "Linking " ++ int i1 ++ str " and " ++ int i2 ++ str ".");
+  debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ 
+		 str " and " ++ pr_idx_term state i2 ++ str ".")) ();
   let r1= get_representative state.uf i1 
   and r2= get_representative state.uf i2 in
     link state.uf i1 i2 eq;
+    Hashtbl.replace state.by_type r1.class_type 
+      (Intset.remove i1 
+	 (try Hashtbl.find state.by_type r1.class_type with 
+	      Not_found -> Intset.empty));
     let f= Intset.union r1.fathers r2.fathers in
-      r2.nfathers<-Intset.cardinal f;
+      r2.weight<-Intset.cardinal f;
       r2.fathers<-f;
       r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
       ST.delete_set state.sigtable r1.fathers;
@@ -483,8 +544,9 @@ let union state i1 i2 eq=
 	| _,_ -> () 
             
 let merge eq state = (* merge and no-merge *)
-  debug msgnl 
-    (str "Merging " ++ int eq.lhs ++ str " and " ++ int eq.rhs ++ str ".");
+  debug (fun () -> msgnl 
+    (str "Merging " ++ pr_idx_term state eq.lhs ++ 
+       str " and " ++ pr_idx_term state eq.rhs ++ str ".")) ();
   let uf=state.uf in
   let i=find uf eq.lhs 
   and j=find uf eq.rhs in
@@ -495,8 +557,8 @@ let merge eq state = (* merge and no-merge *)
 	union state j i (swap eq)
 
 let update t state = (* update 1 and 2 *)
-  debug msgnl 
-    (str "Updating term " ++ int t ++ str ".");
+  debug (fun () -> msgnl 
+    (str "Updating term " ++ pr_idx_term state t ++ str ".")) ();
   let (i,j) as sign = signature state.uf t in
   let (u,v) = subterms state.uf t in
   let rep = get_representative state.uf i in
@@ -556,8 +618,8 @@ let process_constructor_mark t i rep pac state =
 	    end
 
 let process_mark t m state = 
-  debug msgnl 
-    (str "Processing mark for term " ++ int t ++ str ".");
+  debug (fun () -> msgnl 
+    (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) ();
   let i=find state.uf t in
   let rep=get_representative state.uf i in
     match m with
@@ -573,9 +635,9 @@ let check_disequalities state =
   let uf=state.uf in
   let rec check_aux = function
       dis::q -> 
-	debug msg 
-	(str "Checking if " ++ int dis.lhs ++ str " = " ++ 
-	 int dis.rhs ++ str " ... ");  
+	debug (fun () -> msg   
+	(str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ 
+	 pr_idx_term state dis.rhs ++ str " ... ")) ();  
 	if find uf dis.lhs=find uf dis.rhs then 
 	  begin debug msgnl (str "Yes");Some dis end 
 	else
@@ -601,16 +663,35 @@ let one_step state =
 	    update t state;
 	    true
 	with Not_found -> false
-	  
+
+let __eps__ = id_of_string "_eps_"  
+
+let new_state_var typ state =
+  let id = pf_get_new_id __eps__ state.gls in
+    state.gls<-
+      {state.gls with it =
+	  {state.gls.it with evar_hyps = 
+	      Environ.push_named_context_val (id,None,typ) 
+		state.gls.it.evar_hyps}};
+    id
 
 let complete_one_class state i=
   match (get_representative state.uf i).inductive_status with
       Partial pac ->
-	let rec app t n = 
+	let rec app t typ n = 
 	  if n<=0 then t else
-	    app (Appli(t,Eps)) (n-1) in
+	    let _,etyp,rest= destProd typ in
+	    let id = new_state_var etyp state in
+		app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in
+	let _c = pf_type_of state.gls
+	  (constr_of_term (term state.uf pac.cnode)) in
+	let _args = 
+	  List.map (fun i -> constr_of_term (term state.uf  i)) 
+	    pac.args in
+	let typ = prod_applist _c (List.rev _args) in 
+	let ct = app (term state.uf i) typ pac.arity in
 	  state.uf.epsilons <- pac :: state.uf.epsilons; 
-	  ignore (add_term state (app (term state.uf i) pac.arity))
+	  ignore (add_term state ct)
     | _ -> anomaly "wrong incomplete class" 
 
 let complete state =
@@ -624,18 +705,18 @@ type matching_problem =
 let make_fun_table state =
   let uf= state.uf in
   let funtab=ref PafMap.empty in
-  for cl=0 to pred uf.size do 
-    match uf.map.(cl).clas with
-	Rep rep ->
-	  PafMap.iter 
-	    (fun paf _ -> 
-	       let elem = 
-		 try PafMap.find paf !funtab 
-		 with Not_found -> Intset.empty in
-		 funtab:= PafMap.add paf (Intset.add cl elem) !funtab) 
-	    rep.functions
-      | _ -> ()   
-  done;
+  Array.iteri 
+    (fun i inode -> if i < uf.size then
+       match inode.clas with
+	   Rep rep ->
+	     PafMap.iter 
+	       (fun paf _ -> 
+		  let elem = 
+		    try PafMap.find paf !funtab 
+		    with Not_found -> Intset.empty in
+		    funtab:= PafMap.add paf (Intset.add i elem) !funtab) 
+	       rep.functions
+	 | _ -> ()) state.uf.map;
     !funtab
   
 
@@ -656,6 +737,7 @@ let rec do_match state res pb_stack =
 		  else
 		    if mp.mp_subst.(pred i) = cl then
 		      Stack.push {mp with mp_stack=remains} pb_stack
+		    else (* mismatch for non-linear variable in pattern *) ()
 	      | PApp (f,[]) ->
 		  begin
 		    try let j=Hashtbl.find uf.syms f in
@@ -665,19 +747,19 @@ let rec do_match state res pb_stack =
 		  end
 	      | PApp(f, ((last_arg::rem_args) as args)) ->
 		  try 
-		    let j=Hashtbl.find uf.syms f in
+		    let j=Hashtbl.find uf.syms f in 
 		    let paf={fsym=j;fnargs=List.length args} in
 		    let rep=get_representative uf cl in
 		    let good_terms = PafMap.find paf rep.functions in
 		    let aux i = 
-		      let (s,t) = ST.rev_query i state.sigtable in
+		      let (s,t) = signature state.uf i in
 			Stack.push 
 			  {mp with 
 			     mp_subst=Array.copy mp.mp_subst;
 			     mp_stack=
 			      (PApp(f,rem_args),s) :: 
 				(last_arg,t) :: remains} pb_stack in
-		      Intset.iter aux good_terms 
+		      Intset.iter aux good_terms
 		  with Not_found -> ()
 
 let paf_of_patt syms = function
@@ -692,28 +774,50 @@ let init_pb_stack state =
   let funtab = make_fun_table state in
   let aux inst =
     begin
-      if inst.qe_lhs_valid then
-	try 
-	  let paf= paf_of_patt syms inst.qe_lhs in
-	  let good_classes = PafMap.find paf funtab in
-	    Intset.iter (fun i -> 
-			 Stack.push 
-			   {mp_subst = Array.make inst.qe_nvars (-1); 
-			    mp_inst=inst;
-			    mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
-	with Not_found -> ()
+      let good_classes =
+	match inst.qe_lhs_valid with
+	  Creates_variables -> Intset.empty
+	| Normal ->
+	    begin 
+	      try 
+		let paf= paf_of_patt syms inst.qe_lhs in
+		  PafMap.find paf funtab
+	      with Not_found -> Intset.empty
+	    end
+	| Trivial typ -> 
+	    begin 
+	      try 
+		Hashtbl.find state.by_type typ
+	      with Not_found -> Intset.empty
+	    end in
+	Intset.iter (fun i -> 
+		       Stack.push 
+			 {mp_subst = Array.make inst.qe_nvars (-1); 
+			  mp_inst=inst;
+			  mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
     end;
     begin 
-      if inst.qe_rhs_valid then
-	try 
-	  let paf= paf_of_patt syms inst.qe_rhs in
-	  let good_classes = PafMap.find paf funtab in
-	    Intset.iter (fun i -> 
-			   Stack.push 
-			     {mp_subst = Array.make inst.qe_nvars (-1); 
-			      mp_inst=inst;
-			      mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
-	with Not_found -> ()
+      let good_classes =
+	match inst.qe_rhs_valid with
+	  Creates_variables -> Intset.empty
+	| Normal ->
+	    begin 
+	      try 
+		let paf= paf_of_patt syms inst.qe_rhs in
+		  PafMap.find paf funtab
+	      with Not_found -> Intset.empty
+	    end
+	| Trivial typ -> 
+	    begin 
+	      try 
+		Hashtbl.find state.by_type typ
+	      with Not_found -> Intset.empty
+	    end in
+	Intset.iter (fun i -> 
+		       Stack.push 
+			 {mp_subst = Array.make inst.qe_nvars (-1); 
+			  mp_inst=inst;
+			  mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
     end in
     List.iter aux state.quant;
     pb_stack
@@ -724,7 +828,8 @@ let find_instances state =
   let _ =
     debug msgnl (str "Running E-matching algorithm ... ");
     try
-      while true do 
+      while true do
+	check_for_interrupt ();
 	do_match state res pb_stack 
       done;
       anomaly "get out of here !"
@@ -734,7 +839,9 @@ let find_instances state =
 let rec execute first_run state =
   debug msgnl (str "Executing ... ");
   try
-    while one_step state do ()
+    while 
+      check_for_interrupt ();
+      one_step state do ()
     done;
     match check_disequalities state with
 	None -> 
diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli
index 05a5c4d1..cdc0065e 100644
--- a/contrib/cc/ccalgo.mli
+++ b/contrib/cc/ccalgo.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *)
 
 open Util
 open Term
@@ -19,10 +19,16 @@ type cinfo =
 
 type term =
     Symb of constr
-  | Eps
+  | Product of sorts_family * sorts_family
+  | Eps of identifier
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
+type patt_kind =
+    Normal 
+  | Trivial of types
+  | Creates_variables
+
 type ccpattern =
     PApp of term * ccpattern list
   | PVar of int 
@@ -70,7 +76,7 @@ val axioms : forest -> (constr, term * term) Hashtbl.t
 
 val epsilons : forest -> pa_constructor list
 
-val empty : int -> state
+val empty : int -> Proof_type.goal Tacmach.sigma -> state
 
 val add_term : state -> term -> int
 
@@ -79,8 +85,7 @@ val add_equality : state -> constr -> term -> term -> unit
 val add_disequality : state -> from -> term -> term -> unit
 
 val add_quant : state -> identifier -> bool -> 
-  int * bool * ccpattern * bool * ccpattern -> unit
-
+  int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
 
 val tail_pac : pa_constructor -> pa_constructor
 
@@ -102,9 +107,9 @@ type quant_eq=
      qe_pol: bool;
      qe_nvars:int;
      qe_lhs: ccpattern;
-     qe_lhs_valid:bool;
+     qe_lhs_valid:patt_kind;
      qe_rhs: ccpattern;
-     qe_rhs_valid:bool}
+     qe_rhs_valid:patt_kind}
 
 
 type pa_fun=
diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml
index d336f599..a459b18f 100644
--- a/contrib/cc/ccproof.ml
+++ b/contrib/cc/ccproof.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.ml 9856 2007-05-24 14:05:40Z corbinea $ *)
+(* $Id: ccproof.ml 9857 2007-05-24 14:21:08Z corbinea $ *)
 
 (* This file uses the (non-compressed) union-find structure to generate *) 
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli
index 572b2c53..0eb97efe 100644
--- a/contrib/cc/ccproof.mli
+++ b/contrib/cc/ccproof.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.mli 9856 2007-05-24 14:05:40Z corbinea $ *)
+(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *)
 
 open Ccalgo
 open Names
diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml
index dc0dec0e..871d7521 100644
--- a/contrib/cc/cctac.ml
+++ b/contrib/cc/cctac.ml
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: cctac.ml 10121 2007-09-14 09:45:40Z corbinea $ *)
+(* $Id: cctac.ml 10670 2008-03-14 19:30:48Z letouzey $ *)
 
 (* This file is the interface between the c-c algorithm and Coq *)
 
@@ -24,6 +24,7 @@ open Termops
 open Tacmach
 open Tactics
 open Tacticals
+open Typing
 open Ccalgo
 open Tacinterp
 open Ccproof
@@ -49,6 +50,8 @@ let _False = constant ["Init";"Logic"] "False"
 
 (* decompose member of equality in an applicative format *)
 
+let sf_of env sigma c = family_of_sort (destSort (type_of env sigma c))
+
 let whd env=
   let infos=Closure.create_clos_infos Closure.betaiotazeta env in
     (fun t -> Closure.whd_val infos (Closure.inject t))
@@ -57,12 +60,19 @@ let whd_delta env=
    let infos=Closure.create_clos_infos Closure.betadeltaiota env in
     (fun t -> Closure.whd_val infos (Closure.inject t))
 
-let rec decompose_term env t=
+let rec decompose_term env sigma t=
     match kind_of_term (whd env t) with
       App (f,args)->
-	let tf=decompose_term env f in
-	let targs=Array.map (decompose_term env) args in
+	let tf=decompose_term env sigma f in
+	let targs=Array.map (decompose_term env sigma) args in
 	  Array.fold_left (fun s t->Appli (s,t)) tf targs
+    | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
+	let b = pop _b in
+	let sort_b = sf_of env sigma b in
+	let sort_a = sf_of env sigma a in
+	Appli(Appli(Product (sort_a,sort_b) ,
+		    decompose_term env sigma a),
+	      decompose_term env sigma b)
     | Construct c->
 	let (oib,_)=Global.lookup_inductive (fst c) in
 	let nargs=mis_constructor_nargs_env env c in
@@ -73,95 +83,111 @@ let rec decompose_term env t=
 	
 (* decompose equality in members and type *)
 	
-let atom_of_constr env term =
+let atom_of_constr env sigma term =
   let wh =  (whd_delta env term) in
   let kot = kind_of_term wh in 
     match kot with
       App (f,args)->
 	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
 	  then `Eq (args.(0),
-		   decompose_term env args.(1), 
-		   decompose_term env args.(2)) 
-	  else `Other (decompose_term env term)
-    | _ -> `Other (decompose_term env term)
+		   decompose_term env sigma args.(1), 
+		   decompose_term env sigma args.(2)) 
+	  else `Other (decompose_term env sigma term)
+    | _ -> `Other (decompose_term env sigma term)
 
-let rec pattern_of_constr env c =
+let rec pattern_of_constr env sigma c =
   match kind_of_term (whd env c) with
       App (f,args)->
-	let pf = decompose_term env f in
+	let pf = decompose_term env sigma f in
 	let pargs,lrels = List.split 
-	  (array_map_to_list (pattern_of_constr env) args) in
+	  (array_map_to_list (pattern_of_constr env sigma) args) in
 	  PApp (pf,List.rev pargs),
-	List.fold_left Intset.union Intset.empty lrels 
+	List.fold_left Intset.union Intset.empty lrels
+    | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
+	let b =pop _b in
+	let pa,sa = pattern_of_constr env sigma a in
+	let pb,sb = pattern_of_constr env sigma (pop b) in
+	let sort_b = sf_of env sigma b in
+	let sort_a = sf_of env sigma a in
+	  PApp(Product (sort_a,sort_b),
+	       [pa;pb]),(Intset.union sa sb)
     | Rel i -> PVar i,Intset.singleton i
     | _ -> 
-	let pf = decompose_term env c in
+	let pf = decompose_term env sigma c in
 	  PApp (pf,[]),Intset.empty
 
 let non_trivial = function
     PVar _ -> false
   | _ -> true
 
-let patterns_of_constr env nrels term=
+let patterns_of_constr env sigma nrels term=
   let f,args= 
     try destApp (whd_delta env term) with _ -> raise Not_found in
 	if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
 	then 
-	  let patt1,rels1 = pattern_of_constr env args.(1)
-	  and patt2,rels2 = pattern_of_constr env args.(2) in
-	  let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) 
-	  and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in
-	    if valid1 || valid2 then 
+	  let patt1,rels1 = pattern_of_constr env sigma args.(1)
+	  and patt2,rels2 = pattern_of_constr env sigma args.(2) in
+	  let valid1 = 
+	    if Intset.cardinal rels1 <> nrels then Creates_variables
+	    else if non_trivial patt1 then Normal
+	    else Trivial args.(0) 
+	  and valid2 =
+	    if Intset.cardinal rels2 <> nrels then Creates_variables
+	    else if non_trivial patt2 then Normal
+	    else Trivial args.(0) in
+	    if valid1 <> Creates_variables
+	      || valid2 <> Creates_variables  then 
 	      nrels,valid1,patt1,valid2,patt2
 	    else raise Not_found
 	else raise Not_found
 
-let rec quantified_atom_of_constr env nrels term =
+let rec quantified_atom_of_constr env sigma nrels term =
   match kind_of_term (whd_delta env term) with
       Prod (_,atom,ff) -> 
 	if eq_constr ff (Lazy.force _False) then
-	  let patts=patterns_of_constr env nrels atom in
+	  let patts=patterns_of_constr env sigma nrels atom in
 	      `Nrule patts
 	else 
-	  quantified_atom_of_constr env (succ nrels) ff
+	  quantified_atom_of_constr env sigma (succ nrels) ff
     | _ ->  
-	let patts=patterns_of_constr env nrels term in
+	let patts=patterns_of_constr env sigma nrels term in
 	    `Rule patts	  
 
-let litteral_of_constr env term=
+let litteral_of_constr env sigma term=
   match kind_of_term (whd_delta env term) with
     | Prod (_,atom,ff) -> 
 	if eq_constr ff (Lazy.force _False) then
-	  match (atom_of_constr env atom) with
+	  match (atom_of_constr env sigma atom) with
 	      `Eq(t,a,b) -> `Neq(t,a,b)
 	    | `Other(p) -> `Nother(p)
 	else
 	  begin
 	    try 
-	      quantified_atom_of_constr env 1 ff  
+	      quantified_atom_of_constr env sigma 1 ff  
 	    with Not_found ->
-	      `Other (decompose_term env term)
+	      `Other (decompose_term env sigma term)
 	  end
     | _ -> 
-	atom_of_constr env term
+	atom_of_constr env sigma term
 	
 
 (* store all equalities from the context *)
 	
 let rec make_prb gls depth additionnal_terms =
   let env=pf_env gls in
-  let state = empty depth in
+  let sigma=sig_sig gls in
+  let state = empty depth gls in
   let pos_hyps = ref [] in
   let neg_hyps =ref [] in
     List.iter
       (fun c ->
-	 let t = decompose_term env c in
+	 let t = decompose_term env sigma c in
 	   ignore (add_term state t)) additionnal_terms; 
     List.iter 
       (fun (id,_,e) ->
 	 begin
 	   let cid=mkVar id in
-	   match litteral_of_constr env e with
+	   match litteral_of_constr env sigma e with
 	       `Eq (t,a,b) -> add_equality state cid a b
 	     | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b
 	     | `Other ph ->
@@ -180,7 +206,7 @@ let rec make_prb gls depth additionnal_terms =
 	     | `Nrule patts -> add_quant state id false patts
 	 end) (Environ.named_context_of_val gls.it.evar_hyps);
     begin
-      match atom_of_constr env gls.it.evar_concl with
+      match atom_of_constr env sigma gls.it.evar_concl with
 	  `Eq (t,a,b) -> add_disequality state Goal a b
 	|	`Other g ->  
 		  List.iter 
@@ -209,7 +235,7 @@ let build_projection intype outtype (cstr:constructor) special default gls=
   let branches=Array.init lp branch in
   let casee=mkRel 1 in
   let pred=mkLambda(Anonymous,intype,outtype) in
-  let case_info=make_default_case_info (pf_env gls) RegularStyle ind in
+  let case_info=make_case_info (pf_env gls) ind RegularStyle in
   let body= mkCase(case_info, pred, casee, branches) in
   let id=pf_get_new_id (id_of_string "t") gls in     
     mkLambda(Name id,intype,body)
@@ -224,19 +250,19 @@ let rec proof_tac p gls =
     | SymAx c -> 
 	let l=constr_of_term p.p_lhs and 
 	    r=constr_of_term p.p_rhs in
-        let typ = pf_type_of gls l in 	  
+        let typ = refresh_universes (pf_type_of gls l) in 	  
 	  exact_check
 	    (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls
     | Refl t ->
 	let lr = constr_of_term t in
-	let typ = pf_type_of gls lr in 
+	let typ = refresh_universes (pf_type_of gls lr) in 
 	exact_check
 	   (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls
     | Trans (p1,p2)->
 	let t1 = constr_of_term p1.p_lhs and
 	    t2 = constr_of_term p1.p_rhs and
 	    t3 = constr_of_term p2.p_rhs in
-	let typ = pf_type_of gls t2 in 
+	let typ = refresh_universes (pf_type_of gls t2) in 
 	let prf = 
 	  mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in
 	  tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls
@@ -245,16 +271,17 @@ let rec proof_tac p gls =
 	and tx1=constr_of_term p2.p_lhs 
 	and tf2=constr_of_term p1.p_rhs 
 	and tx2=constr_of_term p2.p_rhs in
-	let typf = pf_type_of gls tf1 in
-	let typx = pf_type_of gls tx1 in
-	let typfx = pf_type_of gls (mkApp (tf1,[|tx1|])) in
+	let typf = refresh_universes (pf_type_of gls tf1) in
+	let typx = refresh_universes (pf_type_of gls tx1) in
+	let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in
 	let id = pf_get_new_id (id_of_string "f") gls in
 	let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
 	let lemma1 =
 	  mkApp(Lazy.force _f_equal,
 		[|typf;typfx;appx1;tf1;tf2;_M 1|]) in
 	let lemma2=
-	  mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2;_M 1|]) in
+	  mkApp(Lazy.force _f_equal,
+		[|typx;typfx;tf2;tx1;tx2;_M 1|]) in
 	let prf = 
 	  mkApp(Lazy.force _trans_eq,
 		[|typfx;
@@ -274,8 +301,8 @@ let rec proof_tac p gls =
 	 let ti=constr_of_term prf.p_lhs in
 	 let tj=constr_of_term prf.p_rhs in
 	 let default=constr_of_term p.p_lhs in
-	 let intype=pf_type_of gls ti in
-	 let outtype=pf_type_of gls default in
+	 let intype=refresh_universes (pf_type_of gls ti) in
+	 let outtype=refresh_universes (pf_type_of gls default) in
 	 let special=mkRel (1+nargs-argind) in
 	 let proj=build_projection intype outtype cstr special default gls in
 	 let injt=
@@ -284,7 +311,7 @@ let rec proof_tac p gls =
 
 let refute_tac c t1 t2 p gls =      
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let intype=pf_type_of gls tt1 in
+  let intype=refresh_universes (pf_type_of gls tt1) in
   let neweq=
     mkApp(Lazy.force _eq,
 	  [|intype;tt1;tt2|]) in
@@ -295,7 +322,7 @@ let refute_tac c t1 t2 p gls =
 
 let convert_to_goal_tac c t1 t2 p gls =
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let sort=pf_type_of gls tt2 in
+  let sort=refresh_universes (pf_type_of gls tt2) in
   let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in 
   let e=pf_get_new_id (id_of_string "e") gls in
   let x=pf_get_new_id (id_of_string "X") gls in
@@ -315,7 +342,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls =
   
 let discriminate_tac cstr p gls =
   let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
-  let intype=pf_type_of gls t1 in
+  let intype=refresh_universes (pf_type_of gls t1) in
   let concl=pf_concl gls in
   let outsort=mkType (new_univ ()) in
   let xid=pf_get_new_id (id_of_string "X") gls in
@@ -403,3 +430,29 @@ let congruence_tac depth l =
   tclORELSE 
     (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) 
     cc_fail
+
+(* The [f_equal] tactic.
+
+   It mimics the use of lemmas [f_equal], [f_equal2], etc.
+   This isn't particularly related with congruence, apart from
+   the fact that congruence is called internally. 
+*)
+
+let f_equal gl = 
+  let cut_eq c1 c2 = 
+    let ty = refresh_universes (pf_type_of gl c1) in 
+    tclTHENTRY
+      (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) reflexivity
+  in 
+  try match kind_of_term (pf_concl gl) with 
+    | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> 
+	begin match kind_of_term t, kind_of_term t' with 
+	  | App (f,v), App (f',v') when Array.length v = Array.length v' ->
+	      let rec cuts i = 
+		if i < 0 then tclTRY (congruence_tac 1000 []) 
+		else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
+	      in cuts (Array.length v - 1) gl
+	  | _ -> tclIDTAC gl
+	end
+    | _ -> tclIDTAC gl
+  with Type_errors.TypeError _ -> tclIDTAC gl
diff --git a/contrib/cc/cctac.mli b/contrib/cc/cctac.mli
index ffc4b9c4..57ad0558 100644
--- a/contrib/cc/cctac.mli
+++ b/contrib/cc/cctac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cctac.mli 10121 2007-09-14 09:45:40Z corbinea $ *)
+(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *)
 
 open Term 
 open Proof_type
@@ -18,3 +18,5 @@ val cc_tactic : int -> constr list -> tactic
 val cc_fail : tactic
 
 val congruence_tac : int -> constr list -> tactic
+
+val f_equal : tactic
diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4
index 693aebb4..9877e6fc 100644
--- a/contrib/cc/g_congruence.ml4
+++ b/contrib/cc/g_congruence.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *)
 
 open Cctac
 open Tactics
@@ -17,9 +17,13 @@ open Tacticals
 (* Tactic registration *)
       
 TACTIC EXTEND cc
- [ "congruence" ] -> [ congruence_tac 0 [] ]
+ [ "congruence" ] -> [ congruence_tac 1000 [] ]
  |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
- |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ]
+ |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ]
  |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> 
    [ congruence_tac n l ]
 END
+
+TACTIC EXTEND f_equal
+ [ "f_equal" ] -> [ f_equal ]
+END
diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
index 5f7dfdbf..70f4b730 100644
--- a/contrib/correctness/ProgramsExtraction.v
+++ b/contrib/correctness/ProgramsExtraction.v
@@ -8,9 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ProgramsExtraction.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Extraction.
+(* $Id: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *)
 
 Extract Inductive unit => unit [ "()" ].
 Extract Inductive bool => bool [ true false ].
diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli
deleted file mode 100644
index 70328704..00000000
--- a/contrib/correctness/past.mli
+++ /dev/null
@@ -1,97 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: past.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(*s Abstract syntax of imperative programs. *)
-
-open Names
-open Ptype
-open Topconstr
-
-type termination = 
-  | RecArg of int 
-  | Wf of constr_expr * constr_expr
-
-type variable = identifier
-
-type pattern =
-  | PatVar of identifier
-  | PatConstruct of identifier * ((kernel_name * int) * int)
-  | PatAlias of pattern * identifier
-  | PatPair of pattern * pattern
-  | PatApp of pattern list
-
-type epattern =
-  | ExnConstant of identifier
-  | ExnBind of identifier * identifier
-
-type ('a, 'b) block_st =
-  | Label of string
-  | Assert of 'b Ptype.assertion
-  | Statement of 'a
-
-type ('a, 'b) block = ('a, 'b) block_st list
-
-type ('a, 'b) t = { 
-  desc : ('a, 'b) t_desc;
-  pre  : 'b Ptype.precondition list;
-  post : 'b Ptype.postcondition option;
-  loc  : Util.loc;
-  info : 'a 
-}
-
-and ('a, 'b) t_desc =
-  | Variable of variable
-  | Acc of variable
-  | Aff of variable * ('a, 'b) t
-  | TabAcc of bool * variable * ('a, 'b) t
-  | TabAff of bool * variable * ('a, 'b) t * ('a, 'b) t
-  | Seq of (('a, 'b) t, 'b) block
-  | While of ('a, 'b) t * 'b Ptype.assertion option * ('b * 'b) *
-               (('a, 'b) t, 'b) block
-  | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t
-  | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t
-  | Apply of ('a, 'b) t * ('a, 'b) arg list
-  | SApp of ('a, 'b) t_desc list * ('a, 'b) t list
-  | LetRef of variable * ('a, 'b) t * ('a, 'b) t
-  | Let of variable * ('a, 'b) t * ('a, 'b) t
-  | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list *
-                'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t
-  | PPoint of string * ('a, 'b) t_desc
-  | Expression of Term.constr
-  | Debug of string * ('a, 'b) t
-
-and ('a, 'b) arg =
-  | Term of ('a, 'b) t
-  | Refarg of variable
-  | Type of 'b Ptype.ml_type_v
-
-type program = (unit, Topconstr.constr_expr) t
-
-(*s Intermediate type for CC terms. *)
-
-type cc_type = Term.constr
-
-type cc_bind_type = 
-  | CC_typed_binder of cc_type 
-  | CC_untyped_binder
-
-type cc_binder = variable * cc_bind_type
-
-type cc_term =
-  | CC_var of variable
-  | CC_letin of bool * cc_type * cc_binder list * cc_term * cc_term
-  | CC_lam of cc_binder list * cc_term
-  | CC_app of cc_term * cc_term list
-  | CC_tuple of bool * cc_type list * cc_term list
-  | CC_case of cc_type * cc_term * cc_term list
-  | CC_expr of Term.constr
-  | CC_hole of cc_type
diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml
deleted file mode 100644
index 041cd81f..00000000
--- a/contrib/correctness/pcic.ml
+++ /dev/null
@@ -1,231 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcic.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Util
-open Names
-open Nameops
-open Libnames
-open Term
-open Termops
-open Nametab
-open Declarations
-open Indtypes
-open Sign
-open Rawterm
-open Typeops
-open Entries
-open Topconstr
-
-open Pmisc
-open Past
-
-
-(* Here we translate intermediates terms (cc_term) into CCI terms (constr) *)
-
-let make_hole c = mkCast (isevar, c)
-
-(* Tuples are defined in file Tuples.v 
- * and their constructors are called Build_tuple_n or exists_n,
- * wether they are dependant (last element only) or not. 
- * If necessary, tuples are generated ``on the fly''. *)
-
-let tuple_exists id = 
-  try let _ = Nametab.locate (make_short_qualid id) in true
-  with Not_found -> false
-
-let ast_set = CSort (dummy_loc,RProp Pos)
-
-let tuple_n n =
-  let id = make_ident "tuple_" (Some n) in
-  let l1n = Util.interval 1 n in
-  let params =
-    List.map (fun i ->
-      (LocalRawAssum ([dummy_loc,Name (make_ident "T" (Some i))], ast_set)))
-      l1n in
-  let fields = 
-    List.map
-      (fun i -> 
-	 let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in
-	 let id' = make_ident "T" (Some i) in
-	 (false, Vernacexpr.AssumExpr ((dummy_loc,Name id), mkIdentC id')))
-      l1n 
-  in
-  let cons = make_ident "Build_tuple_" (Some n) in
-  Record.definition_structure
-    ((false, (dummy_loc,id)), params, fields, cons, mk_Set)
-
-(*s [(sig_n n)] generates the inductive
-    \begin{verbatim}
-    Inductive sig_n [T1,...,Tn:Set; P:T1->...->Tn->Prop] : Set :=
-      exist_n : (x1:T1)...(xn:Tn)(P x1 ... xn) -> (sig_n T1 ... Tn P).
-    \end{verbatim} *)
-
-let sig_n n =
-  let id = make_ident "sig_" (Some n) in
-  let l1n = Util.interval 1 n in
-  let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in
-  let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in
-  let idp = make_ident "P" None in
-  let params =
-    let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in
-    (idp, LocalAssum typ) :: 
-    (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT)
-  in
-  let lc = 
-    let app_sig = mkApp(mkRel (2*n+3),
-                        Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in
-    let app_p = mkApp(mkRel (n+1),
-                      Array.init n (fun i -> mkRel (n-i))) in
-    let c = mkArrow app_p app_sig in
-    List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c
-  in
-  let cname = make_ident "exist_" (Some n) in
-  Declare.declare_mind 
-    { mind_entry_finite = true;
-      mind_entry_inds = 
-	[ { mind_entry_params = params;
-	    mind_entry_typename = id;
-	    mind_entry_arity = mkSet;
-	    mind_entry_consnames = [ cname ];
-	    mind_entry_lc = [ lc ] } ] }
-
-(*s On the fly generation of needed (possibly dependent) tuples. *)
-
-let check_product_n n =
-  if n > 2 then
-    let s = Printf.sprintf "tuple_%d" n in
-    if not (tuple_exists (id_of_string s)) then tuple_n n
-
-let check_dep_product_n n =
-  if n > 1 then
-    let s = Printf.sprintf "sig_%d" n in
-    if not (tuple_exists (id_of_string s)) then ignore (sig_n n)
-
-(*s Constructors for the tuples. *)
-	
-let pair = ConstructRef ((coq_constant ["Init"; "Datatypes"] "prod",0),1)
-let exist = ConstructRef ((coq_constant ["Init"; "Specif"] "sig",0),1)
-
-let tuple_ref dep n =
-  if n = 2 & not dep then
-    pair
-  else
-    let n = n - (if dep then 1 else 0) in
-    if dep then
-      if n = 1 then 
-	exist
-      else begin
-	let id = make_ident "exist_" (Some n) in
-	if not (tuple_exists id) then ignore (sig_n n);
-	Nametab.locate (make_short_qualid id)
-      end
-    else begin
-      let id = make_ident "Build_tuple_" (Some n) in
-      if not (tuple_exists id) then tuple_n n;
-      Nametab.locate (make_short_qualid id)
-    end
-
-(* Binders. *)
-
-let trad_binder avoid nenv id = function
-  | CC_untyped_binder -> RHole (dummy_loc,BinderType (Name id))
-  | CC_typed_binder ty -> Detyping.detype (false,Global.env()) avoid nenv ty
-
-let rec push_vars avoid nenv = function
-  | [] -> ([],avoid,nenv)
-  | (id,b) :: bl -> 
-      let b' = trad_binder avoid nenv id b in
-      let bl',avoid',nenv' = 
-	push_vars (id :: avoid) (add_name (Name id) nenv) bl 
-      in
-      ((id,b') :: bl', avoid', nenv')
-
-let rec raw_lambda bl v = match bl with
-  | [] -> 
-      v
-  | (id,ty) :: bl' -> 
-      RLambda (dummy_loc, Name id, ty, raw_lambda bl' v)
-
-(* The translation itself is quite easy.
-   letin are translated into Cases constructions *)
-
-let rawconstr_of_prog p =
-  let rec trad avoid nenv = function
-    | CC_var id -> 
-	RVar (dummy_loc, id)
-
-    (*i optimisation : let x = <constr> in e2  =>  e2[x<-constr] 
-    | CC_letin (_,_,[id,_],CC_expr c,e2) ->
-	real_subst_in_constr [id,c] (trad e2)
-    | CC_letin (_,_,([_] as b),CC_expr e1,e2) ->
-	let (b',avoid',nenv') = push_vars avoid nenv b in
-      	let c1 = Detyping.detype avoid nenv e1 
-	and c2 = trad avoid' nenv' e2 in
-	let id = Name (fst (List.hd b')) in
-	RLetIn (dummy_loc, id, c1, c2)
-    i*)
-
-    | CC_letin (_,_,([_] as b),e1,e2) ->
-	let (b',avoid',nenv') = push_vars avoid nenv b in
-      	let c1 = trad avoid nenv e1 
-	and c2 = trad avoid' nenv' e2 in
-	RApp (dummy_loc, raw_lambda b' c2, [c1])
-
-    | CC_letin (dep,ty,bl,e1,e2) ->
-	let (bl',avoid',nenv') = push_vars avoid nenv bl in
-	let c1 = trad avoid nenv e1
-	and c2 = trad avoid' nenv' e2 in
-	ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |], ref None)
-
-    | CC_lam (bl,e) ->
-	let bl',avoid',nenv' = push_vars avoid nenv bl in
-	let c = trad avoid' nenv' e in 
-	raw_lambda bl' c
-
-    | CC_app (f,args) ->
-	let c = trad avoid nenv f
-	and cargs = List.map (trad avoid nenv) args in
-	RApp (dummy_loc, c, cargs)
-
-    | CC_tuple (_,_,[e]) -> 
-	trad avoid nenv e
-	
-    | CC_tuple (false,_,[e1;e2]) ->
-	let c1 = trad avoid nenv e1 
-	and c2 = trad avoid nenv e2 in
-	RApp (dummy_loc, RRef (dummy_loc,pair),
-	      [RHole (dummy_loc,ImplicitArg (pair,1));
-	       RHole (dummy_loc,ImplicitArg (pair,2));c1;c2])
-
-    | CC_tuple (dep,tyl,l) ->
-      	let n = List.length l in
-      	let cl = List.map (trad avoid nenv) l in
-      	let tuple = tuple_ref dep n in
-	let tyl = List.map (Detyping.detype (false,Global.env()) avoid nenv) tyl in
-      	let args = tyl @ cl in
-	RApp (dummy_loc, RRef (dummy_loc, tuple), args)
-
-    | CC_case (ty,b,el) ->
-	let c = trad avoid nenv b in
-	let cl = List.map (trad avoid nenv) el in
-	let ty = Detyping.detype (false,Global.env()) avoid nenv ty in
-	ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl, ref None)
-
-    | CC_expr c -> 
-	Detyping.detype (false,Global.env()) avoid nenv c
-
-    | CC_hole c -> 
-	RCast (dummy_loc, RHole (dummy_loc, QuestionMark),
-               Detyping.detype (false,Global.env()) avoid nenv c)
-
-  in
-  trad [] empty_names_context p
diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli
deleted file mode 100644
index 67b152f3..00000000
--- a/contrib/correctness/pcic.mli
+++ /dev/null
@@ -1,24 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(*i $Id: pcic.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-open Past
-open Rawterm
-
-(* On-the-fly generation of needed (possibly dependent) tuples. *)
-
-val check_product_n : int -> unit
-val check_dep_product_n : int -> unit
-
-(* transforms intermediate functional programs into (raw) CIC terms *)
-
-val rawconstr_of_prog : cc_term -> rawconstr
-
diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml
deleted file mode 100644
index 368d0281..00000000
--- a/contrib/correctness/pcicenv.ml
+++ /dev/null
@@ -1,118 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcicenv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Sign
-
-open Pmisc
-open Putil
-open Ptype
-open Past
-
-(* on redéfinit add_sign pour éviter de construire des environnements
- * avec des doublons (qui font planter la résolution des implicites !) *)
-
-(* VERY UGLY!! find some work around *)
-let modify_sign id t s =
-  fold_named_context
-    (fun ((x,b,ty) as d) sign ->
-      if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign)
-    s ~init:empty_named_context
-
-let add_sign (id,t) s =
-  try 
-    let _ = lookup_named id s in
-    modify_sign id t s
-  with Not_found ->
-    add_named_decl (id,None,t) s
-
-let cast_set c = mkCast (c, mkSet)
-
-let set = mkCast (mkSet, mkType Univ.prop_univ)
-
-(* [cci_sign_of env] construit un environnement pour CIC ne comprenant que
- * les objets fonctionnels de l'environnement de programes [env]
- *)
-
-let cci_sign_of ren env =
-  Penv.fold_all 
-    (fun (id,v) sign ->
-       match v with
-	 | Penv.TypeV (Ref _ | Array _) -> sign
-	 | Penv.TypeV v -> 
-	     let ty = Pmonad.trad_ml_type_v ren env v in
-	     add_sign (id,cast_set ty) sign
-	 | Penv.Set -> add_sign (id,set) sign)
-    env (Global.named_context ())
-
-(* [sign_meta ren env fadd ini]
- * construit un environnement pour CIC qui prend en compte les variables
- * de programme. 
- * pour cela, cette fonction parcours tout l'envrionnement (global puis
- * local [env]) et pour chaque déclaration, ajoute ce qu'il faut avec la
- * fonction [fadd] s'il s'agit d'un mutable et directement sinon,
- * en partant de [ini].
- *)
-
-let sign_meta ren env fast ini =
-   Penv.fold_all 
-    (fun (id,v) sign ->
-       match v with
-	 | Penv.TypeV (Ref _ | Array _ as v) -> 
-	     let ty = Pmonad.trad_imp_type ren env v in
-	     fast sign id ty
-	 | Penv.TypeV v -> 
-	     let ty = Pmonad.trad_ml_type_v ren env v in
-	     add_sign (id,cast_set ty) sign
-	 | Penv.Set -> add_sign (id,set) sign)
-    env ini
-
-let add_sign_d dates (id,c) sign =
-  let sign =
-    List.fold_left (fun sign d -> add_sign (at_id id d,c) sign) sign dates
-  in
-    add_sign (id,c) sign
- 
-let sign_of add ren env =
-  sign_meta ren env
-    (fun sign id c -> let c = cast_set c in add (id,c) sign)
-    (Global.named_context ())
-
-let result_of sign = function
-    None   -> sign
-  | Some (id,c) -> add_sign (id, cast_set c) sign
-	
-let before_after_result_sign_of res ren env =
-  let dates = "" :: Prename.all_dates ren in
-  result_of (sign_of (add_sign_d dates) ren env) res
-
-let before_after_sign_of ren =
-  let dates = "" :: Prename.all_dates ren in
-  sign_of (add_sign_d dates) ren
-
-let before_sign_of ren =
-  let dates = Prename.all_dates ren in
-  sign_of (add_sign_d dates) ren
-
-let now_sign_of =
-  sign_of (add_sign_d [])
-
-
-(* environnement après traduction *)
-
-let trad_sign_of ren =
-  sign_of
-    (fun (id,c) sign -> add_sign (Prename.current_var ren id,c) sign)
-    ren
-
-
diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli
deleted file mode 100644
index 365fa960..00000000
--- a/contrib/correctness/pcicenv.mli
+++ /dev/null
@@ -1,38 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcicenv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Penv
-open Names
-open Term
-open Sign
-
-(* Translation of local programs environments into Coq signatures.
- * It is mainly used to type the pre/post conditions in the good
- * environment *)
-
-(* cci_sign_of: uniquement les objets purement fonctionnels de l'env. *)
-val cci_sign_of : Prename.t -> local_env -> named_context
-
-(* env. Coq avec seulement les variables X de l'env. *)
-val now_sign_of : Prename.t -> local_env -> named_context
-
-(* + les variables X@d pour toutes les dates de l'env. *)
-val before_sign_of : Prename.t -> local_env -> named_context
-
-(* + les variables `avant' X@ *)
-val before_after_sign_of : Prename.t -> local_env -> named_context
-val before_after_result_sign_of : ((identifier * constr) option)
-                        -> Prename.t -> local_env -> named_context
-
-(* env. des programmes traduits, avec les variables rennomées *)
-val trad_sign_of : Prename.t -> local_env -> named_context
-
diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml
deleted file mode 100644
index 759e9133..00000000
--- a/contrib/correctness/pdb.ml
+++ /dev/null
@@ -1,165 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pdb.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Termops
-open Nametab
-open Constrintern
-
-open Ptype
-open Past
-open Penv
-
-let cci_global id =
-  try
-    global_reference id
-  with
-    _ -> raise Not_found
-
-let lookup_var ids locop id =
-  if List.mem id ids then
-    None
-  else begin
-    try Some (cci_global id)
-    with Not_found -> Perror.unbound_variable id locop
-  end
-
-let check_ref idl loc id =
-  if (not (List.mem id idl)) & (not (Penv.is_global id)) then
-    Perror.unbound_reference id loc
-
-(* db types : only check the references for the moment *)
-
-let rec check_type_v refs = function
-  | Ref v -> 
-      check_type_v refs v
-  | Array (c,v) -> 
-      check_type_v refs v
-  | Arrow (bl,c) -> 
-      check_binder refs c bl
-  | TypePure _ -> 
-      ()
-
-and check_type_c refs ((_,v),e,_,_) =
-  check_type_v refs v;
-  List.iter (check_ref refs None) (Peffect.get_reads e);
-  List.iter (check_ref refs None) (Peffect.get_writes e)
-  (* TODO: check_condition on p and q *)
-
-and check_binder refs c = function
-  | [] -> 
-      check_type_c refs c
-  | (id, BindType (Ref _ | Array _ as v)) :: bl -> 
-      check_type_v refs v;
-      check_binder (id :: refs) c bl
-  | (_, BindType v) :: bl ->
-      check_type_v refs v;
-      check_binder refs c bl
-  | _ :: bl -> 
-      check_binder refs c bl
-
-(* db binders *)
-
-let rec db_binders ((tids,pids,refs) as idl) = function
-  | [] -> 
-      idl, []
-  | (id, BindType (Ref _ | Array _ as v)) as b :: rem ->
-      check_type_v refs v;
-      let idl',rem' = db_binders (tids,pids,id::refs) rem in
-      idl', b :: rem'
-  | (id, BindType v) as b :: rem ->
-      check_type_v refs v;
-      let idl',rem' = db_binders (tids,id::pids,refs) rem in
-      idl', b :: rem'
-  | ((id, BindSet) as t) :: rem ->
-      let idl',rem' = db_binders (id::tids,pids,refs) rem in
-      idl', t :: rem'
-  | a :: rem ->
-      let idl',rem' = db_binders idl rem in idl', a :: rem'
-
-
-(* db programs *)
-  
-let db_prog e =
-  (* tids = type identifiers, ids = variables, refs = references and arrays *)
-  let rec db_desc ((tids,ids,refs) as idl) = function
-    | (Variable x) as t ->
-	(match lookup_var ids (Some e.loc) x with
-	     None -> t
-	   | Some c -> Expression c)
-    | (Acc x) as t ->
-	check_ref refs (Some e.loc) x;
-	t
-    | Aff (x,e1) ->
-	check_ref refs (Some e.loc) x;
-	Aff (x, db idl e1)
-    | TabAcc (b,x,e1) ->
-	check_ref refs (Some e.loc) x;
-	TabAcc(b,x,db idl e1)
-    | TabAff (b,x,e1,e2) ->
-	check_ref refs (Some e.loc) x;
-	TabAff (b,x, db idl e1, db idl e2)
-    | Seq bl ->
-	Seq (List.map (function
-			   Statement p -> Statement (db idl p)
-			 | x -> x) bl)
-    | If (e1,e2,e3) ->
-	If (db idl e1, db idl e2, db idl e3)
-    | While (b,inv,var,bl) ->
-	let bl' = List.map (function
-				Statement p -> Statement (db idl p)
-			      | x -> x) bl in
-	While (db idl b, inv, var, bl')
-	  
-    | Lam (bl,e) ->
-	let idl',bl' = db_binders idl bl in Lam(bl', db idl' e)
-    | Apply (e1,l) ->
-	Apply (db idl e1, List.map (db_arg idl) l)
-    | SApp (dl,l) ->
-	SApp (dl, List.map (db idl) l)
-    | LetRef (x,e1,e2) ->
-	LetRef (x, db idl e1, db (tids,ids,x::refs) e2)
-    | Let (x,e1,e2) ->
-	Let (x, db idl e1, db (tids,x::ids,refs) e2)
-	  
-    | LetRec (f,bl,v,var,e) ->
-	let (tids',ids',refs'),bl' = db_binders idl bl in
-	check_type_v refs' v;
-	LetRec (f, bl, v, var, db (tids',f::ids',refs') e)
-	  
-    | Debug (s,e1) ->
-	Debug (s, db idl e1)
-	  
-    | Expression _ as x -> x
-    | PPoint (s,d) -> PPoint (s, db_desc idl d)
-	  
-  and db_arg ((tids,_,refs) as idl) = function
-    | Term ({ desc = Variable id } as t) -> 
-	if List.mem id refs then Refarg id else Term (db idl t)
-    | Term t -> Term (db idl t)
-    | Type v as ty -> check_type_v refs v; ty
-    | Refarg _ -> assert false
-
-  and db idl e =
-    { desc = db_desc idl e.desc ;
-      pre = e.pre; post = e.post;
-      loc = e.loc; info = e.info }
-
-  in
-  let ids = Termops.ids_of_named_context (Global.named_context ()) in
-            (* TODO: separer X:Set et x:V:Set
-                     virer le reste (axiomes, etc.) *)
-  let vars,refs = all_vars (), all_refs () in
-  db ([],vars@ids,refs) e
-;;
-
diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli
deleted file mode 100644
index d6e647b7..00000000
--- a/contrib/correctness/pdb.mli
+++ /dev/null
@@ -1,25 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pdb.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Ptype
-open Past
-
-
-(* Here we separate local and global variables, we check the use of
- * references and arrays w.r.t the local and global environments, etc.
- * These functions directly raise UserError exceptions on bad programs.
- *)
-
-val check_type_v : Names.identifier list -> 'a ml_type_v -> unit
-
-val db_prog : program -> program
-
diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml
deleted file mode 100644
index faf5f3d3..00000000
--- a/contrib/correctness/peffect.ml
+++ /dev/null
@@ -1,159 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: peffect.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Nameops
-open Pmisc
-
-(* The type of effects.
- *
- * An effect is composed of two lists (r,w) of variables.
- * The first one is the list of read-only variables
- * and the second one is the list of read-write variables.
- *
- * INVARIANT: 1. each list is sorted in decreasing order for Pervasives.compare
- *            2. there are no duplicate elements in each list
- *            3. the two lists are disjoint
- *)
-
-type t = identifier list * identifier list
-
-
-(* the empty effect *)
-
-let bottom = ([], [])
-
-(* basic operations *)
-
-let push x l =
-  let rec push_rec = function
-      [] -> [x]
-    | (y::rem) as l ->
-	if x = y then l else if x > y then x::l else y :: push_rec rem
-  in
-    push_rec l
-
-let basic_remove x l =
-  let rec rem_rec = function
-      [] -> []
-    | y::l -> if x = y then l else y :: rem_rec l
-  in
-    rem_rec l
-
-let mem x (r,w) = (List.mem x r) or (List.mem x w)
-
-let rec basic_union = function
-    [], s2 -> s2
-  | s1, [] -> s1
-  | ((v1::l1) as s1), ((v2::l2) as s2) ->
-      if v1 > v2 then
-	v1 :: basic_union (l1,s2)
-      else if v1 < v2 then
-	v2 :: basic_union (s1,l2)
-      else
-	v1 :: basic_union (l1,l2)
-
-(* adds reads and writes variables *)
-
-let add_read id ((r,w) as e) =
-  (* if the variable is already a RW it is ok, otherwise adds it as a RO. *)
-  if List.mem id w then
-    e
-  else
-    push id r, w
-
-let add_write id (r,w) =
-  (* if the variable is a RO then removes it from RO. Adds it to RW. *)
-  if List.mem id r then
-    basic_remove id r, push id w
-  else
-    r, push id w
-
-(* access *)
-
-let get_reads = basic_union
-let get_writes = snd
-let get_repr e = (get_reads e, get_writes e)
-
-(* tests *)
-
-let is_read  (r,_) id = List.mem id r
-let is_write (_,w) id = List.mem id w
-
-(* union and disjunction *)
-
-let union (r1,w1) (r2,w2) = basic_union (r1,r2), basic_union (w1,w2)
-
-let rec diff = function
-    [], s2 -> []
-  | s1, [] -> s1
-  | ((v1::l1) as s1), ((v2::l2) as s2) ->
-      if v1 > v2 then
-	v1 :: diff (l1,s2)
-      else if v1 < v2 then
-	diff (s1,l2)
-      else
-	diff (l1,l2)
-
-let disj (r1,w1) (r2,w2) =
-  let w1_w2 = diff (w1,w2) and w2_w1 = diff (w2,w1) in
-  let r = basic_union (basic_union (r1,r2), basic_union (w1_w2,w2_w1))
-  and w = basic_union (w1,w2) in
-  r,w
-
-(* comparison relation *)
-
-let le e1 e2 = failwith "effects: le: not yet implemented"
-
-let inf e1 e2 = failwith "effects: inf: not yet implemented"
-
-(* composition *)
-
-let compose (r1,w1) (r2,w2) =
-  let r = basic_union (r1, diff (r2,w1)) in
-  let w = basic_union (w1,w2) in
-    r,w
-
-(* remove *)
-
-let remove (r,w) name = basic_remove name r, basic_remove name w
-
-(* substitution *)
-
-let subst_list (x,x') l =
-  if List.mem x l then push x' (basic_remove x l) else l
-
-let subst_one (r,w) s = subst_list s r, subst_list s w
-
-let subst s e = List.fold_left subst_one e s
-
-(* pretty-print *)
-
-open Pp
-open Util
-open Himsg
-
-let pp (r,w) =
-  hov 0 (if r<>[] then
-	     (str"reads " ++
-		prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r)
-	   else (mt ()) ++
-	   spc () ++
-	   if w<>[] then
-	     (str"writes " ++
-		prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w)
-	   else (mt ())
-)
-
-let ppr e =
-  Pp.pp (pp e)
-
diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli
deleted file mode 100644
index 9a10dea4..00000000
--- a/contrib/correctness/peffect.mli
+++ /dev/null
@@ -1,42 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: peffect.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-(* The abstract type of effects *)
-
-type t
-
-val bottom : t
-val add_read  : identifier -> t -> t
-val add_write : identifier -> t -> t
-
-val get_reads : t -> identifier list
-val get_writes : t -> identifier list
-val get_repr : t -> (identifier list) * (identifier list)
-
-val is_read  : t -> identifier -> bool    (* read-only *)
-val is_write : t -> identifier -> bool    (* read-write *)
-
-val compose : t -> t -> t
-
-val union : t -> t -> t
-val disj : t -> t -> t
-
-val remove : t -> identifier -> t
-
-val subst : (identifier * identifier) list -> t -> t
-
-
-val pp : t -> Pp.std_ppcmds
-val ppr : t -> unit
-
diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml
deleted file mode 100644
index 7f89b1e1..00000000
--- a/contrib/correctness/penv.ml
+++ /dev/null
@@ -1,240 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: penv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pmisc
-open Past
-open Ptype
-open Names
-open Nameops
-open Libobject
-open Library
-open Term
-
-(* Environments for imperative programs.
- *
- * An environment of programs is an association tables
- * from identifiers (Names.identifier) to types of values with effects
- * (ProgAst.ml_type_v), together with a list of these associations, since
- * the order is relevant (we have dependent types e.g. [x:nat; t:(array x T)])
- *)
-
-module Env = struct
-  type 'a t = ('a Idmap.t)
-	    * ((identifier * 'a) list)
-	    * ((identifier * (identifier * variant)) list)
-  let empty = Idmap.empty, [], []
-  let add id v (m,l,r) = (Idmap.add id v m, (id,v)::l, r)
-  let find id (m,_,_) = Idmap.find id m
-  let fold f (_,l,_) x0 = List.fold_right f l x0
-  let add_rec (id,var) (m,l,r) = (m,l,(id,var)::r)
-  let find_rec id (_,_,r) = List.assoc id r
-end
-
-(* Local environments *)
-
-type type_info = Set | TypeV of type_v
-
-type local_env = type_info Env.t
-
-let empty = (Env.empty : local_env)
-
-let add (id,v) = Env.add id (TypeV v)
-
-let add_set id = Env.add id Set
-
-let find id env =
-  match Env.find id env with TypeV v -> v | Set -> raise Not_found
-
-let is_local env id =
-  try
-    match Env.find id env with TypeV _ -> true | Set -> false
-  with
-      Not_found -> false
-
-let is_local_set env id =
-  try
-    match Env.find id env with TypeV _ -> false | Set -> true
-  with
-      Not_found -> false
-
-
-(* typed programs *)
-
-type typing_info = {
-  env : local_env;
-  kappa : constr ml_type_c
-}
-  
-type typed_program = (typing_info, constr) t
-
-
-(* The global environment.
- *
- * We have a global typing environment env
- * We also keep a table of programs for extraction purposes
- * and a table of initializations (still for extraction)
- *)
-
-let (env : type_info Env.t ref) = ref Env.empty
-
-let (pgm_table : (typed_program option) Idmap.t ref) = ref Idmap.empty
-
-let (init_table : constr Idmap.t ref) = ref Idmap.empty
-
-let freeze () = (!env, !pgm_table, !init_table)
-let unfreeze (e,p,i) = env := e; pgm_table := p; init_table := i
-let init () = 
-  env := Env.empty; pgm_table := Idmap.empty; init_table := Idmap.empty
-;;
-
-Summary.declare_summary "programs-environment"
-  { Summary.freeze_function = freeze;
-    Summary.unfreeze_function = unfreeze;
-    Summary.init_function = init;
-    Summary.survive_module = false;
-    Summary.survive_section = false }
-;;
-
-(* Operations on the global environment. *)
-
-let add_pgm id p = pgm_table := Idmap.add id p !pgm_table
-
-let cache_global (_,(id,v,p)) =
-  env := Env.add id v !env; add_pgm id p
-
-let type_info_app f = function Set -> Set | TypeV v -> TypeV (f v)
-
-let subst_global (_,s,(id,v,p)) = (id, type_info_app (type_v_knsubst s) v, p)
-
-let (inProg,outProg) =
-  declare_object { object_name = "programs-objects";
-                   cache_function = cache_global;
-                   load_function = (fun _ -> cache_global);
-                   open_function = (fun _ _ -> ());
-		   classify_function = (fun (_,x) -> Substitute x);
-		   subst_function = subst_global;
-		   export_function = (fun x -> Some x) }
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-
-let add_global id v p =
-  try
-    let _ = Env.find id !env in
-    Perror.clash id None
-  with
-    Not_found -> begin
-      let id' =
-	if is_mutable v then id 
-        else id_of_string ("prog_" ^ (string_of_id id)) 
-      in
-      Lib.add_leaf id' (inProg (id,TypeV v,p))
-    end
-
-let add_global_set id =
-  try
-    let _ = Env.find id !env in
-    Perror.clash id None
-  with
-    Not_found -> Lib.add_leaf id (inProg (id,Set,None))
-
-let is_global id =
-  try
-    match Env.find id !env with TypeV _ -> true | Set -> false
-  with
-    Not_found -> false
-
-let is_global_set id =
-  try
-    match Env.find id !env with TypeV _ -> false | Set -> true
-  with
-    Not_found -> false
-
-
-let lookup_global id =
-  match Env.find id !env with TypeV v -> v | Set -> raise Not_found
-
-let find_pgm id = Idmap.find id !pgm_table
-
-let all_vars () =
-  Env.fold
-    (fun (id,v) l -> match v with TypeV (Arrow _|TypePure _) -> id::l | _ -> l)
-    !env []
-
-let all_refs () =
-  Env.fold
-    (fun (id,v) l -> match v with TypeV (Ref _ | Array _) -> id::l | _ -> l)
-    !env []
-
-(* initializations *)
-
-let cache_init (_,(id,c)) =
-  init_table := Idmap.add id c !init_table
-
-let subst_init (_,s,(id,c)) = (id, subst_mps s c)
-
-let (inInit,outInit) =
-  declare_object { object_name = "programs-objects-init";
-                   cache_function = cache_init;
-                   load_function = (fun _ -> cache_init);
-		   open_function = (fun _ _-> ());
-		   classify_function = (fun (_,x) -> Substitute x);
-		   subst_function = subst_init;
-                   export_function = (fun x -> Some x) }
-
-let initialize id c = Lib.add_anonymous_leaf (inInit (id,c))
-
-let find_init id = Idmap.find id !init_table
-
-
-(* access in env, local then global *)
-
-let type_in_env env id =
-  try find id env with Not_found -> lookup_global id
-
-let is_in_env env id =
-  (is_global id) or (is_local env id)
-
-let fold_all f lenv x0 =
-  let x1 = Env.fold f !env x0 in
-  Env.fold f lenv x1
-
-
-(* recursions *)
-
-let add_recursion = Env.add_rec
-
-let find_recursion = Env.find_rec
-
-
-(* We also maintain a table of the currently edited proofs of programs
- * in order to add them in the environnement when the user does Save *)
-
-open Pp
-open Himsg
-
-let (edited : (type_v * typed_program) Idmap.t ref) = ref Idmap.empty
-
-let new_edited id v =
-  edited := Idmap.add id v !edited
-
-let is_edited id =
-  try let _ = Idmap.find id !edited in true with Not_found -> false
-
-let register id id' =
-  try
-    let (v,p) = Idmap.find id !edited in
-    let _ = add_global id' v (Some p) in
-    Options.if_verbose 
-      msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined"));
-    edited := Idmap.remove id !edited
-  with Not_found -> ()
-
diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli
deleted file mode 100644
index 6743b465..00000000
--- a/contrib/correctness/penv.mli
+++ /dev/null
@@ -1,87 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: penv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Ptype
-open Past
-open Names
-open Libnames
-open Term
-
-(* Environment for imperative programs.
- * 
- * Here we manage the global environment, which is imperative,
- * and we provide a functional local environment. 
- *
- * The most important functions, is_in_env, type_in_env and fold_all
- * first look in the local environment then in the global one.
- *)
-
-(* local environments *)
-
-type local_env
-
-val empty : local_env
-val add : (identifier * type_v) -> local_env -> local_env
-val add_set : identifier -> local_env -> local_env
-val is_local : local_env -> identifier -> bool
-val is_local_set : local_env -> identifier -> bool
-
-(* typed programs *)
-
-type typing_info = {
-  env : local_env;
-  kappa : constr ml_type_c
-}
-  
-type typed_program = (typing_info, constr) t
-
-(* global environment *)
-
-val add_global : identifier -> type_v -> typed_program option -> object_name
-val add_global_set : identifier -> object_name
-val is_global : identifier -> bool
-val is_global_set : identifier -> bool
-val lookup_global : identifier -> type_v
-
-val all_vars : unit -> identifier list
-val all_refs : unit -> identifier list
-
-(* a table keeps the program (for extraction) *)
-
-val find_pgm : identifier -> typed_program option
-
-(* a table keeps the initializations of mutable objects *)
-
-val initialize : identifier -> constr -> unit
-val find_init : identifier -> constr
-
-(* access in env (local then global) *)
-
-val type_in_env : local_env -> identifier -> type_v
-val is_in_env : local_env -> identifier -> bool
-
-type type_info = Set | TypeV of type_v
-val fold_all : (identifier * type_info -> 'a -> 'a) -> local_env -> 'a -> 'a
-
-(* local environnements also contains a list of recursive functions
- * with the associated variant *)
-
-val add_recursion : identifier * (identifier*variant) -> local_env -> local_env
-val find_recursion : identifier -> local_env -> identifier * variant
-
-(* We also maintain a table of the currently edited proofs of programs
- * in order to add them in the environnement when the user does Save *)
-
-val new_edited : identifier -> type_v * typed_program -> unit
-val is_edited : identifier -> bool
-val register : identifier -> identifier -> unit
-
diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml
deleted file mode 100644
index 8415e96d..00000000
--- a/contrib/correctness/perror.ml
+++ /dev/null
@@ -1,172 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: perror.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Himsg
-
-open Ptype
-open Past
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-let is_pure = function TypePure _ -> true | _ -> false
-
-let raise_with_loc = function
-  | None -> raise
-  | Some loc -> Stdpp.raise_with_loc loc 
-
-let unbound_variable id loc =
-  raise_with_loc loc
-    (UserError ("Perror.unbound_variable",
-    (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ()))))
-
-let unbound_reference id loc =
-  raise_with_loc loc
-    (UserError ("Perror.unbound_reference",
-    (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ()))))
-
-let clash id loc =
-  raise_with_loc loc
-    (UserError ("Perror.clash",
-    (hov 0 (str"Clash with previous constant" ++ spc () ++
-    str(string_of_id id) ++ fnl ()))))
-
-let not_defined id =
-  raise
-    (UserError ("Perror.not_defined",
-	       	(hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++
-			  str"is not defined" ++ fnl ()))))
-
-let check_for_reference loc id = function
-    Ref _ -> ()
-  | _ -> Stdpp.raise_with_loc loc 
-	(UserError ("Perror.check_for_reference",
-		    hov 0 (pr_id id ++ spc () ++ 
-			     str"is not a reference")))
-
-let check_for_array loc id = function
-    Array _ -> ()
-  | _ -> Stdpp.raise_with_loc loc 
-	(UserError ("Perror.check_for_array",
-		    hov 0 (pr_id id ++ spc () ++ 
-			     str"is not an array")))
-
-let is_constant_type s = function
-    TypePure c ->
-      let id = id_of_string s in
-      let c' = Constrintern.global_reference id in
-      Reductionops.is_conv (Global.env()) Evd.empty c c'
-  | _ -> false 
-
-let check_for_index_type loc v =
-  let is_index = is_constant_type "Z" v in
-  if not is_index then
-    Stdpp.raise_with_loc loc 
-      (UserError ("Perror.check_for_index",
-		  hov 0 (str"This expression is an index" ++ spc () ++ 
-			   str"and should have type int (Z)")))
-
-let check_no_effect loc ef =
-  if not (Peffect.get_writes ef = []) then
-    Stdpp.raise_with_loc loc 
-      (UserError ("Perror.check_no_effect",
-		  hov 0 (str"A boolean should not have side effects"
-)))
-
-let should_be_boolean loc =
-  Stdpp.raise_with_loc loc 
-    (UserError ("Perror.should_be_boolean",
-		hov 0 (str"This expression is a test:" ++ spc () ++
-			 str"it should have type bool")))
-
-let test_should_be_annotated loc =
-  Stdpp.raise_with_loc loc 
-    (UserError ("Perror.test_should_be_annotated",
-		hov 0 (str"This test should be annotated")))
-
-let if_branches loc =
-  Stdpp.raise_with_loc loc 
-    (UserError ("Perror.if_branches",
-		hov 0 (str"The two branches of an `if' expression" ++ spc () ++
-			 str"should have the same type")))
-
-let check_for_not_mutable loc v =
-  if is_mutable v then
-    Stdpp.raise_with_loc loc 
-      (UserError ("Perror.check_for_not_mutable",
-		  hov 0 (str"This expression cannot be a mutable")))
-
-let check_for_pure_type loc v =
-  if not (is_pure v) then
-    Stdpp.raise_with_loc loc 
-      (UserError ("Perror.check_for_pure_type",
-		  hov 0 (str"This expression must be pure" ++ spc () ++
-			   str"(neither a mutable nor a function)")))
-
-let check_for_let_ref loc v =
-  if not (is_pure v) then
-    Stdpp.raise_with_loc loc 
-      (UserError ("Perror.check_for_let_ref",
-		  hov 0 (str"References can only be bound in pure terms")))
-
-let informative loc s =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.variant_informative",
-	      hov 0 (str s ++ spc () ++ str"must be informative")))
-
-let variant_informative loc = informative loc "Variant"
-let should_be_informative loc = informative loc "This term"
-
-let app_of_non_function loc =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.app_of_non_function",
-	      hov 0 (str"This term cannot be applied" ++ spc () ++
-		       str"(either it is not a function" ++ spc () ++
-		       str"or it is applied to non pure arguments)")))
-  
-let partial_app loc =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.partial_app",
-	      hov 0 (str"This function does not have" ++
-		       spc () ++ str"the right number of arguments")))
-  
-let expected_type loc s =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.expected_type",
-	      hov 0 (str"Argument is expected to have type" ++ spc () ++ s)))
-
-let expects_a_type id loc =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.expects_a_type",
-	      hov 0 (str"The argument " ++ pr_id id ++ spc () ++
-		       str"in this application is supposed to be a type")))
-
-let expects_a_term id =
-  raise
-  (UserError ("Perror.expects_a_type",
-	      hov 0 (str"The argument " ++ pr_id id ++ spc () ++
-		       str"in this application is supposed to be a term")))
-
-let should_be_a_variable loc =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.should_be_a_variable",
-	      hov 0 (str"Argument should be a variable")))
-   
-let should_be_a_reference loc =
-  Stdpp.raise_with_loc loc 
-  (UserError ("Perror.should_be_a_reference",
-	      hov 0 (str"Argument of function should be a reference")))
-
-   
diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli
deleted file mode 100644
index 45b2acdc..00000000
--- a/contrib/correctness/perror.mli
+++ /dev/null
@@ -1,47 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: perror.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Ptype
-open Past
-
-val unbound_variable : identifier -> loc option -> 'a
-val unbound_reference : identifier -> loc option -> 'a
-
-val clash : identifier -> loc option -> 'a
-val not_defined : identifier -> 'a
-
-val check_for_reference : loc -> identifier -> type_v -> unit
-val check_for_array     : loc -> identifier -> type_v -> unit
-
-val check_for_index_type : loc -> type_v -> unit
-val check_no_effect : loc -> Peffect.t -> unit
-val should_be_boolean : loc -> 'a
-val test_should_be_annotated : loc -> 'a
-val if_branches : loc -> 'a
-
-val check_for_not_mutable : loc -> type_v -> unit
-val check_for_pure_type : loc -> type_v -> unit
-val check_for_let_ref : loc -> type_v -> unit
-
-val variant_informative : loc -> 'a
-val should_be_informative : loc -> 'a
-
-val app_of_non_function : loc -> 'a
-val partial_app : loc -> 'a
-val expected_type : loc -> std_ppcmds -> 'a
-val expects_a_type : identifier -> loc -> 'a
-val expects_a_term : identifier -> 'a
-val should_be_a_variable : loc -> 'a
-val should_be_a_reference : loc -> 'a
diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml
deleted file mode 100644
index 407567ad..00000000
--- a/contrib/correctness/pextract.ml
+++ /dev/null
@@ -1,473 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pextract.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp_control
-open Pp
-open Util
-open System
-open Names
-open Term
-open Himsg
-open Reduction
-
-open Putil
-open Ptype
-open Past
-open Penv
-open Putil
-
-let extraction env c =
-  let ren = initial_renaming env in
-  let sign = Pcicenv.now_sign_of ren env in
-  let fsign = Mach.fsign_of_sign (Evd.mt_evd()) sign in
-  match Mach.infexecute (Evd.mt_evd()) (sign,fsign) c with
-    | (_,Inf j) -> j._VAL
-    | (_,Logic) -> failwith "Prog_extract.pp: should be informative"
-
-(* les tableaux jouent un role particulier, puisqu'ils seront extraits
- * vers des tableaux ML *)
-
-let sp_access = coq_constant ["correctness"; "Arrays"] "access"
-let access = ConstRef sp_access
-
-let has_array = ref false
-
-let pp_conversions () =
-  (str"\
-let rec int_of_pos = function
-    XH -> 1
-  | XI p -> 2 * (int_of_pos p) + 1
-  | XO p -> 2 * (int_of_pos p)
- ++ ++
-
-let int_of_z = function
-    ZERO -> 0
-  | POS p -> int_of_pos p
-  | NEG p -> -(int_of_pos p)
- ++ ++
-") (* '"' *)
-
-(* collect all section-path in a CIC constant *)
-
-let spset_of_cci env c =
-  let spl = Fw_env.collect (extraction env c) in
-  let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in
-  has_array := !has_array or (SpSet.mem sp_access sps) ++
-  SpSet.remove sp_access sps
-
-
-(* collect all Coq constants and all pgms appearing in a given program *)
-
-let add_id env ((sp,ids) as s) id =
-  if is_local env id then
-    s
-  else if is_global id then
-    (sp,IdSet.add id ids)
-  else
-    try (SpSet.add (Nametab.sp_of_id FW id) sp,ids) with Not_found -> s
-
-let collect env =
-  let rec collect_desc env s = function
-    | Var x -> add_id env s x
-    | Acc x -> add_id env s x
-    | Aff (x,e1) -> add_id env (collect_rec env s e1) x
-    | TabAcc (_,x,e1) ->
-	has_array := true ++
-	add_id env (collect_rec env s e1) x
-    | TabAff (_,x,e1,e2) ->
-	has_array := true ++
-	add_id env (collect_rec env (collect_rec env s e1) e2) x
-    | Seq bl ->
-	List.fold_left (fun s st -> match st with
-			    Statement p -> collect_rec env s p
-			  | _ -> s) s bl
-    | If (e1,e2,e3) ->
-    	collect_rec env (collect_rec env (collect_rec env s e1) e2) e3
-    | While (b,_,_,bl) ->
-	let s = List.fold_left (fun s st -> match st with
-				    Statement p -> collect_rec env s p
-				  | _ -> s) s bl in
-	  collect_rec env s b
-    | Lam (bl,e) ->
-	collect_rec (traverse_binders env bl) s e
-    | App (e1,l) ->
-	let s = List.fold_left (fun s a -> match a with
-				    Term t -> collect_rec env s t
-				  | Type _ | Refarg _ -> s) s l in
-	  collect_rec env s e1
-    | SApp (_,l) ->
-	List.fold_left (fun s a -> collect_rec env s a) s l
-    | LetRef (x,e1,e2) ->
-	let (_,v),_,_,_ = e1.info.kappa in
-	  collect_rec (add (x,Ref v) env) (collect_rec env s e1) e2
-    | LetIn (x,e1,e2) ->
-	let (_,v),_,_,_ = e1.info.kappa in
-	  collect_rec (add (x,v) env) (collect_rec env s e1) e2
-    | LetRec (f,bl,_,_,e) ->
-	let env' = traverse_binders env bl in
-	let env'' = add (f,make_arrow bl e.info.kappa) env' in
-	  collect_rec env'' s e
-    | Debug (_,e1) -> collect_rec env s e1
-    | PPoint (_,d) -> collect_desc env s d
-    | Expression c ->
-	let (sp,ids) = s in
-	let sp' = spset_of_cci env c in
-	SpSet.fold 
-	  (fun s (es,ei) ->
-	     let id = basename s in
-	     if is_global id then (*SpSet.add s*)es,IdSet.add id ei
-	     else SpSet.add s es,ei)
-	  sp' (sp,ids)
-
-  and collect_rec env s p = collect_desc env s p.desc
-
-  in
-  collect_rec env (SpSet.empty,IdSet.empty)
-
-
-(* On a besoin de faire du renommage, tout comme pour l'extraction des
- * termes Coq. En ce qui concerne les globaux, on utilise la table de
- * Fwtoml. Pour les objects locaux, on introduit la structure de
- * renommage rename_struct
- *)
-
-module Ocaml_ren = Ocaml.OCaml_renaming
-
-let rename_global id =
-  let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in
-  Fwtoml.add_global_renaming (id,id') ++
-  id'
-
-type rename_struct = { rn_map : identifier IdMap.t;
-		       rn_avoid : identifier list }
-
-let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] }
-
-let rename_local rn id =
-  let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in
-  { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid },
-  id'
-
-let get_local_name rn id = IdMap.find id rn.rn_map
-
-let get_name env rn id =
-  if is_local env id then
-    get_local_name rn id
-  else
-    Fwtoml.get_global_name id
-
-let rec rename_binders rn = function
-  | [] -> rn
-  | (id,_) :: bl -> let rn',_ = rename_local rn id in rename_binders rn' bl
-
-(* on a bespoin d'un pretty-printer de constr particulier, qui reconnaisse
- * les acces a des references et dans des tableaux, et qui de plus n'imprime
- * pas de GENTERM lorsque des identificateurs ne sont pas visibles.
- * Il est simplifie dans la mesure ou l'on a ici que des constantes et
- * des applications.
- *)
-
-let putpar par s =
-  if par then (str"(" ++ s ++ str")") else s
-
-let is_ref env id =
-  try
-    (match type_in_env env id with Ref _ -> true | _ -> false)
-  with
-    Not_found -> false
-
-let rec pp_constr env rn = function
-  | VAR id ->
-      if is_ref env id then 
-	(str"!" ++ pID (get_name env rn id)) 
-      else
-	pID (get_name env rn id)
-  | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) ->
-      pID (Fwtoml.name_of_oper oper)
-  | DOPN(AppL,v) ->
-      if Array.length v = 0 then
-	  (mt ())
-      else begin
-	match v.(0) with
-	    DOPN(Const sp,_) when sp = sp_access ->
-	      (pp_constr env rn v.(3) ++ 
-		 str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")")
-	  | _ ->
-	      hov 2 (putpar true (prvect_with_sep (fun () -> (spc ()))
-				    (pp_constr env rn) v))
-      end
-  | DOP2(Cast,c,_) -> pp_constr env rn c
-  | _ -> failwith "Prog_extract.pp_constr: unexpected constr"
-
-
-(* pretty-print of imperative programs *)
-
-let collect_lambda = 
-  let rec collect acc p = match p.desc with
-    | Lam(bl,t) -> collect (bl@acc) t
-    | x         -> acc,p
-  in 
-  collect []
-
-let pr_binding rn = 
-  prlist_with_sep (fun () -> (mt ()))
-    (function 
-       | (id,(Untyped | BindType _)) -> 
-	   (str" " ++ pID (get_local_name rn id))
-       | (id,BindSet) -> (mt ()))
-
-let pp_prog id =
-  let rec pp_d env rn par = function
-    | Var x -> pID (get_name env rn x)
-    | Acc x -> (str"!" ++ pID (get_name env rn x))
-    | Aff (x,e1) -> (pID (get_name env rn x) ++ 
-		       str" := " ++ hov 0 (pp env rn false e1))
-    | TabAcc (_,x,e1) ->
-	(pID (get_name env rn x) ++ 
-	   str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")")
-    | TabAff (_,x,e1,e2) ->
-	(pID (get_name env rn x) ++
-	   str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++
-	   str" <-" ++ spc () ++ hov 2 (pp env rn false e2))
-    | Seq bl ->
-	(str"begin" ++ fnl () ++
-	   str"  " ++ hov 0 (pp_block env rn bl) ++ fnl () ++
-	   str"end")
-    | If (e1,e2,e3) ->
-	putpar par (str"if " ++ (pp env rn false e1) ++
-		      str" then" ++ fnl () ++
-		      str"  " ++ hov 0 (pp env rn false e2) ++ fnl () ++
-		      str"else" ++ fnl () ++
-		      str"  " ++ hov 0 (pp env rn false e3))
-	(* optimisations : then begin .... end else begin ... end *)
-    | While (b,inv,_,bl) ->
-	(str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++		    
-	   str"  " ++
-	   hov 0 ((match inv with
-			 None -> (mt ()) 
-		       | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++ 
-				      str" *)" ++ fnl ())) ++
-		    pp_block env rn bl) ++ fnl () ++
-	   str"done")
-    | Lam (bl,e) ->
-	let env' = traverse_binders env bl in
-	let rn' = rename_binders rn bl in
-	  putpar par 
-	    (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++
-		      spc () ++ pp env' rn' false e))
-    | SApp ((Var id)::_,  [e1; e2])
-	when id = connective_and or id = connective_or ->
-	  let conn = if id = connective_and then "&" else "or" in
-	  putpar par 
-	    (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++
-		      pp env rn true e2))
-    | SApp ((Var id)::_, [e]) when id = connective_not ->
-	putpar par 
-	  (hov 0 (str"not" ++ spc () ++ pp env rn true e))
-    | SApp _ ->
-	invalid_arg "Prog_extract.pp_prog (SApp)"
-    | App(e1,[]) ->
-	hov 0 (pp env rn false e1)
-    | App (e1,l) ->
-	putpar true
-	  (hov 2 (pp env rn true e1 ++
-		    prlist (function 
-				Term p -> (spc () ++ pp env rn true p)
-			      | Refarg x -> (spc () ++ pID (get_name env rn x))
-			      | Type _ -> (mt ())) 
-		      l))
-    | LetRef (x,e1,e2) ->
-	let (_,v),_,_,_ = e1.info.kappa in
-	let env' = add (x,Ref v) env in
-	let rn',x' = rename_local rn x in
-	putpar par 
-	  (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++
-		    str" in" ++ fnl () ++ pp env' rn' false e2))
-    | LetIn (x,e1,e2) ->
-	let (_,v),_,_,_ = e1.info.kappa in
-	let env' = add (x,v) env in
-	let rn',x' = rename_local rn x in
-	putpar par 
-	  (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++
-		    str" in" ++ fnl () ++ pp env' rn' false e2))
-    | LetRec (f,bl,_,_,e) ->
-	let env' = traverse_binders env bl in
-	let rn' = rename_binders rn bl in
-	let env'' = add (f,make_arrow bl e.info.kappa) env' in
-	let rn'',f' = rename_local rn' f in
-	putpar par 
-	  (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++
-		    str"  " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++
-		    str"in " ++ pID f'))
-    | Debug (_,e1) -> pp env rn par e1
-    | PPoint (_,d) -> pp_d env rn par d
-    | Expression c -> 
-	pp_constr env rn (extraction env c)
-
-  and pp_block env rn bl =
-    let bl =
-      map_succeed (function Statement p -> p | _ -> failwith "caught") bl
-    in
-      prlist_with_sep (fun () -> (str";" ++ fnl ()))
-      	(fun p -> hov 0 (pp env rn false p)) bl
-
-  and pp env rn par p = 
-    (pp_d env rn par p.desc)
-
-  and pp_mut v c = match v with
-    | Ref _ ->
-	(str"ref " ++ pp_constr empty rn_empty (extraction empty c))
-    | Array (n,_) ->
-	(str"Array.create " ++ cut () ++
-	   putpar true 
-	     (str"int_of_z " ++
-		pp_constr empty rn_empty (extraction empty n)) ++
-	   str" " ++ pp_constr empty rn_empty (extraction empty c))
-    | _ -> invalid_arg "pp_mut"
-  in
-  let v = lookup_global id in
-  let id' = rename_global id in
-    if is_mutable v then
-      try
-	let c = find_init id in
-	hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c)
-      with Not_found -> 
-	errorlabstrm "Prog_extract.pp_prog"
-	  (str"The variable " ++ pID id ++
-	     str" must be initialized first !")
-    else
-      match find_pgm id with
-	| None -> 
-	    errorlabstrm "Prog_extract.pp_prog"
-	      (str"The program " ++ pID id ++
-		 str" must be realized first !")
-      	| Some p ->
-	    let bl,p = collect_lambda p in
-	    let rn = rename_binders rn_empty bl in
-	    let env = traverse_binders empty bl in
-	    hov 0  (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++ 
-		      str"  " ++ hov 2 (pp env rn false p))
-
-(* extraction des programmes impératifs/fonctionnels vers ocaml *)
-
-(* Il faut parfois importer des modules non ouverts, sinon
- * Ocaml.OCaml_pp_file.pp echoue en disant "machin is not a defined
- * informative object". Cela dit, ce n'est pas tres satisfaisant, vu que
- * la constante existe quand meme: il vaudrait mieux contourner l'echec
- * de ml_import.fwsp_of_id
- *)
-
-let import sp = match repr_path sp with
-  | [m],_,_ ->
-      begin
-	try Library.import_export_module m true
-        with _ -> ()
-      end
-  | _ -> ()
-
-let pp_ocaml file prm =
-  has_array := false ++
-  (* on separe objects Coq et programmes *)
-  let cic,pgms =
-    List.fold_left
-      (fun (sp,ids) id ->
-	 if is_global id then (sp,IdSet.add id ids) else (IdSet.add id sp,ids))
-      (IdSet.empty,IdSet.empty) prm.needed
-  in
-  (* on met les programmes dans l'ordre et pour chacun on recherche les
-   * objects Coq necessaires, que l'on rajoute a l'ensemble cic *)
-  let cic,_,pgms =
-    let o_pgms = fold_all (fun (id,_) l -> id::l) empty [] in
-    List.fold_left
-      (fun (cic,pgms,pl) id -> 
-	 if IdSet.mem id pgms then
-	   let spl,pgms' =
-	     try
-	       (match find_pgm id with
-		  | Some p -> collect empty p
-		  | None ->
-		      (try 
-			 let c = find_init id in
-			 spset_of_cci empty c,IdSet.empty
-		       with Not_found -> 
-			 SpSet.empty,IdSet.empty))
-	     with Not_found -> SpSet.empty,IdSet.empty
-	   in
-	   let cic' = 
-	     SpSet.fold 
-	       (fun sp cic -> import sp ++ IdSet.add (basename sp) cic)
-	       spl cic
-	   in
-	   (cic',IdSet.union pgms pgms',id::pl)
-	 else
-	   (cic,pgms,pl)) 
-      (cic,pgms,[]) o_pgms
-  in
-  let cic = IdSet.elements cic in
-  (* on pretty-print *)
-  let prm' = { needed = cic ++ expand = prm.expand ++ 
-	       expansion = prm.expansion ++ exact = prm.exact } 
-  in
-  let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++
-		fnl () ++ fnl () ++
-		if !has_array then pp_conversions() else (mt ()) ++
-		prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ()))
-		  pgms
-)
-  in
-  (* puis on ecrit dans le fichier *)
-  let chan = open_trapping_failure open_out file ".ml" in
-  let ft = with_output_to chan in
-  begin
-    try  pP_with ft strm ++ pp_flush_with ft ()
-    with e -> pp_flush_with ft () ++ close_out chan ++ raise e
-  end ++
-  close_out chan
-    
-
-(* Initializations of mutable objects *)
-
-let initialize id com =
-  let loc = Ast.loc com in
-  let c = constr_of_com (Evd.mt_evd()) (initial_sign()) com in
-  let ty = 
-    Reductionops.nf_betaiota (type_of (Evd.mt_evd()) (initial_sign()) c) in
-  try
-    let v = lookup_global id in
-    let ety = match v with 
-      | Ref (TypePure c) -> c | Array (_,TypePure c) -> c
-      | _ -> raise Not_found 
-    in
-    if conv (Evd.mt_evd()) ty ety then
-      initialize id c
-    else
-      errorlabstrm "Prog_extract.initialize"
-	(str"Not the expected type for the mutable " ++ pID id)
-  with Not_found -> 
-    errorlabstrm "Prog_extract.initialize"
-      (pr_id id ++ str" is not a mutable")
-
-(* grammaire *)
-
-open Vernacinterp
-
-let _ = vinterp_add "IMPERATIVEEXTRACTION"
-	  (function 
-	     | VARG_STRING file :: rem ->
-		 let prm = parse_param rem in (fun () -> pp_ocaml file prm)
-	     | _ -> assert false)
-	  
-let _ = vinterp_add "INITIALIZE"
-	  (function 
-	     | [VARG_IDENTIFIER id; VARG_COMMAND com] ->
-		 (fun () -> initialize id com)
-	     | _ -> assert false)
diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli
deleted file mode 100644
index 3492729c..00000000
--- a/contrib/correctness/pextract.mli
+++ /dev/null
@@ -1,17 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pextract.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-val pp_ocaml : string -> unit
-
-
diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml
deleted file mode 100644
index 076b11cd..00000000
--- a/contrib/correctness/pmisc.ml
+++ /dev/null
@@ -1,222 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Libnames
-open Topconstr
-
-(* debug *)
-
-let deb_mess s =
-  if !Options.debug then begin
-    msgnl s; pp_flush()
-  end
-
-let deb_print f x =
-  if !Options.debug then begin
-    msgnl (f x); pp_flush()
-  end
-
-let list_of_some = function
-    None -> []
-  | Some x -> [x]
-
-let difference l1 l2 =
-  let rec diff = function
-      [] -> []
-    | a::rem -> if List.mem a l2 then diff rem else a::(diff rem)
-  in
-    diff l1
-
-(* TODO: these functions should be moved in the code of Coq *)
-
-let reraise_with_loc loc f x =
-  try f x with Util.UserError (_,_) as e -> Stdpp.raise_with_loc loc e
-
-
-(* functions on names *)
-
-let at = if !Options.v7 then "@" else "'at'"
-
-let at_id id d = id_of_string ((string_of_id id) ^ at ^ d)
-
-let is_at id =
-  try
-    let _ = string_index_from (string_of_id id) 0 at in true
-  with Not_found ->
-    false
-
-let un_at id =
-  let s = string_of_id id in
-    try
-      let n = string_index_from s 0 at in
-    	id_of_string (String.sub s 0 n),
-	String.sub s (n + String.length at)
-          (String.length s - n - String.length at)
-    with Not_found ->
-      invalid_arg "un_at"
-
-let renaming_of_ids avoid ids =
-  let rec rename avoid = function
-      [] -> [], avoid
-    | x::rem ->
-	let al,avoid = rename avoid rem in
-	let x' = next_ident_away x avoid in
-	  (x,x')::al, x'::avoid
-  in
-    rename avoid ids
-
-let result_id = id_of_string "result"
-
-let adr_id id = id_of_string ("adr_" ^ (string_of_id id))
-
-(* hypotheses names *)
-
-let next s r = function
-    Anonymous -> incr r; id_of_string (s ^ string_of_int !r)
-  | Name id -> id
-
-let reset_names,pre_name,post_name,inv_name,
-    test_name,bool_name,var_name,phi_name,for_name,label_name =
-  let pre = ref 0 in
-  let post = ref 0 in
-  let inv = ref 0 in
-  let test = ref 0 in
-  let bool = ref 0 in
-  let var = ref 0 in
-  let phi = ref 0 in
-  let forr = ref 0 in
-  let label = ref 0 in
-    (fun () -> 
-       pre := 0; post := 0; inv := 0; test := 0; 
-       bool := 0; var := 0; phi := 0; label := 0),
-    (next "Pre" pre),
-    (next "Post" post),
-    (next "Inv" inv),
-    (next "Test" test),
-    (fun () -> next "Bool" bool Anonymous),
-    (next "Variant" var),
-    (fun () -> next "rphi" phi Anonymous),
-    (fun () -> next "for" forr Anonymous),
-    (fun () -> string_of_id (next "Label" label Anonymous))
-
-let default = id_of_string "x_"
-let id_of_name = function Name id -> id | Anonymous -> default
-
-
-(* functions on CIC terms *)
-
-let isevar = Evarutil.new_evar_in_sign (Global.env ())
-
-(* Substitutions of variables by others. *)
-let subst_in_constr alist =
-  let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in
-  replace_vars alist'
-
-(*
-let subst_in_ast alist ast =
-  let rec subst = function
-      Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s)
-    | Node(l,s,args) -> Node(l,s,List.map subst args)
-    | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
-    | x -> x
-  in
-    subst ast
-*)
-(*
-let subst_ast_in_ast alist ast =
-  let rec subst = function
-      Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x)
-    | Node(l,s,args) -> Node(l,s,List.map subst args)
-    | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
-    | x -> x
-  in
-    subst ast
-*)
-
-let rec subst_in_ast alist = function
-  | CRef (Ident (loc,id)) ->
-      CRef (Ident (loc,(try List.assoc id alist with Not_found -> id)))
-  | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x
-
-let rec subst_ast_in_ast alist = function
-  | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x)
-  | x ->
-      map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x
-
-(* subst. of variables by constr *)
-let real_subst_in_constr = replace_vars
-
-(* Coq constants *)
-
-let coq_constant d s =
-  Libnames.encode_kn
-    (make_dirpath (List.rev (List.map id_of_string ("Coq"::d))))
-    (id_of_string s)
-
-let bool_sp = coq_constant ["Init"; "Datatypes"] "bool"
-let coq_true = mkConstruct ((bool_sp,0),1)
-let coq_false = mkConstruct ((bool_sp,0),2)
-
-let constant s =
-  let id = Constrextern.id_of_v7_string s in
-  Constrintern.global_reference id
-
-let connective_and = id_of_string "prog_bool_and"
-let connective_or  = id_of_string "prog_bool_or"
-let connective_not = id_of_string "prog_bool_not"
-
-let is_connective id =
-  id = connective_and or id = connective_or or id = connective_not
-
-(* [conj i s] constructs the conjunction of two constr *)
-
-let conj i s = Term.applist (constant "and", [i; s])
-
-(* [n_mkNamedProd v [xn,tn;...;x1,t1]] constructs the type 
-   [(x1:t1)...(xn:tn)v] *)
-
-let rec n_mkNamedProd v = function
-  | [] -> v
-  | (id,ty) :: rem -> n_mkNamedProd (Term.mkNamedProd id ty v) rem
-
-(* [n_lambda v [xn,tn;...;x1,t1]] constructs the type [x1:t1]...[xn:tn]v *)
-
-let rec n_lambda v = function
-  | [] -> v
-  | (id,ty) :: rem -> n_lambda (Term.mkNamedLambda id ty v) rem
-
-(* [abstract env idl c] constructs [x1]...[xn]c where idl = [x1;...;xn] *)
-
-let abstract ids c = n_lambda c (List.rev ids)
-
-(* substitutivity (of kernel names, for modules management) *)
-
-open Ptype
-
-let rec type_v_knsubst s = function
-  | Ref v -> Ref (type_v_knsubst s v)
-  | Array (c, v) -> Array (subst_mps s c, type_v_knsubst s v)
-  | Arrow (bl, c) -> Arrow (List.map (binder_knsubst s) bl, type_c_knsubst s c)
-  | TypePure c -> TypePure (subst_mps s c)
-
-and type_c_knsubst s ((id,v),e,pl,q) =
-  ((id, type_v_knsubst s v), e, 
-   List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl,
-   option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q)
-
-and binder_knsubst s (id,b) = 
-  (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b)
diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli
deleted file mode 100644
index 9d96467f..00000000
--- a/contrib/correctness/pmisc.mli
+++ /dev/null
@@ -1,81 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmisc.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Ptype
-open Topconstr
-
-(* Some misc. functions *)
-
-val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b
-
-val list_of_some : 'a option -> 'a list
-val difference : 'a list -> 'a list -> 'a list
-
-val at_id : identifier -> string -> identifier
-val un_at : identifier -> identifier * string
-val is_at : identifier -> bool
-
-val result_id : identifier
-val adr_id : identifier -> identifier
-
-val renaming_of_ids : identifier list -> identifier list
-                     -> (identifier * identifier) list * identifier list
-
-val reset_names : unit -> unit
-val pre_name    : name -> identifier
-val post_name   : name -> identifier
-val inv_name    : name -> identifier
-val test_name   : name -> identifier
-val bool_name   : unit -> identifier
-val var_name    : name -> identifier
-val phi_name    : unit -> identifier
-val for_name    : unit -> identifier
-val label_name  : unit -> string
-
-val id_of_name : name -> identifier
-
-(* CIC terms *)
-
-val isevar : constr
-
-val subst_in_constr : (identifier * identifier) list -> constr -> constr
-val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr
-val subst_ast_in_ast :
-  (identifier * constr_expr) list -> constr_expr -> constr_expr
-val real_subst_in_constr : (identifier * constr) list -> constr -> constr
-
-val constant : string -> constr
-val coq_constant : string list -> string -> kernel_name
-val conj : constr -> constr -> constr
-
-val coq_true : constr
-val coq_false : constr
-
-val connective_and : identifier
-val connective_or  : identifier
-val connective_not : identifier
-val is_connective : identifier -> bool
-
-val n_mkNamedProd : constr -> (identifier * constr) list -> constr
-val n_lambda  : constr -> (identifier * constr) list -> constr
-val abstract : (identifier * constr) list -> constr -> constr
-
-val type_v_knsubst : substitution -> type_v -> type_v
-val type_c_knsubst : substitution -> type_c -> type_c
-
-(* for debugging purposes *)
-
-val deb_mess : Pp.std_ppcmds -> unit
-val deb_print : ('a -> Pp.std_ppcmds) -> 'a -> unit
-
diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml
deleted file mode 100644
index e812fa57..00000000
--- a/contrib/correctness/pmlize.ml
+++ /dev/null
@@ -1,320 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmlize.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Termast
-open Pattern
-open Matching
-
-open Pmisc
-open Ptype
-open Past
-open Putil
-open Prename
-open Penv
-open Peffect
-open Ptyping
-open Pmonad
-
-
-let has_proof_part ren env c =
-  let sign = Pcicenv.trad_sign_of ren env in
-  let ty = Typing.type_of (Global.env_of_context sign) Evd.empty c in
-  Hipattern.is_matching_sigma (Reductionops.nf_betaiota ty)
-
-(* main part: translation of imperative programs into functional ones.
- * 
- * [env] is the environment
- * [ren] is the current renamings of variables
- * [t] is the imperative program to translate, annotated with type+effects
- *
- * we return the translated program in type cc_term
- *)
-
-let rec trad ren t =
-  let env = t.info.env in
-  trad_desc ren env t.info.kappa t.desc
-
-and trad_desc ren env ct d =
-  let (_,tt),eft,pt,qt = ct in
-  match d with
-
-  | Expression c ->
-      let ids = get_reads eft in
-      let al = current_vars ren ids in
-      let c' = subst_in_constr al c in
-      if has_proof_part ren env c' then
-	CC_expr c'
-      else
-      	let ty = trad_ml_type_v ren env tt in
-      	make_tuple [ CC_expr c',ty ] qt ren env (current_date ren)
-      
-  | Variable id ->
-      if is_mutable_in_env env id then
-	invalid_arg "Mlise.trad_desc"
-      else if is_local env id then
-	CC_var id
-      else
-	CC_expr (constant (string_of_id id))
-
-  | Acc _ ->
-      failwith "Mlise.trad: pure terms are supposed to be expressions"
-
-  | TabAcc (check, x, e1) ->
-      let _,ty_elem,_ = array_info ren env x in
-      let te1 = trad ren e1 in
-      let (_,ef1,p1,q1) = e1.info.kappa in
-      let w = get_writes ef1 in
-      let ren' = next ren w in
-      let id = id_of_string "index" in
-      let access = 
-	make_raw_access ren' env (x,current_var ren' x) (mkVar id) 
-      in
-      let t,ty = result_tuple ren' (current_date ren) env
-		   (CC_expr access, ty_elem) (eft,qt) in
-      let t =
-	if check then 
-	  let h = make_pre_access ren env x (mkVar id) in 
-	  let_in_pre ty (anonymous_pre true h) t
-	else
-	  t 
-      in
-      make_let_in ren env te1 p1
-	(current_vars ren' w,q1) (id,constant "Z") (t,ty)
-
-  | Aff (x, e1) ->
-      let tx = trad_type_in_env ren env x in
-      let te1 = trad ren e1 in
-      let (_,ef1,p1,q1) = e1.info.kappa in
-      let w1 = get_writes ef1 in
-      let ren' = next ren (x::w1) in
-      let t_ty = result_tuple ren' (current_date ren) env
-		   (CC_expr (constant "tt"), constant "unit") (eft,qt) 
-      in
-      make_let_in ren env te1 p1
-	(current_vars ren' w1,q1) (current_var ren' x,tx) t_ty
-
-  | TabAff (check, x, e1, e2) ->
-      let _,ty_elem,ty_array = array_info ren env x in
-      let te1 = trad ren e1 in
-      let (_,ef1,p1,q1) = e1.info.kappa in
-      let w1 = get_writes ef1 in
-      let ren' = next ren w1 in
-      let te2 = trad ren' e2 in
-      let (_,ef2,p2,q2) = e2.info.kappa in
-      let w2 = get_writes ef2 in
-      let ren'' = next ren' w2 in
-      let id1 = id_of_string "index" in
-      let id2 = id_of_string "v" in
-      let ren''' = next ren'' [x] in
-      let t,ty = result_tuple ren''' (current_date ren) env
-		   (CC_expr (constant "tt"), constant "unit") (eft,qt) in
-      let store = make_raw_store ren'' env (x,current_var ren'' x) (mkVar id1)
-		   (mkVar id2) in
-      let t = make_let_in ren'' env (CC_expr store) [] ([],None) 
-		(current_var ren''' x,ty_array) (t,ty) in
-      let t = make_let_in ren' env te2 p2
-     	(current_vars ren'' w2,q2) (id2,ty_elem) (t,ty) in
-      let t = 
-	if check then
-	  let h = make_pre_access ren' env x (mkVar id1) in
-	  let_in_pre ty (anonymous_pre true h) t
-	else
-	  t 
-      in
-      make_let_in ren env te1 p1
-	(current_vars ren' w1,q1) (id1,constant "Z") (t,ty)
-
-  | Seq bl ->
-      let before = current_date ren in
-      let finish ren = function
-	  Some (id,ty) -> 
-	    result_tuple ren before env (CC_var id, ty) (eft,qt)
-	| None ->
-	    failwith "a block should contain at least one statement"
-      in
-      let bl = trad_block ren env bl in
-      make_block ren env finish bl
-
-  | If (b, e1, e2) ->
-      let tb = trad ren b in
-      let _,efb,_,_ = b.info.kappa in
-      let ren' = next ren (get_writes efb) in
-      let te1 = trad ren' e1 in
-      let te2 = trad ren' e2 in
-      make_if ren env (tb,b.info.kappa) ren' (te1,e1.info.kappa) 
-	(te2,e2.info.kappa) ct
-
-  (* Translation of the while. *)
-
-  | While (b, inv, var, bl) ->
-      let ren' = next ren (get_writes eft) in
-      let tb = trad ren' b in
-      let tbl = trad_block ren' env bl in
-      let var' = typed_var ren env var in
-      make_while ren env var' (tb,b.info.kappa) tbl (inv,ct)
-
-  | Lam (bl, e) ->
-      let bl' = trad_binders ren env bl in
-      let env' = traverse_binders env bl in
-      let ren' = initial_renaming env' in
-      let te = trans ren' e in
-      CC_lam (bl', te)
-
-  | SApp ([Variable id; Expression q1; Expression q2], [e1; e2])
-      when id = connective_and or id = connective_or ->
-      let c = constant (string_of_id id) in
-      let te1 = trad ren e1
-      and te2 = trad ren e2 in
-      let q1' = apply_post ren env (current_date ren) (anonymous q1)
-      and q2' = apply_post ren env (current_date ren) (anonymous q2) in
-      CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2])
-
-  | SApp ([Variable id; Expression q], [e]) when id = connective_not ->
-      let c = constant (string_of_id id) in
-      let te = trad ren e in
-      let q' = apply_post ren env (current_date ren) (anonymous q) in
-      CC_app (CC_expr c, [CC_expr q'.a_value; te])
-
-  | SApp _ ->
-      invalid_arg "mlise.trad (SApp)"
-
-  | Apply (f, args) ->
-      let trad_arg (ren,args) = function
-	| Term a ->
-	    let ((_,tya),efa,_,_) as ca = a.info.kappa in
-	    let ta = trad ren a in
-	    let w = get_writes efa in
-	    let ren' = next ren w in
-	    ren', ta::args
-	| Refarg _ ->
-	    ren, args
-	| Type v -> 
-	    let c = trad_ml_type_v ren env v in
-	    ren, (CC_expr c)::args
-      in
-      let ren',targs = List.fold_left trad_arg (ren,[]) args in
-      let tf = trad ren' f in
-      let cf = f.info.kappa in
-      let c,(s,_,_),capp = effect_app ren env f args in
-      let tc_args =
-	List.combine
-	  (List.rev targs)
-	  (Util.map_succeed
-	     (function
-		| Term x -> x.info.kappa
-		| Refarg _ -> failwith "caught"
-		| Type _ -> 
-		    (result_id,TypePure mkSet),Peffect.bottom,[],None)
-	     args)
-      in
-      make_app env ren tc_args ren' (tf,cf) (c,s,capp) ct
-	
-  | LetRef (x, e1, e2) ->
-      let (_,v1),ef1,p1,q1 = e1.info.kappa in
-      let te1 = trad ren e1 in
-      let tv1 = trad_ml_type_v ren env v1 in
-      let env' = add (x,Ref v1) env in
-      let ren' = next ren [x] in
-      let (_,v2),ef2,p2,q2 = e2.info.kappa in
-      let tv2 = trad_ml_type_v ren' env' v2 in
-      let te2 = trad ren' e2 in
-      let ren'' = next ren' (get_writes ef2) in
-      let t,ty = result_tuple ren'' (current_date ren) env
-		   (CC_var result_id, tv2) (eft,qt) in
-      let t = make_let_in ren' env' te2 p2
-		(current_vars ren'' (get_writes ef2),q2)
-		(result_id,tv2) (t,ty) in
-      let t = make_let_in ren env te1 p1
-     		(current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) 
-      in
-      t
-
-  | Let (x, e1, e2) ->
-      let (_,v1),ef1,p1,q1 = e1.info.kappa in
-      let te1 = trad ren e1 in
-      let tv1 = trad_ml_type_v ren env v1 in
-      let env' = add (x,v1) env in
-      let ren' = next ren (get_writes ef1) in
-      let (_,v2),ef2,p2,q2 = e2.info.kappa in
-      let tv2 = trad_ml_type_v ren' env' v2 in
-      let te2 = trad ren' e2 in
-      let ren'' = next ren' (get_writes ef2) in
-      let t,ty = result_tuple ren'' (current_date ren) env
-		   (CC_var result_id, tv2) (eft,qt) in
-      let t = make_let_in ren' env' te2 p2
-		(current_vars ren'' (get_writes ef2),q2)
-		(result_id,tv2) (t,ty) in
-      let t = make_let_in ren env te1 p1
-     		(current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) 
-      in
-      t
-
-  | LetRec (f,bl,v,var,e) ->
-      let (_,ef,_,_) as c = 
-	match tt with Arrow(_,c) -> c | _ -> assert false in
-      let bl' = trad_binders ren env bl in
-      let env' = traverse_binders env bl in
-      let ren' = initial_renaming env' in
-      let (phi0,var') = find_recursion f e.info.env in
-      let te = trad ren' e in
-      let t = make_letrec ren' env' (phi0,var') f bl' (te,e.info.kappa) c in
-      CC_lam (bl', t)
-
-  | PPoint (s,d) ->       
-      let ren' = push_date ren s in
-      trad_desc ren' env ct d
-
-  | Debug _ -> failwith "Mlise.trad: Debug: not implemented"
-
-
-and trad_binders ren env = function
-  | [] -> 
-      []
-  | (_,BindType (Ref _ | Array _))::bl ->
-      trad_binders ren env bl
-  | (id,BindType v)::bl ->
-      let tt = trad_ml_type_v ren env v in
-      (id, CC_typed_binder tt) :: (trad_binders ren env bl)
-  | (id,BindSet)::bl ->
-      (id, CC_typed_binder mkSet) :: (trad_binders ren env bl)
-  | (_,Untyped)::_ -> invalid_arg "trad_binders"
-
-	
-and trad_block ren env = function
-  | [] -> 
-      []
-  | (Assert c)::block ->
-      (Assert c)::(trad_block ren env block)
-  | (Label s)::block ->
-      let ren' = push_date ren s in
-      (Label s)::(trad_block ren' env block)
-  | (Statement e)::block ->
-      let te = trad ren e in
-      let _,efe,_,_ = e.info.kappa in
-      let w = get_writes efe in
-      let ren' = next ren w in
-      (Statement (te,e.info.kappa))::(trad_block ren' env block)
-
-
-and trans ren e =
-  let env = e.info.env in
-  let _,ef,p,_ = e.info.kappa in
-  let ty = trad_ml_type_c ren env e.info.kappa in
-  let ids = get_reads ef in
-  let al = current_vars ren ids in
-  let c = trad ren e in
-  let c = abs_pre ren env (c,ty) p in
-  let bl = binding_of_alist ren env al in
-  make_abs (List.rev bl) c
-
diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli
deleted file mode 100644
index 1f8936f0..00000000
--- a/contrib/correctness/pmlize.mli
+++ /dev/null
@@ -1,20 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmlize.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Past
-open Penv
-open Names
-
-(* translation of imperative programs into intermediate functional programs *)
-
-val trans : Prename.t -> typed_program -> cc_term
-
diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml
deleted file mode 100644
index 8f1b5946..00000000
--- a/contrib/correctness/pmonad.ml
+++ /dev/null
@@ -1,665 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Term
-open Termast
-
-open Pmisc
-open Putil
-open Ptype
-open Past
-open Prename
-open Penv
-open Pcic
-open Peffect
-
-
-(* [product ren [y1,z1;...;yk,zk] q] constructs
- * the (possibly dependent) tuple type
- *
- *      z1 x ... x zk                             if no post-condition
- * or   \exists. y1:z1. ... yk:zk. (Q x1 ... xn)  otherwise
- *
- * where the xi are given by the renaming [ren].
- *)
-
-let product_name = function
-  | 2 -> "prod"
-  | n -> check_product_n n; Printf.sprintf "tuple_%d" n
-
-let dep_product_name = function
-  | 1 -> "sig"
-  | n -> check_dep_product_n n; Printf.sprintf "sig_%d" n
-
-let product ren env before lo = function
-  | None -> (* non dependent case *)
-      begin match lo with
-	| [_,v] -> v
-	| _ ->
-	    let s = product_name (List.length lo) in
-      	    Term.applist (constant s, List.map snd lo)
-      end
-  | Some q -> (* dependent case *)
-      let s = dep_product_name (List.length lo) in
-      let a' = apply_post ren env before q in
-      Term.applist (constant s, (List.map snd lo) @ [a'.a_value])
-	
-(* [arrow ren v pl] abstracts the term v over the pre-condition if any
- * i.e. computes
- *
- *     (P1 x1 ... xn) -> ... -> (Pk x1 ... xn) -> v
- * 
- * where the xi are given by the renaming [ren].
- *)
-
-let arrow ren env v pl =
-  List.fold_left 
-    (fun t p -> 
-       if p.p_assert then t else Term.mkArrow (apply_pre ren env p).p_value t) 
-    v pl
-	
-(* [abstract_post ren env (e,q) (res,v)] abstract a post-condition q
- * over the write-variables of e *)
-
-let rec abstract_post ren env (e,q) =
-  let after_id id = id_of_string ((string_of_id id) ^ "'") in
-  let (_,go) = Peffect.get_repr e in
-  let al = List.map (fun id -> (id,after_id id)) go in
-  let q = option_map (named_app (subst_in_constr al)) q in
-  let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in
-  option_map (named_app (abstract tgo)) q
-
-(* Translation of effects types in cic types.
- *
- * [trad_ml_type_v] and [trad_ml_type_c] translate types with effects
- * into cic types.
- *)
-
-and prod ren env g = 
-  List.map
-    (fun id -> (current_var ren id, trad_type_in_env ren env id)) 
-    g
-
-and input ren env e  =
-  let i,_ = Peffect.get_repr e in
-  prod ren env i
-
-and output ren env ((id,v),e) =
-  let tv = trad_ml_type_v ren env v in
-  let _,o = Peffect.get_repr e in
-  (prod ren env o) @ [id,tv]
-
-and input_output ren env c =
-  let ((res,v),e,_,_) = c in
-  input ren env e, output ren env ((res,v),e)
-
-(* The function t -> \barre{t} on V and C. *)
-
-and trad_ml_type_c ren env c =
-  let ((res,v),e,p,q) = c in
-  let q = abstract_post ren env (e,q) in
-  let lo = output ren env ((res,v),e) in
-  let ty = product ren env (current_date ren) lo q in
-  let ty = arrow ren env ty p in
-  let li = input ren env e in
-  n_mkNamedProd ty li
-
-and trad_ml_type_v ren env = function
-    
-  | Ref _ | Array _ -> invalid_arg "Monad.trad_ml_type_v"
-	
-  | Arrow (bl, c) ->
-      let bl',ren',env' =
-	List.fold_left
-	  (fun (bl,ren,env) b -> match b with
-	     | (id,BindType ((Ref _ | Array _) as v)) ->
-		 let env' = add (id,v) env in
-		 let ren' = initial_renaming env' in
-		 (bl,ren',env')
-	     | (id,BindType v) -> 
-		 let tt = trad_ml_type_v ren env v in
-		 let env' = add (id,v) env in
-		 let ren' = initial_renaming env' in
-		 (id,tt)::bl,ren',env'
-	     | (id, BindSet) ->
-		 (id,mkSet) :: bl,ren,env
-	     | _ -> failwith "Monad: trad_ml_type_v: not yet implemented"
- 	  )
- 	  ([],ren,env) bl 
-      in
-      n_mkNamedProd (trad_ml_type_c ren' env' c) bl'
-	
-  | TypePure c ->
-      (apply_pre ren env (anonymous_pre false c)).p_value
-
-and trad_imp_type ren env = function
-  | Ref v        -> trad_ml_type_v ren env v
-  | Array (c,v)  -> Term.applist (constant "array", 
-				  [c; trad_ml_type_v ren env v])
-  | _            -> invalid_arg "Monad.trad_imp_type"
-
-and trad_type_in_env ren env id =
-  let v = type_in_env env id in trad_imp_type ren env v
-
-
-
-(* bindings *)
-
-let binding_of_alist ren env al =
-  List.map
-    (fun (id,id') -> (id', CC_typed_binder (trad_type_in_env ren env id)))
-    al
-
-
-(* [make_abs bl t p] abstracts t w.r.t binding list bl., that is
- * [x1:t1]...[xn:tn]t. Returns t if the binding is empty. *)
-
-let make_abs bl t = match bl with
-  | [] -> t
-  | _  -> CC_lam (bl, t)
-
-
-(* [result_tuple ren before env (res,v) (ef,q)] constructs the tuple 
- *
- *    (y1,...,yn,res,?::(q/ren y1 ... yn res))
- *
- * where the yi are the values of the output of ef.
- * if there is no yi and no post-condition, it is simplified in res itself.
- *)
-
-let simple_constr_of_prog = function
-  | CC_expr c -> c
-  | CC_var id -> mkVar id
-  | _ -> assert false
-
-let make_tuple l q ren env before = match l with
-  | [e,_] when q = None -> 
-      e
-  | _ ->
-      let tl = List.map snd l in
-      let dep,h,th = match q with
-	| None -> false,[],[]
-	| Some c ->
-	    let args = List.map (fun (e,_) -> simple_constr_of_prog e) l in
-	    let c = apply_post ren env before c in
-	    true,
-	    [ CC_hole (Term.applist (c.a_value, args)) ], (* hole *)
-	    [ c.a_value ]                     (* type of the hole *)
-      in 
-      CC_tuple (dep, tl @ th, (List.map fst l) @ h)
-
-let result_tuple ren before env (res,v) (ef,q) =
-  let ids = get_writes ef in
-  let lo = 
-    (List.map (fun id -> 
-		 let id' = current_var ren id in
-		 CC_var id', trad_type_in_env ren env id) ids)
-    @ [res,v]
-  in
-  let q = abstract_post ren env (ef,q) in
-  make_tuple lo q ren env before,
-  product ren env before lo q
-
-
-(* [make_let_in ren env fe p (vo,q) (res,v) t] constructs the term
-   
-        [ let h1 = ?:P1 in ... let hn = ?:Pm in ]
-          let y1,y2,...,yn, res [,q] = fe in
-          t
-
-   vo=[_,y1;...;_,ym] are list of renamings.
-   v is the type of res
-   *)
-
-let let_in_pre ty p t =
-  let h = p.p_value in
-  CC_letin (false, ty, [pre_name p.p_name,CC_typed_binder h], CC_hole h, t)
-
-let multiple_let_in_pre ty hl t =
-  List.fold_left (fun t h -> let_in_pre ty h t) t hl
-
-let make_let_in ren env fe p (vo,q) (res,tyres) (t,ty) =
-  let b = [res, CC_typed_binder tyres] in
-  let b',dep = match q with
-    | None -> [],false
-    | Some q -> [post_name q.a_name, CC_untyped_binder],true 
-  in
-  let bl = (binding_of_alist ren env vo) @ b @ b' in
-  let tyapp =
-    let n = succ (List.length vo) in
-    let name = match q with None -> product_name n | _ -> dep_product_name n in
-    constant name 
-  in
-  let t = CC_letin (dep, ty, bl, fe, t) in
-  multiple_let_in_pre ty (List.map (apply_pre ren env) p) t
-
-
-(* [abs_pre ren env (t,ty) pl] abstracts a term t with respect to the 
- * list of pre-conditions [pl]. Some of them are real pre-conditions
- * and others are assertions, according to the boolean field p_assert,
- * so we construct the term
- *   [h1:P1]...[hn:Pn]let h'1 = ?:P'1 in ... let H'm = ?:P'm in t
- *)
-
-let abs_pre ren env (t,ty) pl =
-  List.fold_left
-    (fun t p ->
-       if p.p_assert then
-	 let_in_pre ty (apply_pre ren env p) t
-       else
-	 let h = pre_name p.p_name in 
-	 CC_lam ([h,CC_typed_binder (apply_pre ren env p).p_value],t))
-    t pl
-    
-
-(* [make_block ren env finish bl] builds the translation of a block
- * finish is the function that is applied to the result at the end of the
- * block. *)
-
-let make_block ren env finish bl =
-  let rec rec_block ren result = function
-    | [] ->
-	finish ren result
-    | (Assert c) :: block ->
-	let t,ty = rec_block ren result block in
-	let c = apply_assert ren env c in
-	let p = { p_assert = true; p_name = c.a_name; p_value = c.a_value } in
-	let_in_pre ty p t, ty
-    | (Label s) :: block ->
-	let ren' = push_date ren s in
-	rec_block ren' result block
-    | (Statement (te,info)) :: block ->
-	let (_,tye),efe,pe,qe = info in
-	let w = get_writes efe in
-	let ren' = next ren w in
-	let id = result_id in
-	let tye = trad_ml_type_v ren env tye in
-	let t = rec_block ren' (Some (id,tye)) block in
-	make_let_in ren env te pe (current_vars ren' w,qe) (id,tye) t,
-	snd t
-  in
-  let t,_ = rec_block ren None bl in
-  t
-
-
-(* [make_app env ren args ren' (tf,cf) (cb,s,capp) c]
- * constructs the application of [tf] to [args].
- * capp is the effect of application, after substitution (s) and cb before
- *)
-
-let eq ty e1 e2 =
-  Term.applist (constant "eq", [ty; e1; e2])
-
-let lt r e1 e2 =
-  Term.applist (r, [e1; e2])
-
-let is_recursive env = function
-  | CC_var x -> 
-      (try let _ = find_recursion x env in true with Not_found -> false)
-  | _ -> false
-
-let if_recursion env f = function
-  | CC_var x ->
-      (try let v = find_recursion x env in (f v x) with Not_found -> [])
-  | _ -> []
-
-let dec_phi ren env s svi =
-  if_recursion env
-    (fun (phi0,(cphi,r,_)) f -> 
-       let phi = subst_in_constr svi (subst_in_constr s cphi) in
-       let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
-       [CC_expr phi; CC_hole (lt r phi (mkVar phi0))])
-
-let eq_phi ren env s svi =
-  if_recursion env
-    (fun (phi0,(cphi,_,a)) f ->
-       let phi = subst_in_constr svi (subst_in_constr s cphi) in
-       let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
-       [CC_hole (eq a phi phi)])
-
-let is_ref_binder = function 
-  | (_,BindType (Ref _ | Array _)) -> true
-  | _ -> false
-
-let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c =
-  let ((_,tvf),ef,pf,qf) = cf in
-  let (_,eapp,papp,qapp) = capp in
-  let ((_,v),e,p,q) = c in
-  let bl = List.filter (fun b -> not (is_ref_binder b)) bl in
-  let recur = is_recursive env tf in
-  let before = current_date ren in
-  let ren'' = next ren' (get_writes ef) in
-  let ren''' = next ren'' (get_writes eapp) in
-  let res = result_id in
-  let vi,svi =
-    let ids = List.map fst bl in 
-    let s = fresh (avoid ren ids) ids in
-    List.map snd s, s
-  in
-  let tyres = subst_in_constr svi (trad_ml_type_v ren env v) in
-  let t,ty = result_tuple ren''' before env (CC_var res, tyres) (e,q) in
-  let res_f = id_of_string "vf" in
-  let inf,outf =
-    let i,o = let _,e,_,_ = cb in get_reads e, get_writes e in
-    let apply_s = List.map (fun id -> try List.assoc id s with _ -> id) in
-    apply_s i, apply_s o
-  in
-  let fe =
-    let xi = List.rev (List.map snd (current_vars ren'' inf)) in
-    let holes = List.map (fun x -> (apply_pre ren'' env x).p_value)
-		  (List.map (pre_app (subst_in_constr svi)) papp) in
-    CC_app ((if recur then tf else CC_var res_f),
-	    (dec_phi ren'' env s svi tf) 
-	    @(List.map (fun id -> CC_var id) (vi @ xi))
-	    @(eq_phi ren'' env s svi tf)
-	    @(List.map (fun c -> CC_hole c) holes))
-  in
-  let qapp' = option_map (named_app (subst_in_constr svi)) qapp in
-  let t = 
-    make_let_in ren'' env fe [] (current_vars ren''' outf,qapp')
-      (res,tyres) (t,ty)
-  in
-  let t =
-    if recur then 
-      t
-    else
-      make_let_in ren' env tf pf
-	(current_vars ren'' (get_writes ef),qf)
-	(res_f,trad_ml_type_v ren env tvf) (t,ty)
-  in
-  let rec eval_args ren = function
-    | [] -> t
-    | (vx,(ta,((_,tva),ea,pa,qa)))::args ->
-	let w = get_writes ea in
-	let ren' = next ren w in
-	let t' = eval_args ren' args in
-	make_let_in ren env ta pa (current_vars ren' (get_writes ea),qa)
-	  (vx,trad_ml_type_v ren env tva) (t',ty)
-  in
-  eval_args ren (List.combine vi args)
-
-
-(* [make_if ren env (tb,cb) ren' (t1,c1) (t2,c2)]
- * constructs the term corresponding to a if expression, i.e
- *
- *       [p] let o1, b [,q1] = m1 [?::p1] in
- *           Cases b of
- *              R => let o2, v2 [,q2] = t1  [?::p2] in 
- *                   (proj (o1,o2)), v2 [,?::q] 
- *            | S => let o2, v2 [,q2] = t2  [?::p2] in 
- *                   (proj (o1,o2)), v2 [,?::q] 
- *)
-
-let make_if_case ren env ty (b,qb) (br1,br2) =
-  let id_b,ty',ty1,ty2 = match qb with
-    | Some q ->  
-  	let q = apply_post ren env (current_date ren) q in
-    	let (name,t1,t2) = Term.destLambda q.a_value in
-	q.a_name,
-    	Term.mkLambda (name, t1, mkArrow t2 ty),
-	Term.mkApp (q.a_value, [| coq_true |]),
-	Term.mkApp (q.a_value, [| coq_false |])
-    | None -> assert false
-  in
-  let n = test_name Anonymous in
-  CC_app (CC_case (ty', b, [CC_lam ([n,CC_typed_binder ty1], br1);
-			    CC_lam ([n,CC_typed_binder ty2], br2)]),
-	  [CC_var (post_name id_b)])
-
-let make_if ren env (tb,cb) ren' (t1,c1) (t2,c2) c =
-  let ((_,tvb),eb,pb,qb) = cb in
-  let ((_,tv1),e1,p1,q1) = c1 in
-  let ((_,tv2),e2,p2,q2) = c2 in
-  let ((_,t),e,p,q) = c in
-
-  let wb = get_writes eb in
-  let resb = id_of_string "resultb" in
-  let res = result_id in
-  let tyb = trad_ml_type_v ren' env tvb in
-  let tt = trad_ml_type_v ren env t in
-
-  (* une branche de if *)
-  let branch (tv_br,e_br,p_br,q_br) f_br  = 
-    let w_br = get_writes e_br in
-    let ren'' = next ren' w_br in
-    let t,ty = result_tuple ren'' (current_date ren') env
-		 (CC_var res,tt) (e,q) in
-    make_let_in ren' env f_br p_br (current_vars ren'' w_br,q_br)
-      (res,tt) (t,ty),
-    ty
-  in
-  let t1,ty1 = branch c1 t1 in
-  let t2,ty2 = branch c2 t2 in
-  let ty = ty1 in
-  let qb = force_bool_name qb in
-  let t = make_if_case ren env ty (CC_var resb,qb) (t1,t2) in
-  make_let_in ren env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty)
-
-
-(* [make_while ren env (cphi,r,a) (tb,cb) (te,ce) c]
- * constructs the term corresponding to the while, i.e.
- * 
- *    [h:(I x)](well_founded_induction
- *              A R ?::(well_founded A R)
- *              [Phi:A] (x) Phi=phi(x)->(I x)-> \exists x'.res.(I x')/\(S x')
- *              [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
- *                [x][eq:Phi_0=phi(x)][h:(I x)]
- *                   Cases (b x) of
- *                     (left  HH) => (x,?::(IS x))
- *                   | (right HH) => let x1,_,_ = (e x ?) in
- *                                   (w phi(x1) ? x1 ? ?)
- *              phi(x) x ? ?)
- *)
-
-let id_phi = id_of_string "phi"
-let id_phi0 = id_of_string "phi0"
-
-let make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) =
-  let ((_,tvb),eb,pb,qb) = cb in
-  let (_,ef,_,is) = c in
-
-  let ren' = next ren (get_writes ef) in
-  let before = current_date ren in
-  
-  let ty = 
-    let is = abstract_post ren' env (ef,is) in
-    let _,lo = input_output ren env c in
-    product ren env before lo is 
-  in
-  let resb = id_of_string "resultb" in
-  let tyb = trad_ml_type_v ren' env tvb in
-  let wb = get_writes eb in
-
-  (* première branche: le test est vrai => e;w *)
-  let t1 = 
-    make_block ren' env 
-      (fun ren'' result -> match result with
-	 | Some (id,_) ->
-	     let v = List.rev (current_vars ren'' (get_writes ef)) in
-	       CC_app (CC_var id_w,
-		       [CC_expr (phi_of ren'');
-			CC_hole (lt r (phi_of ren'') (mkVar id_phi0))]
-		       @(List.map (fun (_,id) -> CC_var id) v)
-		       @(CC_hole (eq a (phi_of ren'') (phi_of ren'')))
-		       ::(match i with
-			    | None -> [] 
-			    | Some c -> 
-				[CC_hole (apply_assert ren'' env c).a_value])),
-	       ty
-      	 | None -> failwith "a block should contain at least one statement")
-      tbl
-  in
-        
-  (* deuxième branche: le test est faux => on sort de la boucle *)
-  let t2,_ = 
-    result_tuple ren' before env
-      (CC_expr (constant "tt"),constant "unit") (ef,is)
-  in
-
-  let b_al = current_vars ren' (get_reads eb) in
-  let qb = force_bool_name qb in
-  let t = make_if_case ren' env ty (CC_var resb,qb) (t1,t2) in
-  let t = 
-    make_let_in ren' env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) 
-  in
-  let t = 
-    let pl = List.map (pre_of_assert false) (list_of_some i) in
-    abs_pre ren' env (t,ty) pl 
-  in
-  let t = 
-    CC_lam ([var_name Anonymous,
-	     CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren'))],t) 
-  in
-  let bl = binding_of_alist ren env (current_vars ren' (get_writes ef)) in
-  make_abs (List.rev bl) t
-
-
-let make_while ren env (cphi,r,a) (tb,cb) tbl (i,c) =
-  let (_,ef,_,is) = c in
-  let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
-  let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
-
-  let before = current_date ren in
-  let ren' = next ren (get_writes ef) in
-  let al = current_vars ren' (get_writes ef) in
-  let v =   
-    let _,lo = input_output ren env c in
-    let is = abstract_post ren' env (ef,is) in
-    match i with
-      | None -> product ren' env before lo is
-      | Some ci -> 
-	  Term.mkArrow (apply_assert ren' env ci).a_value 
-	    (product ren' env before lo is) 
-  in
-  let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren')) v in
-  let v = 
-    n_mkNamedProd v 
-      (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) 
-  in
-  let tw = 
-    Term.mkNamedProd id_phi a
-      (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) 
-  in
-  let id_w = id_of_string "loop" in
-  let vars = List.rev (current_vars ren (get_writes ef)) in
-  let body =
-    make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) 
-  in
-  CC_app (CC_expr (constant "well_founded_induction"),
-	  [CC_expr a; CC_expr r;
-	   CC_hole wf_a_r;
-	   CC_expr (Term.mkNamedLambda id_phi a v);
-	   CC_lam ([id_phi0, CC_typed_binder a;
-		    id_w, CC_typed_binder tw],
-		   body);
-	   CC_expr (phi_of ren)]
-	  @(List.map (fun (_,id) -> CC_var id) vars)
-          @(CC_hole (eq a (phi_of ren) (phi_of ren)))
-	  ::(match i with
-	       | None -> [] 
-	       | Some c -> [CC_hole (apply_assert ren env c).a_value])) 
-
-
-(* [make_letrec ren env (phi0,(cphi,r,a)) bl (te,ce) c]
- * constructs the term corresponding to the let rec i.e.
- *
- * [x][h:P(x)](well_founded_induction 
- *              A R ?::(well_founded A R)
- *              [Phi:A] (bl) (x) Phi=phi(x)->(P x)-> \exists x'.res.(Q x x')
- *              [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
- *                [bl][x][eq:Phi_0=phi(x)][h:(P x)]te
- *              phi(x) bl x ? ?)
- *)
-
-let make_letrec ren env (id_phi0,(cphi,r,a)) idf bl (te,ce) c =
-  let (_,ef,p,q) = c in
-  let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
-  let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
-
-  let before = current_date ren in
-  let al = current_vars ren (get_reads ef) in
-  let v = 
-    let _,lo = input_output ren env c in
-    let q = abstract_post ren env (ef,q) in
-    arrow ren env (product ren env (current_date ren) lo q) p 
-  in
-  let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren)) v in
-  let v = 
-    n_mkNamedProd v 
-      (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) 
-  in
-  let v = 
-    n_mkNamedProd v
-      (List.map (function (id,CC_typed_binder c) -> (id,c) 
-		   | _ -> assert false) (List.rev bl)) 
-  in
-  let tw = 
-    Term.mkNamedProd id_phi a
-      (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) 
-  in
-  let vars = List.rev (current_vars ren (get_reads ef)) in
-  let body =
-    let al = current_vars ren (get_reads ef) in
-    let bod = abs_pre ren env (te,v) p in
-    let bod = CC_lam ([var_name Anonymous,
-		       CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren))],
-		      bod) 
-    in
-    let bl' = binding_of_alist ren env al in
-    make_abs (bl@(List.rev bl')) bod
-  in
-  let t =
-    CC_app (CC_expr (constant "well_founded_induction"),
-	    [CC_expr a; CC_expr r;
-	     CC_hole wf_a_r;
-	     CC_expr (Term.mkNamedLambda id_phi a v);
-	     CC_lam ([id_phi0, CC_typed_binder a;
-		      idf, CC_typed_binder tw],
-		     body);
-	     CC_expr (phi_of ren)]
-	    @(List.map (fun (id,_) -> CC_var id) bl)
-	    @(List.map (fun (_,id) -> CC_var id) vars)
-            @[CC_hole (eq a (phi_of ren) (phi_of ren))]
-	   )
-  in
-  (* on abstrait juste par rapport aux variables de ef *)
-  let al = current_vars ren (get_reads ef) in
-  let bl = binding_of_alist ren env al in
-  make_abs (List.rev bl) t
-
-
-(* [make_access env id c] Access in array id.
- *
- * Constructs [t:(array s T)](access_g s T t c ?::(lt c s)).
- *)
-
-let array_info ren env id =
-  let ty = type_in_env env id in
-  let size,v = dearray_type ty in
-  let ty_elem = trad_ml_type_v ren env v in
-  let ty_array = trad_imp_type ren env ty in
-  size,ty_elem,ty_array
-
-let make_raw_access ren env (id,id') c =
-  let size,ty_elem,_ = array_info ren env id in
-  Term.applist (constant "access", [size; ty_elem; mkVar id'; c])
-
-let make_pre_access ren env id c =
-  let size,_,_ = array_info ren env id in
-  conj (lt (constant "Zle") (constant "ZERO") c)
-       (lt (constant "Zlt") c size)
-      
-let make_raw_store ren env (id,id') c1 c2 =
-  let size,ty_elem,_ = array_info ren env id in
-  Term.applist (constant "store", [size; ty_elem; mkVar id'; c1; c2])
diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli
deleted file mode 100644
index a46a040e..00000000
--- a/contrib/correctness/pmonad.mli
+++ /dev/null
@@ -1,106 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmonad.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-
-open Ptype
-open Past
-open Penv
-
-(* Main part of the translation of imperative programs into functional ones
- * (with mlise.ml) *)
-
-(* Here we translate the specification into a CIC specification *)
-
-val trad_ml_type_v : Prename.t -> local_env -> type_v -> constr
-val trad_ml_type_c : Prename.t -> local_env -> type_c -> constr
-val trad_imp_type  : Prename.t -> local_env -> type_v -> constr
-val trad_type_in_env : Prename.t -> local_env -> identifier -> constr
-
-val binding_of_alist : Prename.t -> local_env
-                    -> (identifier * identifier) list
-		    -> cc_binder list
-val make_abs : cc_binder list -> cc_term -> cc_term
-val abs_pre : Prename.t -> local_env -> cc_term * constr -> 
-  constr precondition list -> cc_term
-
-(* The following functions translate the main constructions *)
-
-val make_tuple : (cc_term * cc_type) list -> predicate option
-          -> Prename.t -> local_env -> string
-          -> cc_term
-
-val result_tuple : Prename.t -> string -> local_env
-          -> (cc_term * constr) -> (Peffect.t * predicate option)
-          -> cc_term * constr
-
-val let_in_pre : constr -> constr precondition -> cc_term -> cc_term
-
-val make_let_in : Prename.t -> local_env -> cc_term 
-          -> constr precondition list
-          -> ((identifier * identifier) list * predicate option) 
-	  -> identifier * constr
-	  -> cc_term * constr -> cc_term
-
-val make_block : Prename.t -> local_env
-          -> (Prename.t -> (identifier * constr) option -> cc_term * constr)
-	  -> (cc_term * type_c, constr) block
-	  -> cc_term
-
-val make_app : local_env
-          -> Prename.t -> (cc_term * type_c) list
-	  -> Prename.t -> cc_term * type_c
-	  -> ((type_v binder list) * type_c)
-	    * ((identifier*identifier) list)
-	    * type_c
-	  -> type_c
-          -> cc_term
-
-val make_if : Prename.t -> local_env 
-         -> cc_term * type_c
-	 -> Prename.t
-         -> cc_term * type_c
-         -> cc_term * type_c
-         -> type_c
-         -> cc_term
-
-val make_while : Prename.t -> local_env
-         -> (constr * constr * constr) (* typed variant *)
-         -> cc_term * type_c
-         -> (cc_term * type_c, constr) block
-         -> constr assertion option * type_c
-         -> cc_term
-
-val make_letrec : Prename.t -> local_env
-         -> (identifier * (constr * constr * constr)) (* typed variant *)
-	 -> identifier (* the name of the function *)
-         -> (cc_binder list)
-	 -> (cc_term * type_c)
-	 -> type_c
-         -> cc_term
-
-(* Functions to translate array operations *)
-
-val array_info :
-  Prename.t -> local_env -> identifier -> constr * constr * constr
-
-val make_raw_access :
-  Prename.t -> local_env -> identifier * identifier -> constr -> constr
-
-val make_raw_store :
-  Prename.t -> local_env -> identifier * identifier 
-    -> constr -> constr -> constr
-
-val make_pre_access :
-  Prename.t -> local_env -> identifier -> constr -> constr
-
diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml
deleted file mode 100644
index 669727fc..00000000
--- a/contrib/correctness/pred.ml
+++ /dev/null
@@ -1,115 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pred.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Past
-open Pmisc
-
-let rec cc_subst subst = function
-  | CC_var id as c -> 
-      (try CC_expr (List.assoc id subst) with Not_found -> c)
-  | CC_letin (b,ty,bl,c1,c2) ->
-      CC_letin (b, real_subst_in_constr subst ty, cc_subst_binders subst bl,
-		cc_subst subst c1, cc_subst (cc_cross_binders subst bl) c2)
-  | CC_lam (bl, c) ->
-      CC_lam (cc_subst_binders subst bl, 
-	      cc_subst (cc_cross_binders subst bl) c)
-  | CC_app (c, cl) ->
-      CC_app (cc_subst subst c, List.map (cc_subst subst) cl)
-  | CC_tuple (b, tl, cl) ->
-      CC_tuple (b, List.map (real_subst_in_constr subst) tl,
-		List.map (cc_subst subst) cl)
-  | CC_case (ty, c, cl) ->
-      CC_case (real_subst_in_constr subst ty, cc_subst subst c,
-	       List.map (cc_subst subst) cl)
-  | CC_expr c ->
-      CC_expr (real_subst_in_constr subst c)
-  | CC_hole ty ->
-      CC_hole (real_subst_in_constr subst ty)
-
-and cc_subst_binders subst = List.map (cc_subst_binder subst)
-
-and cc_subst_binder subst = function
-  | id,CC_typed_binder c -> id,CC_typed_binder (real_subst_in_constr subst c)
-  | b -> b
-
-and cc_cross_binders subst = function
-  | [] -> subst
-  | (id,_) :: bl -> cc_cross_binders (List.remove_assoc id subst) bl
-
-(* here we only perform eta-reductions on programs to eliminate
- * redexes of the kind
- *
- *   let (x1,...,xn) = e in (x1,...,xn)  -->  e
- *
- *)
-
-let is_eta_redex bl al =
-  try
-    List.for_all2
-      (fun (id,_) t -> match t with CC_var id' -> id=id' | _ -> false)
-      bl al
-  with
-      Invalid_argument("List.for_all2") -> false
-
-let rec red = function
-  | CC_letin (_, _, [id,_], CC_expr c1, e2) ->
-      red (cc_subst [id,c1] e2)
-  | CC_letin (dep, ty, bl, e1, e2) ->
-      begin match red e2 with
-	| CC_tuple (false,tl,al) ->
-	    if is_eta_redex bl al then
-	      red e1
-	    else
-	      CC_letin (dep, ty, bl, red e1,
-			CC_tuple (false,tl,List.map red al))
-	| e -> CC_letin (dep, ty, bl, red e1, e)
-      end
-  | CC_lam (bl, e) ->
-      CC_lam (bl, red e)
-  | CC_app (e, al) ->
-      CC_app (red e, List.map red al)
-  | CC_case (ty, e1, el) ->
-      CC_case (ty, red e1, List.map red el)
-  | CC_tuple (dep, tl, al) ->
-      CC_tuple (dep, tl, List.map red al)
-  | e -> e
-
-
-(* How to reduce uncomplete proof terms when they have become constr *)
-
-open Term
-open Reductionops
-
-(* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait
- * la substitution d'une métavariable.
- * 
- * On commence par rendre toutes les applications binaire (strong bin_app)
- * puis on applique la reduction spéciale programmes définie dans
- * typing/reduction *)
-
-(*i
-let bin_app = function
-  | DOPN(AppL,v) as c ->
-      (match Array.length v with
-	 | 1 -> v.(0)
-	 | 2 -> c
-	 | n ->
-	     let f = DOPN(AppL,Array.sub v 0 (pred n)) in
-	     DOPN(AppL,[|f;v.(pred n)|]))
-  | c -> c
-i*)
-
-let red_cci c = 
-  (*i let c = strong bin_app c in i*) 
-  strong whd_programs (Global.env ()) Evd.empty c
-
diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli
deleted file mode 100644
index a5a9549b..00000000
--- a/contrib/correctness/pred.mli
+++ /dev/null
@@ -1,26 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pred.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Past
-
-(* reduction on intermediate programs 
- * get rid of redexes of the kind let (x1,...,xn) = e in (x1,...,xn) *)
-
-val red : cc_term -> cc_term
-
-
-(* Ad-hoc reduction on partial proof terms *)
-
-val red_cci : constr -> constr
-
-
diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml
deleted file mode 100644
index 4ef1982d..00000000
--- a/contrib/correctness/prename.ml
+++ /dev/null
@@ -1,139 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: prename.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Nameops
-open Util
-open Pp
-open Himsg
-open Pmisc
-
-(* Variables names management *)
-
-type date = string
-
-(* The following data structure keeps the successive names of the variables
- * as we traverse the program. A each step a ``date'' and a
- * collection of new names is (possibly) given, and updates the
- * previous renaming.
- * 
- * Then, we can ask for the name of a variable, at current date or
- * at a given date.
- *
- * It is easily represented by a list of date x assoc list, most recent coming 
- * first i.e. as follows:
- *
- *   [ date (= current), [ (x,xi); ... ];
- *     date            , [ (z,zk); ... ];
- *     ...
- *     date (= initial), [ (x,xj); (y,yi); ... ]
- *
- * We also keep a list of all names already introduced, in order to
- * quickly get fresh names.
- *)
-
-type t =
-    { levels : (date * (identifier * identifier) list) list;
-      avoid  : identifier list;
-      cpt    : int }
-    
-
-let empty_ren = { levels = []; avoid = []; cpt = 0 }
-
-let update r d ids =
-  let al,av = renaming_of_ids r.avoid ids in
-  { levels = (d,al) :: r.levels; avoid = av; cpt = r.cpt }
-
-let push_date r d = update r d []
-
-let next r ids =
-  let al,av = renaming_of_ids r.avoid ids in
-  let n = succ r.cpt in
-  let d = string_of_int n in
-  { levels = (d,al) :: r.levels; avoid = av; cpt = n }
-
-
-let find r x =
-  let rec find_in_one = function
-      []         -> raise Not_found
-    | (y,v)::rem -> if y = x then v else find_in_one rem
-  in
-  let rec find_in_all = function
-      []         -> raise Not_found
-    | (_,l)::rem -> try find_in_one l with Not_found -> find_in_all rem
-  in
-    find_in_all r.levels
-
-
-let current_var = find
-
-let current_vars r ids = List.map (fun id -> id,current_var r id) ids
-
-
-let avoid r ids = { levels = r.levels; avoid = r.avoid @ ids; cpt = r.cpt }
-
-let fresh r ids = fst (renaming_of_ids r.avoid ids)
-
-
-let current_date r =
-  match r.levels with
-      [] -> invalid_arg "Renamings.current_date"
-    | (d,_)::_ -> d
-
-let all_dates r = List.map fst r.levels
-
-let rec valid_date da r = 
-  let rec valid = function
-      [] -> false
-    | (d,_)::rem -> (d=da) or (valid rem)
-  in
-    valid r.levels
-
-(* [until d r] selects the part of the renaming [r] starting from date [d] *)
-let rec until da r =
-  let rec cut = function
-      [] -> invalid_arg "Renamings.until"
-    | (d,_)::rem as r -> if d=da then r else cut rem
-  in
-    { avoid = r.avoid; levels = cut r.levels; cpt = r.cpt }
-
-let var_at_date r d id =
-  try
-    find (until d r) id
-  with Not_found ->
-    raise (UserError ("Renamings.var_at_date",
-	      hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++
-		       str"at date " ++ str d)))
-
-let vars_at_date r d ids =
-  let r' = until d r in List.map (fun id -> id,find r' id) ids
-
-
-(* pretty-printers *)
-
-open Pp
-open Util
-open Himsg
-
-let pp r = 
-  hov 2 (prlist_with_sep (fun () -> (fnl ()))
-	   (fun (d,l) -> 
-	      (str d ++ str": " ++ 
-		 prlist_with_sep (fun () -> (spc ()))
-		   (fun (id,id') -> 
-		      (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")"))
-		   l))
-	   r.levels)
-
-let ppr e =
-  Pp.pp (pp e)
-
diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli
deleted file mode 100644
index 1d3ab669..00000000
--- a/contrib/correctness/prename.mli
+++ /dev/null
@@ -1,57 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: prename.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-(* Abstract type for renamings 
- * 
- * Records the names of the mutables objets (ref, arrays) at the different
- * moments of the evaluation, called dates
- *)
-
-type t
-
-type date = string
-
-
-val empty_ren : t
-val update    : t -> date -> identifier list -> t
-    (* assign new names for the given variables, associated to a new date *)
-val next      : t -> identifier list -> t
-    (* assign new names for the given variables, associated to a new
-     * date which is generated from an internal counter *)
-val push_date : t -> date -> t
-    (* put a new date on top of the stack *)
-
-val valid_date   : date -> t -> bool
-val current_date : t -> date
-val all_dates    : t -> date list
-
-val current_var  : t -> identifier      -> identifier
-val current_vars : t -> identifier list -> (identifier * identifier) list
-    (* gives the current names of some variables *)
-
-val avoid : t -> identifier list -> t
-val fresh : t -> identifier list -> (identifier * identifier) list
-    (* introduces new names to avoid and renames some given variables *)
-
-val var_at_date  : t -> date -> identifier -> identifier
-    (* gives the name of a variable at a given date *)
-val vars_at_date : t -> date -> identifier list
-                 -> (identifier * identifier) list
-    (* idem for a list of variables *)  
-
-(* pretty-printers *)
-
-val pp : t -> Pp.std_ppcmds
-val ppr : t -> unit
-
diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4
deleted file mode 100644
index 98d43112..00000000
--- a/contrib/correctness/psyntax.ml4
+++ /dev/null
@@ -1,1058 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Options
-open Util
-open Names
-open Nameops
-open Vernacentries
-open Reduction
-open Term
-open Libnames
-open Topconstr
-
-open Prename
-open Pmisc
-open Putil
-open Ptype
-open Past
-open Penv
-open Pmonad
-open Vernacexpr
-
-
-(* We define new entries for programs, with the use of this module
- * Programs. These entries are named Programs.<foo>
- *)
-
-module Gram = Pcoq.Gram
-module Constr = Pcoq.Constr
-module Tactic = Pcoq.Tactic
-
-module Programs =
-  struct
-    let gec s = Gram.Entry.create ("Programs."^s)
-    (* types *)
-    let type_v   = gec "type_v"
-    let type_v0  = gec "type_v0"
-    let type_v1  = gec "type_v1"
-    let type_v2  = gec "type_v2"
-    let type_v3  = gec "type_v3"
-    let type_v_app  = gec "type_v_app"
-    let type_c   = gec "type_c"
-    let effects  = gec "effects"
-    let reads    = gec "reads"
-    let writes   = gec "writes"
-    let pre_condition = gec "pre_condition"
-    let post_condition = gec "post_condition"
-    (* binders *)
-    let binder  = gec "binder"
-    let binder_type = gec "binder_type"
-    let binders  = gec "binders"
-    (* programs *)
-    let program = gec "program"
-    let prog1 = gec "prog1"
-    let prog2 = gec "prog2"
-    let prog3 = gec "prog3"
-    let prog4 = gec "prog4"
-    let prog5 = gec "prog5"
-    let prog6 = gec "prog6"
-    let prog7 = gec "prog7"
-    let ast1 = gec "ast1"
-    let ast2 = gec "ast2"
-    let ast3 = gec "ast3"
-    let ast4 = gec "ast4"
-    let ast5 = gec "ast5"
-    let ast6 = gec "ast6"
-    let ast7 = gec "ast7"
-    let arg = gec "arg"
-    let block = gec "block"
-    let block_statement = gec "block_statement"
-    let relation = gec "relation"
-    let variable = gec "variable"
-    let invariant = gec "invariant"
-    let variant = gec "variant"
-    let assertion = gec "assertion"
-    let precondition = gec "precondition"
-    let postcondition = gec "postcondition"
-    let predicate = gec "predicate"
-    let name = gec "name"
-  end
-
-open Programs
-
-let ast_of_int n = 
-  CDelimiters
-    (dummy_loc, "Z", CNumeral (dummy_loc, Bignat.POS (Bignat.of_string n)))
-
-let constr_of_int n =
-  Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n)
-
-open Util
-open Coqast
-
-let mk_id loc id = mkRefC (Ident (loc, id))
-let mk_ref loc s = mk_id loc (Constrextern.id_of_v7_string s)
-let mk_appl loc1 loc2 f args =
-  CApp (join_loc loc1 loc2, (None,mk_ref loc1 f), List.map (fun a -> a,None) args)
-
-let conj_assert {a_name=n;a_value=a} {a_value=b} = 
-  let loc1 = constr_loc a in
-  let loc2 = constr_loc a in
-  { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n }
-
-let conj = function
-    None,None     -> None
-  | None,b        -> b
-  | a,None        -> a
-  | Some a,Some b -> Some (conj_assert a b)
-
-let without_effect loc d = 
-  { desc = d; pre = []; post = None; loc = loc; info = () }
-
-let isevar = Expression isevar
-
-let bin_op op loc e1 e2 =
-  without_effect loc
-    (Apply (without_effect loc (Expression (constant op)),
-            [ Term e1; Term e2 ]))
-
-let un_op op loc e =
-  without_effect loc
-    (Apply (without_effect loc (Expression (constant op)), [Term e]))
-
-let bool_bin op loc a1 a2 =
-  let w = without_effect loc in
-  let d = SApp ( [Variable op], [a1; a2]) in
-  w d
-
-let bool_or  loc = bool_bin connective_or loc
-let bool_and loc = bool_bin connective_and loc
-
-let bool_not loc a =
-  let w = without_effect loc in
-  let d = SApp ( [Variable connective_not ], [a]) in
-  w d
-
-let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "Z0"]
-
-(* program -> Coq AST *)
-
-let bdize c =
-  let env = 
-    Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty)
-  in
-  Constrextern.extern_constr true env c
-
-let rec coqast_of_program loc = function
-  | Variable id -> mk_id loc id
-  | Acc id -> mk_id loc id
-  | Apply (f,l) -> 
-      let f = coqast_of_program f.loc f.desc in
-      let args = List.map 
-		   (function Term t -> (coqast_of_program t.loc t.desc,None)
-		      | _ -> invalid_arg "coqast_of_program") l
-      in
-      CApp (dummy_loc, (None,f), args)
-  | Expression c -> bdize c
-  | _ -> invalid_arg "coqast_of_program"
-
-(* The construction `for' is syntactic sugar.
- *
- * for i = v1 to v2 do { invariant Inv } block done
- *
- * ==> (let rec f i { variant v2+1-i } = 
- *        { i <= v2+1 /\ Inv(i) }
- *        (if i > v2 then tt else begin block; (f (i+1)) end) 
- *        { Inv(v2+1) }
- *      in (f v1)) { Inv(v2+1) }
- *)
-
-let ast_plus_un loc ast =
-  let un = ast_of_int "1" in
-  mk_appl loc loc "Zplus" [ast;un]
-
-let make_ast_for loc i v1 v2 inv block =
-  let f = for_name() in
-  let id_i = id_of_string i in
-  let var_i = without_effect loc (Variable id_i) in
-  let var_f = without_effect loc (Variable f) in
-  let succ_v2 = 
-    let a_v2 = coqast_of_program v2.loc v2.desc in
-    ast_plus_un loc a_v2 in
-  let post = named_app (subst_ast_in_ast [ id_i, succ_v2 ]) inv in
-  let e1 =
-    let test = bin_op "Z_gt_le_bool" loc var_i v2 in
-    let br_t = without_effect loc (Expression (constant "tt")) in
-    let br_f = 
-      let un = without_effect loc (Expression (constr_of_int "1")) in
-      let succ_i = bin_op "Zplus" loc var_i un in
-      let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in
-      without_effect loc (Seq (block @ [Statement f_succ_i]))
-    in
-    let inv' = 
-      let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in
-      conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv
-    in
-    { desc = If(test,br_t,br_f); loc = loc; 
-      pre = [pre_of_assert false inv']; post = Some post; info = () } 
-  in
-  let bl = 
-    let typez = mk_ref loc "Z" in
-    [(id_of_string i, BindType (TypePure typez))] 
-  in
-  let fv1 = without_effect loc (Apply (var_f, [Term v1])) in
-  let v = TypePure (mk_ref loc "unit") in
-  let var = 
-    let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in
-    (a, ast_zwf_zero loc)
-  in
-  Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1)
-
-let mk_prog loc p pre post =
-  { desc = p.desc; 
-    pre = p.pre @ pre; 
-    post = conj (p.post,post); 
-    loc = loc; 
-    info = () }
-
-if !Options.v7 then
-GEXTEND Gram
-
-  (* Types ******************************************************************)
-  type_v:
-    [ [ t = type_v0 -> t ] ]
-  ;
-  type_v0:
-    [ [ t = type_v1 -> t ] ]
-  ;
-  type_v1:
-    [ [ t = type_v2 -> t ] ]
-  ;
-  type_v2:
-    [ LEFTA
-      [ v = type_v2; IDENT "ref" -> Ref v
-      | t = type_v3 -> t ] ]
-  ;
-  type_v3:
-    [ [ IDENT "array"; size = Constr.constr; "of"; v = type_v0 ->
-          Array (size,v)
-      | IDENT "fun"; bl = binders; c = type_c -> make_arrow bl c
-      | c = Constr.constr -> TypePure c	  
-      ] ]
-  ;
-  type_c:
-    [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
-        e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
-        ((id_of_string id, v), e, list_of_some p, q)
-      ] ] 
-  ;
-  effects:
-    [ [ r = OPT reads; w = OPT writes ->
-	let r' = match r with Some l -> l | _ -> [] in
-	let w' = match w with Some l -> l | _ -> [] in
-	List.fold_left (fun e x -> Peffect.add_write x e)
-	  (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
-          w'
-      ] ]
-  ;
-  reads:
-    [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
-  ;
-  writes:
-    [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
-  ;
-  pre_condition:
-    [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
-  ;
-  post_condition:
-    [ [ IDENT "post"; c = predicate -> c ] ]
-  ;
-
-  (* Binders (for both types and programs) **********************************)
-  binder:
-    [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
-	  List.map (fun s -> (id_of_string s, t)) sl
-      ] ]
-  ;
-  binder_type:
-    [ [ "Set" -> BindSet
-      | v = type_v -> BindType v
-      ] ]
-  ;
-  binders:
-    [ [ bl = LIST0 binder -> List.flatten bl ] ] 
-  ;
-
-  (* annotations *)
-  predicate:
-    [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
-  ;
-  name:
-    [ [ "as"; s = IDENT -> Name (id_of_string s)
-      | -> Anonymous
-      ] ]
-  ;
-
-  (* Programs ***************************************************************)
-  variable:
-    [ [ s = IDENT -> id_of_string s ] ]
-  ;
-  assertion:
-    [ [ "{"; c = predicate; "}" -> c ] ]
-  ;
-  precondition:
-    [ [ "{"; c = predicate; "}" -> pre_of_assert false c ] ]
-  ;
-  postcondition:
-    [ [ "{"; c = predicate; "}" -> c ] ]
-  ;
-  program:
-    [ [ p = prog1 -> p ] ]
-  ;
-  prog1:
-    [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog2:
-    [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog3:
-    [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog4:
-    [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog5:
-    [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog6:
-    [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-
-  ast1:
-    [ [ x = prog2; IDENT "or"; y = prog1  -> bool_or loc x y
-      | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
-      | x = prog2 -> x
-      ] ]
-  ;
-  ast2:
-    [ [ IDENT "not"; x = prog3 -> bool_not loc x
-      | x = prog3 -> x
-      ] ]
-  ;
-  ast3:
-    [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
-      | x = prog4 -> x
-      ] ]
-    ;
-  ast4:
-    [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
-      | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
-      | x = prog5 -> x
-      ] ]
-    ;
-  ast5:
-    [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y 
-      | x = prog6 -> x
-      ] ]
-    ;
-  ast6:
-    [ [ "-"; x = prog6 -> un_op "Zopp" loc x
-      | x = ast7 -> without_effect loc x
-      ] ]
-    ;
-  ast7:
-    [ [ v = variable -> 
-	  Variable v
-      | n = INT ->
-	  Expression (constr_of_int n)
-      | "!"; v = variable ->
-	  Acc v
-      | "?" ->
-	  isevar
-      | v = variable; ":="; p = program ->
-	  Aff (v,p)
-      | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
-      | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
-      | v = variable; "["; e = program; "]"; ":="; p = program -> 
-	  TabAff (true,v,e,p)
-      | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> 
-	  TabAff (true,v,e,p)
-      | IDENT "if"; e1 = program; IDENT "then"; e2 = program;
-	IDENT "else"; e3 = program ->
-	  If (e1,e2,e3)
-      | IDENT "if"; e1 = program; IDENT "then"; e2 = program ->
-	  If (e1,e2,without_effect loc (Expression (constant "tt")))
-      | IDENT "while"; b = program; IDENT "do"; 
-	"{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
-	bl = block; IDENT "done" ->
-	  While (b, inv, wf, bl)
-      | IDENT "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
-	IDENT "do"; "{"; inv = invariant; "}"; 
-	bl = block; IDENT "done" -> 
-	  make_ast_for loc i v1 v2 inv bl
-      | IDENT "let"; v = variable; "="; IDENT "ref"; p1 = program;
-	"in"; p2 = program ->
-	  LetRef (v, p1, p2)
-      | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
-	  Let (v, p1, p2)
-      | IDENT "begin"; b = block; "end" ->
-	  Seq b
-      | IDENT "fun"; bl = binders; "->"; p = program ->
-	  Lam (bl,p)
-      | IDENT "let"; IDENT "rec"; f = variable; 
-	bl = binders; ":"; v = type_v;
-	"{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
-	  LetRec (f,bl,v,var,p)
-      | IDENT "let"; IDENT "rec"; f = variable; 
-	bl = binders; ":"; v = type_v;
-	"{"; IDENT "variant"; var = variant; "}"; "="; p = program;
- 	"in"; p2 = program ->
-	  Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
-
-      | "@"; s = STRING; p = program ->
-	  Debug (s,p)
-
-      | "("; p = program; args = LIST0 arg; ")" ->
-	  match args with 
-	      [] -> 
-		if p.pre<>[] or p.post<>None then
-		  Pp.warning "Some annotations are lost";
-		p.desc
-            | _  -> 
-		Apply(p,args)
-     ] ]
-  ;
-  arg:
-    [ [ "'"; t = type_v -> Type t
-      | p = program -> Term p
-      ] ]
-  ;
-  block:
-    [ [ s = block_statement; ";"; b = block -> s::b
-      | s = block_statement                 -> [s] ] ]
-  ;
-  block_statement:
-    [ [ IDENT "label"; s = IDENT -> Label s
-      | IDENT "assert"; c = assertion -> Assert c 
-      | p = program -> Statement p ] ]
-  ;
-  relation:
-    [ [ "<"  -> "Z_lt_ge_bool"
-      | "<=" -> "Z_le_gt_bool"
-      | ">"  -> "Z_gt_le_bool"
-      | ">=" -> "Z_ge_lt_bool"
-      | "="  -> "Z_eq_bool"
-      | "<>" -> "Z_noteq_bool" ] ] 
-  ;
-
-  (* Other entries (invariants, etc.) ***************************************)
-  invariant:
-    [ [ IDENT "invariant"; c = predicate -> c ] ]
-  ;
-  variant:
-    [ [ c = Constr.constr; IDENT "for"; r = Constr.constr -> (c, r)
-      | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
-  ;
-  END
-else
-GEXTEND Gram
-  GLOBAL: type_v program;
-
-  (* Types ******************************************************************)
-  type_v:
-    [ [ t = type_v0 -> t ] ]
-  ;
-  type_v0:
-    [ [ t = type_v1 -> t ] ]
-  ;
-  type_v1:
-    [ [ t = type_v2 -> t ] ]
-  ;
-  type_v2:
-    [ LEFTA
-      [ v = type_v2; IDENT "ref" -> Ref v
-      | t = type_v3 -> t ] ]
-  ;
-  type_v3:
-    [ [ IDENT "array"; size = Constr.constr; IDENT "of"; v = type_v0 ->
-          Array (size,v)
-      | "fun"; bl = binders; c = type_c -> make_arrow bl c
-      | c = Constr.constr -> TypePure c	  
-      ] ]
-  ;
-  type_c:
-    [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
-        e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
-        ((id_of_string id, v), e, list_of_some p, q)
-      ] ] 
-  ;
-  effects:
-    [ [ r = OPT reads; w = OPT writes ->
-	let r' = match r with Some l -> l | _ -> [] in
-	let w' = match w with Some l -> l | _ -> [] in
-	List.fold_left (fun e x -> Peffect.add_write x e)
-	  (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
-          w'
-      ] ]
-  ;
-  reads:
-    [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
-  ;
-  writes:
-    [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
-  ;
-  pre_condition:
-    [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
-  ;
-  post_condition:
-    [ [ IDENT "post"; c = predicate -> c ] ]
-  ;
-
-  (* Binders (for both types and programs) **********************************)
-  binder:
-    [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
-	  List.map (fun s -> (id_of_string s, t)) sl
-      ] ]
-  ;
-  binder_type:
-    [ [ "Set" -> BindSet
-      | v = type_v -> BindType v
-      ] ]
-  ;
-  binders:
-    [ [ bl = LIST0 binder -> List.flatten bl ] ] 
-  ;
-
-  (* annotations *)
-  predicate:
-    [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
-  ;
-  dpredicate:
-    [ [ c = Constr.lconstr; n = name -> { a_name = n; a_value = c } ] ]
-  ;
-  name:
-    [ [ "as"; s = IDENT -> Name (id_of_string s)
-      | -> Anonymous
-      ] ]
-  ;
-
-  (* Programs ***************************************************************)
-  variable:
-    [ [ s = IDENT -> id_of_string s ] ]
-  ;
-  assertion:
-    [ [ "{"; c = dpredicate; "}" -> c ] ]
-  ;
-  precondition:
-    [ [ "{"; c = dpredicate; "}" -> pre_of_assert false c ] ]
-  ;
-  postcondition:
-    [ [ "{"; c = dpredicate; "}" -> c ] ]
-  ;
-  program:
-    [ [ p = prog1 -> p ] ]
-  ;
-  prog1:
-    [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog2:
-    [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog3:
-    [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog4:
-    [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog5:
-    [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-  prog6:
-    [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
-	  mk_prog loc ast pre post ] ]
-  ;
-
-  ast1:
-    [ [ x = prog2; IDENT "or"; y = prog1  -> bool_or loc x y
-      | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
-      | x = prog2 -> x
-      ] ]
-  ;
-  ast2:
-    [ [ IDENT "not"; x = prog3 -> bool_not loc x
-      | x = prog3 -> x
-      ] ]
-  ;
-  ast3:
-    [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
-      | x = prog4 -> x
-      ] ]
-    ;
-  ast4:
-    [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
-      | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
-      | x = prog5 -> x
-      ] ]
-    ;
-  ast5:
-    [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y 
-      | x = prog6 -> x
-      ] ]
-    ;
-  ast6:
-    [ [ "-"; x = prog6 -> un_op "Zopp" loc x
-      | x = ast7 -> without_effect loc x
-      ] ]
-    ;
-  ast7:
-    [ [ v = variable -> 
-	  Variable v
-      | n = INT ->
-	  Expression (constr_of_int n)
-      | "!"; v = variable ->
-	  Acc v
-      | "?" ->
-	  isevar
-      | v = variable; ":="; p = program ->
-	  Aff (v,p)
-      | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
-      | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
-      | v = variable; "["; e = program; "]"; ":="; p = program -> 
-	  TabAff (true,v,e,p)
-      | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> 
-	  TabAff (true,v,e,p)
-      | "if"; e1 = program; "then"; e2 = program; "else"; e3 = program ->
-	  If (e1,e2,e3)
-      | "if"; e1 = program; "then"; e2 = program ->
-	  If (e1,e2,without_effect loc (Expression (constant "tt")))
-      | IDENT "while"; b = program; IDENT "do"; 
-	"{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
-	bl = block; IDENT "done" ->
-	  While (b, inv, wf, bl)
-      | "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
-	IDENT "do"; "{"; inv = invariant; "}"; 
-	bl = block; IDENT "done" -> 
-	  make_ast_for loc i v1 v2 inv bl
-      | "let"; v = variable; "="; IDENT "ref"; p1 = program;
-	"in"; p2 = program ->
-	  LetRef (v, p1, p2)
-      | "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
-	  Let (v, p1, p2)
-      | IDENT "begin"; b = block; "end" ->
-	  Seq b
-      | "fun"; bl = binders; "=>"; p = program ->
-	  Lam (bl,p)
-      | "let"; IDENT "rec"; f = variable; 
-	bl = binders; ":"; v = type_v;
-	"{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
-	  LetRec (f,bl,v,var,p)
-      | "let"; IDENT "rec"; f = variable; 
-	bl = binders; ":"; v = type_v;
-	"{"; IDENT "variant"; var = variant; "}"; "="; p = program;
- 	"in"; p2 = program ->
-	  Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
-
-      | "@"; s = STRING; p = program ->
-	  Debug (s,p)
-
-      | "("; p = program; args = LIST0 arg; ")" ->
-	  match args with 
-	      [] -> 
-		if p.pre<>[] or p.post<>None then
-		  Pp.warning "Some annotations are lost";
-		p.desc
-            | _  -> 
-		Apply(p,args)
-     ] ]
-  ;
-  arg:
-    [ [ "'"; t = type_v -> Type t
-      | p = program -> Term p
-      ] ]
-  ;
-  block:
-    [ [ s = block_statement; ";"; b = block -> s::b
-      | s = block_statement                 -> [s] ] ]
-  ;
-  block_statement:
-    [ [ IDENT "label"; s = IDENT -> Label s
-      | IDENT "assert"; c = assertion -> Assert c 
-      | p = program -> Statement p ] ]
-  ;
-  relation:
-    [ [ "<"  -> "Z_lt_ge_bool"
-      | "<=" -> "Z_le_gt_bool"
-      | ">"  -> "Z_gt_le_bool"
-      | ">=" -> "Z_ge_lt_bool"
-      | "="  -> "Z_eq_bool"
-      | "<>" -> "Z_noteq_bool" ] ] 
-  ;
-
-  (* Other entries (invariants, etc.) ***************************************)
-  invariant:
-    [ [ IDENT "invariant"; c = predicate -> c ] ]
-  ;
-  variant:
-    [ [ c = Constr.constr; "for"; r = Constr.constr -> (c, r)
-      | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
-  ;
-  END
-;;
-
-let wit_program, globwit_program, rawwit_program =
-  Genarg.create_arg "program"
-let wit_type_v, globwit_type_v, rawwit_type_v =
-  Genarg.create_arg "type_v"
-
-open Pp
-open Util
-open Himsg
-open Vernacinterp
-open Vernacexpr
-open Declare
-
-let is_assumed global ids =
-  if List.length ids = 1 then
-    msgnl (str (if global then "A global variable " else "") ++ 
-	     pr_id (List.hd ids) ++ str " is assumed")
-  else
-    msgnl (str (if global then "Some global variables " else "") ++
-	     prlist_with_sep (fun () -> (str ", ")) pr_id ids ++
-	     str " are assumed")
-
-open Pcoq
-
-(* Variables *)
-
-let wit_variables, globwit_variables, rawwit_variables =
-  Genarg.create_arg "variables"
-
-let variables = Gram.Entry.create "Variables"
-
-GEXTEND Gram
-  variables: [ [ l = LIST1 Prim.ident SEP "," -> l ] ];
-END
-
-let pr_variables _prc _prtac l = spc() ++ prlist_with_sep pr_coma pr_id l
-
-let _ =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_variables, pr_variables)
-    (globwit_variables, pr_variables)
-    (wit_variables, pr_variables)
-
-(* then_tac *)
-
-open Genarg
-open Tacinterp
-
-let pr_then_tac _ prt = function
-  | None -> mt ()
-  | Some t -> pr_semicolon () ++ prt t
-
-ARGUMENT EXTEND then_tac
-  TYPED AS tactic_opt 
-  PRINTED BY pr_then_tac
-  INTERPRETED BY interp_genarg
-  GLOBALIZED BY intern_genarg
-| [ ";" tactic(t) ] -> [ Some t ]
-| [ ] -> [ None ]
-END
-
-(* Correctness *)
-
-VERNAC COMMAND EXTEND Correctness
-  [ "Correctness" preident(str) program(pgm) then_tac(tac) ]
-   -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ]
-END
-
-(* Show Programs *)
-
-let show_programs () =
-  fold_all 
-    (fun (id,v) _ -> 
-      msgnl (pr_id id ++ str " : " ++ 
-      hov 2 (match v with TypeV v -> pp_type_v v
-	| Set -> (str "Set")) ++
-      fnl ()))
-    Penv.empty ()
-
-VERNAC COMMAND EXTEND ShowPrograms
-  [ "Show" "Programs" ] -> [ show_programs () ]
-END
-
-(* Global Variable *)
-
-let global_variable ids v =
-  List.iter
-    (fun id -> if Penv.is_global id then
-      Util.errorlabstrm "PROGVARIABLE"
-	(str"Clash with previous constant " ++ pr_id id))
-    ids;
-  Pdb.check_type_v (all_refs ()) v;
-  let env = empty in
-  let ren = update empty_ren "" [] in
-  let v = Ptyping.cic_type_v env ren v in
-  if not (is_mutable v) then begin
-    let c = 
-      Entries.ParameterEntry (trad_ml_type_v ren env v),
-      Decl_kinds.IsAssumption Decl_kinds.Definitional in
-    List.iter 
-      (fun id -> ignore (Declare.declare_constant id c)) ids;
-    if_verbose (is_assumed false) ids
-  end;
-  if not (is_pure v) then begin
-    List.iter (fun id -> ignore (Penv.add_global id v None)) ids;
-    if_verbose (is_assumed true) ids
-  end
-
-VERNAC COMMAND EXTEND ProgVariable
-  [ "Global" "Variable" variables(ids) ":" type_v(t) ]
-  -> [ global_variable ids t]
-END
-
-let pr_id id = pr_id (Constrextern.v7_to_v8_id id)
-
-(* Type printer *)
-
-let pr_reads = function
-  | [] -> mt ()
-  | l -> spc () ++
-      hov 0 (str "reads" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
-
-let pr_writes = function
-  | [] -> mt ()
-  | l -> spc () ++
-      hov 0 (str "writes" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
-
-let pr_effects x =
-  let (ro,rw) = Peffect.get_repr x in pr_reads ro ++ pr_writes rw
-
-let pr_predicate delimited { a_name = n; a_value = c } =
-  (if delimited then Ppconstr.pr_lconstr else Ppconstr.pr_constr) c ++
-  (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt())
-
-let pr_assert b { p_name = x; p_value = v } =
-  pr_predicate b { a_name = x; a_value = v }
-
-let pr_pre_condition_list = function
-  | [] -> mt ()
-  | [pre] -> spc() ++ hov 0 (str "pre" ++ spc () ++ pr_assert false pre)
-  | _ -> assert false
-
-let pr_post_condition_opt = function
-  | None -> mt ()
-  | Some post ->
-      spc() ++ hov 0 (str "post" ++ spc () ++ pr_predicate false post)
-
-let rec pr_type_v_v8 = function
-  | Array (a,v) ->
-      str "array" ++ spc() ++ Ppconstr.pr_constr a ++ spc() ++ str "of " ++
-      pr_type_v_v8 v
-  | v -> pr_type_v3 v
-
-and pr_type_v3 = function
-  | Ref v -> pr_type_v3 v ++ spc () ++ str "ref"
-  | Arrow (bl,((id,v),e,prel,postl)) ->
-      str "fun" ++ spc() ++ hov 0 (prlist_with_sep cut pr_binder bl) ++
-      spc () ++ str "returns" ++ spc () ++ pr_id id ++ str ":" ++ 
-      pr_type_v_v8 v ++ pr_effects e ++ 
-      pr_pre_condition_list prel ++ pr_post_condition_opt postl ++
-      spc () ++ str "end"
-  | TypePure a -> Ppconstr.pr_constr a
-  | v -> str "(" ++ pr_type_v_v8 v ++ str ")"
-
-and pr_binder = function
-  | (id,BindType c) ->
-      str "(" ++ pr_id id ++ str ":" ++ pr_type_v_v8 c ++ str ")"
-  | (id,BindSet) ->
-      str "(" ++ pr_id id ++ str ":" ++ str "Set" ++ str ")"
-  | (id,Untyped) ->
-      str "<<<<< TODO: Untyped binder >>>>"
-
-let _ =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_type_v, fun _ _ -> pr_type_v_v8)
-    (globwit_type_v, fun _ -> raise Not_found)
-    (wit_type_v, fun _ -> raise Not_found)
-
-(* Program printer *)
-
-let pr_precondition pred = str "{" ++ pr_assert true pred ++ str "}" ++ spc ()
-
-let pr_postcondition pred = str "{" ++ pr_predicate true pred ++ str "}"
-
-let pr_invariant = function
-  | None -> mt ()
-  | Some c -> hov 2 (str "invariant" ++ spc ()  ++ pr_predicate false c)
-
-let pr_variant (c1,c2) =
-  Ppconstr.pr_constr c1 ++
-  (try Constrextern.check_same_type c2 (ast_zwf_zero dummy_loc); mt ()
-   with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstr.pr_constr c2))
-
-let rec pr_desc = function
-  | Variable id ->
-      (* Unsafe: should distinguish global names and bound vars *)
-      let vars = (* TODO *) Idset.empty in
-      let id = try 
-        snd (repr_qualid
-          (snd (qualid_of_reference 
-            (Constrextern.extern_reference
-              dummy_loc vars (Nametab.locate (make_short_qualid id))))))
-      with _ -> id in
-      pr_id id
-  | Acc id -> str "!" ++ pr_id id
-  | Aff (id,p) -> pr_id id ++ spc() ++ str ":=" ++ spc() ++ pr_prog p
-  | TabAcc (b,id,p) -> pr_id id ++ str "[" ++ pr_prog p ++ str "]"
-  | TabAff (b,id,p1,p2) ->
-      pr_id id ++ str "[" ++ pr_prog p1 ++ str "]" ++
-      str ":=" ++ pr_prog p2
-  | Seq bll -> 
-      hv 0 (str "begin" ++ spc () ++ pr_block bll ++ spc () ++ str "end")
-  | While (p1,inv,var,bll) ->
-      hv 0 (
-	hov 0 (str "while" ++ spc () ++ pr_prog p1 ++ spc () ++ str "do") ++
-	brk (1,2) ++
-	hv 2 (
-	  str "{ " ++ 
-	  pr_invariant inv ++ spc() ++
-	  hov 0 (str "variant" ++ spc () ++ pr_variant var)
-	  ++ str " }") ++ cut () ++
-	hov 0 (pr_block bll) ++ cut () ++ 
-	str "done")
-  | If (p1,p2,p3) ->
-      hov 1 (str "if " ++ pr_prog p1) ++ spc () ++
-      hov 0 (str "then" ++ spc () ++ pr_prog p2) ++ spc () ++
-      hov 0 (str "else" ++ spc () ++ pr_prog p3)
-  | Lam (bl,p) ->
-      hov 0 
-        (str "fun" ++ spc () ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ 
-	 spc () ++ str "=>") ++
-      pr_prog p
-  | Apply ({desc=Expression e; pre=[]; post=None} as p,args) when isConst e ->
-      begin match
-	string_of_id (snd (repr_path (Nametab.sp_of_global (ConstRef (destConst e))))),
-	args
-      with
-      | "Zmult", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"*" ++ pr_arg a2 ++ str ")"
-      | "Zplus", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"+" ++ pr_arg a2 ++ str ")"
-      | "Zminus", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"-" ++ pr_arg a2 ++ str ")"
-      | "Zopp", [a] ->
-	  str "( -" ++ pr_arg a ++ str ")"
-      | "Z_lt_ge_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"<" ++ pr_arg a2 ++ str ")"
-      | "Z_le_gt_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"<=" ++ pr_arg a2 ++ str ")"
-      | "Z_gt_le_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str">" ++ pr_arg a2 ++ str ")"
-      | "Z_ge_lt_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str">=" ++ pr_arg a2 ++ str ")"
-      | "Z_eq_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"=" ++ pr_arg a2 ++ str ")"
-      | "Z_noteq_bool", [a1;a2] ->
-	  str "(" ++ pr_arg a1 ++ str"<> " ++ pr_arg a2 ++ str ")"
-      | _ -> 
-	  str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
-	  str ")"
-      end
-  | Apply (p,args) ->
-      str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
-      str ")"
-  | SApp ([Variable v], args) ->
-      begin match string_of_id v, args with
-	| "prog_bool_and", [a1;a2] -> 
-	    str"(" ++ pr_prog a1 ++ spc() ++ str"and " ++ pr_prog a2 ++str")"
-	| "prog_bool_or", [a1;a2] -> 
-	    str"(" ++ pr_prog a1 ++ spc() ++ str"or " ++ pr_prog a2 ++ str")"
-	| "prog_bool_not", [a] ->
-	    str "(not " ++ pr_prog a ++ str ")"
-	| _ -> failwith "Correctness printer: TODO"
-      end
-  | SApp _ -> failwith "Correctness printer: TODO"
-  | LetRef (v,p1,p2) ->
-      hov 2 (
-	str "let " ++ pr_id v ++ str " =" ++ spc () ++ str "ref" ++ spc () ++
-	pr_prog p1 ++ str " in") ++
-      spc () ++ pr_prog p2
-  | Let (id, {desc=LetRec (f,bl,v,var,p); pre=[]; post=None },p2) when f=id ->
-      hov 2 (
-	str "let rec " ++ pr_id f ++ spc () ++
-	hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
-	str ":" ++ pr_type_v_v8 v ++ spc () ++
-	hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ 
-	spc() ++ str "=" ++ spc () ++ pr_prog p ++
- 	str " in") ++
-      spc () ++ pr_prog p2
-  | Let (v,p1,p2) ->
-      hov 2 (
-	str "let " ++ pr_id v ++ str " =" ++ spc () ++ pr_prog p1 ++ str" in")
-      ++ spc () ++ pr_prog p2
-  | LetRec (f,bl,v,var,p) ->
-      str "let rec " ++ pr_id f ++ spc () ++
-      hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
-      str ":" ++ pr_type_v_v8 v ++ spc () ++
-      hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++
-      spc () ++ str "=" ++ spc () ++ pr_prog p
-  | PPoint _ -> str "TODO: Ppoint" (* Internal use only *)
-  | Expression c ->
-      (* Numeral or "tt": use a printer which doesn't globalize *)
-      Ppconstr.pr_constr
-        (Constrextern.extern_constr_in_scope false "Z_scope" (Global.env()) c)
-  | Debug (s,p) -> str "@" ++ Pptactic.qsnew s ++ pr_prog p
-
-and pr_block_st = function
-  | Label s -> hov 0 (str "label" ++ spc() ++ str s)
-  | Assert pred -> 
-      hov 0 (str "assert" ++ spc() ++ hov 0 (pr_postcondition pred))
-  | Statement p -> pr_prog p
-
-and pr_block bl = prlist_with_sep pr_semicolon pr_block_st bl
-
-and pr_arg = function
-  | Past.Term p -> pr_prog p
-  | Past.Type t -> str "'" ++ pr_type_v_v8 t
-  | Refarg _ -> str "TODO: Refarg" (* Internal use only *)
-
-and pr_prog0 b { desc = desc; pre = pre; post = post } =
-  hv 0 (
-    prlist pr_precondition pre ++
-    hov 0
-      (if b & post<>None then str"(" ++ pr_desc desc ++ str")"
-       else pr_desc desc)
-    ++ Ppconstr.pr_opt pr_postcondition post)
-
-and pr_prog x = pr_prog0 true x
-
-let _ =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_program, fun _ _ a -> spc () ++ pr_prog0 false a)
-    (globwit_program, fun _ -> raise Not_found)
-    (wit_program, fun _ -> raise Not_found)
-
diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli
deleted file mode 100644
index c0f0990b..00000000
--- a/contrib/correctness/psyntax.mli
+++ /dev/null
@@ -1,25 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: psyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pcoq
-open Ptype
-open Past
-open Topconstr
-
-(* Grammar for the programs and the tactic Correctness *)
-
-module Programs :
-  sig
-    val program : program Gram.Entry.e
-    val type_v  : constr_expr ml_type_v Gram.Entry.e
-    val type_c  : constr_expr ml_type_c Gram.Entry.e
-  end
diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml
deleted file mode 100644
index babc607d..00000000
--- a/contrib/correctness/ptactic.ml
+++ /dev/null
@@ -1,258 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *)
-
-open Pp
-open Options
-open Names
-open Libnames
-open Term
-open Pretyping
-open Pfedit
-open Decl_kinds
-open Vernacentries
-
-open Pmisc
-open Putil
-open Past
-open Penv
-open Prename
-open Peffect
-open Pmonad
-
-(* [coqast_of_prog: program -> constr * constr]
- * Traduction d'un programme impératif en un but (second constr)
- * et un terme de preuve partiel pour ce but (premier constr)
- *)
-
-let coqast_of_prog p =
-  (* 1. db : séparation dB/var/const *)
-  let p = Pdb.db_prog p in
-
-  (* 2. typage avec effets *)
-  deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ());
-  let env = Penv.empty in
-  let ren = initial_renaming env in
-  let p = Ptyping.states ren env p in
-  let ((_,v),_,_,_) as c = p.info.kappa in
-  Perror.check_for_not_mutable p.loc v;
-  deb_print pp_type_c c;
-
-  (* 3. propagation annotations *)
-  let p = Pwp.propagate ren p in
-
-  (* 4a. traduction type *)
-  let ty = Pmonad.trad_ml_type_c ren env c in
-  deb_print (Printer.pr_lconstr_env (Global.env())) ty;
-
-  (* 4b. traduction terme (terme intermédiaire de type cc_term) *)
-  deb_mess 
-    (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ());
-  let cc = Pmlize.trans ren p in
-  let cc = Pred.red cc in
-  deb_print Putil.pp_cc_term cc;
-
-  (* 5. traduction en constr *)
-  deb_mess 
-    (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++ 
-       fnl ());
-  let r = Pcic.rawconstr_of_prog cc in
-  deb_print Printer.pr_lrawconstr r;
-
-  (* 6. résolution implicites *)
-  deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ());
-  let oc = understand_gen_tcc Evd.empty (Global.env()) [] None r in
-  deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
-
-  p,oc,ty,v
-
-(* [automatic : tactic]
- * 
- * Certains buts engendrés par "correctness" (ci-dessous)
- * sont réellement triviaux. On peut les résoudre aisément, sans pour autant
- * tomber dans la solution trop lourde qui consiste à faire "; Auto."
- *
- * Cette tactique fait les choses suivantes :
- *   o  elle élimine les hypothèses de nom loop<i>
- *   o  sur  G |- (well_founded nat lt) ==> Exact lt_wf.  
- *   o  sur  G |- (well_founded Z (Zwf c)) ==> Exact (Zwf_well_founded c)
- *   o  sur  G |- e = e' ==> Reflexivity.  (arg. de decr. des boucles)
- *                           sinon Try Assumption.
- *   o  sur  G |- P /\ Q ==> Try (Split; Assumption). (sortie de boucle)
- *   o  sinon, Try AssumptionBis (= Assumption + décomposition /\ dans hyp.)
- *             (pour entrée dans corps de boucle par ex.)
- *)
-
-open Pattern
-open Tacmach
-open Tactics
-open Tacticals
-open Equality
-open Nametab
-
-let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0)
-let lt = ConstRef (coq_constant ["Init";"Peano"] "lt")
-let well_founded = ConstRef (coq_constant ["Init";"Wf"] "well_founded")
-let z = IndRef (coq_constant ["ZArith";"BinInt"] "Z", 0)
-let and_ = IndRef (coq_constant ["Init";"Logic"] "and", 0)
-let eq = IndRef (coq_constant ["Init";"Logic"] "eq", 0)
-
-let mkmeta n = Nameops.make_ident "X" (Some n)
-let mkPMeta n = PMeta (Some (mkmeta n))
-
-(* ["(well_founded nat lt)"] *)
-let wf_nat_pattern = 
-  PApp (PRef well_founded, [| PRef nat; PRef lt |])
-(* ["((well_founded Z (Zwf ?1))"] *)
-let wf_z_pattern = 
-  let zwf = ConstRef (coq_constant ["ZArith";"Zwf"] "Zwf") in
-  PApp (PRef well_founded, [| PRef z; PApp (PRef zwf, [| mkPMeta 1 |]) |])
-(* ["(and ?1 ?2)"] *)
-let and_pattern = 
-  PApp (PRef and_, [| mkPMeta 1; mkPMeta 2 |])
-(* ["(eq ?1 ?2 ?3)"] *)
-let eq_pattern = 
-  PApp (PRef eq, [| mkPMeta 1; mkPMeta 2; mkPMeta 3 |])
-
-(* loop_ids: remove loop<i> hypotheses from the context, and rewrite
- * using Variant<i> hypotheses when needed. *)
- 
-let (loop_ids : tactic) = fun gl ->
-  let rec arec hyps gl =
-    let env = pf_env gl in
-    let concl = pf_concl gl in 
-    match hyps with
-      | [] -> tclIDTAC gl
-      | (id,a) :: al ->
-	  let s = string_of_id id in
-	  let n = String.length s in
-	  if n >= 4 & (let su = String.sub s 0 4 in su="loop" or su="Bool")
-	  then
-	    tclTHEN (clear [id]) (arec al) gl
-	  else if n >= 7 & String.sub s 0 7 = "Variant" then begin
-	    match pf_matches gl eq_pattern (body_of_type a) with
-	      | [_; _,varphi; _] when isVar varphi ->
-		  let phi = destVar varphi in
-		  if Termops.occur_var env phi concl then
-		    tclTHEN (rewriteLR (mkVar id)) (arec al) gl
-		  else
-		    arec al gl
-	      | _ -> assert false end
-	  else
-	    arec al gl
-  in 
-  arec (pf_hyps_types gl) gl
-
-(* assumption_bis: like assumption, but also solves ... h:A/\B ... |- A 
- * (resp. B) *)
-
-let (assumption_bis : tactic) = fun gl ->
-  let concl = pf_concl gl in 
-  let rec arec = function
-    | [] -> Util.error "No such assumption"
-    | (s,a) :: al ->
-	let a = body_of_type a in
-	if pf_conv_x_leq gl a concl then 
-          refine (mkVar s) gl
-	else if pf_is_matching gl and_pattern a then
-	  match pf_matches gl and_pattern a with
-	    | [_,c1; _,c2] -> 
-		if pf_conv_x_leq gl c1 concl then
-		  exact_check (applistc (constant "proj1") [c1;c2;mkVar s]) gl
-		else if pf_conv_x_leq gl c2 concl then
-		  exact_check (applistc (constant "proj2") [c1;c2;mkVar s]) gl
-		else
-		  arec al
-	    | _ -> assert false
-	else
-	  arec al
-  in 
-  arec (pf_hyps_types gl)
-
-(* automatic: see above *)
-
-let (automatic : tactic) =
-  tclTHEN
-    loop_ids
-    (fun gl ->
-       let c = pf_concl gl in
-	 if pf_is_matching gl wf_nat_pattern c then
-	   exact_check (constant "lt_wf") gl
-	 else if pf_is_matching gl wf_z_pattern c then
-	   let (_,z) = List.hd (pf_matches gl wf_z_pattern c) in
-	   exact_check (Term.applist (constant "Zwf_well_founded",[z])) gl
-	 else if pf_is_matching gl and_pattern c then
-	   (tclORELSE assumption_bis
-	      (tclTRY (tclTHEN simplest_split assumption))) gl
-	 else if pf_is_matching gl eq_pattern c then
-	   (tclORELSE reflexivity (tclTRY assumption_bis)) gl
-	 else
-	   tclTRY assumption_bis gl)
-      
-(* [correctness s p] : string -> program -> tactic option -> unit
- *
- * Vernac: Correctness <string> <program> [; <tactic>].
- *)
-
-let reduce_open_constr (em0,c) =
-  let existential_map_of_constr = 
-    let rec collect em c = match kind_of_term c with
-      | Cast (c',t) -> 
-	  (match kind_of_term c' with
-	     | Evar (ev,_) ->
-                 if not (Evd.mem em ev) then
-                   Evd.add em ev (Evd.find em0 ev)
-                 else
-                   em
-	     | _ -> fold_constr collect em c)
-      | Evar _ -> 
-	  assert false (* all existentials should be casted *)
-      | _ -> 
-	  fold_constr collect em c
-    in
-    collect Evd.empty
-  in
-  let c = Pred.red_cci c in
-  let em = existential_map_of_constr c in
-  (em,c)
-
-let register id n =
-  let id' = match n with None -> id | Some id' -> id' in
-  Penv.register id id'
-
-  (* On dit à la commande "Save" d'enregistrer les nouveaux programmes *)
-let correctness_hook _ ref = 
-  let pf_id = Nametab.id_of_global ref in
-  register pf_id None
-
-let correctness s p opttac =
-  Coqlib.check_required_library ["Coq";"correctness";"Correctness"];
-  Pmisc.reset_names();
-  let p,oc,cty,v = coqast_of_prog p in
-  let env = Global.env () in
-  let sign = Global.named_context () in
-  let sigma = Evd.empty in
-  let cty = Reduction.nf_betaiota cty in
-  let id = id_of_string s in 
-  start_proof id (IsGlobal (Proof Lemma)) sign cty correctness_hook;
-  Penv.new_edited id (v,p);
-  if !debug then msg (Pfedit.pr_open_subgoals());
-  deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ());
-  let oc = reduce_open_constr oc in
-  deb_mess (str"AFTER REDUCTION:" ++ fnl ());
-  deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
-  let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in
-  let tac = match opttac with 
-    | None -> tac
-    | Some t -> tclTHEN tac t
-  in
-  solve_nth 1 tac;
-  if_verbose msg (pr_open_subgoals ())
diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli
deleted file mode 100644
index 87378cff..00000000
--- a/contrib/correctness/ptactic.mli
+++ /dev/null
@@ -1,22 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptactic.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(* The main tactic: takes a name N, a program P, creates a goal
- * of name N with the functional specification of P, then apply the Refine
- * tactic with the partial proof term obtained by the translation of
- * P into a functional program.
- *
- * Then an ad-hoc automatic tactic is applied on each subgoal to solve the
- * trivial proof obligations *)
-
-val correctness : string -> Past.program -> Tacmach.tactic option -> unit
-
diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli
deleted file mode 100644
index be181bcc..00000000
--- a/contrib/correctness/ptype.mli
+++ /dev/null
@@ -1,73 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptype.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-
-(* Types des valeurs (V) et des calculs (C).
- *
- * On a C = r:V,E,P,Q 
- *
- *   et V = (x1:V1)...(xn:Vn)C | V ref | V array | <type pur>
- *
- * INVARIANT: l'effet E contient toutes les variables apparaissant dans
- *            le programme ET les annotations P et Q
- *            Si E = { x1,...,xn | y1,...,ym }, les variables x sont les
- *            variables en lecture seule et y1 les variables modifiées
- *            les xi sont libres dans P et Q, et les yi,result liées dans Q
- *            i.e.  P = p(x)
- *               et Q = [y1]...[yn][res]q(x,y,res)
- *)
-
-(* pre and post conditions *)
-
-type 'a precondition = { p_assert : bool; p_name : Names.name; p_value : 'a }
-
-type 'a assertion  = { a_name : Names.name; a_value : 'a }
-
-type 'a postcondition = 'a assertion
-
-type predicate = constr assertion
-
-(* binders *)
-
-type 'a binder_type =
-    BindType  of 'a
-  | BindSet
-  | Untyped
-
-type 'a binder = Names.identifier * 'a binder_type
-
-(* variant *)
-
-type variant = constr * constr * constr (* phi, R, A *)
-
-(* types des valeurs *)
-
-type 'a ml_type_v =
-    Ref       of 'a ml_type_v
-  | Array     of 'a * 'a ml_type_v   (* size x type *)
-  | Arrow     of 'a ml_type_v binder list * 'a ml_type_c
-
-  | TypePure  of 'a
-
-(* et type des calculs *)
-
-and 'a ml_type_c =
-    (Names.identifier * 'a ml_type_v) 
-  * Peffect.t
-  * ('a precondition list) * ('a postcondition option)
-
-(* at beginning they contain Coq AST but they become constr after typing *)
-type type_v = constr ml_type_v
-type type_c = constr ml_type_c
-
-
diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml
deleted file mode 100644
index 91c1f293..00000000
--- a/contrib/correctness/ptyping.ml
+++ /dev/null
@@ -1,600 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptyping.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Term
-open Termops
-open Environ
-open Constrintern
-open Himsg
-open Proof_trees
-open Topconstr
-
-open Pmisc
-open Putil
-open Prename
-open Ptype
-open Past
-open Penv 
-open Peffect
-open Pcicenv
-
-(* Ce module implante le jugement  Gamma |-a e : kappa  de la thèse.
- * Les annotations passent du type CoqAst.t au type Term.constr ici. 
- * Les post-conditions sont abstraites par rapport au résultat. *)
-
-let simplify_type_of env sigma t =
-  Reductionops.nf_betaiota (Typing.type_of env sigma t)
-
-let just_reads e =
-  difference (get_reads e) (get_writes e)
-
-let type_v_sup loc t1 t2 =
-  if t1 = t2 then
-    t1
-  else
-    Perror.if_branches loc
-
-let typed_var ren env (phi,r) =
-  let sign = Pcicenv.before_after_sign_of ren env in
-  let a = simplify_type_of (Global.env_of_context sign) Evd.empty phi in
-  (phi,r,a)
-
-(* Application de fonction *)
-
-let rec convert = function
-  | (TypePure c1, TypePure c2) -> 
-      Reductionops.is_conv (Global.env ()) Evd.empty c1 c2
-  | (Ref v1, Ref v2) -> 
-      convert (v1,v2)
-  | (Array (s1,v1), Array (s2,v2)) -> 
-      (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2))
-  | (v1,v2) -> v1 = v2
-      
-let effect_app ren env f args =
-  let n = List.length args in
-  let tf = 
-    let ((_,v),_,_,_) = f.info.kappa in
-    match v with TypePure c -> v_of_constr c | _ -> v
-  in
-  let bl,c = 
-    match tf with
-	Arrow (bl, c) ->
-	  if List.length bl <> n then Perror.partial_app f.loc;
-	  bl,c
-      | _ -> Perror.app_of_non_function f.loc
-  in
-  let check_type loc v t so =
-    let v' = type_v_rsubst so v in
-    if not (convert (v',t)) then Perror.expected_type loc (pp_type_v v')
-  in
-  let s,so,ok = 
-    (* s est la substitution des références, so celle des autres arg. 
-     * ok nous dit si les arguments sont sans effet i.e. des expressions *)
-    List.fold_left
-    (fun (s,so,ok) (b,a) ->
-       match b,a with
-	   (id,BindType (Ref _ | Array _ as v)), Refarg id' ->
-	     let ta = type_in_env env id' in
-	     check_type f.loc v ta so;
-	     (id,id')::s, so, ok
-	 | _, Refarg _ -> Perror.should_be_a_variable f.loc
-	 | (id,BindType v), Term t ->
-	     let ((_,ta),_,_,_) = t.info.kappa in
-	     check_type t.loc v ta so;
-	     (match t.desc with
-		  Expression c -> s, (id,c)::so, ok
-		| _ -> s,so,false)
-	 | (id,BindSet), Type v ->
-	     let c = Pmonad.trad_ml_type_v ren env v in
-	     s, (id,c)::so, ok
-	 | (id,BindSet), Term t -> Perror.expects_a_type id t.loc
-	 | (id,BindType _), Type _ -> Perror.expects_a_term id
-	 | (_,Untyped), _ -> invalid_arg "effects_app")
-    ([],[],true)
-    (List.combine bl args)
-  in
-  let (id,v),ef,pre,post = type_c_subst s c in
-  (bl,c), (s,so,ok), ((id,type_v_rsubst so v),ef,pre,post)
-
-(* Execution of a Coq AST. Returns value and type.
- * Also returns its variables *)
-
-let state_coq_ast sign a =
-  let env = Global.env_of_context sign in
-  let j =
-    reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in
-  let ids = global_vars env j.uj_val in
-  j.uj_val, j.uj_type, ids
-
-(* [is_pure p] tests wether the program p is an expression or not. *)
-
-let type_of_expression ren env c =
-  let sign = now_sign_of ren env in
-  simplify_type_of (Global.env_of_context sign) Evd.empty c
-
-let rec is_pure_type_v = function
-    TypePure _ -> true
-  | Arrow (bl,c) -> List.for_all is_pure_arg bl & is_pure_type_c c
-  | Ref _ | Array _ -> false
-and is_pure_arg = function
-    (_,BindType v) -> is_pure_type_v v
-  | (_,BindSet) -> true
-  | (_,Untyped) -> false
-and is_pure_type_c = function
-    (_,v),_,[],None -> is_pure_type_v v
-  | _ -> false
-
-let rec is_pure_desc ren env = function
-    Variable id ->
-      not (is_in_env env id) or (is_pure_type_v (type_in_env env id))
-  | Expression c -> 
-      (c = isevar) or (is_pure_cci (type_of_expression ren env c))
-  | Acc _ -> true
-  | TabAcc (_,_,p) -> is_pure ren env p
-  | Apply (p,args) -> 
-      is_pure ren env p & List.for_all (is_pure_arg ren env) args
-  | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _ 
-  | Lam _ | LetRef _ | Let _ | LetRec _ -> false
-  | Debug (_,p) -> is_pure ren env p
-  | PPoint (_,d) -> is_pure_desc ren env d
-and is_pure ren env p =
-  p.pre = [] & p.post = None & is_pure_desc ren env p.desc
-and is_pure_arg ren env = function
-    Term p -> is_pure ren env p
-  | Type _ -> true
-  | Refarg _ -> false
-
-(* [state_var ren env (phi,r)] returns a tuple (e,(phi',r')) 
- * where e is the effect of the variant phi and phi',r' the corresponding 
- * constr of phi and r.
- *)
-
-let state_var ren env (phi,r) = 
-  let sign = Pcicenv.before_after_sign_of ren env in
-  let phi',_,ids = state_coq_ast sign phi in
-  let ef = List.fold_left
-	     (fun e id ->
-		if is_mutable_in_env env id then Peffect.add_read id e else e)
-	     Peffect.bottom ids in
-  let r',_,_ = state_coq_ast (Global.named_context ()) r in
-  ef,(phi',r')
-	
-(* [state_pre ren env pl] returns a pair (e,c) where e is the effect of the
- * pre-conditions list pl and cl the corresponding constrs not yet abstracted
- * over the variables xi (i.e. c NOT [x1]...[xn]c !)
- *)
-
-let state_pre ren env pl =
-  let state e p =
-    let sign = Pcicenv.before_sign_of ren env in
-    let cc,_,ids = state_coq_ast sign p.p_value in
-    let ef = List.fold_left
-	       (fun e id ->
-		  if is_mutable_in_env env id then
-		    Peffect.add_read id e
-		  else if is_at id then
-		    let uid,_ = un_at id in
-		    if is_mutable_in_env env uid then
-		      Peffect.add_read uid e
-		    else
-		      e
-	     	  else
-		    e)
-	       e ids 
-    in
-    ef,{ p_assert = p.p_assert; p_name = p.p_name; p_value = cc }
-  in
-  List.fold_left 
-    (fun (e,cl) p -> let ef,c = state e p in (ef,c::cl)) 
-    (Peffect.bottom,[]) pl
-
-let state_assert ren env a =
-  let p = pre_of_assert true a in
-  let e,l = state_pre ren env [p] in
-  e,assert_of_pre (List.hd l)
-
-let state_inv ren env = function
-    None -> Peffect.bottom, None
-  | Some i -> let e,p = state_assert ren env i in e,Some p
-	  
-(* [state_post ren env (id,v,ef) q] returns a pair (e,c)
- * where e is the effect of the
- * post-condition q and c the corresponding constr not yet abstracted
- * over the variables xi, yi and result.
- * Moreover the RW variables not appearing in ef have been replaced by
- * RO variables, and (id,v) is the result
- *)
-
-let state_post ren env (id,v,ef) = function
-    None -> Peffect.bottom, None
-  | Some q ->
-      let v' = Pmonad.trad_ml_type_v ren env v in
-      let sign = Pcicenv.before_after_result_sign_of (Some (id,v')) ren env in
-      let cc,_,ids = state_coq_ast sign q.a_value in
-      let ef,c = 
-	List.fold_left
-	  (fun (e,c) id ->
-	     if is_mutable_in_env env id then
-	       if is_write ef id then
-		 Peffect.add_write id e, c
-	       else
-		 Peffect.add_read id e,
-		 subst_in_constr [id,at_id id ""] c
-	     else if is_at id then
-	       let uid,_ = un_at id in
-	       if is_mutable_in_env env uid then
-		 Peffect.add_read uid e, c
-	       else
-		 e,c
-	     else
-	       e,c)
-	  (Peffect.bottom,cc) ids 
-      in
-      let c = abstract [id,v'] c in
-      ef, Some { a_name = q.a_name; a_value = c }
-
-(* transformation of AST into constr in types V and C *)
-
-let rec cic_type_v env ren = function
-  | Ref v -> Ref (cic_type_v env ren v)
-  | Array (com,v) ->
-      let sign = Pcicenv.now_sign_of ren env in
-      let c = interp_constr Evd.empty (Global.env_of_context sign) com in
-      Array (c, cic_type_v env ren v)
-  | Arrow (bl,c) ->
-      let bl',ren',env' =
-	List.fold_left
-	(fun (bl,ren,env) b ->
-	   let b' = cic_binder env ren b in
-	   let env' = traverse_binders env [b'] in
-	   let ren' = initial_renaming env' in
-	     b'::bl,ren',env')
-	([],ren,env) bl
-      in
-      let c' = cic_type_c env' ren' c in
-      Arrow (List.rev bl',c')
-  | TypePure com ->
-      let sign = Pcicenv.cci_sign_of ren env in
-      let c = interp_constr Evd.empty (Global.env_of_context sign) com in
-      TypePure c
-
-and cic_type_c env ren ((id,v),e,p,q) =
-  let v' = cic_type_v env ren v in
-  let cv = Pmonad.trad_ml_type_v ren env v' in
-  let efp,p' = state_pre ren env p in
-  let efq,q' = state_post ren env (id,v',e) q in
-  let ef = Peffect.union e (Peffect.union efp efq) in
-  ((id,v'),ef,p',q')
-
-and cic_binder env ren = function
-  | (id,BindType v) ->
-      let v' = cic_type_v env ren v in
-      let env' = add (id,v') env in
-      let ren' = initial_renaming env' in
-      (id, BindType v')
-  | (id,BindSet) -> (id,BindSet)
-  | (id,Untyped) -> (id,Untyped)
-
-and cic_binders env ren = function
-    [] -> []
-  | b::bl ->
-      let b' = cic_binder env ren b in
-      let env' = traverse_binders env [b'] in
-      let ren' = initial_renaming env' in
-      b' :: (cic_binders env' ren' bl)
-
-
-(* The case of expressions.
- * 
- * Expressions are programs without neither effects nor pre/post conditions.
- * But access to variables are allowed.
- *
- * Here we transform an expression into the corresponding constr,
- * the variables still appearing as VAR (they will be abstracted in
- * Mlise.trad)
- * We collect the pre-conditions (e<N for t[e]) as we traverse the term.
- * We also return the effect, which does contain only *read* variables.
- *)
-
-let states_expression ren env expr =
-  let rec effect pl = function
-    | Variable id -> 
-	(if is_global id then constant (string_of_id id) else mkVar id),
-	pl, Peffect.bottom
-    | Expression c -> c, pl, Peffect.bottom
-    | Acc id -> mkVar id, pl, Peffect.add_read id Peffect.bottom
-    | TabAcc (_,id,p) ->
-	let c,pl,ef = effect pl p.desc in
-	let pre = Pmonad.make_pre_access ren env id c in
-	Pmonad.make_raw_access ren env (id,id) c, 
-	(anonymous_pre true pre)::pl, Peffect.add_read id ef
-    | Apply (p,args) ->
-	let a,pl,e = effect pl p.desc in
-	let args,pl,e =
-	  List.fold_right
-	    (fun arg (l,pl,e) -> 
-	       match arg with
-		   Term p ->
-		     let carg,pl,earg = effect pl p.desc in
-		     carg::l,pl,Peffect.union e earg
-		 | Type v ->
-		     let v' = cic_type_v env ren v in
-		     (Pmonad.trad_ml_type_v ren env v')::l,pl,e
-		 | Refarg _ -> assert false) 
-	    args ([],pl,e) 
-	in
-	Term.applist (a,args),pl,e
-    | _ -> invalid_arg "Ptyping.states_expression"
-  in
-  let e0,pl0 = state_pre ren env expr.pre in
-  let c,pl,e = effect [] expr.desc in
-  let sign = Pcicenv.before_sign_of ren env in
-  (*i WAS
-  let c = (Trad.ise_resolve true empty_evd [] (gLOB sign) c)._VAL in
-  i*)
-  let ty = simplify_type_of (Global.env_of_context sign) Evd.empty c in
-  let v = TypePure ty in
-  let ef = Peffect.union e0 e in
-  Expression c, (v,ef), pl0@pl
-
-
-(* We infer here the type with effects.
- * The type of types with effects (ml_type_c) is defined in the module ProgAst.
- * 
- * A program of the shape {P} e {Q} has a type 
- *   
- *        V, E, {None|Some P}, {None|Some Q}
- *
- * where - V is the type of e
- *       - E = (I,O) is the effect; the input I contains
- *         all the input variables appearing in P,e and Q;
- *         the output O contains variables possibly modified in e
- *       - P is NOT abstracted
- *       - Q = [y'1]...[y'k][result]Q where O = {y'j}
- *         i.e. Q is only abstracted over the output and the result
- *         the other variables now refer to value BEFORE
- *)
-
-let verbose_fix = ref false
-
-let rec states_desc ren env loc = function
-	
-    Expression c ->
-      let ty = type_of_expression ren env c in
-      let v = v_of_constr ty in
-      Expression c, (v,Peffect.bottom)
-
-  | Acc _ ->
-      failwith "Ptyping.states: term is supposed not to be pure"
-
-  | Variable id ->
-      let v = type_in_env env id in
-      let ef = Peffect.bottom in
-      Variable id, (v,ef)
-
-  | Aff (x, e1) ->
-      Perror.check_for_reference loc x (type_in_env env x);
-      let s_e1 = states ren env e1 in
-      let _,e,_,_ = s_e1.info.kappa in
-      let ef = add_write x e in
-      let v = constant_unit () in
-      Aff (x, s_e1), (v, ef)
-
-  | TabAcc (check, x, e) ->
-      let s_e = states ren env e in
-      let _,efe,_,_ = s_e.info.kappa in
-      let ef = Peffect.add_read x efe in
-      let _,ty = dearray_type (type_in_env env x) in
-      TabAcc (check, x, s_e), (ty, ef)
-
-  | TabAff (check, x, e1, e2) ->
-      let s_e1 = states ren env e1 in
-      let s_e2 = states ren env e2 in 
-      let _,ef1,_,_ = s_e1.info.kappa in
-      let _,ef2,_,_ = s_e2.info.kappa in
-      let ef = Peffect.add_write x (Peffect.union ef1 ef2) in
-      let v = constant_unit () in
-      TabAff (check, x, s_e1, s_e2), (v,ef)
-
-  | Seq bl ->
-      let bl,v,ef,_ = states_block ren env bl in
-      Seq bl, (v,ef)
-	      
-  | While(b, invopt, var, bl) ->
-      let efphi,(cvar,r') = state_var ren env var in
-      let ren' = next ren [] in
-      let s_b = states ren' env b in
-      let s_bl,_,ef_bl,_ = states_block ren' env bl in
-      let cb = s_b.info.kappa in
-      let efinv,inv = state_inv ren env invopt in
-      let _,efb,_,_ = s_b.info.kappa in
-      let ef = 
-	Peffect.union (Peffect.union ef_bl efb) (Peffect.union efinv efphi)
-      in
-      let v = constant_unit () in
-      let cvar = 
-	let al = List.map (fun id -> (id,at_id id "")) (just_reads ef) in
-	subst_in_constr al cvar 
-      in
-      While (s_b,inv,(cvar,r'),s_bl), (v,ef)
-      
-  | Lam ([],_) ->
-      failwith "Ptyping.states: abs. should have almost one binder"
-
-  | Lam (bl, e) ->
-      let bl' = cic_binders env ren bl in
-      let env' = traverse_binders env bl' in
-      let ren' = initial_renaming env' in
-      let s_e = states ren' env' e in
-      let v = make_arrow bl' s_e.info.kappa in
-      let ef = Peffect.bottom in
-      Lam(bl',s_e), (v,ef)
-	 
-  (* Connectives AND and OR *)
-  | SApp ([Variable id], [e1;e2]) ->
-      let s_e1 = states ren env e1
-      and s_e2 = states ren env e2 in
-      let (_,ef1,_,_) = s_e1.info.kappa
-      and (_,ef2,_,_) = s_e2.info.kappa in
-      let ef = Peffect.union ef1 ef2 in
-      SApp ([Variable id], [s_e1; s_e2]), 
-      (TypePure (constant "bool"), ef)
-
-  (* Connective NOT *)
-  | SApp ([Variable id], [e]) ->
-      let s_e = states ren env e in
-      let (_,ef,_,_) = s_e.info.kappa in
-      SApp ([Variable id], [s_e]), 
-      (TypePure (constant "bool"), ef)
-      
-  | SApp _ -> invalid_arg "Ptyping.states (SApp)"
-
-  (* ATTENTION:
-     Si un argument réel de type ref. correspond à une ref. globale
-     modifiée par la fonction alors la traduction ne sera pas correcte.
-     Exemple:
-            f=[x:ref Int]( r := !r+1 ; x := !x+1) modifie r et son argument x
-            donc si on l'applique à r justement, elle ne modifiera que r
-            mais le séquencement ne sera pas correct. *)
-
-  | Apply (f, args) ->
-      let s_f = states ren env f in
-      let _,eff,_,_ = s_f.info.kappa in
-      let s_args = List.map (states_arg ren env) args in
-      let ef_args = 
-	List.map 
-	  (function Term t -> let (_,e,_,_) = t.info.kappa in e
-	          | _ -> Peffect.bottom) 
-	  s_args 
-      in
-      let _,_,((_,tapp),efapp,_,_) = effect_app ren env s_f s_args in
-      let ef = 
-	Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp
-      in
-      Apply (s_f, s_args), (tapp, ef)
-      
-  | LetRef (x, e1, e2) ->
-      let s_e1 = states ren env e1 in
-      let (_,v1),ef1,_,_ = s_e1.info.kappa in
-      let env' = add (x,Ref v1) env in
-      let ren' = next ren [x] in
-      let s_e2 = states ren' env' e2 in
-      let (_,v2),ef2,_,_ = s_e2.info.kappa in
-      Perror.check_for_let_ref loc v2;
-      let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in
-      LetRef (x, s_e1, s_e2), (v2,ef)
-	
-  | Let (x, e1, e2) ->
-      let s_e1 = states ren env e1 in
-      let (_,v1),ef1,_,_ = s_e1.info.kappa in
-      Perror.check_for_not_mutable e1.loc v1;
-      let env' = add (x,v1) env in
-      let s_e2 = states ren env' e2 in
-      let (_,v2),ef2,_,_ = s_e2.info.kappa in
-      let ef = Peffect.compose ef1 ef2 in
-      Let (x, s_e1, s_e2), (v2,ef)
-	    
-  | If (b, e1, e2) ->
-      let s_b = states ren env b in
-      let s_e1 = states ren env e1
-      and s_e2 = states ren env e2 in
-      let (_,tb),efb,_,_ = s_b.info.kappa in
-      let (_,t1),ef1,_,_ = s_e1.info.kappa in
-      let (_,t2),ef2,_,_ = s_e2.info.kappa in
-      let ef = Peffect.compose efb (disj ef1 ef2) in
-      let v = type_v_sup loc t1 t2 in
-      If (s_b, s_e1, s_e2), (v,ef)
-
-  | LetRec (f,bl,v,var,e) ->
-      let bl' = cic_binders env ren bl in
-      let env' = traverse_binders env bl' in
-      let ren' = initial_renaming env' in
-      let v' = cic_type_v env' ren' v in
-      let efvar,var' = state_var ren' env' var in
-      let phi0 = phi_name () in
-      let tvar = typed_var ren env' var' in
-      (* effect for a let/rec construct is computed as a fixpoint *)
-      let rec state_rec c =
-	let tf = make_arrow bl' c in
-	let env'' = add_recursion (f,(phi0,tvar)) (add (f,tf) env') in
-	let s_e = states ren' env'' e in
-	if s_e.info.kappa = c then
-	  s_e
-      	else begin
-	  if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ;
-	  state_rec s_e.info.kappa
-      	end
-      in 
-      let s_e = state_rec ((result_id,v'),efvar,[],None) in
-      let tf = make_arrow bl' s_e.info.kappa in
-      LetRec (f,bl',v',var',s_e), (tf,Peffect.bottom)
-
-  | PPoint (s,d) -> 
-      let ren' = push_date ren s in
-      states_desc ren' env loc d
-	
-  | Debug _ -> failwith "Ptyping.states: Debug: TODO"
-
-
-and states_arg ren env = function
-    Term a    -> let s_a = states ren env a in Term s_a
-  | Refarg id -> Refarg id
-  | Type v    -> let v' = cic_type_v env ren v in Type v'
-	
-
-and states ren env expr =
-  (* Here we deal with the pre- and post- conditions:
-   * we add their effects to the effects of the program *)
-  let (d,(v,e),p1) = 
-    if is_pure_desc ren env expr.desc then
-      states_expression ren env expr
-    else
-      let (d,ve) = states_desc ren env expr.loc expr.desc in (d,ve,[])
-  in
-  let (ep,p) = state_pre ren env expr.pre in
-  let (eq,q) = state_post ren env (result_id,v,e) expr.post in
-  let e' = Peffect.union e (Peffect.union ep eq) in
-  let p' = p1 @ p in
-  let tinfo = { env = env; kappa = ((result_id,v),e',p',q) } in
-  { desc = d;
-    loc = expr.loc;
-    pre = p'; post = q; (* on les conserve aussi ici pour prog_wp *)
-    info = tinfo }
-
-
-and states_block ren env bl =
-  let rec ef_block ren tyres = function
-      [] ->
-	begin match tyres with
-	    Some ty -> [],ty,Peffect.bottom,ren
-	  | None -> failwith "a block should contain at least one statement"
-	end
-    | (Assert p)::block -> 
-	let ep,c = state_assert ren env p in
-	let bl,t,ef,ren' = ef_block ren tyres block in
-	(Assert c)::bl,t,Peffect.union ep ef,ren'
-    | (Label s)::block ->
-	let ren' = push_date ren s in
-	let bl,t,ef,ren'' = ef_block ren' tyres block in
-	(Label s)::bl,t,ef,ren''
-    | (Statement e)::block ->
-	let s_e = states ren env e in
-	let (_,t),efe,_,_ = s_e.info.kappa in
-	let ren' = next ren (get_writes efe) in
-	let bl,t,ef,ren'' = ef_block ren' (Some t) block in
-	(Statement s_e)::bl,t,Peffect.compose efe ef,ren''
-  in
-  ef_block ren None bl
-
diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli
deleted file mode 100644
index eaf548b1..00000000
--- a/contrib/correctness/ptyping.mli
+++ /dev/null
@@ -1,36 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptyping.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Topconstr
-
-open Ptype
-open Past
-open Penv
-
-(* This module realizes type and effect inference *)
-
-val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v
-
-val effect_app : Prename.t -> local_env
-            -> (typing_info,'b) Past.t
-            -> (typing_info,constr) arg list
-            -> (type_v binder list * type_c) 
-             * ((identifier*identifier) list * (identifier*constr) list * bool)
-             * type_c
-
-val typed_var : Prename.t -> local_env -> constr * constr -> variant
-
-val type_of_expression : Prename.t -> local_env -> constr -> constr
-
-val states : Prename.t -> local_env -> program -> typed_program
diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml
deleted file mode 100644
index 18c3ba35..00000000
--- a/contrib/correctness/putil.ml
+++ /dev/null
@@ -1,303 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Pattern
-open Matching
-open Hipattern
-open Environ
-
-open Pmisc
-open Ptype
-open Past
-open Penv
-open Prename
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-let is_pure = function TypePure _ -> true | _ -> false
-
-let named_app f x = { a_name = x.a_name; a_value = (f x.a_value) }
-
-let pre_app f x = 
-  { p_assert = x.p_assert; p_name = x.p_name; p_value = f x.p_value }
-
-let post_app = named_app
-
-let anonymous x = { a_name = Anonymous; a_value = x }
-
-let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x }
-
-let force_name f x =
-  option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x
-
-let force_post_name x = force_name post_name x
-
-let force_bool_name x = 
-  force_name (function Name id -> id | Anonymous -> bool_name()) x
-
-let out_post = function
-    Some { a_value = x } -> x
-  | None -> invalid_arg "out_post"
-
-let pre_of_assert b x =
-  { p_assert = b; p_name = x.a_name; p_value = x.a_value }
-
-let assert_of_pre x =
-  { a_name = x.p_name; a_value = x.p_value }
-
-(* Some generic functions on programs *)
-
-let is_mutable_in_env env id =
-  (is_in_env env id) & (is_mutable (type_in_env env id))
-
-let now_vars env c =
-  Util.map_succeed 
-    (function id -> if is_mutable_in_env env id then id else failwith "caught")
-    (global_vars (Global.env()) c)
-
-let make_before_after c =
-  let ids = global_vars (Global.env()) c in
-  let al = 
-    Util.map_succeed
-      (function id -> 
-	 if is_at id then 
-	   match un_at id with (uid,"") -> (id,uid) | _ -> failwith "caught"
-	 else failwith "caught")
-      ids
-  in
-  subst_in_constr al c
-
-(* [apply_pre] and [apply_post] instantiate pre- and post- conditions
- * according to a given renaming of variables (and a date that means
- * `before' in the case of the post-condition).
- *)
-
-let make_assoc_list ren env on_prime ids =
-  List.fold_left
-    (fun al id ->
-       if is_mutable_in_env env id then
-	 (id,current_var ren id)::al
-       else if is_at id then
-	 let uid,d = un_at id in
-	   if is_mutable_in_env env uid then
-	     (match d with
-		  "" -> (id,on_prime ren uid)
-		| _  -> (id,var_at_date ren d uid))::al
-	   else
-	     al
-       else
-	 al) 
-    [] ids
-
-let apply_pre ren env c =
-  let ids = global_vars (Global.env()) c.p_value in
-  let al = make_assoc_list ren env current_var ids in
-  { p_assert = c.p_assert; p_name = c.p_name; 
-    p_value = subst_in_constr al c.p_value }
-
-let apply_assert ren env c =
-  let ids = global_vars (Global.env()) c.a_value in
-  let al = make_assoc_list ren env current_var ids in
-  { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
- 
-let apply_post ren env before c =
-  let ids = global_vars (Global.env()) c.a_value in
-  let al = 
-    make_assoc_list ren env (fun r uid -> var_at_date r before uid) ids in
-  { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
-
-(* [traverse_binder ren env bl] updates renaming [ren] and environment [env]
- * as we cross the binders [bl]
- *)
-
-let rec traverse_binders env = function
-    [] -> env
-  | (id,BindType v)::rem ->
-      traverse_binders (add (id,v) env) rem
-  | (id,BindSet)::rem ->
-      traverse_binders (add_set id env) rem
-  | (_,Untyped)::_ ->
-      invalid_arg "traverse_binders"
-	  
-let initial_renaming env =
-  let ids = Penv.fold_all (fun (id,_) l -> id::l) env [] in
-    update empty_ren "0" ids
-
-
-(* Substitutions *)
-
-let rec type_c_subst s ((id,t),e,p,q) =
-  let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in
-  (id, type_v_subst s t), Peffect.subst s e,
-  List.map (pre_app (subst_in_constr s)) p,
-  option_map (post_app (subst_in_constr s')) q
-
-and type_v_subst s = function
-    Ref v -> Ref (type_v_subst s v)
-  | Array (n,v) -> Array (n,type_v_subst s v)
-  | Arrow (bl,c) -> Arrow(List.map (binder_subst s) bl, type_c_subst s c)
-  | (TypePure _) as v -> v
-
-and binder_subst s = function
-    (n, BindType v) -> (n, BindType (type_v_subst s v))
-  | b -> b
-
-(* substitution of constr by others *)
-
-let rec type_c_rsubst s ((id,t),e,p,q) =
-  (id, type_v_rsubst s t), e,
-    List.map (pre_app (real_subst_in_constr s)) p,
-    option_map (post_app (real_subst_in_constr s)) q
-
-and type_v_rsubst s = function
-    Ref v -> Ref (type_v_rsubst s v)
-  | Array (n,v) -> Array (real_subst_in_constr s n,type_v_rsubst s v)
-  | Arrow (bl,c) -> Arrow(List.map (binder_rsubst s) bl, type_c_rsubst s c)
-  | TypePure c -> TypePure (real_subst_in_constr s c)
-
-and binder_rsubst s = function
-  | (n, BindType v) -> (n, BindType (type_v_rsubst s v))
-  | b -> b
-
-(* make_arrow bl c = (x1:V1)...(xn:Vn)c *)
-
-let make_arrow bl c = match bl with
-  | [] -> invalid_arg "make_arrow: no binder"
-  | _ -> Arrow (bl,c)
-
-(* misc. functions *)
-
-let deref_type = function
-  | Ref v -> v
-  | _ -> invalid_arg "deref_type"
-
-let dearray_type = function
-  | Array (size,v) -> size,v
-  | _ -> invalid_arg "dearray_type"
-
-let constant_unit () = TypePure (constant "unit")
-
-let id_from_name = function Name id -> id | Anonymous -> (id_of_string "X")
-
-(* v_of_constr : traduit un type CCI en un type ML *)
-
-(* TODO: faire un test plus serieux sur le type des objets Coq *)
-let rec is_pure_cci c = match kind_of_term c with
-  | Cast (c,_) -> is_pure_cci c
-  | Prod(_,_,c') -> is_pure_cci c'
-  | Rel _ | Ind _ | Const _ -> true (* heu... *)
-  | App _ -> not (is_matching_sigma c)
-  | _ -> Util.error "CCI term not acceptable in programs"
-
-let rec v_of_constr c = match kind_of_term c with
-  | Cast (c,_) -> v_of_constr c
-  | Prod _ ->
-      let revbl,t2 = Term.decompose_prod c in
-      let bl =
-	List.map
-	  (fun (name,t1) -> (id_from_name name, BindType (v_of_constr t1)))
-	  (List.rev revbl)
-      in
-      let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in
-      Arrow (bl, c_of_constr (substl vars t2))
-  | Ind _ | Const _ | App _ ->
-      TypePure c
-  | _ -> 
-      failwith "v_of_constr: TODO"
-
-and c_of_constr c =
-  if is_matching_sigma c then
-    let (a,q) = match_sigma c in
-    (result_id, v_of_constr a), Peffect.bottom, [], Some (anonymous q)
-  else
-    (result_id, v_of_constr c), Peffect.bottom, [], None
-
-
-(* pretty printers (for debugging purposes) *)
-
-open Pp
-open Util
-
-let pr_lconstr x = Printer.pr_lconstr_env (Global.env()) x
-
-let pp_pre = function
-    [] -> (mt ())
-  | l  ->
-      hov 0 (str"pre " ++ 
-	       prlist_with_sep (fun () -> (spc ())) 
-		 (fun x -> pr_lconstr x.p_value) l)
-
-let pp_post = function
-    None -> (mt ())
-  | Some c -> hov 0 (str"post " ++ pr_lconstr c.a_value)
-
-let rec pp_type_v = function
-    Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref")
-  | Array (cc,v) -> hov 0 (str"array " ++ pr_lconstr cc ++ str" of " ++ pp_type_v v)
-  | Arrow (b,c) -> 
-      hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ 
-	       pp_type_c c)
-  | TypePure c -> pr_lconstr c
-
-and pp_type_c ((id,v),e,p,q) =
-  hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ 
-	   Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++
-	   spc () ++ str"end")
-
-and pp_binder = function
-    id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")")
-  | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)")
-  | id,Untyped -> (str"(" ++ pr_id id ++ str")")
-
-(* pretty-print of cc-terms (intermediate terms) *)
-
-let rec pp_cc_term = function
-    CC_var id -> pr_id id
-  | CC_letin (_,_,bl,c,c1) ->
-      hov 0 (hov 2 (str"let " ++
-		  	prlist_with_sep (fun () -> (str","))
-			  (fun (id,_) -> pr_id id) bl ++
-		  	str" =" ++ spc () ++
-		  	pp_cc_term c ++
-		  	str " in") ++
-	       fnl () ++
-	       pp_cc_term c1)
-  | CC_lam (bl,c) ->
-      hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++
-	       cut () ++
-	       pp_cc_term c)
-  | CC_app (f,args) ->
-      hov 2 (str"(" ++ 
-	       pp_cc_term f ++ spc () ++
-	       prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++
-	       str")")
-  | CC_tuple (_,_,cl) ->
-      hov 2 (str"(" ++
-	       prlist_with_sep (fun () -> (str"," ++ cut ()))
-		 pp_cc_term cl ++
-	       str")")
-  | CC_case (_,b,[e1;e2]) ->
-      hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++
-	       str"  " ++ hov 0 (pp_cc_term e1) ++ fnl () ++
-	       str"else" ++ fnl () ++
-	       str"  " ++ hov 0 (pp_cc_term e2))
-  | CC_case _ ->
-      hov 0 (str"<Case: not yet implemented>")
-  | CC_expr c ->
-      hov 0 (pr_lconstr c)
-  | CC_hole c ->
-      (str"(?::" ++ pr_lconstr c ++ str")")
-
diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli
deleted file mode 100644
index 6c487f3f..00000000
--- a/contrib/correctness/putil.mli
+++ /dev/null
@@ -1,72 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: putil.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Names
-open Term
-open Pmisc
-open Ptype
-open Past
-open Penv
-
-val is_mutable : 'a ml_type_v -> bool
-val is_pure : 'a ml_type_v -> bool
-
-val named_app : ('a -> 'b) -> 'a assertion -> 'b assertion
-val pre_app : ('a -> 'b) -> 'a precondition -> 'b precondition
-val post_app : ('a -> 'b) -> 'a postcondition -> 'b postcondition
-
-val anonymous : 'a -> 'a assertion
-val anonymous_pre : bool -> 'a -> 'a precondition
-val out_post : 'a postcondition option -> 'a
-val pre_of_assert : bool -> 'a assertion -> 'a precondition
-val assert_of_pre : 'a precondition -> 'a assertion
-
-val force_post_name : 'a postcondition option -> 'a postcondition option
-val force_bool_name : 'a postcondition option -> 'a postcondition option
-
-val make_before_after : constr -> constr
-
-val traverse_binders : local_env -> (type_v binder) list -> local_env
-val initial_renaming : local_env -> Prename.t
-
-val apply_pre : Prename.t -> local_env -> constr precondition ->
-  constr precondition
-val apply_post : Prename.t -> local_env -> string -> constr postcondition ->
-  constr postcondition
-val apply_assert : Prename.t -> local_env -> constr assertion ->
-  constr assertion
-
-val type_v_subst : (identifier * identifier) list -> type_v -> type_v
-val type_c_subst : (identifier * identifier) list -> type_c -> type_c
-
-val type_v_rsubst : (identifier * constr) list -> type_v -> type_v
-val type_c_rsubst : (identifier * constr) list -> type_c -> type_c
-
-val make_arrow : ('a ml_type_v binder) list -> 'a ml_type_c -> 'a ml_type_v
-
-val is_mutable_in_env : local_env -> identifier -> bool
-val now_vars : local_env -> constr -> identifier list
-
-val deref_type : 'a ml_type_v -> 'a ml_type_v
-val dearray_type : 'a ml_type_v -> 'a * 'a ml_type_v
-val constant_unit : unit -> constr ml_type_v
-val v_of_constr : constr -> constr ml_type_v
-val c_of_constr : constr -> constr ml_type_c
-val is_pure_cci : constr -> bool
-
-(* pretty printers *)
-
-val pp_type_v : type_v -> std_ppcmds
-val pp_type_c : type_c -> std_ppcmds
-val pp_cc_term : cc_term -> std_ppcmds
-
diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml
deleted file mode 100644
index f422c5cd..00000000
--- a/contrib/correctness/pwp.ml
+++ /dev/null
@@ -1,347 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Libnames
-open Term
-open Termops
-open Environ
-open Nametab
-
-open Pmisc
-open Ptype
-open Past
-open Putil
-open Penv
-open Peffect
-open Ptyping
-open Prename
-
-(* In this module:
- *  - we try to insert more annotations to achieve a greater completeness;
- *  - we recursively propagate annotations inside programs;
- *  - we normalize boolean expressions.
- *
- * The propagation schemas are the following:
- * 
- *  1. (f a1 ... an)  ->  (f a1 ... an) {Qf} if the ai are functional
- *
- *  2. (if e1 then e2 else e3) {Q}  ->  (if e1 then e2 {Q} else e3 {Q}) {Q}
- * 
- *  3. (let x = e1 in e2) {Q}  ->  (let x = e1 in e2 {Q}) {Q}
- *)
-
-(* force a post-condition *)
-let update_post env top ef c =
-  let i,o = Peffect.get_repr ef in
-  let al = 
-    List.fold_left 
-      (fun l id -> 
-	 if is_mutable_in_env env id then
-	   if is_write ef id then l else (id,at_id id "")::l
-	 else if is_at id then
-	   let (uid,d) = un_at id in
-	   if is_mutable_in_env env uid & d="" then 
-	     (id,at_id uid top)::l 
-	   else 
-	     l
-	 else
-	   l) 
-      [] (global_vars (Global.env()) c)
-  in
-  subst_in_constr al c
-  
-let force_post up env top q e =
-  let (res,ef,p,_) = e.info.kappa in
-  let q' = 
-    if up then option_map (named_app (update_post env top ef)) q else q 
-  in
-  let i = { env = e.info.env; kappa = (res,ef,p,q') } in
-  { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i }
-
-(* put a post-condition if none is present *)
-let post_if_none_up env top q = function
-  | { post = None } as p -> force_post true env top q p 
-  | p -> p
-
-let post_if_none env q = function
-  | { post = None } as p -> force_post false env "" q p 
-  | p -> p
-
-(* [annotation_candidate p] determines if p is a candidate for a 
- * post-condition *)
-
-let annotation_candidate = function
-  | { desc = If _ | Let _ | LetRef _ ; post = None } -> true
-  | _ -> false
-
-(* [extract_pre p] erase the pre-condition of p and returns it *)
-let extract_pre pr =
-  let (v,e,p,q) = pr.info.kappa in
-  { desc = pr.desc; pre = []; post = pr.post; loc = pr.loc;
-    info = { env = pr.info.env; kappa = (v,e,[],q) } },
-  p
-
-(* adds some pre-conditions *)
-let add_pre p1 pr =
-  let (v,e,p,q) = pr.info.kappa in
-  let p' = p1 @ p in
-  { desc = pr.desc; pre = p'; post = pr.post; loc = pr.loc;
-    info = { env = pr.info.env; kappa = (v,e,p',q) } }
-  
-(* change the statement *)
-let change_desc p d =
-  { desc = d; pre = p.pre; post = p.post; loc = p.loc; info = p.info }
-
-let create_bool_post c =
-  Some { a_value = c; a_name = Name (bool_name()) }
-
-(* [normalize_boolean b] checks if the boolean expression b (of type bool) is 
- * annotated, and if it is not the case tries to add the annotation
- * (if result then c=true else c=false) if b is an expression c.
- *)
-
-let is_bool = function
-  | TypePure c ->
-      (match kind_of_term (strip_outer_cast c) with
-	 | Ind op ->
-             string_of_id (id_of_global (IndRef op)) = "bool"
-	 | _ -> false)
-  | _ -> false
-
-let normalize_boolean ren env b =
-  let ((res,v),ef,p,q) = b.info.kappa in
-  Perror.check_no_effect b.loc ef;
-  if is_bool v then
-    match q with
-      | Some _ ->
-	  (* il y a une annotation : on se contente de lui forcer un nom *)
-	  let q = force_bool_name q in
-	  { desc = b.desc; pre = b.pre; post = q; loc = b.loc;
-	    info = { env = b.info.env; kappa = ((res,v),ef,p,q) } }
-      | None -> begin
-	  (* il n'y a pas d'annotation : on cherche à en mettre une *)
-	  match b.desc with
-	      Expression c ->
-	    	let c' = Term.applist (constant "annot_bool",[c]) in
-		let ty = type_of_expression ren env c' in
-		let (_,q') = Hipattern.match_sigma ty in
-		let q' = Some { a_value = q'; a_name = Name (bool_name()) } in
-		{ desc = Expression c'; 
-		  pre = b.pre; post = q'; loc = b.loc;
-		  info = { env = b.info.env; kappa = ((res, v),ef,p,q') } }
-	    | _ -> b
-	end
-  else
-    Perror.should_be_boolean b.loc
-
-(* [decomp_boolean c] returns the specs R and S of a boolean expression *)
-
-let decomp_boolean = function
-  | Some { a_value = q } ->
-      Reductionops.whd_betaiota (Term.applist (q, [constant "true"])),
-      Reductionops.whd_betaiota (Term.applist (q, [constant "false"]))
-  | _ -> invalid_arg "Ptyping.decomp_boolean"
-
-(* top point of a program *)
-
-let top_point = function
-  | PPoint (s,_) as p -> s,p
-  | p -> let s = label_name() in s,PPoint(s,p)
-
-let top_point_block = function
-  | (Label s :: _) as b -> s,b
-  | b -> let s = label_name() in s,(Label s)::b
-
-let abstract_unit q = abstract [result_id,constant "unit"] q
-
-(* [add_decreasing env ren ren' phi r bl] adds the decreasing condition
- *    phi(ren') r phi(ren)
- * to the last assertion of the block [bl], which is created if needed
- *)
-
-let add_decreasing env inv (var,r) lab bl =
-  let ids = now_vars env var in
-  let al = List.map (fun id -> (id,at_id id lab)) ids in
-  let var_lab = subst_in_constr al var in
-  let dec = Term.applist (r, [var;var_lab]) in
-  let post = match inv with
-      None -> anonymous dec
-    | Some i -> { a_value = conj dec i.a_value; a_name = i.a_name }
-  in
-  bl @ [ Assert post ]
-
-(* [post_last_statement env top q bl] annotates the last statement of the
- * sequence bl with q if necessary *)
-
-let post_last_statement env top q bl =
-  match List.rev bl with
-    | Statement e :: rem when annotation_candidate e -> 
-	List.rev ((Statement (post_if_none_up env top q e)) :: rem)
-    | _ -> bl
-
-(* [propagate_desc] moves the annotations inside the program 
- * info is the typing information coming from the outside annotations *)
-let rec propagate_desc ren info d = 
-  let env = info.env in
-  let (_,_,p,q) = info.kappa in
-  match d with
-    | If (e1,e2,e3) ->
-      (* propagation number 2 *)
-	let e1' = normalize_boolean ren env (propagate ren e1) in
-	if e2.post = None or e3.post = None then
-	  let top = label_name() in
-	  let ren' = push_date ren top in
-	  PPoint (top, If (e1', 
-			   propagate ren' (post_if_none_up env top q e2),
-			   propagate ren' (post_if_none_up env top q e3)))
-	else
-	  If (e1', propagate ren e2, propagate ren e3)
-    | Aff (x,e) ->
-      	Aff (x, propagate ren e)
-    | TabAcc (ch,x,e) ->
-      	TabAcc (ch, x, propagate ren e)
-    | TabAff (ch,x,({desc=Expression c} as e1),e2) ->
-	let p = Pmonad.make_pre_access ren env x c in
-	let e1' = add_pre [(anonymous_pre true p)] e1 in
-      	TabAff (false, x, propagate ren e1', propagate ren e2)
-    | TabAff (ch,x,e1,e2) ->
-      	TabAff (ch, x, propagate ren e1, propagate ren e2)
-    | Apply (f,l) ->
-      	Apply (propagate ren f, List.map (propagate_arg ren) l)
-    | SApp (f,l) ->
-	let l = 
-	  List.map (fun e -> normalize_boolean ren env (propagate ren e)) l
-	in
-      	SApp (f, l)
-    | Lam (bl,e) ->
-      	Lam (bl, propagate ren e)
-    | Seq bl ->
-	let top,bl = top_point_block bl in
-	let bl = post_last_statement env top q bl in
-      	Seq (propagate_block ren env bl)
-    | While (b,inv,var,bl) ->
-	let b = normalize_boolean ren env (propagate ren b) in
-	let lab,bl = top_point_block bl in
-	let bl = add_decreasing env inv var lab bl in
-      	While (b,inv,var,propagate_block ren env bl)
-    | LetRef (x,e1,e2) ->
-	let top = label_name() in
-	let ren' = push_date ren top in
-	PPoint (top, LetRef (x, propagate ren' e1, 
-	      		     propagate ren' (post_if_none_up env top q e2)))
-    | Let (x,e1,e2) ->
-	let top = label_name() in
-	let ren' = push_date ren top in
-      	PPoint (top, Let (x, propagate ren' e1, 
-			    propagate ren' (post_if_none_up env top q e2)))
-    | LetRec (f,bl,v,var,e) ->
-      	LetRec (f, bl, v, var, propagate ren e)
-    | PPoint (s,d) -> 
-      	PPoint (s, propagate_desc ren info d)
-    | Debug _ | Variable _ 
-    | Acc _ | Expression _ as d -> d
-	  
-
-(* [propagate] adds new annotations if possible *)
-and propagate ren p =
-  let env = p.info.env in
-  let p = match p.desc with
-    | Apply (f,l) ->
-	let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in
-	if ok then
-	  let q = option_map (named_app (real_subst_in_constr so)) qapp in
-	  post_if_none env q p
-	else
-	  p
-    | _ -> p
-  in
-  let d = propagate_desc ren p.info p.desc in
-  let p = change_desc p d in
-  match d with
-    | Aff (x,e) ->
-	let e1,p1 = extract_pre e in
-	change_desc (add_pre p1 p) (Aff (x,e1))
-
-    | TabAff (check, x, ({ desc = Expression _ } as e1), e2) ->
-	let e1',p1 = extract_pre e1 in
-	let e2',p2 = extract_pre e2 in
-	change_desc (add_pre (p1@p2) p) (TabAff (check,x,e1',e2'))
-
-    | While (b,inv,_,_) ->
-	let _,s = decomp_boolean b.post in
-	let s = make_before_after s in
-	let q = match inv with
-	    None -> Some (anonymous s)
-	  | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name }
-	in
-	let q = option_map (named_app abstract_unit) q in
-	post_if_none env q p
-
-    | SApp ([Variable id], [e1;e2]) 
-      when id = connective_and or id = connective_or ->
-	let (_,_,_,q1) = e1.info.kappa
-	and (_,_,_,q2) = e2.info.kappa in
-	let (r1,s1) = decomp_boolean q1
-	and (r2,s2) = decomp_boolean q2 in
-	let q =
-	  let conn = if id = connective_and then "spec_and" else "spec_or" in
-	  let c = Term.applist (constant conn, [r1; s1; r2; s2]) in
-	  let c = Reduction.whd_betadeltaiota (Global.env()) c in
-	  create_bool_post c
-	in
-	let d = 
-	  SApp ([Variable id;
-                 Expression (out_post q1);
-                 Expression (out_post q2)], 
-		[e1; e2] ) 
-	in
-	post_if_none env q (change_desc p d)
-
-    | SApp ([Variable id], [e1]) when id = connective_not ->
-	let (_,_,_,q1) = e1.info.kappa in
-	let (r1,s1) = decomp_boolean q1 in
-	let q = 
-	  let c = Term.applist (constant "spec_not", [r1; s1]) in
-	  let c = Reduction.whd_betadeltaiota (Global.env ()) c in
-	  create_bool_post c 
-	in
-	let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in
-	post_if_none env q (change_desc p d)
-
-    | _ -> p
-
-and propagate_arg ren = function
-  | Type _ | Refarg _ as a -> a
-  | Term e -> Term (propagate ren e)
-
-
-and propagate_block ren env = function 
-  | [] -> 
-      []
-  | (Statement p) :: (Assert q) :: rem when annotation_candidate p ->
-      (* TODO: plutot p.post = None ? *)
-      let q' =
-	let ((id,v),_,_,_) = p.info.kappa in
-	let tv = Pmonad.trad_ml_type_v ren env v in
-	named_app (abstract [id,tv]) q
-      in
-      let p' = post_if_none env (Some q') p in
-      (Statement (propagate ren p')) :: (Assert q) 
-      :: (propagate_block ren env rem)
-  | (Statement p) :: rem ->
-      (Statement (propagate ren p)) :: (propagate_block ren env rem)
-  | (Label s as x) :: rem ->
-      x :: propagate_block (push_date ren s) env rem
-  | x :: rem ->
-      x :: propagate_block ren env rem
diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli
deleted file mode 100644
index 4027a623..00000000
--- a/contrib/correctness/pwp.mli
+++ /dev/null
@@ -1,18 +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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pwp.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Penv
-
-val update_post : local_env -> string -> Peffect.t -> constr -> constr
-
-val propagate : Prename.t -> typed_program -> typed_program
diff --git a/contrib/dp/Dp.v b/contrib/dp/Dp.v
new file mode 100644
index 00000000..857c182c
--- /dev/null
+++ b/contrib/dp/Dp.v
@@ -0,0 +1,120 @@
+(* Calls to external decision procedures *)
+
+Require Export ZArith.
+Require Export Classical.
+
+(* Zenon *)
+
+(*  Copyright 2004 INRIA  *)
+(*  $Id: Dp.v 10739 2008-04-01 14:45:20Z herbelin $  *)
+
+Lemma zenon_nottrue :
+  (~True -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_noteq : forall (T : Type) (t : T),
+  ((t <> t) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_and : forall P Q : Prop,
+  (P -> Q -> False) -> (P /\ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_or : forall P Q : Prop,
+  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_imply : forall P Q : Prop,
+  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_equiv : forall P Q : Prop,
+  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notand : forall P Q : Prop,
+  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notor : forall P Q : Prop,
+  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notimply : forall P Q : Prop,
+  (P -> ~Q -> False) -> (~(P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notequiv : forall P Q : Prop,
+  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
+  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
+  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
+  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
+  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
+Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
+
+Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
+Proof. auto. Qed.
+
+Lemma zenon_equal_step :
+  forall (S T : Type) (fa fb : S -> T) (a b : S),
+  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
+Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
+
+Lemma zenon_pnotp : forall P Q : Prop,
+  (P = Q) -> (P -> ~Q -> False).
+Proof. intros P Q Ha. rewrite Ha. auto. Qed.
+
+Lemma zenon_notequal : forall (T : Type) (a b : T),
+  (a = b) -> (a <> b -> False).
+Proof. auto. Qed.
+
+Ltac zenon_intro id :=
+  intro id || let nid := fresh in (intro nid; clear nid)
+.
+
+Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
+Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
+Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
+Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
+Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
+Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
+Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
+Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
+Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
+Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
+
+Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
+Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
+
+(* Ergo *)
+
+Set Implicit Arguments.
+Section congr.
+  Variable t:Type.
+Lemma ergo_eq_concat_1 : 
+  forall (P:t -> Prop) (x y:t),
+    P x -> x = y -> P y.
+Proof.
+  intros; subst; auto.
+Qed.
+
+Lemma ergo_eq_concat_2 : 
+  forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
+    P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
+Proof.
+  intros; subst; auto.
+Qed.
+
+End congr.
diff --git a/contrib/dp/TODO b/contrib/dp/TODO
index 387cacdf..44349e21 100644
--- a/contrib/dp/TODO
+++ b/contrib/dp/TODO
@@ -21,8 +21,4 @@ TODO
 BUGS
 ----
 
-- value = Some : forall A:Set, A -> option A
-
-  -> eta_expanse échoue sur assert false (ligne 147)
-
 
diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml
index 131dd029..79ffaf3f 100644
--- a/contrib/dp/dp.ml
+++ b/contrib/dp/dp.ml
@@ -13,6 +13,8 @@
 
 open Util
 open Pp
+open Libobject
+open Summary
 open Term
 open Tacmach
 open Tactics
@@ -25,12 +27,46 @@ open Coqlib
 open Hipattern
 open Libnames
 open Declarations
+open Dp_why
 
 let debug = ref false
+let set_debug b = debug := b
+let trace = ref false
+let set_trace b = trace := b
+let timeout = ref 10
+let set_timeout n = timeout := n
+
+let (dp_timeout_obj,_) = 
+  declare_object 
+    {(default_object "Dp_timeout") with  
+       cache_function = (fun (_,x) -> set_timeout x);
+       load_function = (fun _ (_,x) -> set_timeout x);
+       export_function = (fun x -> Some x)}
+
+let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
+
+let (dp_debug_obj,_) = 
+  declare_object 
+    {(default_object "Dp_debug") with  
+       cache_function = (fun (_,x) -> set_debug x);
+       load_function = (fun _ (_,x) -> set_debug x);
+       export_function = (fun x -> Some x)}
+
+let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
+
+let (dp_trace_obj,_) = 
+  declare_object 
+    {(default_object "Dp_trace") with  
+       cache_function = (fun (_,x) -> set_trace x);
+       load_function = (fun _ (_,x) -> set_trace x);
+       export_function = (fun x -> Some x)}
+
+let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x)
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
 let coq_modules =
   init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
+    @ [["Coq"; "ZArith"; "BinInt"]]
     @ [["Coq"; "omega"; "OmegaLemmas"]]
 
 let constant = gen_constant_in_modules "dp" coq_modules
@@ -52,6 +88,7 @@ let coq_Zneg = lazy (constant "Zneg")
 let coq_xH = lazy (constant "xH")
 let coq_xI = lazy (constant "xI")
 let coq_xO = lazy (constant "xO")
+let coq_iff = lazy (constant "iff")
 
 (* not Prop typed expressions *)
 exception NotProp
@@ -104,7 +141,7 @@ let coq_rename_vars env vars =
    type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
 let decomp_type_quantifiers env t =
   let rec loop vars t = match kind_of_term t with
-    | Prod (n, a, t) when is_Set a -> 
+    | Prod (n, a, t) when is_Set a || is_Type a -> 
 	loop ((n,a) :: vars) t
     | _ -> 
 	let vars, env = coq_rename_vars env vars in
@@ -116,7 +153,7 @@ let decomp_type_quantifiers env t =
 (* same thing with lambda binders (for axiomatize body) *)
 let decomp_type_lambdas env t =
   let rec loop vars t = match kind_of_term t with
-    | Lambda (n, a, t) when is_Set a -> 
+    | Lambda (n, a, t) when is_Set a || is_Type a -> 
 	loop ((n,a) :: vars) t
     | _ -> 
 	let vars, env = coq_rename_vars env vars in
@@ -314,7 +351,7 @@ and make_term_abstraction tv env c =
  *)
 and tr_decl env id ty =
   let tv, env, t = decomp_type_quantifiers env ty in
-  if is_Set t then
+  if is_Set t || is_Type t then
     DeclType (id, List.length tv)
   else if is_Prop t then
     DeclPred (id, List.length tv, [])
@@ -329,8 +366,8 @@ and tr_decl env id ty =
 	DeclPred(id, List.length tv, l)
       else 
 	let s = Typing.type_of env Evd.empty t in
-	if is_Set s then 
-	  DeclFun(id, List.length tv, l, tr_type tv env t)
+	if is_Set s || is_Type s then 
+	  DeclFun (id, List.length tv, l, tr_type tv env t)
 	else 
 	  raise NotFO
 
@@ -364,17 +401,18 @@ and axiomatize_body env r id d = match r with
       begin match (Global.lookup_constant c).const_body with
 	| Some b ->
 	    let b = force b in
-	    let tv, env, b = decomp_type_lambdas env b in
 	    let axioms =
 	      (match d with
 		 | DeclPred (id, _, []) ->
+		     let tv, env, b = decomp_type_lambdas env b in
 		     let value = tr_formula tv [] env b in
 		     [id, Iff (Fatom (Pred (id, [])), value)]
 		 | DeclFun (id, _, [], _) ->
+		     let tv, env, b = decomp_type_lambdas env b in
 		     let value = tr_term tv [] env b in
 		     [id, Fatom (Eq (Fol.App (id, []), value))]
 		 | DeclFun (id, _, l, _) | DeclPred (id, _, l) ->
-		     Format.eprintf "axiomatize_body %S@." id;
+		     (*Format.eprintf "axiomatize_body %S@." id;*)
 		     let b = match kind_of_term b with
 		       (* a single recursive function *)
 		       | Fix (_, (_,_,[|b|])) -> 
@@ -391,6 +429,7 @@ and axiomatize_body env r id d = match r with
 		       | _ -> 
 			   b
 		     in
+		     let tv, env, b = decomp_type_lambdas env b in
 		     let vars, t = decompose_lam b in
 		     let n = List.length l in
 		     let k = List.length vars in
@@ -401,21 +440,21 @@ and axiomatize_body env r id d = match r with
 		     let vars = List.rev vars in
 		     let bv = vars in
 		     let vars = List.map (fun x -> string_of_id x) vars in
-		     let fol_var x =
-		       Fol.App (x, []) in
+		     let fol_var x = Fol.App (x, []) in
 		     let fol_vars = List.map fol_var vars in
 		     let vars = List.combine vars l in
 		     begin match d with
-		       | DeclFun _ ->
+		       | DeclFun (_, _, _, ty) ->
 			   begin match kind_of_term t with
 			     | Case (ci, _, e, br) ->
 				 equations_for_case env id vars tv bv ci e br
 			     | _ -> 
-				 let p = 
-				   Fatom (Eq (App (id, fol_vars), 
-					      tr_term tv bv env t)) 
+				 let t = tr_term tv bv env t in
+				 let ax = 
+				   add_proof (Fun_def (id, vars, ty, t))
 				 in
-				 [id, foralls vars p]
+				 let p = Fatom (Eq (App (id, fol_vars), t)) in
+				 [ax, foralls vars p]
 			   end
 		       | DeclPred _ ->
 			   let value = tr_formula tv bv env t in
@@ -436,7 +475,7 @@ and axiomatize_body env r id d = match r with
   | IndRef i ->
       iter_all_constructors i
 	(fun _ c ->
-	   let rc = reference_of_constr c in
+	   let rc = global_of_constr c in
 	   try
 	     begin match tr_global env rc with
 	       | DeclFun (_, _, [], _) -> ()
@@ -453,18 +492,20 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
       iter_all_constructors ci.ci_ind
 	(fun j cj ->
 	   try
-	     let cjr = reference_of_constr cj in
+	     let cjr = global_of_constr cj in
 	     begin match tr_global env cjr with
 	       | DeclFun (idc, _, l, _) ->
 		   let b = br.(j) in
 		   let rec_vars, b = decompose_lam b in
 		   let rec_vars, env = coq_rename_vars env rec_vars in
-		   let b = substl (List.map mkVar rec_vars) b in
+		   let coq_rec_vars = List.map mkVar rec_vars in
+		   let b = substl coq_rec_vars b in
 		   let rec_vars = List.rev rec_vars in
+		   let coq_rec_term = applist (cj, List.rev coq_rec_vars) in
+		   let b = replace_vars [x, coq_rec_term] b in
 		   let bv = bv @ rec_vars in
 		   let rec_vars = List.map string_of_id rec_vars in
-		   let fol_var x =
-		     Fol.App (x, []) in
+		   let fol_var x = Fol.App (x, []) in
 		   let fol_rec_vars = List.map fol_var rec_vars in
 		   let fol_rec_term = App (idc, fol_rec_vars) in
 		   let rec_vars = List.combine rec_vars l in
@@ -558,7 +599,7 @@ and tr_formula tv bv env f =
 	Fatom (Pred (rename_global (VarRef id), []))
     | _, [t;a;b] when c = build_coq_eq () ->
 	let ty = Typing.type_of env Evd.empty t in
-	if is_Set ty then
+	if is_Set ty || is_Type ty then
 	  let _ = tr_type tv env t in
 	  Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
 	else 
@@ -581,6 +622,8 @@ and tr_formula tv bv env f =
 	And (tr_formula tv bv env a, tr_formula tv bv env b)
     | _, [a;b] when c = build_coq_or () ->
 	Or (tr_formula tv bv env a, tr_formula tv bv env b)
+    | _, [a;b] when c = Lazy.force coq_iff ->
+	Iff (tr_formula tv bv env a, tr_formula tv bv env b)
     | Prod (n, a, b), _ ->
 	if is_imp_term f then
 	  Imp (tr_formula tv bv env a, tr_formula tv bv env b)
@@ -632,55 +675,164 @@ let tr_goal gl =
   hyps, c
 
 
-type prover = Simplify | CVCLite | Harvey | Zenon
+type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy
 
 let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
 
 let sprintf = Format.sprintf
 
+let file_contents f =
+  let buf = Buffer.create 1024 in
+  try
+    let c = open_in f in
+    begin try 
+      while true do 
+	let s = input_line c in Buffer.add_string buf s; 
+	Buffer.add_char buf '\n'
+      done;
+      assert false
+    with End_of_file ->
+      close_in c;
+      Buffer.contents buf
+    end
+  with _ -> 
+    sprintf "(cannot open %s)" f
+
+let timeout_sys_command cmd =
+  if !debug then Format.eprintf "command line: %s@." cmd;
+  let out = Filename.temp_file "out" "" in
+  let cmd = sprintf "cpulimit %d %s > %s 2>&1" !timeout cmd out in
+  let ret = Sys.command cmd in
+  if !debug then 
+    Format.eprintf "Output file %s:@.%s@." out (file_contents out);
+  ret, out
+
+let timeout_or_failure c cmd out =
+  if c = 152 then 
+    Timeout 
+  else
+    Failure 
+      (sprintf "command %s failed with output:\n%s " cmd (file_contents out))
+
+let prelude_files = ref ([] : string list)
+
+let set_prelude l = prelude_files := l
+
+let (dp_prelude_obj,_) = 
+  declare_object 
+    {(default_object "Dp_prelude") with  
+       cache_function = (fun (_,x) -> set_prelude x);
+       load_function = (fun _ (_,x) -> set_prelude x);
+       export_function = (fun x -> Some x)}
+
+let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x)
+
+let why_files f = String.concat " " (!prelude_files @ [f])
+
 let call_simplify fwhy =
-  let cmd = sprintf "why --simplify %s" fwhy in
-  if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed");
+  let cmd = 
+    sprintf "why --no-arrays --simplify --encoding sstrat %s" (why_files 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
+    sprintf "timeout %d Simplify %s > out 2>&1 && grep -q -w Valid out" 
+      !timeout fsx
   in
   let out = Sys.command cmd in
-  let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in
+  let r = 
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
+  in
   if not !debug then remove_files [fwhy; fsx];
   r
 
+let call_ergo fwhy =
+  let cmd = sprintf "why --no-arrays --why %s" (why_files fwhy) in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in
+  let ftrace = Filename.temp_file "ergo_trace" "" in
+  let cmd = 
+    if !trace then
+      sprintf "ergo -cctrace %s %s" ftrace fwhy
+    else
+      sprintf "ergo %s" fwhy
+  in
+  let ret,out = timeout_sys_command cmd in
+  let r = 
+    if ret <> 0 then 
+      timeout_or_failure ret cmd out
+    else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then
+      Valid (if !trace then Some ftrace else None)
+    else if Sys.command (sprintf "grep -q -w \"I don't know\" %s" out) = 0 then
+      DontKnow
+    else if Sys.command (sprintf "grep -q -w \"Invalid\" %s" out) = 0 then
+      Invalid
+    else
+      Failure ("command failed: " ^ cmd)
+  in
+  if not !debug then remove_files [fwhy; out];
+  r
+
 let call_zenon fwhy =
-  let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in
+  let cmd = 
+    sprintf "why --no-prelude --no-zenon-prelude --zenon %s" (why_files fwhy)
+  in
   if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
   let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
+  let out = Filename.temp_file "dp_out" "" in
   let cmd = 
-    sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn
+    sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out 
+  in
+  let c = Sys.command cmd in
+  if not !debug then remove_files [fwhy; fznn];
+  if c = 137 then 
+    Timeout
+  else begin
+    if c <> 0 then anomaly ("command failed: " ^ cmd);
+    if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then
+      error "Zenon failed";
+    let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in
+    if c = 0 then Valid (Some out) else Invalid
+  end
+
+let call_yices fwhy =
+  let cmd = 
+    sprintf "why --no-arrays -smtlib --encoding sstrat %s" (why_files fwhy)
+  in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+  let cmd = 
+    sprintf "timeout %d yices -pc 0 -smt < %s > out 2>&1 && grep -q -w unsat out" 
+      !timeout fsmt
   in
   let out = Sys.command cmd in
   let r = 
-    if out = 0 then Valid 
-    else if out = 1 then Invalid 
-    else if out = 137 then Timeout 
-    else anomaly ("malformed Zenon input file " ^ fznn)
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
   in
-  if not !debug then remove_files [fwhy; fznn];
+  if not !debug then remove_files [fwhy; fsmt];
   r
 
 let call_cvcl fwhy =
-  let cmd = sprintf "why --cvcl %s" fwhy in
+  let cmd = 
+    sprintf "why --no-arrays --cvcl --encoding sstrat %s" (why_files 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
+    sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" 
+      !timeout fcvc
   in
   let out = Sys.command cmd in
-  let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in
+  let r = 
+    if out = 0 then Valid None else if out = 1 then Invalid else Timeout 
+  in
   if not !debug then remove_files [fwhy; fcvc];
   r
 
 let call_harvey fwhy =
-  let cmd = sprintf "why --harvey %s" fwhy in
+  let cmd = 
+    sprintf "why --no-arrays --harvey --encoding strat %s" (why_files 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
@@ -688,7 +840,8 @@ let call_harvey fwhy =
   let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
   let outf = Filename.temp_file "rv" ".out" in
   let out = 
-    Sys.command (sprintf "timeout 10 rv -e\"-T 2000\" %s > %s 2>&1" f outf) 
+    Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" 
+		   !timeout f outf) 
   in
   let r =
     if out <> 0 then 
@@ -697,40 +850,69 @@ let call_harvey fwhy =
       let cmd = 
 	sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
       in
-      if Sys.command cmd = 0 then Valid else Invalid
+      if Sys.command cmd = 0 then Valid None else Invalid
   in
   if not !debug then remove_files [fwhy; frv; outf];
   r
 
+let call_gwhy fwhy =
+  let cmd = sprintf "gwhy --no-arrays  %s" (why_files fwhy) in
+  if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy));
+  NoAnswer
+
+let ergo_proof_from_file f gl =
+  let s =
+    let buf = Buffer.create 1024 in
+    let c = open_in f in
+    try
+      while true do Buffer.add_string buf (input_line c) done; assert false
+    with End_of_file ->
+      close_in c;
+      Buffer.contents buf
+  in
+  let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in
+  let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in
+  exact_check t gl
+
 let call_prover prover q =
   let fwhy = Filename.temp_file "coq_dp" ".why" in
   Dp_why.output_file fwhy q;
-  if !debug then ignore (Sys.command (sprintf "cat %s" fwhy));
   match prover with
     | Simplify -> call_simplify fwhy
+    | Ergo -> call_ergo fwhy
+    | Yices -> call_yices fwhy
     | Zenon -> call_zenon fwhy
     | CVCLite -> call_cvcl fwhy
     | Harvey -> call_harvey fwhy
+    | Gwhy -> call_gwhy fwhy
   
 let dp prover gl =
+  Coqlib.check_required_library ["Coq";"ZArith";"ZArith"];
   let concl_type = pf_type_of gl (pf_concl gl) in
   if not (is_Prop concl_type) then error "Conclusion is not a Prop";
   try 
     let q = tr_goal gl in
     begin match call_prover prover q with
-      | Valid -> Tactics.admit_as_an_axiom gl
+      | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl
+      | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl
+      | Valid _ -> Tactics.admit_as_an_axiom gl
       | Invalid -> error "Invalid"
       | DontKnow -> error "Don't know"
       | Timeout -> error "Timeout"
+      | Failure s -> error s
+      | NoAnswer -> Tacticals.tclIDTAC gl
     end
   with NotFO ->
     error "Not a first order goal"
-  
+      
 
 let simplify = tclTHEN intros (dp Simplify)
+let ergo = tclTHEN intros (dp Ergo)
+let yices = tclTHEN intros (dp Yices)
 let cvc_lite = tclTHEN intros (dp CVCLite)
 let harvey = dp Harvey
 let zenon = tclTHEN intros (dp Zenon)
+let gwhy = tclTHEN intros (dp Gwhy)
 
 let dp_hint l =
   let env = Global.env () in
@@ -741,7 +923,8 @@ let dp_hint l =
       if is_Prop s then
 	try
 	  let id = rename_global r in
-	  let d = Axiom (id, tr_formula [] [] env ty) in
+	  let tv, env, ty = decomp_type_quantifiers env ty in
+	  let d = Axiom (id, tr_formula tv [] env ty) in
 	  add_global r (Gfo d);
 	  globals_stack := d :: !globals_stack
 	with NotFO ->
@@ -757,3 +940,52 @@ let dp_hint l =
     end
   in
   List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
+
+let (dp_hint_obj,_) = 
+  declare_object 
+    {(default_object "Dp_hint") with  
+       cache_function = (fun (_,l) -> dp_hint l);
+       load_function = (fun _ (_,l) -> dp_hint l);
+       export_function = (fun x -> Some x)}
+
+let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l)
+
+let dp_predefined qid s =
+  let r = Nametab.global qid in
+  let ty = Global.type_of_global r in
+  let env = Global.env () in
+  let id = rename_global r in
+  try
+    let d = match tr_decl env id ty with
+      | DeclType (_, n) -> DeclType (s, n)
+      | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty)
+      | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) 
+      | Axiom _ as d -> d
+    in
+    match d with
+      | Axiom _ ->  msg_warning (str " ignored (axiom)")
+      | d -> add_global r (Gfo d)
+  with NotFO ->
+    msg_warning (str " ignored (not a first order declaration)")
+
+let (dp_predefined_obj,_) = 
+  declare_object 
+    {(default_object "Dp_predefined") with  
+       cache_function = (fun (_,(id,s)) -> dp_predefined id s);
+       load_function = (fun _ (_,(id,s)) -> dp_predefined id s);
+       export_function = (fun x -> Some x)}
+
+let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s))
+
+let _ = declare_summary "Dp options" 
+	  { freeze_function = 
+	      (fun () -> !debug, !trace, !timeout, !prelude_files);
+	    unfreeze_function = 
+	      (fun (d,tr,tm,pr) -> 
+		debug := d; trace := tr; timeout := tm; prelude_files := pr);
+	    init_function = 
+	      (fun () -> 
+		debug := false; trace := false; timeout := 10; 
+		prelude_files := []);
+	    survive_module = true;
+	    survive_section = true }  
diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli
index 3dad469c..6dbc05e1 100644
--- a/contrib/dp/dp.mli
+++ b/contrib/dp/dp.mli
@@ -3,10 +3,18 @@ open Libnames
 open Proof_type
 
 val simplify : tactic
+val ergo : tactic
+val yices : tactic
 val cvc_lite : tactic
 val harvey : tactic
 val zenon : tactic
+val gwhy : tactic
 
 val dp_hint : reference list -> unit
+val dp_timeout : int -> unit
+val dp_debug : bool -> unit
+val dp_trace : bool -> unit
+val dp_prelude : string list -> unit
+val dp_predefined : reference -> string -> unit
 
 
diff --git a/contrib/dp/dp_cvcl.ml b/contrib/dp/dp_cvcl.ml
deleted file mode 100644
index 05d43081..00000000
--- a/contrib/dp/dp_cvcl.ml
+++ /dev/null
@@ -1,112 +0,0 @@
-
-open Format
-open Fol
-
-let rec print_list sep print fmt = function
-  | [] -> ()
-  | [x] -> print fmt x
-  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-let space fmt () = fprintf fmt "@ "
-let comma fmt () = fprintf fmt ",@ "
-
-let rec print_term fmt = function
-  | Cst n -> 
-      fprintf fmt "%d" n
-  | Plus (a, b) ->
-      fprintf fmt "@[(%a@ +@ %a)@]" print_term a print_term b
-  | Moins (a, b) ->
-      fprintf fmt "@[(%a@ -@ %a)@]" print_term a print_term b
-  | Mult (a, b) ->
-      fprintf fmt "@[(%a@ *@ %a)@]" print_term a print_term b
-  | Div (a, b) ->
-      fprintf fmt "@[(%a@ /@ %a)@]" print_term a print_term b
-  | App (id, []) ->
-      fprintf fmt "@[%s@]" id
-  | App (id, tl) ->
-      fprintf fmt "@[%s(%a)@]" id print_terms tl
-
-and print_terms fmt tl = 
-  print_list comma print_term fmt tl
-
-let rec print_predicate fmt p = 
-  let pp = print_predicate in 
-  match p with
-  | True ->
-      fprintf fmt "TRUE"
-  | False ->
-      fprintf fmt "FALSE"
-  | Fatom (Eq (a, b)) ->
-      fprintf fmt "@[(%a = %a)@]" print_term a print_term b
-  | Fatom (Le (a, b)) ->
-      fprintf fmt "@[(%a@ <= %a)@]" print_term a print_term b
-  | Fatom (Lt (a, b))->
-      fprintf fmt "@[(%a@ < %a)@]" print_term a print_term b
-  | Fatom (Ge (a, b)) ->
-      fprintf fmt "@[(%a@ >= %a)@]" print_term a print_term b
-  | Fatom (Gt (a, b)) ->
-      fprintf fmt "@[(%a@ > %a)@]" print_term a print_term b
-  | Fatom (Pred (id, [])) ->
-      fprintf fmt "@[%s@]" id
-  | Fatom (Pred (id, tl)) ->
-      fprintf fmt "@[%s(%a)@]" id print_terms tl
-  | Imp (a, b) ->
-      fprintf fmt "@[(%a@ => %a)@]" pp a pp b
-  | And (a, b) ->
-      fprintf fmt "@[(%a@ AND@ %a)@]" pp a pp b
-  | Or (a, b) ->
-      fprintf fmt "@[(%a@ OR@ %a)@]" pp a pp b
-  | Not a ->
-      fprintf fmt "@[(NOT@ %a)@]" pp a
-  | Forall (id, t, p) -> 
-      fprintf fmt "@[(FORALL (%s:%s): %a)@]" id t pp p
-  | Exists (id, t, p) -> 
-      fprintf fmt "@[(EXISTS (%s:%s): %a)@]" id t pp p
-
-let rec string_of_type_list  = function
-  | [] -> assert false
-  | [e] -> e
-  | e :: l' -> e ^ ", " ^ (string_of_type_list l')
-
-let print_query fmt (decls,concl) =
-  let print_decl = function
-    | DeclVar (id, [], t) ->
-	fprintf fmt "@[%s: %s;@]@\n" id t
-    | DeclVar (id, [e], t) ->
-	fprintf fmt "@[%s: [%s -> %s];@]@\n"
-	  id e t
-    | DeclVar (id, l, t) ->
-	fprintf fmt "@[%s: [[%s] -> %s];@]@\n"
-	  id (string_of_type_list l) t
-    | DeclPred (id, []) ->
-	fprintf fmt "@[%s: BOOLEAN;@]@\n" id
-     | DeclPred (id, [e]) ->
-	fprintf fmt "@[%s: [%s -> BOOLEAN];@]@\n"
-	  id e
-   | DeclPred (id, l) ->
-	fprintf fmt "@[%s: [[%s] -> BOOLEAN];@]@\n"
-	  id (string_of_type_list l)
-    | DeclType id ->
-	fprintf fmt "@[%s: TYPE;@]@\n" id
-    | Assert (id, f)  -> 
-	fprintf fmt "@[ASSERT %% %s@\n %a;@]@\n" id print_predicate f
-  in
-  List.iter print_decl decls;
-  fprintf fmt "QUERY %a;" print_predicate concl
-
-let call q = 
-  let f = Filename.temp_file "coq_dp" ".cvc" in
-  let c = open_out f in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[%a@]@." print_query q;
-  close_out c;
-  ignore (Sys.command (sprintf "cat %s" f));
-  let cmd = 
-    sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" f
-  in
-  prerr_endline cmd; flush stderr;
-  let out = Sys.command cmd in
-  if out = 0 then Valid else if out = 1 then Invalid else Timeout
-  (* TODO: effacer le fichier f et le fichier out *)
-
-
diff --git a/contrib/dp/dp_cvcl.mli b/contrib/dp/dp_cvcl.mli
deleted file mode 100644
index 03b6d347..00000000
--- a/contrib/dp/dp_cvcl.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val call : query -> prover_answer
diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml
new file mode 100644
index 00000000..70439a97
--- /dev/null
+++ b/contrib/dp/dp_gappa.ml
@@ -0,0 +1,445 @@
+
+open Format
+open Util
+open Pp
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Names
+open Nameops
+open Termops
+open Coqlib
+open Hipattern
+open Libnames
+open Declarations
+open Evarutil
+
+let debug = ref false
+
+(* 1. gappa syntax trees and output *)
+
+module Constant = struct
+
+  open Bigint
+
+  type t = { mantissa : bigint; base : int; exp : bigint }
+
+  let create (b, m, e) =
+    { mantissa = m; base = b; exp = e }
+
+  let of_int x = 
+    { mantissa = x; base = 1; exp = zero }
+
+  let print fmt x = match x.base with
+    | 1 -> fprintf fmt "%s" (to_string x.mantissa)
+    | 2 -> fprintf fmt "%sb%s" (to_string x.mantissa) (to_string x.exp)
+    | 10 -> fprintf fmt "%se%s" (to_string x.mantissa) (to_string x.exp)
+    | _ -> assert false
+
+end
+
+type binop = Bminus | Bplus | Bmult | Bdiv
+
+type unop = Usqrt | Uabs | Uopp
+
+type rounding_mode = string
+
+type term =
+  | Tconst of Constant.t
+  | Tvar of string
+  | Tbinop of binop * term * term
+  | Tunop of unop * term
+  | Tround of rounding_mode * term
+
+type pred =
+  | Pin of term * Constant.t * Constant.t
+
+let rec print_term fmt = function
+  | Tconst c -> Constant.print fmt c
+  | Tvar s -> pp_print_string fmt s
+  | Tbinop (op, t1, t2) -> 
+      let op = match op with 
+	| Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/"
+      in
+      fprintf fmt "(%a %s %a)" print_term t1 op print_term t2
+  | Tunop (Uabs, t) ->
+      fprintf fmt "|%a|" print_term t
+  | Tunop (Uopp | Usqrt as op, t) ->
+      let s = match op with 
+	| Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false 
+      in
+      fprintf fmt "(%s(%a))" s print_term t
+  | Tround (m, t) ->
+      fprintf fmt "(%s(%a))" m print_term t
+
+let print_pred fmt = function
+  | Pin (t, c1, c2) -> 
+      fprintf fmt "%a in [%a, %a]" 
+	print_term t Constant.print c1 Constant.print c2
+
+let temp_file f = if !debug then f else Filename.temp_file f ".v"
+let remove_file f = if not !debug then try Sys.remove f with _ -> ()
+
+let read_gappa_proof f =
+  let buf = Buffer.create 1024 in
+  Buffer.add_char buf '(';
+  let cin = open_in f in
+  let rec skip_space () =
+    let c = input_char cin in if c = ' ' then skip_space () else c
+  in
+  while input_char cin <> '=' do () done;
+  try
+    while true do
+      let c = skip_space () in
+      if c = ':' then raise Exit;
+      Buffer.add_char buf c;
+      let s = input_line cin in
+      Buffer.add_string buf s; 
+      Buffer.add_char buf '\n';
+    done;
+    assert false
+  with Exit ->
+    close_in cin;
+    remove_file f;
+    Buffer.add_char buf ')';
+    Buffer.contents buf
+
+exception GappaFailed
+exception GappaProofFailed
+
+let patch_gappa_proof fin fout =
+  let cin = open_in fin in
+  let cout = open_out fout in
+  let fmt = formatter_of_out_channel cout in
+  let last = ref "" in
+  let defs = ref "" in
+  try
+    while true do
+      let s = input_line cin in
+      if s = "Qed." then
+	fprintf fmt "Defined.@\n"
+      else begin
+	begin 
+	  try Scanf.sscanf s "Lemma %s " 
+	    (fun n -> defs := n ^ " " ^ !defs; last := n)
+	  with Scanf.Scan_failure _ ->
+	    try Scanf.sscanf s "Definition %s " 
+	      (fun n -> defs := n ^ " " ^ !defs)
+	    with Scanf.Scan_failure _ ->
+	      ()
+	end;
+	fprintf fmt "%s@\n" s
+      end
+    done
+  with End_of_file ->
+    close_in cin;
+    fprintf fmt "Definition proof := Eval cbv delta [%s] in %s.@." !defs !last;
+    close_out cout
+    
+let call_gappa hl p =
+  let gappa_in = temp_file "gappa_input" in
+  let c = open_out gappa_in in
+  let fmt = formatter_of_out_channel c in
+  fprintf fmt "@[{ "; 
+  List.iter (fun h -> fprintf fmt "%a ->@ " print_pred h) hl;
+  fprintf fmt "%a }@]@." print_pred p;
+  close_out c;
+  let gappa_out = temp_file "gappa_output" in
+  let cmd = sprintf "gappa -Bcoq < %s > %s 2> /dev/null" gappa_in gappa_out in
+  let out = Sys.command cmd in
+  if out <> 0 then raise GappaFailed;
+  remove_file gappa_in;
+  let gappa_out2 = temp_file "gappa2" in
+  patch_gappa_proof gappa_out gappa_out2;
+  remove_file gappa_out;
+  let cmd = sprintf "%s/coqc %s" Coq_config.bindir gappa_out2 in
+  let out = Sys.command cmd in
+  if out <> 0 then raise GappaProofFailed;
+  let gappa_out3 = temp_file "gappa3" in
+  let c = open_out gappa_out3 in
+  let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in
+  Printf.fprintf c 
+    "Require \"%s\". Set Printing Depth 9999999. Print %s.proof." 
+    (Filename.chop_suffix gappa_out2 ".v") gappa2;
+  close_out c;
+  let lambda = temp_file "gappa_lambda" in
+  let cmd = sprintf "%s/coqc %s > %s" Coq_config.bindir gappa_out3 lambda in
+  let out = Sys.command cmd in
+  if out <> 0 then raise GappaProofFailed;
+  remove_file gappa_out2; remove_file gappa_out3;
+  remove_file (gappa_out2 ^ "o"); remove_file (gappa_out3 ^ "o");
+  read_gappa_proof lambda
+
+(* 2. coq -> gappa translation *)
+
+exception NotGappa
+
+let logic_dir = ["Coq";"Logic";"Decidable"]
+let coq_modules =
+  init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
+    @ [["Coq"; "ZArith"; "BinInt"];
+       ["Coq"; "Reals"; "Rdefinitions"]; 
+       ["Coq"; "Reals"; "Raxioms";];
+       ["Coq"; "Reals"; "Rbasic_fun";];
+       ["Coq"; "Reals"; "R_sqrt";];
+       ["Coq"; "Reals"; "Rfunctions";];
+       ["Gappa"; "Gappa_tactic";];
+       ["Gappa"; "Gappa_fixed";];
+       ["Gappa"; "Gappa_float";];
+       ["Gappa"; "Gappa_round_def";];
+       ["Gappa"; "Gappa_pred_bnd";];  
+       ["Gappa"; "Gappa_definitions";];
+  ]
+
+let constant = gen_constant_in_modules "gappa" coq_modules
+
+let coq_refl_equal = lazy (constant "refl_equal")
+let coq_Rle = lazy (constant "Rle")
+let coq_R = lazy (constant "R")
+(*
+let coq_Rplus = lazy (constant "Rplus")
+let coq_Rminus = lazy (constant "Rminus")
+let coq_Rmult = lazy (constant "Rmult")
+let coq_Rdiv = lazy (constant "Rdiv")
+let coq_powerRZ = lazy (constant "powerRZ")
+let coq_R1 = lazy (constant "R1")
+let coq_Ropp = lazy (constant "Ropp")
+let coq_Rabs = lazy (constant "Rabs")
+let coq_sqrt = lazy (constant "sqrt")
+*)
+
+let coq_convert = lazy (constant "convert")
+let coq_reUnknown = lazy (constant "reUnknown")
+let coq_reFloat2 = lazy (constant "reFloat2")
+let coq_reFloat10 = lazy (constant "reFloat10")
+let coq_reInteger = lazy (constant "reInteger")
+let coq_reBinary = lazy (constant "reBinary")
+let coq_reUnary = lazy (constant "reUnary")
+let coq_reRound = lazy (constant "reRound")
+let coq_roundDN = lazy (constant "roundDN")
+let coq_roundUP = lazy (constant "roundUP")
+let coq_roundNE = lazy (constant "roundNE")
+let coq_roundZR = lazy (constant "roundZR")
+let coq_rounding_fixed = lazy (constant "rounding_fixed")
+let coq_rounding_float = lazy (constant "rounding_float")
+let coq_boAdd = lazy (constant "boAdd")
+let coq_boSub = lazy (constant "boSub")
+let coq_boMul = lazy (constant "boMul")
+let coq_boDiv = lazy (constant "boDiv")
+let coq_uoAbs = lazy (constant "uoAbs")
+let coq_uoNeg = lazy (constant "uoNeg")
+let coq_uoSqrt = lazy (constant "uoSqrt")
+let coq_subset = lazy (constant "subset")
+let coq_makepairF = lazy (constant "makepairF")
+
+let coq_true = lazy (constant "true")
+let coq_false = lazy (constant "false")
+
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
+let coq_xH = lazy (constant "xH")
+let coq_xI = lazy (constant "xI")
+let coq_xO = lazy (constant "xO")
+let coq_IZR = lazy (constant "IZR")
+
+(* translates a closed Coq term p:positive into a FOL term of type int *)
+let rec tr_positive p = match kind_of_term p with
+  | Term.Construct _ when p = Lazy.force coq_xH ->
+      1
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+      2 * (tr_positive a) + 1
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+      2 * (tr_positive a)
+  | Term.Cast (p, _, _) ->
+      tr_positive p
+  | _ ->
+      raise NotGappa
+
+(* translates a closed Coq term t:Z into a term of type int *)
+let rec tr_arith_constant t = match kind_of_term t with
+  | Term.Construct _ when t = Lazy.force coq_Z0 -> 0
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_positive a
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - (tr_positive a)
+  | Term.Cast (t, _, _) -> tr_arith_constant t
+  | _ -> raise NotGappa
+
+(* translates a closed Coq term p:positive into a FOL term of type bigint *)
+let rec tr_bigpositive p = match kind_of_term p with
+  | Term.Construct _ when p = Lazy.force coq_xH -> 
+      Bigint.one
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+      Bigint.add_1 (Bigint.mult_2 (tr_bigpositive a))
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+      (Bigint.mult_2 (tr_bigpositive a))
+  | Term.Cast (p, _, _) ->
+      tr_bigpositive p
+  | _ ->
+      raise NotGappa
+
+(* translates a closed Coq term t:Z into a term of type bigint *)
+let rec tr_arith_bigconstant t = match kind_of_term t with
+  | Term.Construct _ when t = Lazy.force coq_Z0 -> Bigint.zero
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_bigpositive a
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> 
+      Bigint.neg (tr_bigpositive a)
+  | Term.Cast (t, _, _) -> tr_arith_bigconstant t
+  | _ -> raise NotGappa
+
+let decomp c = 
+  let c, args = decompose_app c in
+  kind_of_term c, args
+
+let tr_bool c = match decompose_app c with
+  | c, [] when c = Lazy.force coq_true -> true
+  | c, [] when c = Lazy.force coq_false -> false
+  | _ -> raise NotGappa
+
+let tr_float b m e =
+  (b, tr_arith_bigconstant m, tr_arith_bigconstant e)
+
+let tr_binop c = match decompose_app c with
+  | c, [] when c = Lazy.force coq_boAdd -> Bplus
+  | c, [] when c = Lazy.force coq_boSub -> Bminus
+  | c, [] when c = Lazy.force coq_boMul -> Bmult
+  | c, [] when c = Lazy.force coq_boDiv -> Bdiv
+  | _ -> assert false
+
+let tr_unop c = match decompose_app c with
+  | c, [] when c = Lazy.force coq_uoNeg -> Uopp
+  | c, [] when c = Lazy.force coq_uoSqrt -> Usqrt
+  | c, [] when c = Lazy.force coq_uoAbs -> Uabs
+  | _ -> raise NotGappa
+
+let tr_var c = match decomp c with
+  | Var x, [] -> string_of_id x
+  | _ -> assert false
+
+let tr_mode c = match decompose_app c with
+  | c, [] when c = Lazy.force coq_roundDN -> "dn"
+  | c, [] when c = Lazy.force coq_roundNE -> "ne"
+  | c, [] when c = Lazy.force coq_roundUP -> "up"
+  | c, [] when c = Lazy.force coq_roundZR -> "zr"
+  | _ -> raise NotGappa
+
+let tr_rounding_mode c = match decompose_app c with
+  | c, [a;b] when c = Lazy.force coq_rounding_fixed ->
+      let a = tr_mode a in
+      let b = tr_arith_constant b in
+      sprintf "fixed<%d,%s>" b a
+  | c, [a;p;e] when c = Lazy.force coq_rounding_float ->
+      let a = tr_mode a in
+      let p = tr_positive p in
+      let e = tr_arith_constant e in
+      sprintf "float<%d,%d,%s>" p (-e) a
+  | _ ->
+      raise NotGappa
+
+(* REexpr -> term *)
+let rec tr_term c0 = 
+  let c, args = decompose_app c0 in
+  match kind_of_term c, args with
+    | _, [a] when c = Lazy.force coq_reUnknown ->
+	Tvar (tr_var a)
+    | _, [a; b] when c = Lazy.force coq_reFloat2 ->
+	Tconst (Constant.create (tr_float 2 a b))
+    | _, [a; b] when c = Lazy.force coq_reFloat10 ->
+	Tconst (Constant.create (tr_float 10 a b))
+    | _, [a] when c = Lazy.force coq_reInteger ->
+	Tconst (Constant.create (1, tr_arith_bigconstant a, Bigint.zero))
+    | _, [op;a;b] when c = Lazy.force coq_reBinary ->
+	Tbinop (tr_binop op, tr_term a, tr_term b)
+    | _, [op;a] when c = Lazy.force coq_reUnary ->
+	Tunop (tr_unop op, tr_term a)
+    | _, [op;a] when c = Lazy.force coq_reRound ->
+	Tround (tr_rounding_mode op, tr_term a)
+    | _ -> 
+	msgnl (str "tr_term: " ++ Printer.pr_constr c0); 
+	assert false
+
+let tr_rle c = 
+  let c, args = decompose_app c in
+  match kind_of_term c, args with
+    | _, [a;b] when c = Lazy.force coq_Rle ->  
+	begin match decompose_app a, decompose_app b with
+	  | (ac, [at]), (bc, [bt]) 
+	    when ac = Lazy.force coq_convert && bc = Lazy.force coq_convert ->
+	      at, bt
+	  | _ ->
+	      raise NotGappa
+	end
+    | _ -> 
+	raise NotGappa
+
+let tr_pred c =
+  let c, args = decompose_app c in
+  match kind_of_term c, args with
+    | _, [a;b] when c = build_coq_and () ->
+	begin match tr_rle a, tr_rle b with
+	  | (c1, t1), (t2, c2) when t1 = t2 -> 
+	      begin match tr_term c1, tr_term c2 with
+		| Tconst c1, Tconst c2 ->
+		    Pin (tr_term t1, c1, c2)
+		| _ -> 
+		    raise NotGappa
+	      end
+	  | _ -> 
+	      raise NotGappa
+	end
+    | _ -> 
+	raise NotGappa
+
+let is_R c = match decompose_app c with
+  | c, [] when c = Lazy.force coq_R -> true
+  | _ -> false
+
+let tr_hyps =
+  List.fold_left 
+    (fun acc (_,h) -> try tr_pred h :: acc with NotGappa -> acc) []
+
+let constr_of_string gl s = 
+  let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
+  Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
+
+let var_name = function
+  | Name id -> 
+      let s = string_of_id id in
+      let s = String.sub s 1 (String.length s - 1) in
+      mkVar (id_of_string s)
+  | Anonymous -> 
+       assert false
+
+let build_proof_term c0 =
+  let bl,c = decompose_lam c0 in
+  List.fold_right 
+    (fun (x,t) pf -> 
+      mkApp (pf, [| if is_R t then var_name x else mk_new_meta () |]))
+    bl c0
+
+let gappa_internal gl =
+  try
+    let c = tr_pred (pf_concl gl) in
+    let s = call_gappa (tr_hyps (pf_hyps_types gl)) c in
+    let pf = constr_of_string gl s in
+    let pf = build_proof_term pf in
+    Tacticals.tclTHEN (Tacmach.refine_no_check pf) Tactics.assumption gl
+  with 
+    | NotGappa -> error "not a gappa goal"
+    | GappaFailed -> error "gappa failed"
+    | GappaProofFailed -> error "incorrect gappa proof term"
+
+let gappa_prepare =
+  let id = Ident (dummy_loc, id_of_string "gappa_prepare") in
+  lazy (Tacinterp.interp (Tacexpr.TacArg (Tacexpr.Reference id)))
+
+let gappa gl =
+  Coqlib.check_required_library ["Gappa"; "Gappa_tactic"];
+  Tacticals.tclTHEN (Lazy.force gappa_prepare) gappa_internal gl
+
+(*
+Local Variables: 
+compile-command: "make -C ../.. bin/coqc.opt bin/coqide.opt"
+End: 
+*)
+
diff --git a/contrib/dp/dp_simplify.ml b/contrib/dp/dp_simplify.ml
deleted file mode 100644
index d5376b8d..00000000
--- a/contrib/dp/dp_simplify.ml
+++ /dev/null
@@ -1,117 +0,0 @@
-
-open Format
-open Fol
-
-let is_simplify_ident s =
-  let is_simplify_char = function
-    | 'a'..'z' | 'A'..'Z' | '0'..'9' -> true 
-    | _ -> false
-  in
-  try 
-    String.iter (fun c -> if not (is_simplify_char c) then raise Exit) s; true
-  with Exit ->
-    false
-
-let ident fmt s =
-  if is_simplify_ident s then fprintf fmt "%s" s else fprintf fmt "|%s|" s
-
-let rec print_list sep print fmt = function
-  | [] -> ()
-  | [x] -> print fmt x
-  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-let space fmt () = fprintf fmt "@ "
-let comma fmt () = fprintf fmt ",@ "
-
-let rec print_term fmt = function
-  | Cst n -> 
-      fprintf fmt "%d" n
-  | Plus (a, b) ->
-      fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b
-  | Moins (a, b) ->
-      fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b
-  | Mult (a, b) ->
-      fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b
-  | Div (a, b) ->
-      fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b
-  | App (id, []) ->
-      fprintf fmt "%a" ident id
-  | App (id, tl) ->
-      fprintf fmt "@[(%a@ %a)@]" ident id print_terms tl
-
-and print_terms fmt tl = 
-  print_list space print_term fmt tl
-
-let rec print_predicate fmt p = 
-  let pp = print_predicate in 
-  match p with
-  | True ->
-      fprintf fmt "TRUE"
-  | False ->
-      fprintf fmt "FALSE"
-  | Fatom (Eq (a, b)) ->
-      fprintf fmt "@[(EQ %a@ %a)@]" print_term a print_term b
-  | Fatom (Le (a, b)) ->
-      fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b
-  | Fatom (Lt (a, b))->
-      fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b
-  | Fatom (Ge (a, b)) ->
-      fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b
-  | Fatom (Gt (a, b)) ->
-      fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b
-  | Fatom (Pred (id, tl)) -> 
-      fprintf fmt "@[(EQ (%a@ %a) |@@true|)@]" ident id print_terms tl
-  | Imp (a, b) ->
-      fprintf fmt "@[(IMPLIES@ %a@ %a)@]" pp a pp b
-  | And (a, b) ->
-      fprintf fmt "@[(AND@ %a@ %a)@]" pp a pp b
-  | Or (a, b) ->
-      fprintf fmt "@[(OR@ %a@ %a)@]" pp a pp b
-  | Not a ->
-      fprintf fmt "@[(NOT@ %a)@]" pp a
-  | Forall (id, _, p) -> 
-      fprintf fmt "@[(FORALL (%a)@ %a)@]" ident id pp p
-  | Exists (id, _, p) -> 
-      fprintf fmt "@[(EXISTS (%a)@ %a)@]" ident id pp p
-
-(**
-let rec string_list l = match l with
-    [] -> ""
-  | [e] -> e
-  | e::l' -> e ^ " " ^ (string_list l')
-**)
-
-let print_query fmt (decls,concl) =
-  let print_decl = function
-    | DeclVar (id, [], t) ->
-	fprintf fmt "@[;; %s : %s@]@\n"	id t
-    | DeclVar (id, l, t) ->
-	fprintf fmt "@[;; %s : %a -> %s@]@\n" 
-	  id (print_list comma pp_print_string) l t
-    | DeclPred (id, []) ->
-	fprintf fmt "@[;; %s : BOOLEAN @]@\n" id
-    | DeclPred (id, l) -> 
-	fprintf fmt "@[;; %s : %a -> BOOLEAN@]@\n" 
-	  id (print_list comma pp_print_string) l
-    | DeclType id ->
-	fprintf fmt "@[;; %s : TYPE@]@\n" id
-    | Assert (id, f)  -> 
-	fprintf fmt "@[(BG_PUSH ;; %s@\n %a)@]@\n" id print_predicate f
-  in
-  List.iter print_decl decls;
-  fprintf fmt "%a@." print_predicate concl
-
-let call q = 
-  let f = Filename.temp_file "coq_dp" ".sx" in
-  let c = open_out f in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[%a@]@." print_query q;
-  close_out c;
-  ignore (Sys.command (sprintf "cat %s" f));
-  let cmd = 
-    sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" f
-  in
-  prerr_endline cmd; flush stderr;
-  let out = Sys.command cmd in
-  if out = 0 then Valid else if out = 1 then Invalid else Timeout
-  (* TODO: effacer le fichier f et le fichier out *)
diff --git a/contrib/dp/dp_simplify.mli b/contrib/dp/dp_simplify.mli
deleted file mode 100644
index 03b6d347..00000000
--- a/contrib/dp/dp_simplify.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val call : query -> prover_answer
diff --git a/contrib/dp/dp_sorts.ml b/contrib/dp/dp_sorts.ml
deleted file mode 100644
index 7dbdfa56..00000000
--- a/contrib/dp/dp_sorts.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-
-open Fol
-
-let term_has_sort x s = Fatom (Pred ("%sort_" ^ s, [x]))
-
-let has_sort x s = term_has_sort (App (x, [])) s
-
-let rec form = function
-  | True | False | Fatom _ as f -> f
-  | Imp (f1, f2) -> Imp (form f1, form f2)
-  | And (f1, f2) -> And (form f1, form f2)
-  | Or (f1, f2) -> Or (form f1, form f2)
-  | Not f -> Not (form f)
-  | Forall (x, ("INT" as t), f) -> Forall (x, t, form f)
-  | Forall (x, t, f) -> Forall (x, t, Imp (has_sort x t, form f))
-  | Exists (x, ("INT" as t), f) -> Exists (x, t, form f)
-  | Exists (x, t, f) -> Exists (x, t, Imp (has_sort x t, form f))
-
-let sort_ax = let r = ref 0 in fun () -> incr r; "sort_ax_" ^ string_of_int !r
-
-let hyp acc = function
-  | Assert (id, f) -> 
-      (Assert (id, form f)) :: acc
-  | DeclVar (id, _, "INT") as d ->
-      d :: acc
-  | DeclVar (id, [], t) as d -> 
-      (Assert (sort_ax (), has_sort id t)) :: d :: acc
-  | DeclVar (id, l, t) as d -> 
-      let n = ref 0 in
-      let xi = 
-	List.fold_left 
-	  (fun l t -> incr n; ("x" ^ string_of_int !n, t) :: l) [] l
-      in
-      let f =
-	List.fold_left
-	  (fun f (x,t) -> if t = "INT" then f else Imp (has_sort x t, f))
-	  (term_has_sort 
-	     (App (id, List.rev_map (fun (x,_) -> App (x,[])) xi)) t)
-	  xi 
-      in
-      let f = List.fold_left (fun f (x,t) -> Forall (x, t, f)) f xi in
-      (Assert (sort_ax (), f)) :: d :: acc
-  | DeclPred _ as d ->
-      d :: acc
-  | DeclType t as d ->
-      (DeclPred ("%sort_" ^ t, [t])) :: d :: acc
-
-let query (hyps, f) =
-  let hyps' = List.fold_left hyp [] hyps in
-  List.rev hyps', form f
-
diff --git a/contrib/dp/dp_sorts.mli b/contrib/dp/dp_sorts.mli
deleted file mode 100644
index 9e74f997..00000000
--- a/contrib/dp/dp_sorts.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val query : query -> query
diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml
index e1ddb039..e24049ad 100644
--- a/contrib/dp/dp_why.ml
+++ b/contrib/dp/dp_why.ml
@@ -4,6 +4,18 @@
 open Format
 open Fol
 
+type proof = 
+  | Immediate of Term.constr
+  | Fun_def of string * (string * typ) list * typ * term
+
+let proofs = Hashtbl.create 97
+let proof_name = 
+  let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r
+
+let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n
+
+let find_proof = Hashtbl.find proofs
+
 let rec print_list sep print fmt = function
   | [] -> ()
   | [x] -> print fmt x
diff --git a/contrib/dp/dp_why.mli b/contrib/dp/dp_why.mli
new file mode 100644
index 00000000..b38a3d37
--- /dev/null
+++ b/contrib/dp/dp_why.mli
@@ -0,0 +1,17 @@
+
+open Fol
+
+(* generation of the Why file *)
+
+val output_file : string -> query -> unit
+
+(* table to translate the proofs back to Coq (used in dp_zenon) *)
+
+type proof = 
+  | Immediate of Term.constr
+  | Fun_def of string * (string * typ) list * typ * term
+
+val add_proof : proof -> string
+val find_proof : string -> proof
+
+
diff --git a/contrib/dp/dp_zenon.ml b/contrib/dp/dp_zenon.ml
deleted file mode 100644
index 57b0a44f..00000000
--- a/contrib/dp/dp_zenon.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-
-open Format
-open Fol
-
-let rec print_list sep print fmt = function
-  | [] -> ()
-  | [x] -> print fmt x
-  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-let space fmt () = fprintf fmt "@ "
-
-let rec print_term fmt = function
-  | Cst n -> 
-      fprintf fmt "%d" n
-  | Plus (a, b) ->
-      fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b
-  | Moins (a, b) ->
-      fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b
-  | Mult (a, b) ->
-      fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b
-  | Div (a, b) ->
-      fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b
-  | App (id, []) ->
-      fprintf fmt "%s" id 
-  | App (id, tl) ->
-      fprintf fmt "@[(%s@ %a)@]" id print_terms tl
-
-and print_terms fmt tl = 
-  print_list space print_term fmt tl
-
-let rec print_predicate fmt p = 
-  let pp = print_predicate in 
-  match p with
-  | True ->
-      fprintf fmt "True"
-  | False ->
-      fprintf fmt "False"
-  | Fatom (Eq (a, b)) ->
-      fprintf fmt "@[(= %a@ %a)@]" print_term a print_term b
-  | Fatom (Le (a, b)) ->
-      fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b
-  | Fatom (Lt (a, b))->
-      fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b
-  | Fatom (Ge (a, b)) ->
-      fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b
-  | Fatom (Gt (a, b)) ->
-      fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b
-  | Fatom (Pred (id, tl)) -> 
-      fprintf fmt "@[(%s@ %a)@]" id print_terms tl
-  | Imp (a, b) ->
-      fprintf fmt "@[(=>@ %a@ %a)@]" pp a pp b
-  | And (a, b) ->
-      fprintf fmt "@[(/\\@ %a@ %a)@]" pp a pp b
-  | Or (a, b) ->
-      fprintf fmt "@[(\\/@ %a@ %a)@]" pp a pp b
-  | Not a ->
-      fprintf fmt "@[(-.@ %a)@]" pp a
-  | Forall (id, t, p) -> 
-      fprintf fmt "@[(A. ((%s \"%s\")@ %a))@]" id t pp p
-  | Exists (id, t, p) -> 
-      fprintf fmt "@[(E. ((%s \"%s\")@ %a))@]" id t pp p
-
-let rec string_of_type_list  = function
-  | [] -> ""
-  | e :: l' -> e ^ " -> " ^ (string_of_type_list l')
-
-let print_query fmt (decls,concl) =
-  let print_decl = function
-    | DeclVar (id, [], t) ->
-	fprintf fmt "@[;; %s: %s@]@\n" id t
-    | DeclVar (id, l, t) ->
-	fprintf fmt "@[;; %s: %s%s@]@\n"
-	  id (string_of_type_list l) t
-    | DeclPred (id, l) -> 
-	fprintf fmt "@[;; %s: %sBOOLEAN@]@\n"
-	  id (string_of_type_list l)
-    | DeclType id ->
-	fprintf fmt "@[;; %s: TYPE@]@\n" id
-    | Assert (id, f)  -> 
-	fprintf fmt "@[\"%s\" %a@]@\n" id print_predicate f
-  in
-  List.iter print_decl decls;
-  fprintf fmt "$goal %a@." print_predicate concl
-
-let call q = 
-  let f = Filename.temp_file "coq_dp" ".znn" in
-  let c = open_out f in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[%a@]@." print_query q;
-  close_out c;
-  ignore (Sys.command (sprintf "cat %s" f));
-  let cmd = 
-    sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" f
-  in
-  prerr_endline cmd; flush stderr;
-  let out = Sys.command cmd in
-  if out = 0 then Valid 
-  else if out = 1 then Invalid 
-  else if out = 137 then Timeout
-  else Util.anomaly "malformed Zenon input file"
-  (* TODO: effacer le fichier f et le fichier out *)
-
-
diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli
index 03b6d347..0a727d1f 100644
--- a/contrib/dp/dp_zenon.mli
+++ b/contrib/dp/dp_zenon.mli
@@ -1,4 +1,7 @@
 
 open Fol
 
-val call : query -> prover_answer
+val set_debug : bool -> unit
+
+val proof_from_file : string -> Proof_type.tactic
+
diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll
new file mode 100644
index 00000000..2fc2a5f4
--- /dev/null
+++ b/contrib/dp/dp_zenon.mll
@@ -0,0 +1,181 @@
+
+{
+
+  open Lexing 
+  open Pp
+  open Util
+  open Names
+  open Tacmach
+  open Dp_why
+  open Tactics
+  open Tacticals
+
+  let debug = ref false
+  let set_debug b = debug := b
+  
+  let buf = Buffer.create 1024
+    
+  let string_of_global env ref =
+    Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref)
+
+  let axioms = ref []
+
+  (* we cannot interpret the terms as we read them (since some lemmas
+     may need other lemmas to be already interpreted) *)
+  type lemma = { l_id : string; l_type : string; l_proof : string }
+  type zenon_proof = lemma list * string
+
+}
+
+let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+
+let space = [' ' '\t' '\r']
+
+rule start = parse
+| "(* BEGIN-PROOF *)" "\n" { scan lexbuf }
+| _ { start lexbuf }
+| eof { anomaly "malformed Zenon proof term" }
+
+(* here we read the lemmas and the main proof term;
+   meanwhile we maintain the set of axioms that were used *)
+
+and scan = parse
+| "Let" space (ident as id) space* ":"
+  { let t = read_coq_term lexbuf in
+    let p = read_lemma_proof lexbuf in
+    let l,pr = scan lexbuf in
+    { l_id = id; l_type = t; l_proof = p } :: l, pr }
+| "Definition theorem:"
+  { let t = read_main_proof lexbuf in [], t }
+| _ | eof
+  { anomaly "malformed Zenon proof term" }
+
+and read_coq_term = parse
+| "." "\n" 
+  { let s = Buffer.contents buf in Buffer.clear buf; s }
+| "coq__" (ident as id) (* a Why keyword renamed *)
+  { Buffer.add_string buf id; read_coq_term lexbuf }
+| ("dp_axiom__" ['0'-'9']+) as id 
+  { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf }
+| _ as c 
+  { Buffer.add_char buf c; read_coq_term lexbuf }
+| eof 
+  { anomaly "malformed Zenon proof term" }
+
+and read_lemma_proof = parse
+| "Proof" space
+  { read_coq_term lexbuf }
+| _ | eof
+  { anomaly "malformed Zenon proof term" }
+
+(* skip the main proof statement and then read its term *)
+and read_main_proof = parse
+| ":=" "\n"
+  { read_coq_term lexbuf }
+| _ 
+  { read_main_proof lexbuf }
+| eof
+  { anomaly "malformed Zenon proof term" }
+
+
+{
+
+  let read_zenon_proof f =
+    Buffer.clear buf;
+    let c = open_in f in
+    let lb = from_channel c in
+    let p = start lb in
+    close_in c;
+    if not !debug then begin try Sys.remove f with _ -> () end;
+    p
+
+  let constr_of_string gl s = 
+    let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
+    Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
+
+  (* we are lazy here: we build strings containing Coq terms using a *)
+  (* pretty-printer Fol -> Coq *)
+  module Coq = struct
+    open Format
+    open Fol
+
+    let rec print_list sep print fmt = function
+      | [] -> ()
+      | [x] -> print fmt x
+      | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+	  
+    let space fmt () = fprintf fmt "@ "
+    let comma fmt () = fprintf fmt ",@ "
+
+    let rec print_typ fmt = function
+      | Tvar x -> fprintf fmt "%s" x
+      | Tid ("int", []) -> fprintf fmt "Z"
+      | Tid (x, []) -> fprintf fmt "%s" x
+      | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t 
+      | Tid (x,tl) -> 
+	  fprintf fmt "(%s %a)" x (print_list comma print_typ) tl 
+	  
+    let rec print_term fmt = function
+      | Cst n -> 
+	  fprintf fmt "%d" n
+      | Plus (a, b) ->
+	  fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b
+      | Moins (a, b) ->
+	  fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b
+      | Mult (a, b) ->
+	  fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b
+      | Div (a, b) ->
+	  fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b
+      | App (id, []) ->
+	  fprintf fmt "%s" id
+      | App (id, tl) ->
+	  fprintf fmt "@[(%s %a)@]" id print_terms tl
+
+    and print_terms fmt tl = 
+      print_list space print_term fmt tl
+
+    (* builds the text for "forall vars, f vars = t" *)
+    let fun_def_axiom f vars t =
+      let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in
+      fprintf str_formatter
+	"@[(forall %a, %s %a = %a)@]@."
+	(print_list space binder) vars f 
+	(print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars
+	print_term t;
+      flush_str_formatter ()
+			   
+  end
+
+  let prove_axiom id = match Dp_why.find_proof id with
+    | Immediate t -> 
+	exact_check t
+    | Fun_def (f, vars, ty, t) -> 
+	tclTHENS
+	  (fun gl ->
+	     let s = Coq.fun_def_axiom f vars t in
+	     if !debug then Format.eprintf "axiom fun def = %s@." s;
+	     let c = constr_of_string gl s in
+	     assert_tac true (Name (id_of_string id)) c gl)
+	  [tclTHEN intros reflexivity; tclIDTAC]
+
+  let exact_string s gl =
+    let c = constr_of_string gl s in
+    exact_check c gl
+
+  let interp_zenon_proof (ll,p) =
+    let interp_lemma l gl =
+      let ty = constr_of_string gl l.l_type in
+      tclTHENS
+	(assert_tac true (Name (id_of_string l.l_id)) ty)
+	[exact_string l.l_proof; tclIDTAC]
+	gl
+    in
+    tclTHEN (tclMAP interp_lemma ll) (exact_string p)
+
+  let proof_from_file f =
+    axioms := [];
+    msgnl (str "proof_from_file " ++ str f);
+    let zp = read_zenon_proof f in
+    msgnl (str "proof term is " ++ str (snd zp));
+    tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp)
+
+}
diff --git a/contrib/dp/fol.mli b/contrib/dp/fol.mli
index a85469cc..b94bd3e3 100644
--- a/contrib/dp/fol.mli
+++ b/contrib/dp/fol.mli
@@ -45,4 +45,11 @@ type query = decl list * form
 
 (* prover result *)
 
-type prover_answer = Valid | Invalid | DontKnow | Timeout
+type prover_answer = 
+  | Valid of string option 
+  | Invalid
+  | DontKnow
+  | Timeout
+  | NoAnswer
+  | Failure of string
+
diff --git a/contrib/dp/g_dp.ml4 b/contrib/dp/g_dp.ml4
index eb7fb73b..99bcf477 100644
--- a/contrib/dp/g_dp.ml4
+++ b/contrib/dp/g_dp.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_dp.ml4 7165 2005-06-24 12:56:46Z coq $ *)
+(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *)
 
 open Dp
 
@@ -16,6 +16,14 @@ TACTIC EXTEND Simplify
   [ "simplify" ] -> [ simplify ]
 END
 
+TACTIC EXTEND Ergo
+  [ "ergo" ] -> [ ergo ]
+END
+
+TACTIC EXTEND Yices
+  [ "yices" ] -> [ yices ]
+END
+
 TACTIC EXTEND CVCLite
   [ "cvcl" ] -> [ cvc_lite ]
 END
@@ -28,6 +36,18 @@ TACTIC EXTEND Zenon
   [ "zenon" ] -> [ zenon ]
 END
 
+TACTIC EXTEND Gwhy
+  [ "gwhy" ] -> [ gwhy ]
+END
+
+TACTIC EXTEND Gappa_internal
+  [ "gappa_internal" ] -> [ Dp_gappa.gappa_internal ]
+END
+
+TACTIC EXTEND Gappa
+  [ "gappa" ] -> [ Dp_gappa.gappa ]
+END
+
 (* should be part of basic tactics syntax *)
 TACTIC EXTEND admit
   [ "admit"    ] -> [ Tactics.admit_as_an_axiom ]
@@ -36,3 +56,24 @@ END
 VERNAC COMMAND EXTEND Dp_hint 
   [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
 END
+
+VERNAC COMMAND EXTEND Dp_timeout
+| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ]
+END
+
+VERNAC COMMAND EXTEND Dp_prelude
+| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ]
+END
+
+VERNAC COMMAND EXTEND Dp_predefined
+| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ]
+END
+
+VERNAC COMMAND EXTEND Dp_debug
+| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ]
+END
+
+VERNAC COMMAND EXTEND Dp_trace
+| [ "Dp_trace" ] -> [ dp_trace true ]
+END
+
diff --git a/contrib/dp/test2.v b/contrib/dp/test2.v
index 4e933a3c..3e4c0f6d 100644
--- a/contrib/dp/test2.v
+++ b/contrib/dp/test2.v
@@ -5,6 +5,10 @@ Require Import List.
 Open Scope list_scope.
 Open Scope Z_scope.
 
+Dp_debug.
+Dp_timeout 3.
+Require Export zenon.
+
 Definition neg (z:Z) : Z := match z with
   | Z0 => Z0
   | Zpos p => Zneg p
@@ -18,9 +22,7 @@ Open Scope nat_scope.
 Print plus.
 
 Goal forall x, x+0=x.
-  induction x.
-  zenon.
-  zenon.
+  induction x; ergo.
   (* simplify resoud le premier, pas le second *)
   Admitted.
 
diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v
new file mode 100644
index 00000000..eb65a59d
--- /dev/null
+++ b/contrib/dp/test_gappa.v
@@ -0,0 +1,91 @@
+Require Export Gappa_tactic.
+Require Export Reals.
+
+Open Scope Z_scope.
+Open Scope R_scope.
+
+Lemma test_base10 : 
+  forall x y:R,
+  0 <= x <= 4 -> 
+  0 <= x * (24 * powerRZ 10 (-1)) <= 10.
+Proof.
+  gappa.
+Qed.
+
+(*
+@rnd = float< ieee_32, zr >;
+a = rnd(a_); b = rnd(b_);
+{ a in [3.2,3.3] /\ b in [1.4,1.9] ->
+  rnd(a - b) - (a - b) in [0,0] }
+*)
+
+Definition rnd := gappa_rounding (rounding_float roundZR 43 (120)).
+
+Lemma test_float3 :
+  forall a_ b_ a b : R,
+  a = rnd a_ ->
+  b = rnd b_ ->
+  52 / 16 <= a <= 53 / 16 ->
+  22 / 16 <= b <= 30 / 16 ->
+  0 <= rnd (a - b) - (a - b) <= 0.
+Proof.
+  unfold rnd.
+  gappa.
+Qed.
+
+Lemma test_float2 :
+  forall x y:R,
+  0 <= x <= 1 ->
+  0 <= y <= 1 ->
+  0 <= gappa_rounding (rounding_float roundNE 53 (1074)) (x+y) <= 2. 
+Proof.
+  gappa.
+Qed.
+
+Lemma test_float1 :
+  forall x y:R,
+  0 <= gappa_rounding (rounding_fixed roundDN (0)) x -
+           gappa_rounding (rounding_fixed roundDN (0)) y <= 0 ->
+  Rabs (x - y) <= 1.
+Proof.
+  gappa.
+Qed.
+
+Lemma test1 : 
+  forall x y:R,
+  0 <= x <= 1 -> 
+  0 <= -y <= 1 ->  
+  0 <= x  * (-y) <= 1.
+Proof.
+  gappa.
+Qed.
+
+Lemma test2 : 
+  forall x y:R,
+  3/4 <= x <= 3 -> 
+  0 <= sqrt x <= 1775 * (powerRZ 2 (-10)).
+Proof.
+  gappa.
+Qed.
+
+Lemma test3 : 
+  forall x y z:R,
+  0 <= x - y <= 3 -> 
+  -2 <= y - z <= 4 ->
+  -2 <= x - z <= 7.
+Proof.
+  gappa.
+Qed.
+
+Lemma test4 : 
+  forall x1 x2 y1 y2 : R,
+  1 <= Rabs y1 <= 1000 ->
+  1 <= Rabs y2 <= 1000 ->
+  - powerRZ 2 (-53) <= (x1 - y1) / y1 <= powerRZ 2 (-53) ->
+  - powerRZ 2 (-53) <= (x2 - y2) / y2 <= powerRZ 2 (-53) ->
+  - powerRZ 2 (-51) <= (x1 * x2 - y1 * y2) / (y1 * y2) <= powerRZ 2 (-51).
+Proof.
+  gappa.
+Qed.
+
+
diff --git a/contrib/dp/tests.v b/contrib/dp/tests.v
index 52a57a0c..a6d4f2e1 100644
--- a/contrib/dp/tests.v
+++ b/contrib/dp/tests.v
@@ -2,48 +2,115 @@
 Require Import ZArith.
 Require Import Classical.
 
+Dp_debug.
+Dp_timeout 3.
+
+(* module renamings *)
+
+Module M.
+  Parameter t : Set.
+End M.
+
+Lemma test_module_0 : forall x:M.t, x=x.
+ergo.
+Qed.
+
+Module N := M.
+
+Lemma test_module_renaming_0 : forall x:N.t, x=x.
+ergo.
+Qed.
+
+Dp_predefined M.t => "int".
+
+Lemma test_module_renaming_1 : forall x:N.t, x=x.
+ergo.
+Qed.
+
+(* Coq lists *)
+
+Require Export List.
+
+Lemma test_pol_0 : forall l:list nat, l=l.
+ergo.
+Qed.
+
+Parameter nlist: list nat -> Prop.
+
+Lemma poly_1 : forall l,  nlist l -> True.
+intros. 
+simplify.
+Qed.
+
+(* user lists *)
+
+Inductive list (A:Set) : Set :=
+| nil : list A
+| cons: forall a:A, list A -> list A.
+
+Fixpoint app (A:Set) (l m:list A) {struct l} : list A :=
+match l with
+| nil => m
+| cons a l1 => cons A a (app A l1 m)
+end.
+
+Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. 
+intros; ergo. 
+Qed.
+
+(* polymorphism *)
+Require Import List.
+
+Inductive mylist (A:Set) : Set :=
+  mynil : mylist A
+| mycons : forall a:A, mylist A -> mylist A.
+
+Parameter my_nlist: mylist nat -> Prop.
+
+ Goal forall l,  my_nlist l -> True.
+ intros.
+ simplify. 
+Qed.
+
 (* First example with the 0 and the equality translated *)
 
 Goal 0 = 0.
-zenon.
+simplify.
 Qed.
 
-
 (* Examples in the Propositional Calculus
    and theory of equality *)
 
 Parameter A C : Prop.
 
 Goal A -> A.
-zenon.
+simplify.
 Qed.
 
 
 Goal A -> (A \/ C).
 
-zenon.
+simplify.
 Qed.
 
 
 Parameter x y z : Z.
 
 Goal x = y -> y = z -> x = z.
-
-zenon.
+ergo.
 Qed.
 
 
 Goal ((((A -> C) -> A) -> A) -> C) -> C.
 
-zenon.
+ergo.
 Qed.
 
-
 (* Arithmetic *)
 Open Scope Z_scope.
 
 Goal 1 + 1 = 2.
-simplify.
+yices.
 Qed.
 
 
@@ -57,14 +124,12 @@ Qed.
 
 Goal (forall (x y : Z), x = y) -> 0=1.
 try zenon.
-simplify.
+ergo.
 Qed.
 
 Goal forall (x: nat), (x + 0 = x)%nat.
 
-induction x0.
-zenon.
-zenon.
+induction x0; ergo.
 Qed.
 
 
@@ -106,7 +171,7 @@ Inductive even : Z -> Prop :=
    unlike CVC Lite *)
 
 Goal even 4.
-cvcl.
+ergo.
 Qed.
 
 
@@ -115,8 +180,7 @@ Definition skip_z (z : Z) (n : nat) := n.
 Definition skip_z1 := skip_z.
 
 Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
-
-zenon.
+yices.
 Qed.
 
 
@@ -133,8 +197,7 @@ Dp_hint add_S.
    unlike zenon *)
 
 Goal forall n : nat, add n 0 = n.
-
-induction n ; zenon.
+induction n ; yices.
 Qed.
 
 
@@ -144,8 +207,8 @@ Definition pred (n : nat) : nat := match n with
 end.
 
 Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
-
-zenon.
+yices.
+(*zenon.*)
 Qed.
 
 
@@ -157,7 +220,7 @@ end.
 
 Goal forall n : nat, plus n 0%nat = n.
 
-induction n; zenon.
+induction n; ergo.
 Qed.
 
 
@@ -173,8 +236,11 @@ with odd_b (n : nat) : bool := match n with
 end.
 
 Goal even_b (S (S O)) = true.
-
+ergo.
+(*
+simplify.
 zenon.
+*)
 Qed.
 
 
@@ -184,7 +250,8 @@ Parameter foo : Set.
 Parameter ff : nat -> foo -> foo -> nat.
 Parameter g : foo -> foo.
 Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
-zenon.
+yices.
+(*zenon.*)
 Qed.
 
 
@@ -194,7 +261,8 @@ Qed.
 Parameter poly_f : forall A:Set, A->A.
 
 Goal forall x:nat, poly_f nat x = poly_f nat x.
-zenon.
+ergo.
+(*zenon.*)
 Qed.
 
 
diff --git a/contrib/dp/zenon.v b/contrib/dp/zenon.v
new file mode 100644
index 00000000..4ad00a11
--- /dev/null
+++ b/contrib/dp/zenon.v
@@ -0,0 +1,94 @@
+(*  Copyright 2004 INRIA  *)
+(*  $Id: zenon.v 10739 2008-04-01 14:45:20Z herbelin $  *)
+
+Require Export Classical.
+
+Lemma zenon_nottrue :
+  (~True -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_noteq : forall (T : Type) (t : T),
+  ((t <> t) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_and : forall P Q : Prop,
+  (P -> Q -> False) -> (P /\ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_or : forall P Q : Prop,
+  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_imply : forall P Q : Prop,
+  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_equiv : forall P Q : Prop,
+  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notand : forall P Q : Prop,
+  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notor : forall P Q : Prop,
+  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notimply : forall P Q : Prop,
+  (P -> ~Q -> False) -> (~(P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notequiv : forall P Q : Prop,
+  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
+  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
+  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
+  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
+  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
+Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
+
+Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
+Proof. auto. Qed.
+
+Lemma zenon_equal_step :
+  forall (S T : Type) (fa fb : S -> T) (a b : S),
+  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
+Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
+
+Lemma zenon_pnotp : forall P Q : Prop,
+  (P = Q) -> (P -> ~Q -> False).
+Proof. intros P Q Ha. rewrite Ha. auto. Qed.
+
+Lemma zenon_notequal : forall (T : Type) (a b : T),
+  (a = b) -> (a <> b -> False).
+Proof. auto. Qed.
+
+Ltac zenon_intro id :=
+  intro id || let nid := fresh in (intro nid; clear nid)
+.
+
+Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
+Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
+Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
+Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
+Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
+Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
+Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
+Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
+Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
+Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
+
+Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
+Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES
index 83ea4910..acd1dbda 100644
--- a/contrib/extraction/CHANGES
+++ b/contrib/extraction/CHANGES
@@ -346,8 +346,8 @@ Dyade/BDDS				boolean tautology checker.
 Lyon/CIRCUITS				multiplication via a modelization of a circuit.
 Lyon/FIRING-SQUAD			print the states of the firing squad.
 Marseille/CIRCUITS			compares integers via a modelization of a circuit. 
-Nancy/FOUnify				unification of two first-orderde deux termes.
-Rocq/ARITH/Chinese			computation of the chinese remaindering.  
+Nancy/FOUnify				unification of two first-order terms.
+Rocq/ARITH/Chinese			computation of the chinese remainder.  
 Rocq/COC				small coc typechecker. (test by B. Barras, not by me)
 Rocq/HIGMAN				run the proof on one example. 
 Rocq/GRAPHS				linear constraints checker in Z. 
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
index 346201ec..5ad4a288 100644
--- a/contrib/extraction/common.ml
+++ b/contrib/extraction/common.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
+(*i $Id: common.ml 10596 2008-02-27 15:30:11Z letouzey $ i*)
 
 open Pp
 open Util
@@ -17,42 +17,218 @@ open Nameops
 open Libnames
 open Table
 open Miniml
+open Mlutil
 open Modutil
-open Ocaml
+open Mod_subst
 
-(*S Renamings. *)
+(*s Some pretty-print utility functions. *)
+
+let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+
+let pp_apply st par args = match args with
+  | [] -> st
+  | _  -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
+
+let pr_binding = function
+  | [] -> mt ()
+  | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
+
+let fnl2 () = fnl () ++ fnl () 
+
+let space_if = function true -> str " " | false -> mt ()
+
+let sec_space_if = function true -> spc () | false -> mt ()
+
+let is_digit = function 
+  | '0'..'9' -> true
+  | _ -> false
+
+let begins_with_CoqXX s = 
+  let n = String.length s in 
+  n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' &&
+  let i = ref 3 in 
+  try while !i < n do
+    if s.[!i] = '_' then i:=n (*Stop*)
+    else if is_digit s.[!i] then incr i 
+    else raise Not_found
+  done; true
+  with Not_found -> false
+  
+let unquote s = 
+  if lang () <> Scheme then s 
+  else 
+    let s = String.copy s in 
+    for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
+    s
+      
+let rec dottify = function 
+  | [] -> assert false 
+  | [s] -> unquote s 
+  | s::[""] -> unquote s 
+  | s::l -> (dottify l)^"."^(unquote s)
+
+(*s Uppercase/lowercase renamings. *) 
+
+let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let uppercase_id id = id_of_string (String.capitalize (string_of_id id))
+
+(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
+let pr_upper_id id = str (String.capitalize (string_of_id id))
+
+
+(*s de Bruijn environments for programs *)
+
+type env = identifier list * Idset.t
+
+(*s Generic renaming issues for local variable names. *)
+
+let rec rename_id id avoid = 
+  if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
+
+let rec rename_vars avoid = function
+  | [] -> 
+      [], avoid
+  | id :: idl when id == dummy_name ->
+      (* we don't rename dummy binders *)
+      let (idl', avoid') = rename_vars avoid idl in
+      (id :: idl', avoid')
+  | id :: idl ->
+      let (idl, avoid) = rename_vars avoid idl in
+      let id = rename_id (lowercase_id id) avoid in
+      (id :: idl, Idset.add id avoid)
+
+let rename_tvars avoid l = 
+  let rec rename avoid = function 
+    | [] -> [],avoid 
+    | id :: idl -> 
+	let id = rename_id (lowercase_id id) avoid in 
+	let idl, avoid = rename (Idset.add id avoid) idl in 
+	(id :: idl, avoid) in
+  fst (rename avoid l)
+
+let push_vars ids (db,avoid) =
+  let ids',avoid' = rename_vars avoid ids in
+  ids', (ids' @ db, avoid')
+
+let get_db_name n (db,_) = 
+  let id = List.nth db (pred n) in 
+  if id = dummy_name then id_of_string "__" else id
+
+
+(*S Renamings of global objects. *)
 
 (*s Tables of global renamings *)
 
 let keywords = ref Idset.empty
+let set_keywords kws = keywords := kws
+
 let global_ids = ref Idset.empty
-let modular = ref false
+let add_global_ids s = global_ids := Idset.add s !global_ids
+let global_ids_list () = Idset.elements !global_ids
+
+let empty_env () = [], !global_ids
+
+let mktable () = 
+  let h = Hashtbl.create 97 in 
+  (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h)
+
+let mkset () = 
+  let h = Hashtbl.create 97 in 
+  (fun x -> Hashtbl.add h x ()), (Hashtbl.mem h), (fun () -> Hashtbl.clear h)
+
+let mktriset () = 
+  let h = Hashtbl.create 97 in
+  (fun x y z -> Hashtbl.add h (x,y,z) ()), 
+  (fun x y z -> Hashtbl.mem h (x,y,z)), 
+  (fun () -> Hashtbl.clear h)
 
 (* For each [global_reference], this table will contain the different parts 
-   of its renamings, in [string list] form. *)
-let renamings = Hashtbl.create 97
-let rename r l = Hashtbl.add renamings r l
-let get_renamings r = Hashtbl.find renamings r 
+   of its renaming, in [string list] form. *)
+let add_renaming, get_renaming, clear_renaming = mktable ()
 
 (* Idem for [module_path]. *)
-let mp_renamings = Hashtbl.create 97
-let mp_rename mp l = Hashtbl.add mp_renamings mp l
-let mp_get_renamings mp = Hashtbl.find mp_renamings mp 
+let add_mp_renaming, get_mp_renaming, clear_mp_renaming = mktable ()
 
-let modvisited = ref MPset.empty
-let modcontents = ref Gset.empty
-let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents
-let module_contents mp s = Gset.mem (mp,s) !modcontents
+(* A table for function modfstlev_rename *)
+let add_modfstlev, get_modfstlev, clear_modfstlev = mktable ()
 
-let to_qualify = ref Refset.empty
+(* A set of all external objects that will have to be fully qualified *)
+let add_static_clash, static_clash, clear_static_clash = mkset ()
 
-let mod_1st_level = ref Idmap.empty
+(* Two tables of triplets [kind * module_path * string]. The first one 
+   will record the first level of all MPfile, not only the current one. 
+   The second table will contains local renamings. *)
 
-(*s Uppercase/lowercase renamings. *) 
+type kind = Term | Type | Cons | Mod
 
-let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+let add_ext_mpmem, ext_mpmem, clear_ext_mpmem = mktriset ()
+let add_loc_mpmem, loc_mpmem, clear_loc_mpmem = mktriset ()
+
+(* The list of external modules that will be opened initially *)
+let add_mpfiles, mem_mpfiles, list_mpfiles, clear_mpfiles = 
+  let m = ref MPset.empty in 
+  (fun mp -> m:= MPset.add mp !m), 
+  (fun mp -> MPset.mem mp !m),
+  (fun () -> MPset.elements !m),
+  (fun () -> m:= MPset.empty)
+
+(*s table containing the visible horizon at a precise moment *)
+
+let visible = ref ([] : module_path list)
+let pop_visible () = visible := List.tl !visible
+let push_visible mp = visible := mp :: !visible
+let top_visible_mp () = List.hd !visible
+
+(*s substitutions for printing signatures *)
+
+let substs = ref empty_subst
+let add_subst msid mp = substs := add_msid msid mp !substs
+let subst_mp mp = subst_mp !substs mp
+let subst_kn kn = subst_kn !substs kn
+let subst_con c = fst (subst_con !substs c)
+let subst_ref = function 
+  | ConstRef con -> ConstRef (subst_con con)
+  | IndRef (kn,i) -> IndRef (subst_kn kn,i)
+  | ConstructRef ((kn,i),j) -> ConstructRef ((subst_kn kn,i),j)
+  | _ -> assert false
 
-let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+let duplicate_index = ref 0
+let to_duplicate = ref Gmap.empty
+let add_duplicate mp l = 
+  incr duplicate_index; 
+  let ren = "Coq__" ^ string_of_int (!duplicate_index) in 
+  to_duplicate := Gmap.add (mp,l) ren !to_duplicate
+let check_duplicate mp l = 
+  let mp' = subst_mp mp in 
+  Gmap.find (mp',l) !to_duplicate
+
+type reset_kind = OnlyLocal | AllButExternal | Everything
+
+let reset_allbutext () = 
+  clear_loc_mpmem (); 
+  global_ids := !keywords; 
+  clear_renaming (); 
+  clear_mp_renaming (); 
+  clear_modfstlev (); 
+  clear_static_clash (); 
+  clear_mpfiles (); 
+  duplicate_index := 0; 
+  to_duplicate := Gmap.empty; 
+  visible := []; 
+  substs := empty_subst
+ 
+let reset_everything () = reset_allbutext (); clear_ext_mpmem ()
+
+let reset_renaming_tables = function 
+  | OnlyLocal -> clear_loc_mpmem ()
+  | AllButExternal -> reset_allbutext ()
+  | Everything -> reset_everything ()
+
+(*S Renaming functions *)
 
 (* This function creates from [id] a correct uppercase/lowercase identifier. 
    This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes 
@@ -69,389 +245,238 @@ let modular_rename up id =
   then prefix ^ s
   else s
 
-let rename_module = modular_rename true 
-
-(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when 
-   [mpl] is the context of visible modules. More precisely, we check if 
-   there exists a mp1, module (sub-)path of an element of [mpl], such as 
-   module [mp1-l] contains [s]. 
-   The verification stops if we encounter [mp1=mp0]. *)
-
-exception Stop 
-
-let clash mp0 l s mpl = 
-  let rec clash_one mp = match mp with
-    | _ when mp = mp0 -> raise Stop
-    | MPdot (mp',_) -> 
-	(module_contents (add_labels_mp mp l) s) || (clash_one mp') 
-    | mp when is_toplevel mp -> false
-    | _ -> module_contents (add_labels_mp mp l) s
+(*s [record_contents_fstlev] finds the names of the first-level objects 
+  exported by the ground-level modules in [struc]. *)
+
+let rec record_contents_fstlev struc = 
+  let upper_type = (lang () = Haskell) in 
+  let addtyp mp id = add_ext_mpmem Type mp (modular_rename upper_type id) in
+  let addcons mp id = add_ext_mpmem Cons mp (modular_rename true id) in
+  let addterm mp id = add_ext_mpmem Term mp (modular_rename false id) in
+  let addmod mp id = add_ext_mpmem Mod mp (modular_rename true id) in 
+  let addfix mp r = 
+    add_ext_mpmem Term mp (modular_rename false (id_of_global r))
+  in
+  let f mp = function 
+    | (l,SEdecl (Dind (_,ind))) -> 
+	Array.iter 
+	  (fun ip -> 
+	     addtyp mp ip.ip_typename; Array.iter (addcons mp) ip.ip_consnames)
+	  ind.ind_packets
+    | (l,SEdecl (Dtype _)) -> addtyp mp (id_of_label l)
+    | (l,SEdecl (Dterm _)) -> addterm mp (id_of_label l)
+    | (l,SEdecl (Dfix  (rv,_,_))) -> Array.iter (addfix mp) rv
+    | (l,SEmodule _) -> addmod mp (id_of_label l)
+    | (l,SEmodtype _) -> addmod mp (id_of_label l)
   in
-  let rec clash_list = function 
-    | [] -> false
-    | mp :: mpl -> (clash_one mp) || (clash_list mpl) 
-  in try clash_list mpl with Stop -> false
-
-(*s [contents_first_level mp] finds the names of the first-level objects 
-  exported by module [mp]. Nota: it might fail if [mp] isn't a directly 
-  visible module. Ex: [MPself] under functor, [MPbound], etc ... *)
-
-let contents_first_level mp = 
-  if not (MPset.mem mp !modvisited) then begin 
-    modvisited := MPset.add mp !modvisited; 
-    match (Global.lookup_module mp).mod_type with 
-      | MTBsig (msid,msb) -> 
-	  let add b id = add_module_contents mp (modular_rename b id) in 
-	  let upper_type = (lang () = Haskell) in
-	  List.iter 
-	    (function 
-	       | (l, SPBconst cb) -> 
-		   (match Extraction.constant_kind (Global.env ()) cb with 
-		      | Extraction.Logical -> () 
-		      | Extraction.Type -> add upper_type (id_of_label l)
-		      | Extraction.Term -> add false (id_of_label l))
-	       | (_, SPBmind mib) ->
-		   Array.iter 
-		     (fun mip -> if snd (Inductive.mind_arity mip) <> InProp
-		      then begin
-			add upper_type mip.mind_typename; 
-			Array.iter (add true) mip.mind_consnames
-		      end)
-		     mib.mind_packets
-	       | _ -> ())
-	    (Modops.subst_signature_msid msid mp msb)
-      | _ -> ()
-  end
+  List.iter (fun (mp,sel) -> List.iter (f mp) sel) struc
 
-(*s Initial renamings creation, for modular extraction. *) 
+(*s For monolithic extraction, first-level modules might have to be renamed 
+    with unique numbers *)
 
-let rec mp_create_modular_renamings mp = 
-  try mp_get_renamings mp 
+let modfstlev_rename l =
+  let coqid = id_of_string "Coq" in 
+  let id = id_of_label l in 
+  try 
+    let coqset = get_modfstlev id in 
+    let nextcoq = next_ident_away coqid coqset in 
+    add_modfstlev id (nextcoq::coqset); 
+    (string_of_id nextcoq)^"_"^(string_of_id id) 
+  with Not_found -> 
+    let s = string_of_id id in 
+    if is_lower s || begins_with_CoqXX s then
+      (add_modfstlev id [coqid]; "Coq_"^s)
+    else
+      (add_modfstlev id []; s)
+
+
+(*s Creating renaming for a [module_path] *)
+
+let rec mp_create_renaming mp = 
+  try get_mp_renaming mp 
   with Not_found -> 
     let ren = match mp with 
+      | _ when not (modular ()) && at_toplevel mp -> [""]
       | MPdot (mp,l) -> 
-	  (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp)
-      | MPself msid -> [rename_module (id_of_msid msid)]
-      | MPbound mbid -> [rename_module (id_of_mbid mbid)]
-      | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))]
-    in mp_rename mp ren; ren
+	  let lmp = mp_create_renaming mp in 
+	  if lmp = [""] then (modfstlev_rename l)::lmp
+	  else (modular_rename true (id_of_label l))::lmp
+      | MPself msid -> [modular_rename true (id_of_msid msid)]
+      | MPbound mbid -> [modular_rename true (id_of_mbid mbid)]
+      | MPfile _ when not (modular ()) -> assert false
+      | MPfile _ -> [string_of_modfile mp]
+    in add_mp_renaming mp ren; ren
+
+(* [clash mp0 s mpl] checks if [mp0-s] can be printed as [s] when 
+   [mpl] is the context of visible modules. More precisely, we check if 
+   there exists a [mp] in [mpl] that contains [s]. 
+   The verification stops if we encounter [mp=mp0]. *)
 
+let rec clash mem mp0 s = function 
+  | [] -> false
+  | mp :: _ when mp = mp0 -> false
+  | mp :: mpl -> mem mp s || clash mem mp0 s mpl
+    
+(*s Initial renamings creation, for modular extraction. *) 
 
 let create_modular_renamings struc = 
   let current_module = fst (List.hd struc) in 
-  let modfiles = ref MPset.empty in 
-  let { up = u ; down = d } = struct_get_references_set struc 
+  let { typ = ty ; trm = tr ; cons = co } = struct_get_references_set struc 
   in 
   (* 1) creates renamings of objects *)
   let add upper r = 
     let mp = modpath_of_r r in 
-    let l = mp_create_modular_renamings mp in 
+    let l = mp_create_renaming mp in 
     let s = modular_rename upper (id_of_global r) in 
-    global_ids := Idset.add (id_of_string s) !global_ids;    
-    rename r (s::l); 
+    add_global_ids (id_of_string s);
+    add_renaming r (s::l); 
     begin try 
-      let mp = modfile_of_mp mp in 
-      if mp <> current_module then modfiles := MPset.add mp !modfiles
+      let mp = modfile_of_mp mp in if mp <> current_module then add_mpfiles mp
     with Not_found -> () 
     end; 
   in
-  Refset.iter (add true) u; 
-  Refset.iter (add false) d; 
+  Refset.iter (add (lang () = Haskell)) ty; 
+  Refset.iter (add true) co;
+  Refset.iter (add false) tr;
   
   (* 2) determines the opened libraries. *)
-  let used_modules = MPset.elements !modfiles in 
-
-  (* [s] will contain all first-level sub-modules of [cur_mp] *)
-  let s = ref Stringset.empty in 
-  begin 
-    let add l = s := Stringset.add (rename_module (id_of_label l)) !s in 
-    match (Global.lookup_module current_module).mod_type with 
-      | MTBsig (_,msb) ->
-	  List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb
-      | _ -> ()
-  end;
-  (* We now compare [s] with the modules coming from [used_modules]. *)
-  List.iter 
-    (function 
-       | MPfile d -> 
-	   let s_mp = 
-	     String.capitalize (string_of_id (List.hd (repr_dirpath d))) in 
-	   if Stringset.mem s_mp !s then error_module_clash s_mp 
-	   else s:= Stringset.add s_mp !s 
-       | _ -> assert false)
-    used_modules;
+  let used_modules = list_mpfiles () in 
+  let used_modules' = List.rev used_modules in 
+  let str_list = List.map string_of_modfile used_modules' 
+  in
+  let rec check_elsewhere mpl sl = match mpl, sl with
+    | [], [] -> []
+    | mp::mpl, _::sl -> 
+	if List.exists (ext_mpmem Mod mp) sl then
+	  check_elsewhere mpl sl
+	else mp :: (check_elsewhere mpl sl)
+    | _ -> assert false
+  in 
+  let opened_modules = check_elsewhere used_modules' str_list in 
+  clear_mpfiles (); 
+  List.iter add_mpfiles opened_modules; 
 
   (* 3) determines the potential clashes *)
-  List.iter contents_first_level used_modules; 
-  let used_modules' = List.rev used_modules in 
-  let needs_qualify r = 
+  let needs_qualify k r = 
     let mp = modpath_of_r r in 
-    if (is_modfile mp) && mp <> current_module && 
-      (clash mp [] (List.hd (get_renamings r)) used_modules')
-    then to_qualify := Refset.add r !to_qualify
+      if (is_modfile mp) && mp <> current_module && 
+	(clash (ext_mpmem k) mp (List.hd (get_renaming r)) opened_modules)
+      then add_static_clash r
   in
-  Refset.iter needs_qualify u;
-  Refset.iter needs_qualify d; 
-  used_modules
+    Refset.iter (needs_qualify Type) ty;
+    Refset.iter (needs_qualify Term) tr;
+    Refset.iter (needs_qualify Cons) co;
+    List.rev opened_modules
 
 (*s Initial renamings creation, for monolithic extraction. *)
 
-let begins_with_CoqXX s = 
-  (String.length s >= 4) && 
-  (String.sub s 0 3 = "Coq") &&
-  (try 
-     for i = 4 to (String.index s '_')-1 do 
-       match s.[i] with 
-	 | '0'..'9' -> () 
-	 | _ -> raise Not_found
-     done; 
-     true
-   with Not_found -> false)
-
-let mod_1st_level_rename l =
-  let coqid = id_of_string "Coq" in 
-  let id = id_of_label l in 
-  try 
-    let coqset = Idmap.find id !mod_1st_level in 
-    let nextcoq = next_ident_away coqid coqset in 
-    mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level; 
-    (string_of_id nextcoq)^"_"^(string_of_id id) 
-  with Not_found -> 
-    let s = string_of_id id in 
-    if is_lower s || begins_with_CoqXX s then
-      (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s)
-    else
-      (mod_1st_level := Idmap.add id [] !mod_1st_level; s)
-
-let rec mp_create_mono_renamings mp = 
-  try mp_get_renamings mp 
-  with Not_found -> 
-    let ren = match mp with 
-       | _ when (at_toplevel mp) -> [""]
-       | MPdot (mp,l) -> 
-	   let lmp = mp_create_mono_renamings mp in
-	   if lmp = [""] then (mod_1st_level_rename l)::lmp
-	   else (rename_module (id_of_label l))::lmp
-       | MPself msid -> [rename_module (id_of_msid msid)]
-       | MPbound mbid -> [rename_module (id_of_mbid mbid)]
-       | _ -> assert false
-    in mp_rename mp ren; ren
-
 let create_mono_renamings struc = 
-  let { up = u ; down = d } = struct_get_references_list struc in 
+  let { typ = ty ; trm = tr ; cons = co } = struct_get_references_list struc in
   let add upper r = 
     let mp = modpath_of_r r in 
-    let l = mp_create_mono_renamings mp in
+    let l = mp_create_renaming mp in
     let mycase = if upper then uppercase_id else lowercase_id in 
     let id = 
       if l = [""] then 
-	next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids)
+	next_ident_away (mycase (id_of_global r)) (global_ids_list ())
       else id_of_string (modular_rename upper (id_of_global r))
     in 
-    global_ids := Idset.add id !global_ids;    
-    rename r ((string_of_id id)::l) 
+    add_global_ids id; 
+    add_renaming r ((string_of_id id)::l) 
   in
-  List.iter (add true) (List.rev u); 
-  List.iter (add false) (List.rev d)
-		    
-(*s Renaming issues at toplevel *)
-
-module TopParams = struct
-  let globals () = Idset.empty
-  let pp_global _ r = pr_id (id_of_global r)
-  let pp_module _ mp = str (string_of_mp mp)
-end
-
-(*s Renaming issues for a monolithic or modular extraction. *)
-
-module StdParams = struct
-
-  let globals () = !global_ids
-
-  let unquote s = 
-    if lang () <> Scheme then s 
-    else 
-      let s = String.copy s in 
-      for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
-      s
-
-  let rec dottify = function 
-    | [] -> assert false 
-    | [s] -> unquote s 
-    | s::[""] -> unquote s 
-    | s::l -> (dottify l)^"."^(unquote s)
-
-  let pp_global mpl r = 
-    let ls = get_renamings r in 
-    let s = List.hd ls in 
-    let mp = modpath_of_r r in 
-    let ls = 
-      if mp = List.hd mpl then [s] (* simpliest situation *)
-      else match lang () with 
-	| Scheme -> [s] (* no modular Scheme extraction... *)
-	| Toplevel -> [s] (* idem *)
-	| Haskell -> 
-	    if !modular then 
-	      ls (* for the moment we always qualify in modular Haskell *)
-	    else [s]
-	| Ocaml -> 
-	    try (* has [mp] something in common with one of those in [mpl] ? *)
-	      let pref = common_prefix_from_list mp mpl in 
-	      (*i TODO: possibilité de clash i*)
-	      list_firstn ((mp_length mp)-(mp_length pref)+1) ls
-	    with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
-	      let base = base_mp mp in 
-	      if !modular &&  
-		(at_toplevel mp) && 
-		not (Refset.mem r !to_qualify) && 
-		not (clash base [] s mpl) 
-	      then snd (list_sep_last ls)
-	      else ls
-    in 
-    add_module_contents mp s; (* update the visible environment *)
-    str (dottify ls)
-
-  (* The next function is used only in Ocaml extraction...*)
-  let pp_module mpl mp = 
-    let ls = 
-      if !modular 
-      then mp_create_modular_renamings mp 
-      else mp_create_mono_renamings mp 
-    in 
-    let ls = 
-      try (* has [mp] something in common with one of those in [mpl] ? *)
-	let pref = common_prefix_from_list mp mpl in 
-	(*i TODO: clash possible i*)
-	list_firstn ((mp_length mp)-(mp_length pref)) ls
-      with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
-	if !modular && (at_toplevel mp) 
-	then snd (list_sep_last ls)
-	else ls
-    in str (dottify ls) 
-
-end
-
-module ToplevelPp = Ocaml.Make(TopParams)
-module OcamlPp = Ocaml.Make(StdParams)
-module HaskellPp = Haskell.Make(StdParams)
-module SchemePp = Scheme.Make(StdParams)
-
-let pp_decl mp d = match lang () with 
-  | Ocaml -> OcamlPp.pp_decl mp d 
-  | Haskell -> HaskellPp.pp_decl mp d
-  | Scheme -> SchemePp.pp_decl mp d 
-  | Toplevel -> ToplevelPp.pp_decl mp d 
-
-let pp_struct s = match lang () with 
-  | Ocaml -> OcamlPp.pp_struct s 
-  | Haskell -> HaskellPp.pp_struct s
-  | Scheme -> SchemePp.pp_struct s
-  | Toplevel -> ToplevelPp.pp_struct s
-
-let pp_signature s = match lang () with 
-  | Ocaml -> OcamlPp.pp_signature s 
-  | Haskell -> HaskellPp.pp_signature s
-  | _ -> assert false
-
-let set_keywords () =
-  (match lang () with 
-    | Ocaml -> keywords := Ocaml.keywords
-    | Haskell -> keywords := Haskell.keywords
-    | Scheme -> keywords := Scheme.keywords
-    | Toplevel -> keywords := Idset.empty);
-  global_ids := !keywords; 
-  to_qualify := Refset.empty
+  List.iter (add (lang () = Haskell)) (List.rev ty); 
+  List.iter (add false) (List.rev tr);
+  List.iter (add true) (List.rev co);
+  []
+
+let create_renamings struc = 
+  if modular () then create_modular_renamings struc
+  else create_mono_renamings struc
     
-let preamble prm = match lang () with 
-  | Ocaml -> Ocaml.preamble prm   
-  | Haskell -> Haskell.preamble prm
-  | Scheme -> Scheme.preamble prm
-  | Toplevel -> (fun _ _ _ -> mt ())
-
-let preamble_sig prm = match lang () with 
-  | Ocaml -> Ocaml.preamble_sig prm   
-  | _ -> assert false
-
-(*S Extraction of one decl to stdout. *)
-
-let print_one_decl struc mp decl = 
-  set_keywords (); 
-  modular := false; 
-  create_mono_renamings struc;
-  msgnl (pp_decl [mp] decl)
-
-(*S Extraction to a file. *)
-
-let info f = 
-  Options.if_verbose msgnl 
-    (str ("The file "^f^" has been created by extraction."))
-
-let print_structure_to_file f prm struc =
-  Hashtbl.clear renamings;
-  mod_1st_level := Idmap.empty; 
-  modcontents := Gset.empty;
-  modvisited := MPset.empty; 
-  set_keywords ();
-  modular := prm.modular; 
-  let used_modules =
-    if lang () = Toplevel then []
-    else if prm.modular then create_modular_renamings struc
-    else (create_mono_renamings struc; [])
-  in 
-  let print_dummys =
-    (struct_ast_search ((=) MLdummy) struc, 
-     struct_type_search Mlutil.isDummy struc, 
-     struct_type_search ((=) Tunknown) struc)
-  in 
-  let print_magic = 
-    if lang () <> Haskell then false 
-    else struct_ast_search (function MLmagic _ -> true | _ -> false) struc
-  in
-  (* print the implementation *)
-  let cout = option_map (fun (f,_) -> open_out f) f in 
-  let ft = match cout with 
-    | None -> !Pp_control.std_ft
-    | Some cout -> Pp_control.with_output_to cout in 
-  begin try 
-    msg_with ft (preamble prm used_modules print_dummys print_magic);
-    msg_with ft (pp_struct struc);
-    option_iter close_out cout; 
-  with e -> 
-    option_iter close_out cout; raise e
-  end;
-  option_iter (fun (f,_) -> info f) f;
-  (* print the signature *)
-  match f with 
-    | Some (_,f) when lang () = Ocaml -> 
-	let cout = open_out f in
-	let ft = Pp_control.with_output_to cout in
-	begin try 
-	  msg_with ft (preamble_sig prm used_modules print_dummys);
-	  msg_with ft (pp_signature (signature_of_structure struc));
-	  close_out cout;
-	with e -> 
-	  close_out cout; raise e 
-	end; 
-	info f 
-    | _ -> ()
-	  
-
-(*i 
-  (* DO NOT REMOVE: used when making names resolution *)
-  let cout = open_out (f^".ren") in 
-  let ft = Pp_control.with_output_to cout in
-  Hashtbl.iter 
-    (fun r id -> 
-       if short_module r = !current_module then 
-	 msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r)))
-    renamings;
-  pp_flush_with ft ();
-  close_out cout;
-i*)    
-
-
-
-
-
-
+		    
+(*s On-the-fly qualification issues for both monolithic or modular extraction. *)
+
+let pp_global k r = 
+  let ls = get_renaming r in 
+  assert (List.length ls > 1); 
+  let s = List.hd ls in 
+  let mp = modpath_of_r r in 
+  if mp = top_visible_mp () then 
+    (* simpliest situation: definition of r (or use in the same context) *)
+    (* we update the visible environment *)
+    (add_loc_mpmem k mp s; unquote s)
+  else match lang () with 
+    | Scheme -> unquote s (* no modular Scheme extraction... *)
+    | Haskell -> 
+	(* for the moment we always qualify in modular Haskell *)
+	if modular () then dottify ls else s
+    | Ocaml -> 
+	try (* has [mp] something in common with one of [!visible] ? *)
+	  let prefix = common_prefix_from_list mp !visible in 
+	  let delta = mp_length mp - mp_length prefix in 
+	  let ls = list_firstn (delta+1) ls in 
+	  (* Difficulty: in ocaml we cannot qualify more than [ls], 
+             but this (not-so-long) name can in fact be hidden. Solution: 
+	     duplication of the _definition_ of r in a Coq__XXX module *)
+	  let s,ls' = list_sep_last ls in 
+	  let k' = if ls' = [] then k else Mod in 
+	  if clash (loc_mpmem k') prefix s !visible then 
+	    let front = if ls' = [] then [s] else ls' in 
+	    let l = get_nth_label delta r in 
+	    try dottify (front @ [check_duplicate prefix l])
+	    with Not_found -> add_duplicate prefix l; dottify ls
+	  else dottify ls 
+	with Not_found -> 
+	  (* [mp] belongs to a closed module, not one of [!visible]. *)
+	  let base = base_mp mp in 
+	  let base_s,ls1 = list_sep_last ls in 
+	  let s,ls2 = list_sep_last ls1 in  
+	  let k' = if ls2 = [] then k else Mod in 
+	  if modular () && (mem_mpfiles base) && 
+	    not (static_clash r) && 
+	    (* k' = Mod can't clash in an opened module, see earlier check *)
+	    not (clash (loc_mpmem k') base s !visible)
+	  then (* Standard situation of an object in another file: *)
+	    (* Thanks to the "open" of this file we remove its name *) 
+	    dottify ls1
+	  else if clash (loc_mpmem Mod) base base_s !visible then 
+	    error_module_clash base_s
+	  else dottify ls 
+	    
+(* The next function is used only in Ocaml extraction...*)
+let pp_module mp = 
+  let ls = mp_create_renaming mp in
+  if List.length ls = 1 then dottify ls 
+  else match mp with 
+    | MPdot (mp0,_) when mp0 = top_visible_mp () -> 
+	(* simpliest situation: definition of mp (or use in the same context) *)
+	(* we update the visible environment *)
+	let s = List.hd ls in 
+	add_loc_mpmem Mod mp0 s; s
+    | _ ->
+	try (* has [mp] something in common with one of those in [!visible] ? *)
+	  let prefix = common_prefix_from_list mp !visible in 
+	  assert (mp <> prefix); (* no use of mp as whole module from itself *)
+	  let delta = mp_length mp - mp_length prefix in 
+	  let ls = list_firstn delta ls in
+	  (* Difficulty: in ocaml we cannot qualify more than [ls], 
+	     but this (not-so-long) name can in fact be hidden. Solution: 
+	     duplication of the _definition_ of mp via a Coq__XXX module *)
+	  let s,ls' = list_sep_last ls in 
+	  if clash (loc_mpmem Mod) prefix s !visible then 
+	    let l = get_nth_label_mp delta mp in 
+	    try dottify (ls' @ [check_duplicate prefix l])
+	    with Not_found -> add_duplicate prefix l; dottify ls
+	  else dottify ls
+	with Not_found -> 
+	  (* [mp] belongs to a closed module, not one of [!visible]. *)
+	  let base = base_mp mp in 
+	  let base_s,ls' = list_sep_last ls in 
+	  let s = fst (list_sep_last ls) in 
+	  if modular () && (mem_mpfiles base) &&
+	    not (clash (loc_mpmem Mod) base s !visible)
+	  then dottify ls'
+	  else if clash (loc_mpmem Mod) base base_s !visible then 
+	    error_module_clash base_s
+	  else dottify ls
 
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
index 2ba51e1c..5cd26584 100644
--- a/contrib/extraction/common.mli
+++ b/contrib/extraction/common.mli
@@ -6,16 +6,56 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: common.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
 
 open Names
+open Libnames
 open Miniml
 open Mlutil
+open Pp
 
-val print_one_decl :
-  ml_structure -> module_path -> ml_decl -> unit
+val fnl2 : unit -> std_ppcmds
+val space_if : bool -> std_ppcmds
+val sec_space_if : bool -> std_ppcmds
 
-val print_structure_to_file : 
-  (string * string) option -> extraction_params -> ml_structure -> unit
+val pp_par : bool -> std_ppcmds -> std_ppcmds
+val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds 
+val pr_binding : identifier list -> std_ppcmds
 
+val rename_id : identifier -> Idset.t -> identifier
 
+val lowercase_id : identifier -> identifier
+val uppercase_id : identifier -> identifier
+
+val pr_upper_id : identifier -> std_ppcmds
+
+type env = identifier list * Idset.t
+val empty_env : unit -> env
+
+val rename_vars: Idset.t -> identifier list -> env
+val rename_tvars: Idset.t -> identifier list -> identifier list 
+val push_vars : identifier list -> env -> identifier list * env
+val get_db_name : int -> env -> identifier
+
+val record_contents_fstlev : ml_structure -> unit
+
+val create_renamings : ml_structure -> module_path list
+
+type kind = Term | Type | Cons | Mod
+
+val pp_global : kind -> global_reference -> string
+val pp_module : module_path -> string
+
+val top_visible_mp : unit -> module_path
+val push_visible : module_path -> unit
+val pop_visible : unit -> unit
+
+val add_subst : mod_self_id -> module_path -> unit
+
+val check_duplicate : module_path -> label -> string
+
+type reset_kind = OnlyLocal | AllButExternal | Everything
+
+val reset_renaming_tables : reset_kind -> unit
+
+val set_keywords : Idset.t -> unit
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
index 825b3554..311b42c0 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 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: extract_env.ml 10794 2008-04-15 00:12:06Z letouzey $ i*)
 
 open Term
 open Declarations
@@ -21,7 +21,9 @@ open Modutil
 open Common
 open Mod_subst
 
-(*s Obtaining Coq environment. *)
+(***************************************)
+(*S Part I: computing Coq environment. *)
+(***************************************)
 
 let toplevel_env () = 
   let seg = Lib.contents_after None in 
@@ -29,16 +31,17 @@ let toplevel_env () =
     | (_,kn), Lib.Leaf o ->
 	let mp,_,l = repr_kn kn in 
 	let seb = match Libobject.object_tag o with
-	  | "CONSTANT" -> SEBconst (Global.lookup_constant (constant_of_kn kn))
-	  | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) 
-	  | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l)))
-	  | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn)
+	  | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
+	  | "INDUCTIVE" -> SFBmind (Global.lookup_mind kn) 
+	  | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l)))
+	  | "MODULE TYPE" -> 
+	      SFBmodtype (Global.lookup_modtype (MPdot (mp,l)))
 	  | _ -> failwith "caught"
 	in l,seb
     | _ -> failwith "caught"
   in 
   match current_toplevel () with 
-    | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg))
+    | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg))
     | _ -> assert false
 
 let environment_until dir_opt = 
@@ -130,58 +133,87 @@ let factor_fix env l cb msb =
     list_iter_i 
       (fun j -> 
 	 function 
-	   | (l,SEBconst cb') -> 
+	   | (l,SFBconst cb') -> 
 	       if check <> check_fix env cb' (j+1) then raise Impossible; 
 	       labels.(j+1) <- l; 
 	   | _ -> raise Impossible) msb'; 
     labels, recd, msb''
   end
 
-let rec extract_msig env mp = function 
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+   to specifications. *)
+
+let rec extract_sfb_spec env mp = function 
   | [] -> [] 
-  | (l,SPBconst cb) :: msig -> 
+  | (l,SFBconst 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 mp msig
-      else begin
-	Visit.add_spec_deps s;
-	(l,Spec s) :: (extract_msig env mp msig)
-      end
-  | (l,SPBmind cb) :: msig -> 
+      let specs = extract_sfb_spec env mp msig in
+      if logical_spec s then specs 
+      else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
+  | (l,SFBmind 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 mp msig
-      else begin 
-	Visit.add_spec_deps s;
-	(l,Spec s) :: (extract_msig env mp msig)
-      end
-  | (l,SPBmodule {msb_modtype=mtb}) :: msig -> 
-      (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig)
-  | (l,SPBmodtype mtb) :: msig -> 
-      (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig)
-
-and extract_mtb env mpo = function 
-  | MTBident kn -> Visit.add_kn kn; MTident kn 
-  | MTBfunsig (mbid, mtb, mtb') -> 
+      let specs = extract_sfb_spec env mp msig in
+      if logical_spec s then specs 
+      else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
+  | (l,SFBmodule mb) :: msig -> 
+      let specs = extract_sfb_spec env mp msig in 
+      let mtb = Modops.type_of_mb env mb in 
+      let spec = extract_seb_spec env (mb.mod_type<>None) mtb in 
+      (l,Smodule spec) :: specs
+  | (l,SFBmodtype mtb) :: msig -> 
+      let specs = extract_sfb_spec env mp msig in
+      (l,Smodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: specs
+  | (l,SFBalias(mp1,_))::msig -> 
+      extract_sfb_spec env mp 
+	((l,SFBmodule {mod_expr = Some (SEBident mp1);
+		      mod_type = None;
+		      mod_constraints = Univ.Constraint.empty;
+		      mod_alias = Mod_subst.empty_subst;
+		      mod_retroknowledge = []})::msig)
+
+(* From [struct_expr_body] to specifications *)
+
+
+and extract_seb_spec env truetype = function
+  | SEBident kn when truetype -> Visit.add_mp kn; MTident kn 
+  | SEBwith(mtb',With_definition_body(idl,cb))->
+      let mtb''= extract_seb_spec env truetype mtb' in
+      (match extract_with_type env cb with (* cb peut contenir des kn  *)
+	 | None ->  mtb''
+	 | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ)))
+  | SEBwith(mtb',With_module_body(idl,mp,_))-> 
+      Visit.add_mp mp;
+      MTwith(extract_seb_spec env truetype mtb',
+	     ML_With_module(idl,mp))
+  | SEBfunctor (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 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_module mp (Modops.module_body_of_type mtb) env in
+	MTfunsig (mbid, extract_seb_spec env true mtb.typ_expr, 
+		  extract_seb_spec env' truetype mtb')
+  | SEBstruct (msid, msig) -> 
+      let mp = MPself msid in 
       let env' = Modops.add_signature mp msig env in 
-      MTsig (msid, extract_msig env' mp msig) 
+	MTsig (msid, extract_sfb_spec env' mp msig) 
+  | (SEBapply _|SEBident _ (*when not truetype*)) as mtb -> 
+      extract_seb_spec env truetype (Modops.eval_struct env mtb)
+
+
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+   to implementations. 
 
-let rec extract_msb env mp all = function 
+   NB: when [all=false], the evaluation order of the list is
+   important: last to first ensures correct dependencies.
+*)
+
+let rec extract_sfb env mp all = function 
   | [] -> [] 
-  | (l,SEBconst cb) :: msb -> 
+  | (l,SFBconst cb) :: msb -> 
       (try 
 	 let vl,recd,msb = factor_fix env l cb msb in 
 	 let vc = Array.map (make_con mp empty_dirpath) vl in
-	 let ms = extract_msb env mp all msb in 
+	 let ms = extract_sfb env mp all msb in 
 	 let b = array_exists Visit.needed_con vc in 
 	 if all || b then 
 	   let d = extract_fixpoint env vc recd in
@@ -189,7 +221,7 @@ let rec extract_msb env mp all = function
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_msb env mp all msb in 
+	 let ms = extract_sfb 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 
@@ -197,8 +229,8 @@ let rec extract_msb env mp all = function
 	   if (not b) && (logical_decl d) then ms 
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
-  | (l,SEBmind mib) :: msb ->
-      let ms = extract_msb env mp all msb in
+  | (l,SFBmind mib) :: msb ->
+      let ms = extract_sfb env mp all msb in
       let kn = make_kn mp empty_dirpath l in 
       let b = Visit.needed_kn kn in
       if all || b then 
@@ -206,48 +238,68 @@ let rec extract_msb env mp all = function
 	if (not b) && (logical_decl d) then ms 
 	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
-  | (l,SEBmodule mb) :: msb -> 
-      let ms = extract_msb env mp all msb in
+  | (l,SFBmodule mb) :: msb -> 
+      let ms = extract_sfb env mp all msb in
       let mp = MPdot (mp,l) in 
       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 mp all msb in
-      let kn = make_kn mp empty_dirpath l in
-      if all || Visit.needed_kn kn then 
-	(l,SEmodtype (extract_mtb env None mtb)) :: ms
+  | (l,SFBmodtype mtb) :: msb ->
+      let ms = extract_sfb env mp all msb in
+      let mp = MPdot (mp,l) in
+       if all || Visit.needed_mp mp then 
+	(l,SEmodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: ms
+      else ms
+  | (l,SFBalias (mp1,cst)) :: msb -> 
+      let ms = extract_sfb env mp all msb in
+      let mp = MPdot (mp,l) in 
+      if all || Visit.needed_mp mp then 
+	(l,SEmodule (extract_module env mp true 
+		       {mod_expr = Some (SEBident mp1);
+			mod_type = None;
+		        mod_constraints= Univ.Constraint.empty;
+			mod_alias = empty_subst;
+			mod_retroknowledge = []})) :: ms
       else ms
 
-and extract_meb env mpo all = function 
-  | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
-  | MEBident mp -> Visit.add_mp mp; MEident mp 
-  | MEBapply (meb, meb',_) -> 
-      MEapply (extract_meb env None true meb, 
-	       extract_meb env None true meb')
-  | MEBfunctor (mbid, mtb, meb) -> 
+(* From [struct_expr_body] to implementations *)
+
+and extract_seb env mpo all = function 
+  | SEBident mp ->  
+      if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; 
+      Visit.add_mp mp; MEident mp 
+  | SEBapply (meb, meb',_) -> 
+      MEapply (extract_seb env None true meb, 
+	       extract_seb env None true meb')
+  | SEBfunctor (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 None mtb, 
-		 extract_meb env' None true meb)
-  | MEBstruct (msid, msb) -> 
+      MEfunctor (mbid, extract_seb_spec env true mtb.typ_expr, 
+		 extract_seb env' None true meb)
+  | SEBstruct (msid, msb) -> 
       let mp,msb = match mpo with 
 	| None -> MPself msid, msb 
-	| Some mp -> mp, subst_msb (map_msid msid mp) msb
+	| Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb
       in 
-      let env' = add_structure mp msb env in 
-      MEstruct (msid, extract_msb env' mp all msb) 
+      let env' = Modops.add_signature mp msb env in 
+      MEstruct (msid, extract_sfb env' mp all msb) 
+  | SEBwith (_,_) -> anomaly "Not available yet"
 
 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
-  let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in
+  let meb = Option.get mb.mod_expr in
+  let mtb = match mb.mod_type with 
+    | None -> Modops.eval_struct env meb 
+    | Some mt -> mt 
+  in
   (* 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 (Some mp) all meb;
-    ml_mod_type = extract_mtb env None mtb }
+  (* PL 26/02/2008: is this still relevant ?
+  let mtb = replicate_msid meb mtb in *)
+  { ml_mod_expr = extract_seb env (Some mp) all meb;
+    ml_mod_type = extract_seb_spec env (mb.mod_type<>None) mtb }
+
 
 let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
 
@@ -258,161 +310,198 @@ let mono_environment refs mpl =
   let env = Global.env () in 
   let l = List.rev (environment_until None) in 
   List.rev_map 
-    (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l
+    (fun (mp,m) -> mp, unpack (extract_seb env (Some mp) false m)) l
+
+(**************************************)
+(*S Part II : Input/Output primitives *)
+(**************************************)
+
+let descr () = match lang () with 
+  | Ocaml -> Ocaml.ocaml_descr 
+  | Haskell -> Haskell.haskell_descr 
+  | Scheme -> Scheme.scheme_descr
+
+(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" 
+   Works similarly for the other languages. *)
+
+let default_id = id_of_string "Main"
+
+let mono_filename f = 
+  let d = descr () in 
+  match f with 
+    | None -> None, None, default_id
+    | Some f -> 
+	let f = 
+	  if Filename.check_suffix f d.file_suffix then 
+	    Filename.chop_suffix f d.file_suffix 
+	  else f
+	in
+	let id = 
+	  if lang () <> Haskell then default_id
+	  else try id_of_string (Filename.basename f)
+	  with _ -> error "Extraction: provided filename is not a valid identifier"
+	in
+	Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id
+
+(* Builds a suitable filename from a module id *)
+
+let module_filename m = 
+  let d = descr () in 
+  let f = if d.capital_file then String.capitalize else String.uncapitalize in 
+  let fn = f (string_of_id m) in
+  Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, m
+
+(*s Extraction of one decl to stdout. *)
+
+let print_one_decl struc mp decl =
+  let d = descr () in 
+  reset_renaming_tables AllButExternal; 
+  ignore (create_renamings struc);
+  push_visible mp; 
+  msgnl (d.pp_decl decl); 
+  pop_visible ()
+
+(*s Extraction of a ml struct to a file. *)
+
+let print_structure_to_file (fn,si,mo) struc =
+  let d = descr () in 
+  reset_renaming_tables AllButExternal; 
+  let used_modules = create_renamings struc in 
+  let unsafe_needs = {
+    mldummy = struct_ast_search ((=) MLdummy) struc; 
+    tdummy = struct_type_search Mlutil.isDummy struc; 
+    tunknown = struct_type_search ((=) Tunknown) struc; 
+    magic = 
+      if lang () <> Haskell then false 
+      else struct_ast_search (function MLmagic _ -> true | _ -> false) struc }
+  in
+  (* print the implementation *)
+  let cout = Option.map open_out fn in 
+  let ft = match cout with 
+    | None -> !Pp_control.std_ft
+    | Some cout -> Pp_control.with_output_to cout in 
+  begin try 
+    msg_with ft (d.preamble mo used_modules unsafe_needs);
+    if lang () = Ocaml then begin 
+      (* for computing objects to duplicate *)
+      let devnull = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in
+      msg_with devnull (d.pp_struct struc);
+      reset_renaming_tables OnlyLocal; 
+    end; 
+    msg_with ft (d.pp_struct struc);
+    Option.iter close_out cout; 
+  with e -> 
+    Option.iter close_out cout; raise e
+  end;
+  Option.iter info_file fn;
+  (* print the signature *)
+  Option.iter 
+    (fun si -> 
+       let cout = open_out si in
+       let ft = Pp_control.with_output_to cout in
+       begin try 
+	 msg_with ft (d.sig_preamble mo used_modules unsafe_needs);
+	 reset_renaming_tables OnlyLocal;
+	 msg_with ft (d.pp_sig (signature_of_structure struc));
+	 close_out cout;
+       with e -> 
+	 close_out cout; raise e 
+       end; 
+       info_file si)
+    si
+
+
+(*********************************************)
+(*s Part III: the actual extraction commands *)
+(*********************************************)
+
+
+let reset () =  
+  Visit.reset (); reset_tables (); reset_renaming_tables Everything
+
+let init modular = 
+  check_inside_section (); check_inside_module ();
+  set_keywords (descr ()).keywords;
+  set_modular modular;
+  reset ();
+  if modular && lang () = Scheme then error_scheme ()
+
 
-    
 (*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. *)
+    \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when 
+    extracting to a file with the command: 
+    \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
 
-let mono_extraction (f,m) qualids = 
-  check_inside_section (); 
-  check_inside_module ();
+let full_extraction f qualids = 
+  init false; 
   let rec find = function 
     | [] -> [],[]
     | q::l -> 
 	let refs,mps = find l in 
 	try 
-	  let mp = Nametab.locate_module (snd (qualid_of_reference q))
-	  in refs,(mp::mps)
+	  let mp = Nametab.locate_module (snd (qualid_of_reference q)) in 
+	  if is_modfile mp then error_MPfile_as_mod mp true; 
+	  refs,(mp::mps)
 	with Not_found -> (Nametab.global q)::refs, mps 
-  in 	    
+  in  
   let refs,mps = find qualids in
-  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 struc = optimize_struct refs (mono_environment refs mps) in 
+  warning_axioms (); 
+  print_structure_to_file (mono_filename f) struc; 
+  reset ()
 
-let extraction_rec = mono_extraction (None,id_of_string "Main")
 
-(*s Extraction in the Coq toplevel. We display the extracted term in
-    Ocaml syntax and we use the Coq printers for globals. The
-    vernacular command is \verb!Extraction! [qualid]. *)
+(*s Simple extraction in the Coq toplevel. The vernacular command 
+    is \verb!Extraction! [qualid]. *)
 
-let extraction qid = 
-  check_inside_section (); 
-  check_inside_module ();
+let simple_extraction qid = 
+  init false; 
   try 
-    let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in 
-    extraction_rec [qid]
+    let mp = Nametab.locate_module (snd (qualid_of_reference qid)) in 
+    if is_modfile mp then error_MPfile_as_mod mp true; 
+    full_extraction None [qid]
   with Not_found -> 
     let r = Nametab.global qid in 
     if is_custom r then
       msgnl (str "User defined extraction:" ++ spc () ++ 
 	       str (find_custom r) ++ fnl ()) 
     else
-      let prm = 
-	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in
-      let struc = optimize_struct prm None (mono_environment [r] []) in 
+      let struc = optimize_struct [r] (mono_environment [r] []) in
       let d = get_decl_in_structure r struc in 
+      warning_axioms (); 
       print_one_decl struc (modpath_of_r r) d;
-      Visit.reset (); 
-      reset_tables () 
-
-(*s Extraction to a file (necessarily recursive). 
-    The vernacular command is 
-    \verb!Extraction "file"! [qualid1] ... [qualidn].*)
-
-let lang_suffix () = match lang () with 
-  | Ocaml -> ".ml",".mli"
-  | Haskell -> ".hs",".hi"
-  | Scheme -> ".scm",".scm"
-  | Toplevel -> assert false
-
-let filename f = 
-  let s,s' = lang_suffix () in
-  if Filename.check_suffix f s then 
-    let f' = Filename.chop_suffix f s in 
-    Some (f,f'^s'),id_of_string f' 
-  else Some (f^s,f^s'),id_of_string f
-
-let extraction_file f vl =
-  if lang () = Toplevel then error_toplevel () 
-  else mono_extraction (filename f) vl
-
-(*s Extraction of a module at the toplevel. *)
-
-let extraction_module m = 
-  check_inside_section (); 
-  check_inside_module ();
-  begin match lang () with 
-    | Toplevel -> error_toplevel ()
-    | Scheme -> error_scheme ()
-    | _ -> ()
-  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 ()
+      reset ()
 
 
 (*s (Recursive) Extraction of a library. The vernacular command is 
   \verb!(Recursive) Extraction Library! [M]. *) 
 
-let module_file_name m = match lang () with 
-  | Ocaml -> let f = String.uncapitalize (string_of_id m) in  f^".ml", f^".mli"
-  | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi"
-  | _ -> assert false
-
-let dir_module_of_id m = 
-  let q = make_short_qualid m in 
-  try Nametab.full_name_module q with Not_found -> error_unknown_module q
-
 let extraction_library is_rec m =
-  check_inside_section (); 
-  check_inside_module ();  
-  begin match lang () with 
-    | Toplevel -> error_toplevel ()
-    | Scheme -> error_scheme ()
-    | _ -> () 
-  end; 
-  let dir_m = dir_module_of_id m in 
-  Visit.reset (); 
+  init true; 
+  let dir_m = 
+    let q = make_short_qualid m in 
+    try Nametab.full_name_module q with Not_found -> error_unknown_module q
+  in 
   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 
+    then (mp, unpack (extract_seb 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 struc = optimize_struct [] struc in 
+  warning_axioms (); 
+  record_contents_fstlev struc; 
   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_structure_to_file (module_filename short_m) [e]; 
 	print l 
     | _ -> assert false
   in 
   print struc; 
-  Visit.reset ();
-  reset_tables ()
-
-
-
-
-
+  reset ()
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
index a09464a1..8d906985 100644
--- a/contrib/extraction/extract_env.mli
+++ b/contrib/extraction/extract_env.mli
@@ -6,15 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: extract_env.mli 10895 2008-05-07 16:06:26Z letouzey $ i*)
 
 (*s This module declares the extraction commands. *)
 
 open Names
 open Libnames
 
-val extraction : reference -> unit
-val extraction_rec : reference list -> unit
-val extraction_file : string -> reference list -> unit
-val extraction_module : reference -> unit
+val simple_extraction : reference -> unit
+val full_extraction : string option -> reference list -> unit
 val extraction_library : bool -> identifier -> unit
+
+(* For debug / external output via coqtop.byte + Drop : *)
+
+val mono_environment : 
+ global_reference list -> module_path list -> Miniml.ml_structure
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 6982ffc6..fdc84a64 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 10195 2007-10-08 01:47:55Z letouzey $ i*)
+(*i $Id: extraction.ml 10497 2008-02-01 12:18:37Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -310,7 +310,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
   with Not_found -> 
     (* 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; 
+    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 
@@ -337,7 +337,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
       {ind_info = Standard; 
        ind_nparams = npar; 
        ind_packets = packets; 
-       ind_equiv = mib.mind_equiv };
+       ind_equiv = match mib.mind_equiv with 
+         | None -> NoEquiv 
+	 | Some kn -> Equiv kn
+      };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
       let p = packets.(i) in 
@@ -410,7 +413,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
             (Inductive.type_of_inductive env (mib,mip0))
 	  in
 	  List.iter 
-	    (option_iter 
+	    (Option.iter 
 	       (fun kn -> if Cset.mem kn !projs then add_projection n kn))
 	    (lookup_projections ip)
 	with Not_found -> ()
@@ -421,7 +424,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     let i = {ind_info = ind_info; 
 	     ind_nparams = npar; 
 	     ind_packets = packets; 
-	     ind_equiv = mib.mind_equiv}
+	     ind_equiv = match mib.mind_equiv with 
+	       | None -> NoEquiv
+	       | Some kn -> Equiv kn }
     in
     add_ind kn mib i; 
     i
@@ -750,7 +755,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	end 
       else 
 	(* Standard case: we apply [extract_branch]. *)
-	MLcase (mi.ind_info, a, Array.init br_size extract_branch)
+	MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch)
   
 (*s Extraction of a (co)-fixpoint. *)
 
@@ -828,18 +833,18 @@ let extract_constant env kn cb =
     | None -> (* A logical axiom is risky, an informative one is fatal. *) 
         (match flag_of_type env typ with
 	   | (Info,TypeScheme) -> 
-	       if not (is_custom r) then warning_info_ax r; 
+	       if not (is_custom r) then add_info_axiom r; 
 	       let n = type_scheme_nb_args env typ in 
 	       let ids = iterate (fun l -> anonymous::l) n [] in 
 	       Dtype (r, ids, Taxiom) 
            | (Info,Default) -> 
-	       if not (is_custom r) then warning_info_ax r; 
+	       if not (is_custom r) then add_info_axiom r; 
 	       let t = snd (record_constant_type env kn (Some typ)) in 
 	       Dterm (r, MLaxiom, type_expunge env t) 
            | (Logic,TypeScheme) -> 
-	       warning_log_ax r; Dtype (r, [], Tdummy Ktype)
+	       add_log_axiom r; Dtype (r, [], Tdummy Ktype)
 	   | (Logic,Default) -> 
-	       warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother))
+	       add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother))
     | Some body ->
 	(match flag_of_type env typ with
 	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother)
@@ -871,6 +876,20 @@ let extract_constant_spec env kn cb =
 	let t = snd (record_constant_type env kn (Some typ)) in 
 	Sval (r, type_expunge env t)
 
+let extract_with_type env cb = 
+  let typ = Typeops.type_of_constant_type env cb.const_type in 
+  match flag_of_type env typ with 
+    | (_ , Default) -> None
+    | (Logic, TypeScheme) ->Some ([],Tdummy Ktype)
+    | (Info, TypeScheme) -> 
+	let s,vl = type_sign_vl env typ in 
+	  (match cb.const_body with 
+	  | None -> assert false
+	  | Some body -> 
+	      let db = db_from_sign s in 
+	      let t = extract_type_scheme env db (force body) (List.length s)
+	      in Some ( vl, t) )
+		   
 let extract_inductive env kn = 
   let ind = extract_ind env kn in 
   add_recursors env kn; 
@@ -880,24 +899,6 @@ let extract_inductive env kn =
       ind.ind_packets
   in { ind with ind_packets = packets }
 
-(*s From a global reference to a ML declaration. *)
-
-let extract_declaration env r = match r with
-  | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env)
-  | IndRef (kn,_) -> Dind (kn, extract_inductive env kn)
-  | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn)
-  | VarRef kn -> assert false
-
-(*s Without doing complete extraction, just guess what a constant would be. *) 
-
-type kind = Logical | Term | Type 
-    
-let constant_kind env cb = 
-  match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with 
-    | (Logic,_) -> Logical
-    | (Info,TypeScheme) -> Type
-    | (Info,Default) -> Term
-
 (*s Is a [ml_decl] logical ? *) 
 
 let logical_decl = function 
@@ -916,9 +917,3 @@ let logical_spec = function
   | Sval (_,Tdummy _) -> true
   | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
-
-  
-
-
-
-
diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli
index 1dfd7e1a..6d41b630 100644
--- a/contrib/extraction/extraction.mli
+++ b/contrib/extraction/extraction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*)
+(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
 
 (*s Extraction from Coq terms to Miniml. *)
 
@@ -21,21 +21,13 @@ val extract_constant : env -> constant -> constant_body -> ml_decl
 
 val extract_constant_spec : env -> constant -> constant_body -> ml_spec
 
+val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option
+
 val extract_fixpoint : 
   env -> constant array -> (constr, types) prec_declaration -> ml_decl 
 
 val extract_inductive : env -> kernel_name -> ml_ind
 
-(*s ML declaration corresponding to a Coq reference. *)
-
-val extract_declaration : env -> global_reference -> ml_decl
-
-(*s Without doing complete extraction, just guess what a constant would be. *) 
-
-type kind = Logical | Term | Type 
-
-val constant_kind : env -> constant_body -> kind
-
 (*s Is a [ml_decl] or a [ml_spec] logical ? *) 
 
 val logical_decl : ml_decl -> bool
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
index 13b29c7b..cb95808d 100644
--- a/contrib/extraction/g_extraction.ml4
+++ b/contrib/extraction/g_extraction.ml4
@@ -31,19 +31,18 @@ VERNAC ARGUMENT EXTEND language
 | [ "Ocaml" ] -> [ Ocaml ]
 | [ "Haskell" ] -> [ Haskell ]
 | [ "Scheme" ] -> [ Scheme ]
-| [ "Toplevel" ] -> [ Toplevel ]
 END
 
 (* Extraction commands *)
 
 VERNAC COMMAND EXTEND Extraction
 (* Extraction in the Coq toplevel *)
-| [ "Extraction" global(x) ] -> [ extraction x ]
-| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ]
+| [ "Extraction" global(x) ] -> [ simple_extraction x ]
+| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ]
 
 (* Monolithic extraction to a file *)
 | [ "Extraction" string(f) ne_global_list(l) ] 
-  -> [ extraction_file f l ]
+  -> [ full_extraction (Some f) l ]
 END
 
 (* Modular extraction (one Coq library = one ML module) *)
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
index f924396c..0ef225c0 100644
--- a/contrib/extraction/haskell.ml
+++ b/contrib/extraction/haskell.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
+(*i $Id: haskell.ml 10233 2007-10-17 23:29:08Z letouzey $ i*)
 
 (*s Production of Haskell syntax. *)
 
@@ -18,7 +18,7 @@ open Libnames
 open Table
 open Miniml
 open Mlutil
-open Ocaml
+open Common
 
 (*s Haskell renaming issues. *)
 
@@ -30,22 +30,19 @@ let keywords =
     "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
   Idset.empty
 
-let preamble prm used_modules (mldummy,tdummy,tunknown) magic =
-  let pp_mp = function 
-    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
-    | _ -> assert false 
-  in  
-  (if not magic then mt () 
+let preamble mod_name used_modules usf =
+  let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n")
+  in 
+  (if not usf.magic then mt () 
    else
      str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++
      str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n")
   ++
-  str "module " ++ pr_upper_id prm.mod_name ++ str " where" ++ fnl () 
-  ++ fnl() ++ 
-  str "import qualified Prelude" ++ fnl() ++
-  prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules
-  ++ fnl () ++
-  (if not magic then mt () 
+  str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++
+  str "import qualified Prelude" ++ fnl () ++
+  prlist pp_import used_modules ++ fnl () ++ 
+  (if used_modules = [] then mt () else fnl ()) ++
+  (if not usf.magic then mt () 
    else str "\
 #ifdef __GLASGOW_HASKELL__
 import qualified GHC.Base
@@ -54,16 +51,10 @@ unsafeCoerce = GHC.Base.unsafeCoerce#
 -- HUGS
 import qualified IOExts
 unsafeCoerce = IOExts.unsafeCoerce
-#endif")
-  ++
-  fnl() ++ fnl() 
+#endif" ++ fnl2 ())
   ++
-  (if not mldummy then mt () 
-   else
-     str "__ = Prelude.error \"Logical or arity value used\"" 
-     ++ fnl () ++ fnl())
-
-let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO" 
+  (if not usf.mldummy then mt () 
+   else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ())
 
 let pp_abst = function
   | [] -> (mt ())
@@ -73,17 +64,11 @@ let pp_abst = function
 
 let pr_lower_id id = pr_id (lowercase_id id)
 
-(*s The pretty-printing functor. *)
+(*s The pretty-printer for haskell syntax *)
 
-module Make = functor(P : Mlpp_param) -> struct
-
-let local_mpl = ref ([] : module_path list)
-
-let pp_global r = 
+let pp_global k r = 
   if is_inline_custom r then str (find_custom r) 
-  else P.pp_global !local_mpl r
-
-let empty_env () = [], P.globals()
+  else str (Common.pp_global k r)
 
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
@@ -96,13 +81,14 @@ let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ -> assert false 
     | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i))
-    | Tglob (r,[]) -> pp_global r	
+    | Tglob (r,[]) -> pp_global Type r	
     | Tglob (r,l) -> 
 	if r = IndRef (kn_sig,0) then 
 	  pp_type true vl (List.hd l)
 	else 
 	  pp_par par 
-	    (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l)
+	    (pp_global Type r ++ spc () ++ 
+	     prlist_with_sep spc (pp_type true vl) l)
     | Tarr (t1,t2) ->
 	pp_par par 
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
@@ -151,20 +137,20 @@ let rec pp_expr par env args =
 		    spc () ++ str "in") ++
 		 spc () ++ hov 0 pp_a2)))
     | MLglob r -> 
-	apply (pp_global r)
+	apply (pp_global Term r)
     | MLcons (_,r,[]) ->
-	assert (args=[]); pp_global r
+	assert (args=[]); pp_global Cons r
     | MLcons (_,r,[a]) ->
 	assert (args=[]);
-	pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a)
+	pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a)
     | MLcons (_,r,args') ->
 	assert (args=[]);
-	pp_par par (pp_global r ++ spc () ++ 
+	pp_par par (pp_global Cons r ++ spc () ++ 
 		    prlist_with_sep spc (pp_expr true env []) args')
-    | MLcase (_,t, pv) ->
+    | MLcase ((_,factors),t, pv) ->
       	apply (pp_par par' 
 		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
-		       fnl () ++ str "  " ++ pp_pat env pv)))
+		       fnl () ++ str "  " ++ pp_pat env factors pv)))
     | MLfix (i,ids,defs) ->
 	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
       	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
@@ -177,11 +163,11 @@ let rec pp_expr par env args =
 	pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args)
     | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"")
 
-and pp_pat env pv = 
+and pp_pat env factors pv = 
   let pp_one_pat (name,ids,t) =
     let ids,env' = push_vars (List.rev ids) env in
     let par = expr_needs_par t in
-    hov 2 (pp_global name ++
+    hov 2 (pp_global Cons name ++
 	   (match ids with 
 	      | [] -> mt ()
 	      | _  -> (str " " ++ 
@@ -189,7 +175,18 @@ and pp_pat env pv =
 			 (fun () -> (spc ())) pr_id (List.rev ids))) ++
 	   str " ->" ++ spc () ++ pp_expr par env' [] t)
   in 
-  (prvect_with_sep (fun () -> (fnl () ++ str "  ")) pp_one_pat pv)
+  prvecti 
+    (fun i x -> if List.mem i factors then mt () else 
+       (pp_one_pat pv.(i) ++
+	if factors = [] && i = Array.length pv - 1 then mt ()
+	else fnl () ++ str "  ")) pv
+  ++
+  match factors with 
+    | [] -> mt ()
+    | i::_ -> 
+	let (_,ids,t) = pv.(i) in 
+	let t = ast_lift (-List.length ids) t in 
+	hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
 
 (*s names of the functions ([ids]) are already pushed in [env],
     and passed here just for convenience. *)
@@ -223,7 +220,7 @@ let pp_logical_ind packet =
 let pp_singleton kn packet = 
   let l = rename_tvars keywords packet.ip_vars in 
   let l' = List.rev l in 
-  hov 2 (str "type " ++ pp_global (IndRef (kn,0)) ++ spc () ++ 
+  hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ 
 	 prlist_with_sep spc pr_id l ++
 	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
 	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
@@ -233,7 +230,7 @@ let pp_singleton kn packet =
 let pp_one_ind ip pl cv =
   let pl = rename_tvars keywords pl in
   let pp_constructor (r,l) =
-    (pp_global r ++
+    (pp_global Cons r ++
      match l with
        | [] -> (mt ()) 
        | _  -> (str " " ++
@@ -241,7 +238,7 @@ let pp_one_ind ip pl cv =
 		  (fun () -> (str " ")) (pp_type true pl) l))
   in
   str (if Array.length cv = 0 then "type " else "data ") ++ 
-  pp_global (IndRef ip) ++ str " " ++
+  pp_global Type (IndRef ip) ++ str " " ++
   prlist_with_sep (fun () -> str " ") pr_lower_id pl ++
   (if pl = [] then mt () else str " ") ++
   if Array.length cv = 0 then str "= () -- empty inductive"
@@ -269,9 +266,7 @@ let rec pp_ind first kn i ind =
 
 let pp_string_parameters ids = prlist (fun id -> str id ++ str " ")
 
-let pp_decl mpl = 
-  local_mpl := mpl;
-  function
+let pp_decl = function
   | Dind (kn,i) when i.ind_info = Singleton -> 
       pp_singleton kn i.ind_packets.(0) ++ fnl ()
   | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
@@ -288,38 +283,51 @@ let pp_decl mpl =
 	    if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
 	    else str "=" ++ spc () ++ pp_type false l t
 	in 
-	hov 2 (str "type " ++ pp_global r ++ spc () ++ st) ++ fnl () ++ fnl ()
+	hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 ()
   | Dfix (rv, defs, typs) ->
       let max = Array.length rv in 
       let rec iter i = 
 	if i = max then mt () 
 	else
-	  let e = pp_global rv.(i) in 
+	  let e = pp_global Term rv.(i) in 
 	  e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () 
-	  ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ fnl () 
+	  ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 ()
 	  ++ iter (i+1)
       in iter 0
   | Dterm (r, a, t) ->
       if is_inline_custom r then mt () 
       else 
-	let e = pp_global r in 
+	let e = pp_global Term r in 
 	e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
 	  if is_custom r then 	
-	    hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl() ++ fnl ())
+	    hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
 	  else 
-	    hov 0 (pp_function (empty_env ()) e a ++ fnl () ++ fnl ())
+	    hov 0 (pp_function (empty_env ()) e a ++ fnl2 ())
 
-let pp_structure_elem mpl = function 
-  | (l,SEdecl d) -> pp_decl mpl d
+let pp_structure_elem = function 
+  | (l,SEdecl d) -> pp_decl d
   | (l,SEmodule m) -> 
       failwith "TODO: Haskell extraction of modules not implemented yet"
   | (l,SEmodtype m) -> 
       failwith "TODO: Haskell extraction of modules not implemented yet"
 
 let pp_struct = 
-  prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel)
-
-let pp_signature s = failwith "TODO"
-
-end
-
+  let pp_sel (mp,sel) = 
+    push_visible mp; 
+    let p = prlist_strict pp_structure_elem sel in 
+    pop_visible (); p
+  in 
+  prlist_strict pp_sel 
+
+
+let haskell_descr = {
+  keywords = keywords;  
+  file_suffix = ".hs"; 
+  capital_file = true;  
+  preamble = preamble; 
+  pp_struct = pp_struct; 
+  sig_suffix = None;
+  sig_preamble = (fun _ _ _ -> mt ()); 
+  pp_sig = (fun _ -> mt ());
+  pp_decl = pp_decl; 
+}
diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli
index 106f7868..1af9c231 100644
--- a/contrib/extraction/haskell.mli
+++ b/contrib/extraction/haskell.mli
@@ -6,15 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
+(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
 
-open Pp
-open Names
-open Miniml
+val haskell_descr : Miniml.language_descr
 
-val keywords : Idset.t
-
-val preamble : 
-  extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-module Make : functor(P : Mlpp_param) -> Mlpp
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
index 3b4146f8..dfe4eb48 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 9456 2006-12-17 20:08:38Z letouzey $ i*)
+(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
 
 (*s Target language for extraction: a core ML called MiniML. *)
 
@@ -58,6 +58,8 @@ type inductive_info =
   | Standard 
   | Record of global_reference list 
 
+type case_info = int list (* list of branches to merge in a _ pattern *)
+
 (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. 
    If the inductive is logical ([ip_logical = false]), then all other fields
    are unused. Otherwise, 
@@ -76,11 +78,16 @@ type ml_ind_packet = {
 
 (* [ip_nparams] contains the number of parameters. *)
 
+type equiv = 
+  | NoEquiv
+  | Equiv of kernel_name 
+  | RenEquiv of string
+
 type ml_ind = {
   ind_info : inductive_info;
   ind_nparams : int; 	       
   ind_packets : ml_ind_packet array;
-  ind_equiv : kernel_name option
+  ind_equiv : equiv
 }
 
 (*s ML terms. *)
@@ -92,7 +99,7 @@ type ml_ast =
   | MLletin  of identifier * ml_ast * ml_ast
   | MLglob   of global_reference
   | MLcons   of inductive_info * global_reference * ml_ast list
-  | MLcase   of inductive_info * ml_ast * 
+  | MLcase   of (inductive_info*case_info) * ml_ast * 
       (global_reference * identifier list * ml_ast) array
   | MLfix    of int * identifier array * ml_ast array
   | MLexn    of string
@@ -119,9 +126,14 @@ type ml_specif =
   | Smodtype of ml_module_type
 
 and ml_module_type = 
-  | MTident of kernel_name
+  | MTident of module_path
   | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
   | MTsig of mod_self_id * ml_module_sig
+  | MTwith of ml_module_type * ml_with_declaration
+
+and ml_with_declaration =  
+  | ML_With_type of identifier list * identifier list * ml_type
+  | ML_With_module of identifier list * module_path
 
 and ml_module_sig = (label * ml_specif) list
 
@@ -149,24 +161,28 @@ type ml_structure = (module_path * ml_module_structure) list
 
 type ml_signature = (module_path * ml_module_sig) list
 
-(*s Pretty-printing of MiniML in a given concrete syntax is parameterized
-    by a function [pp_global] that pretty-prints global references. 
-    The resulting pretty-printer is a module of type [Mlpp] providing
-    functions to print types, terms and declarations. *)
-
-module type Mlpp_param = sig
-  val globals : unit -> Idset.t
-  val pp_global : module_path list -> global_reference -> std_ppcmds
-  val pp_module : module_path list -> module_path -> std_ppcmds
-end
-
-module type Mlpp = sig
-  val pp_decl : module_path list -> ml_decl -> std_ppcmds
-  val pp_struct : ml_structure -> std_ppcmds
-  val pp_signature : ml_signature -> std_ppcmds
-end
-
-type extraction_params =  
-  { modular : bool; 
-    mod_name : identifier; 
-    to_appear : global_reference list }
+type unsafe_needs = {
+  mldummy : bool; 
+  tdummy : bool; 
+  tunknown : bool; 
+  magic : bool
+}
+
+type language_descr = {
+  keywords : Idset.t; 
+
+  (* Concerning the source file *)
+  file_suffix : string;  
+  capital_file : bool; (* should we capitalize filenames ? *)
+  preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; 
+  pp_struct : ml_structure -> std_ppcmds; 
+
+  (* Concerning a possible interface file *)
+  sig_suffix : string option; 
+  sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  pp_sig : ml_signature -> std_ppcmds; 
+
+  (* for an isolated declaration print *)
+  pp_decl : ml_decl -> std_ppcmds; 
+
+}  
diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml
index 6bfedce5..79aeea33 100644
--- a/contrib/extraction/mlutil.ml
+++ b/contrib/extraction/mlutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*)
+(*i $Id: mlutil.ml 10329 2007-11-21 21:21:36Z letouzey $ i*)
 
 (*i*)
 open Pp
@@ -573,14 +573,20 @@ let eta_red e =
   if n = 0 then e 
   else match t with 
     | MLapp (f,a) -> 
-	let m = (List.length a) - n in 
-	if m < 0 then e 
-	else
-	  let a1,a2 = list_chop m a in 
-	  let f = if m = 0 then f else MLapp (f,a1) in 
-	  if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f)
-	  then ast_lift (-n) f
-	  else e 
+	let m = List.length a in 
+	let ids,body,args = 
+	  if m = n then 
+	    [], f, a
+	  else if m < n then 
+	    snd (list_chop (n-m) ids), f, a 
+	  else (* m > n *)
+	    let a1,a2 = list_chop (m-n) a in 
+	    [], MLapp (f,a1), a2
+	in 
+	let p = List.length args in  
+	if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body)
+	then named_lams ids (ast_lift (-p) body)
+	else e
     | _ -> e
 
 (*s Computes all head linear beta-reductions possible in [(t a)].
@@ -658,20 +664,27 @@ let check_generalizable_case unsafe br =
     if check_and_generalize br.(i) <> f then raise Impossible 
   done; f
 
-(*s Do all branches correspond to the same thing? *)
+(*s Detecting similar branches of a match *)
 
-let check_constant_case br = 
-  if Array.length br = 0 then raise Impossible; 
-  let (r,l,t) = br.(0) in
-  let n = List.length l in 
-  if ast_occurs_itvl 1 n t then raise Impossible; 
-  let cst = ast_lift (-n) t in 
-  for i = 1 to Array.length br - 1 do 
-    let (r,l,t) = br.(i) in
-    let n = List.length l in
-    if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t)) 
-    then raise Impossible
-  done; cst
+(* If several branches of a match are equal (and independent from their 
+   patterns) we will print them using a _ pattern. If _all_ branches 
+   are equal, we remove the match.
+*)
+
+let common_branches br = 
+  let tab = Hashtbl.create 13 in 
+  for i = 0 to Array.length br - 1 do 
+    let (r,ids,t) = br.(i) in 
+    let n = List.length ids in 
+    if not (ast_occurs_itvl 1 n t) then 
+       let t = ast_lift (-n) t in 
+       let l = try Hashtbl.find tab t with Not_found -> [] in 
+       Hashtbl.replace tab t (i::l)
+  done; 
+  let best = ref [] in 
+  Hashtbl.iter 
+    (fun _ l -> if List.length l > List.length !best then best := l) tab; 
+  if List.length !best < 2 then [] else !best
 
 (*s If all branches are functions, try to permut the case and the functions. *)
 
@@ -805,18 +818,20 @@ and simpl_case o i br e =
       let f = check_generalizable_case o.opt_case_idg br in 
       simpl o (MLapp (MLlam (anonymous,f),[e]))
     with Impossible -> 
-      try (* Is each branch independant of [e] ? *) 
-	if not o.opt_case_cst then raise Impossible;
-	check_constant_case br 
-      with Impossible ->
+      (* Detect common branches *)
+      let common_br = if not o.opt_case_cst then [] else common_branches br in
+      if List.length common_br = Array.length br && br <> [||] then 
+	let (_,ids,t) = br.(0) in ast_lift (-List.length ids) t
+      else 
+	let new_i = (fst i, common_br) in 
 	(* Swap the case and the lam if possible *)
 	if o.opt_case_fun 
 	then 
 	  let ids,br = permut_case_fun br [] in 
 	  let n = List.length ids in 
-	  if n <> 0 then named_lams ids (MLcase (i,ast_lift n e, br))
-	  else MLcase (i,e,br) 
-	else MLcase (i,e,br)
+	  if n <> 0 then named_lams ids (MLcase (new_i,ast_lift n e, br))
+	  else MLcase (new_i,e,br) 
+	else MLcase (new_i,e,br)
 
 let rec post_simpl = function 
   | MLletin(_,c,e) when (is_atomic (eta_red c)) -> 
@@ -1122,13 +1137,15 @@ let is_not_strict t =
    Futhermore we don't expand fixpoints. *)
 
 let inline_test t = 
-  not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict t)
+  let t1 = eta_red t in 
+  let t2 = snd (collect_lams t1) in
+  not (is_fix t2) && ml_size t < 12 && is_not_strict t
 
 let manual_inline_list = 
   let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in 
   List.map (fun s -> (make_con mp empty_dirpath (mk_label s)))
     [ "well_founded_induction_type"; "well_founded_induction"; 
-      "Acc_rect"; "Acc_rec" ; "Acc_iter" ]
+      "Acc_rect"; "Acc_rec" ; "Acc_iter" ; "Fix" ]
 
 let manual_inline = function 
   | ConstRef c -> List.mem c manual_inline_list
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
index c9d4e237..48444509 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 9456 2006-12-17 20:08:38Z letouzey $ i*)
+(*i $Id: modutil.ml 10665 2008-03-14 12:10:09Z soubiran $ i*)
 
 open Names
 open Declarations
@@ -20,121 +20,34 @@ open Mod_subst
 
 (*S Functions upon modules missing in [Modops]. *) 
 
-(*s Add _all_ direct subobjects of a module, not only those exported. 
-   Build on the [Modops.add_signature] model. *)
-
-let add_structure mp msb env = 
-  let add_one env (l,elem) = 
-    let kn = make_kn mp empty_dirpath l in 
-    let con = make_con mp empty_dirpath l in 
-    match elem with 
-      | SEBconst cb -> Environ.add_constant con cb env 
-      | SEBmind mib -> Environ.add_mind kn mib env 
-      | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env 
-      | SEBmodtype mtb -> Environ.add_modtype kn mtb env  
-  in List.fold_left add_one env msb
-
-(*s Apply a module path substitution on a module.
-   Build on the [Modops.subst_modtype] model. *)
-
-let rec subst_module sub mb =
-  let mtb' = Modops.subst_modtype sub mb.mod_type
-  and meb' = option_smartmap (subst_meb sub) mb.mod_expr
-  and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type
-  and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in
-  if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) && 
-    (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv)
-  then mb
-  else { mod_expr= meb'; 
-	 mod_type=mtb'; 
-	 mod_user_type=mtb''; 
-	 mod_equiv=mpo'; 
-	 mod_constraints=mb.mod_constraints }
-
-and subst_meb sub = function 
-  | MEBident mp -> MEBident (subst_mp sub mp) 
-  | MEBfunctor (mbid, mtb, meb) -> 
-      assert (not (occur_mbid mbid sub)); 
-      MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb)
-  | MEBstruct (msid, msb) -> 
-      assert (not (occur_msid msid sub));
-      MEBstruct (msid, subst_msb sub msb)
-  | MEBapply (meb, meb', c) -> 
-      MEBapply (subst_meb sub meb, subst_meb sub meb', c)
-
-and subst_msb sub msb = 
-  let subst_body = function
-    | SEBconst cb -> SEBconst (subst_const_body sub cb)
-    | SEBmind mib -> SEBmind (subst_mind sub mib)
-    | SEBmodule mb -> SEBmodule (subst_module sub mb)
-    | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb)
-  in List.map (fun (l,b) -> (l,subst_body b)) msb
-
 (*s Change a msid in a module type, to follow a module expr. 
   Because of the "with" construct, the module type of a module can be a 
   [MTBsig] with a msid different from the one of the module. *)
 
 let rec replicate_msid meb mtb = match meb,mtb with 
-  | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) -> 
+  | SEBfunctor (_, _, meb), SEBfunctor (mbid, mtb1, mtb2) -> 
       let mtb' = replicate_msid meb mtb2 in 
-      if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb')
-  | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 -> 
+      if mtb' == mtb2 then mtb else SEBfunctor (mbid, mtb1, mtb')
+  | SEBstruct (msid, _), SEBstruct (msid1, msig) when msid <> msid1 -> 
       let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in
-      if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig')
+      if msig' == msig then SEBstruct (msid, msig) else SEBstruct (msid, msig')
   | _ -> mtb
 
-
-(*S More functions concerning [module_path]. *)
-
-let rec mp_length = function
-  | MPdot (mp, _) -> 1 + (mp_length mp)
-  | _ -> 1
-
-let rec prefixes_mp mp = match mp with 
-  | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
-  | _ -> MPset.singleton mp 
-
-let rec common_prefix prefixes_mp1 mp2 = 
-  if MPset.mem mp2 prefixes_mp1 then mp2 
-  else match mp2 with 
-    | MPdot (mp,_) -> common_prefix prefixes_mp1 mp 
-    | _ -> raise Not_found
-
-let common_prefix_from_list mp0 mpl = 
-  let prefixes_mp0 = prefixes_mp mp0 in 
-  let rec f = function 
-    | [] -> raise Not_found
-    | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l
-  in f mpl
-
-let rec modfile_of_mp mp = match mp with 
-  | MPfile _ -> mp
-  | MPdot (mp,_) -> modfile_of_mp mp 
-  | _ -> raise Not_found
-
-let rec parse_labels ll = function 
-  | MPdot (mp,l) -> parse_labels (l::ll) mp 
-  | mp -> mp,ll
-
-let labels_of_mp mp = parse_labels [] mp 
-
-let labels_of_ref r = 
- let mp,_,l =
-  match r with
-     ConstRef con -> repr_con con
-   | IndRef (kn,_)
-   | ConstructRef ((kn,_),_) -> repr_kn kn
-   | VarRef _ -> assert false
- in
-  parse_labels [l] mp
-
-let rec add_labels_mp mp = function 
-  | [] -> mp 
-  | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
-
-
 (*S Functions upon ML modules. *)
-
+let rec  msid_of_mt = function
+  | MTident mp -> begin
+      match Modops.eval_struct (Global.env()) (SEBident mp) with
+	| SEBstruct(msid,_) -> MPself msid
+	| _ -> anomaly "Extraction:the With can't be applied to a funsig"
+    end
+  | MTwith(mt,_)-> msid_of_mt mt
+  | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+      
+let  make_mp_with mp idl =
+  let idl_rev = List.rev idl in
+  let idl' = List.rev (List.tl idl_rev) in
+    (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+       mp idl')
 (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a 
    [ml_structure]. *) 
 
@@ -142,6 +55,16 @@ let struct_iter do_decl do_spec s =
   let rec mt_iter = function 
     | MTident _ -> () 
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
+    | MTwith (mt,ML_With_type(idl,l,t))->
+	let mp_mt = msid_of_mt mt in
+      let mp = make_mp_with mp_mt idl in
+      let gr = ConstRef (
+	(make_con mp empty_dirpath
+	  (label_of_id ( 
+	    List.hd (List.rev idl))))) in
+	mt_iter mt;do_decl 
+	  (Dtype(gr,l,t))
+    | MTwith (mt,_)->mt_iter mt
     | MTsig (_, sign) -> List.iter spec_iter sign
   and spec_iter = function 
     | (_,Spec s) -> do_spec s
@@ -186,7 +109,7 @@ let ast_iter_references do_term do_cons do_type a =
 	  if lang () = Ocaml then record_iter_references do_term i; 
 	  do_cons r 
       | MLcase (i,_,v) -> 
-	  if lang () = Ocaml then record_iter_references do_term i; 
+	  if lang () = Ocaml then record_iter_references do_term (fst i); 
 	  Array.iter (fun (r,_,_) -> do_cons r) v
       | _ -> ()
   in iter a
@@ -197,7 +120,9 @@ let ind_iter_references do_term do_cons do_type kn ind =
   let packet_iter ip p = 
     do_type (IndRef ip); 
     if lang () = Ocaml then 
-      option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; 
+      (match ind.ind_equiv with 
+	 | Equiv kne -> do_type (IndRef (kne, snd ip)); 
+	 | _ -> ()); 
     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; 
@@ -215,7 +140,7 @@ let decl_iter_references do_term do_cons do_type =
 
 let spec_iter_references do_term do_cons do_type = function 
   | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind
-  | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot
+  | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot
   | Sval (r,t) -> do_term r; type_iter_references do_type t
 
 let struct_iter_references do_term do_cons do_type = 
@@ -225,13 +150,13 @@ let struct_iter_references do_term do_cons do_type =
 
 (*s Get all references used in one [ml_structure], either in [list] or [set]. *)
 
-type 'a updown = { mutable up : 'a ; mutable down : 'a }
+type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a }
 
 let struct_get_references empty add struc = 
-  let o = { up = empty ; down = empty } in 
-  let do_term r = o.down <- add r o.down in
-  let do_cons r = o.up <- add r o.up in 
-  let do_type = if lang () = Haskell then do_cons else do_term in 
+  let o = { typ = empty ; trm = empty ; cons = empty } in 
+  let do_type r = o.typ <- add r o.typ in 
+  let do_term r = o.trm <- add r o.trm in
+  let do_cons r = o.cons <- add r o.cons in 
   struct_iter_references do_term do_cons do_type struc; o
 
 let struct_get_references_set = struct_get_references Refset.empty Refset.add
@@ -248,7 +173,9 @@ end
 
 let struct_get_references_list struc = 
   let o = struct_get_references Orefset.empty Orefset.add struc in 
-  { up = Orefset.list o.up; down = Orefset.list o.down }
+  { typ = Orefset.list o.typ; 
+    trm = Orefset.list o.trm; 
+    cons = Orefset.list o.cons }
 
 
 (*s Searching occurrences of a particular term (no lifting done). *)
@@ -284,7 +211,7 @@ let spec_type_search f = function
   | Sind (_,{ind_packets=p}) -> 
       Array.iter 
 	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
-  | Stype (_,_,ot) -> option_iter (type_search f) ot
+  | Stype (_,_,ot) -> Option.iter (type_search f) ot
   | Sval (_,u) -> type_search f u
 
 let struct_type_search f s = 
@@ -360,38 +287,40 @@ let dfix_to_mlfix rv av i =
   let c = Array.map (subst 0) av 
   in MLfix(i, ids, c)
 
-let rec optim prm s = function
+let rec optim to_appear s = function
   | [] -> []
   | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l ->
-      if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l
+      if List.mem r to_appear 
+      then d :: (optim to_appear s l) 
+      else optim to_appear s l
   | Dterm (r,t,typ) :: l ->
       let t = normalize (ast_glob_subst !s t) in 
       let i = inline r t in 
       if i then s := Refmap.add r t !s; 
-      if not i || prm.modular || List.mem r prm.to_appear 
+      if not i || modular () || List.mem r to_appear 
       then 
 	let d = match optimize_fix t with 
 	  | MLfix (0, _, [|c|]) -> 
 	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|])
 	  | t -> Dterm (r, t, typ)
-	in d :: (optim prm s l)
-      else optim prm s l
-  | d :: l -> d :: (optim prm s l)
+	in d :: (optim to_appear s l)
+      else optim to_appear s l
+  | d :: l -> d :: (optim to_appear s l)
 
-let rec optim_se top prm s = function 
+let rec optim_se top to_appear s = function 
   | [] -> [] 
   | (l,SEdecl (Dterm (r,a,t))) :: lse -> 
       let a = normalize (ast_glob_subst !s a) in 
       let i = inline r a in 
       if i then s := Refmap.add r a !s; 
-      if top && i && not prm.modular && not (List.mem r prm.to_appear)
-      then optim_se top prm s lse
+      if top && i && not (modular ()) && not (List.mem r to_appear)
+      then optim_se top to_appear s lse
       else 
 	let d = match optimize_fix a with 
 	  | MLfix (0, _, [|c|]) -> 
 	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
 	  | a -> Dterm (r, a, t)
-	in (l,SEdecl d) :: (optim_se top prm s lse)
+	in (l,SEdecl d) :: (optim_se top to_appear s lse)
   | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> 
       let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in 
       let all = ref true in 
@@ -402,22 +331,22 @@ let rec optim_se top prm s = function
 	then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
 	else all := false
       done; 
-      if !all && top && not prm.modular 
-	&& (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv)  
-      then optim_se top prm s lse
-      else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse)
+      if !all && top && not (modular ())
+	&& (array_for_all (fun r -> not (List.mem r to_appear)) rv)  
+      then optim_se top to_appear s lse
+      else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse)
   | (l,SEmodule m) :: lse -> 
-      let m = { m with ml_mod_expr = optim_me prm s m.ml_mod_expr}
-      in (l,SEmodule m) :: (optim_se top prm s lse)
-  | se :: lse -> se :: (optim_se top prm s lse) 
+      let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr}
+      in (l,SEmodule m) :: (optim_se top to_appear s lse)
+  | se :: lse -> se :: (optim_se top to_appear s lse) 
 
-and optim_me prm s = function 
-  | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm s lse)
+and optim_me to_appear s = function 
+  | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse)
   | MEident mp as me -> me
-  | MEapply (me, me') -> MEapply (optim_me prm s me, optim_me prm s me')
-  | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s me)
+  | MEapply (me, me') -> 
+      MEapply (optim_me to_appear s me, optim_me to_appear s me')
+  | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me)
 
-let optimize_struct prm before struc = 
+let optimize_struct to_appear struc = 
   let subst = ref (Refmap.empty : ml_ast Refmap.t) in 
-  option_iter (fun l -> ignore (optim prm subst l)) before; 
-  List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc
+  List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc
diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli
index 115a42ca..85d58a4b 100644
--- a/contrib/extraction/modutil.mli
+++ b/contrib/extraction/modutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
+(*i $Id: modutil.mli 10620 2008-03-05 10:54:41Z letouzey $ i*)
 
 open Names
 open Declarations
@@ -17,29 +17,9 @@ open Mod_subst
 
 (*s Functions upon modules missing in [Modops]. *) 
 
-(* Add _all_ direct subobjects of a module, not only those exported. 
-   Build on the [Modops.add_signature] model. *)
-
-val add_structure : module_path -> module_structure_body -> env -> env 
-
-(* Apply a module path substitution on a module.
-   Build on the [Modops.subst_modtype] model. *)
-
-val subst_module : substitution -> module_body -> module_body 
-val subst_meb : substitution -> module_expr_body -> module_expr_body
-val subst_msb : substitution -> module_structure_body -> module_structure_body
-
 (* Change a msid in a module type, to follow a module expr. *)
 
-val replicate_msid : module_expr_body -> module_type_body -> module_type_body
-
-(*s More utilities concerning [module_path]. *)
-
-val mp_length : module_path -> int
-val prefixes_mp : module_path -> MPset.t
-val modfile_of_mp : module_path -> module_path
-val common_prefix_from_list : module_path -> module_path list -> module_path
-val add_labels_mp : module_path -> label list -> module_path
+val replicate_msid : struct_expr_body -> struct_expr_body -> struct_expr_body
 
 (*s Functions upon ML modules. *)
 
@@ -52,10 +32,10 @@ val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
 val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
 val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit
 
-type 'a updown = { mutable up : 'a ; mutable down : 'a }
+type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a }
 
-val struct_get_references_set : ml_structure -> Refset.t updown
-val struct_get_references_list : ml_structure -> global_reference list updown
+val struct_get_references_set : ml_structure -> Refset.t kinds
+val struct_get_references_list : ml_structure -> global_reference list kinds
 
 val signature_of_structure : ml_structure -> ml_signature
 
@@ -65,7 +45,7 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
    all beta redexes (when the argument does not occur, it is just
    thrown away; when it occurs exactly once it is substituted; otherwise
    a let-in redex is created for clarity) and iota redexes, plus some other
-   optimizations. *)
+   optimizations. The first argument is the list of objects we want to appear.
+*)
 
-val optimize_struct : 
-  extraction_params -> ml_decl list option -> ml_structure -> ml_structure
+val optimize_struct : global_reference list -> ml_structure -> ml_structure
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
index 35f9a83c..64c80a2a 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 9472 2007-01-05 15:49:32Z letouzey $ i*)
+(*i $Id: ocaml.ml 10592 2008-02-27 14:16:07Z letouzey $ i*)
 
 (*s Production of Ocaml syntax. *)
 
@@ -19,10 +19,27 @@ open Table
 open Miniml
 open Mlutil
 open Modutil
+open Common
+open Declarations
+
 
 (*s Some utility functions. *)
 
-let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+let rec  msid_of_mt = function
+  | MTident mp -> begin
+      match Modops.eval_struct (Global.env()) (SEBident mp) with
+	| SEBstruct(msid,_) -> MPself msid
+	| _ -> anomaly "Extraction:the With can't be applied to a funsig"
+    end
+  | MTwith(mt,_)-> msid_of_mt mt
+  | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+
+let  make_mp_with mp idl =
+  let idl_rev = List.rev idl in
+  let idl' = List.rev (List.tl idl_rev) in
+    (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+       mp idl')
+
 
 let pp_tvar id = 
   let s = string_of_id id in 
@@ -52,70 +69,12 @@ let pp_abst = function
       str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ 
       str " ->" ++ spc ()
 
-let pp_apply st par args = match args with
-  | [] -> st
-  | _  -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
-
-let pr_binding = function
-  | [] -> mt ()
-  | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
-
-let space_if = function true -> str " " | false -> mt ()
-
-let sec_space_if = function true -> spc () | false -> mt ()
-
-let fnl2 () = fnl () ++ fnl () 
-
 let pp_parameters l = 
   (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
 
 let pp_string_parameters l = 
   (pp_boxed_tuple str l ++ space_if (l<>[])) 
 
-(*s Generic renaming issues. *)
-
-let rec rename_id id avoid = 
-  if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
-
-let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
-let uppercase_id id = id_of_string (String.capitalize (string_of_id id))
-
-(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
-let pr_upper_id id = str (String.capitalize (string_of_id id))
-
-(*s de Bruijn environments for programs *)
-
-type env = identifier list * Idset.t
-
-let rec rename_vars avoid = function
-  | [] -> 
-      [], avoid
-  | id :: idl when id == dummy_name ->
-      (* we don't rename dummy binders *)
-      let (idl', avoid') = rename_vars avoid idl in
-      (id :: idl', avoid')
-  | id :: idl ->
-      let (idl, avoid) = rename_vars avoid idl in
-      let id = rename_id (lowercase_id id) avoid in
-      (id :: idl, Idset.add id avoid)
-
-let rename_tvars avoid l = 
-  let rec rename avoid = function 
-    | [] -> [],avoid 
-    | id :: idl -> 
-	let id = rename_id (lowercase_id id) avoid in 
-	let idl, avoid = rename (Idset.add id avoid) idl in 
-	(id :: idl, avoid) in
-  fst (rename avoid l)
-
-let push_vars ids (db,avoid) =
-  let ids',avoid' = rename_vars avoid ids in
-  ids', (ids' @ db, avoid')
-
-let get_db_name n (db,_) = 
-  let id = List.nth db (pred n) in 
-  if id = dummy_name then id_of_string "__" else id
-
 (*s Ocaml renaming issues. *)
 
 let keywords =     
@@ -130,46 +89,39 @@ let keywords =
     "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] 
   Idset.empty
 
-let preamble _ used_modules (mldummy,tdummy,tunknown) _ = 
-  let pp_mp = function 
-    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
-    | _ -> assert false 
-  in 
-  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
-  ++ 
-  (if used_modules = [] then mt () else fnl ())
-  ++
-  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt()) 
-  ++
-  (if mldummy then 
-     str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl ()
-   else mt ()) 
-  ++ 
-  (if tdummy || tunknown || mldummy then fnl () else mt ())
-
-let preamble_sig _ used_modules (_,tdummy,tunknown) = 
-  let pp_mp = function 
-    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
-    | _ -> assert false 
-  in 
-  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
-  ++ 
-  (if used_modules = [] then mt () else fnl ())
-  ++
-  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl () 
-   else mt()) 
+let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
 
-(*s The pretty-printing functor. *)
+let preamble _ used_modules usf = 
+  prlist pp_open used_modules ++
+  (if used_modules = [] then mt () else fnl ()) ++
+  (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++
+  (if usf.mldummy then 
+     str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n"
+   else mt ()) ++
+  (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ())
 
-module Make = functor(P : Mlpp_param) -> struct
+let sig_preamble _ used_modules usf =
+  prlist pp_open used_modules ++
+  (if used_modules = [] then mt () else fnl ()) ++
+  (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt())
 
-let local_mpl = ref ([] : module_path list)
+(*s The pretty-printer for Ocaml syntax*)
 
-let pp_global r = 
+let pp_global k r = 
   if is_inline_custom r then str (find_custom r) 
-  else P.pp_global !local_mpl  r
+  else str (Common.pp_global k r)
+
+let pp_modname mp = str (Common.pp_module mp)
 
-let empty_env () = [], P.globals ()
+let is_infix r = 
+  is_inline_custom r && 
+  (let s = find_custom r in 
+   let l = String.length s in 
+   l >= 2 && s.[0] = '(' && s.[l-1] = ')')
+
+let get_infix r = 
+  let s = find_custom r in 
+  String.sub s 1 (String.length s - 2)
 
 exception NoRecord
 
@@ -187,12 +139,16 @@ let rec pp_type par vl t =
     | Tmeta _ | Tvar' _ | Taxiom -> assert false
     | Tvar i -> (try pp_tvar (List.nth vl (pred i)) 
 		 with _ -> (str "'a" ++ int i))
-    | Tglob (r,[]) -> pp_global r
+    | Tglob (r,[a1;a2]) when is_infix r -> 
+	pp_par par 
+	  (pp_rec true a1 ++ spc () ++ str (get_infix r) ++ spc () ++ 
+	   pp_rec true a2)
+    | Tglob (r,[]) -> pp_global Type r
     | Tglob (r,l) -> 
 	if r = IndRef (kn_sig,0) then 
 	  pp_tuple_light pp_rec l
 	else 
-	  pp_tuple_light pp_rec l ++ spc () ++ pp_global r
+	  pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
     | Tarr (t1,t2) ->
 	pp_par par 
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
@@ -206,10 +162,16 @@ let rec pp_type par vl t =
     de Bruijn variables. [args] is the list of collected arguments
     (already pretty-printed). *)
 
+let is_ifthenelse = function 
+  | [|(r1,[],_);(r2,[],_)|] -> 
+      (try (find_custom r1 = "true") && (find_custom r2 = "false") 
+       with Not_found -> false)
+  | _ -> false
+
 let expr_needs_par = function
   | MLlam _  -> true
   | MLcase (_,_,[|_|]) -> false 
-  | MLcase _ -> true
+  | MLcase (_,_,pv) -> not (is_ifthenelse pv)
   | _        -> false 
 
 
@@ -244,26 +206,31 @@ let rec pp_expr par env args =
 	(try 
 	   let args = list_skipn (projection_arity r) args in 
 	   let record = List.hd args in 
-	   pp_apply (record ++ str "." ++ pp_global r) par (List.tl args)
-	 with _ -> apply (pp_global r))
+	   pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args)
+	 with _ -> apply (pp_global Term r))
     | MLcons (Coinductive,r,[]) ->
 	assert (args=[]);
-	pp_par par (str "lazy " ++ pp_global r)
+	pp_par par (str "lazy " ++ pp_global Cons r)
     | MLcons (Coinductive,r,args') -> 
 	assert (args=[]);
 	let tuple = pp_tuple (pp_expr true env []) args' in 
-	pp_par par (str "lazy (" ++ pp_global r ++ spc() ++ tuple ++str ")")
+	pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")")
     | MLcons (_,r,[]) -> 
 	assert (args=[]);
-	pp_global r
+	pp_global Cons r
     | MLcons (Record projs, r, args') -> 
 	assert (args=[]); 
 	pp_record_pat (projs, List.map (pp_expr true env []) args')
+    | MLcons (_,r,[arg1;arg2]) when is_infix r -> 
+	assert (args=[]); 
+	pp_par par
+	  ((pp_expr true env [] arg1) ++ spc () ++ str (get_infix r) ++
+	   spc () ++ (pp_expr true env [] arg2))
     | MLcons (_,r,args') -> 
 	assert (args=[]);
 	let tuple = pp_tuple (pp_expr true env []) args' in 
-	pp_par par (pp_global r ++ spc () ++ tuple)
-    | MLcase (i, t, pv) ->
+	pp_par par (pp_global Cons r ++ spc () ++ tuple)
+    | MLcase ((i,factors), t, pv) ->
 	let expr = if i = Coinductive then 
 	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
 	else 
@@ -276,7 +243,7 @@ let rec pp_expr par env args =
 	   match c with 
 	     | MLrel i when i <= n -> 
 		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++ 
-				     pp_global (List.nth projs (n-i)))) 
+				     pp_global Term (List.nth projs (n-i))))
 	     | MLapp (MLrel i, a) when i <= n -> 
 		 if List.exists (ast_occurs_itvl 1 n) a 
 		 then raise NoRecord
@@ -284,7 +251,7 @@ let rec pp_expr par env args =
 		   let ids,env' = push_vars (List.rev ids) env in
 		   (pp_apply 
 		      (pp_expr true env [] t ++ str "." ++ 
-		       pp_global (List.nth projs (n-i)))
+		       pp_global Term (List.nth projs (n-i)))
 		      par ((List.map (pp_expr true env' []) a) @ args))
 	     | _ -> raise NoRecord
 	 with NoRecord -> 
@@ -297,11 +264,13 @@ let rec pp_expr par env args =
 			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) 
 			 ++ spc () ++ str "in") ++ 
 		      spc () ++ hov 0 s2)))
-	   else
-	     apply
+	   else 
+ 	     apply
       	       (pp_par par' 
-      		  (v 0 (str "match " ++ expr ++ str " with" ++
-			fnl () ++ str "  | " ++ pp_pat env i pv))))
+		  (try pp_ifthenelse par' env expr pv 
+		   with Not_found -> 
+		     v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++
+			  str "  | " ++ pp_pat env (i,factors) pv))))
     | MLfix (i,ids,defs) ->
 	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
       	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
@@ -319,10 +288,21 @@ let rec pp_expr par env args =
 and pp_record_pat (projs, args) =
    str "{ " ++
    prlist_with_sep (fun () -> str ";" ++ spc ()) 
-     (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a)
+     (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a)
      (List.combine projs args) ++
    str " }"
 
+and pp_ifthenelse par env expr pv = match pv with 
+  | [|(tru,[],the);(fal,[],els)|] when 
+      (find_custom tru = "true") && (find_custom fal = "false")
+      -> 
+      hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ 
+            hov 2 (str "then " ++
+		   hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ 
+	    hov 2 (str "else " ++
+	           hov 2 (pp_expr (expr_needs_par els) env [] els)))
+  | _ -> raise Not_found
+
 and pp_one_pat env i (r,ids,t) = 
   let ids,env' = push_vars (List.rev ids) env in
   let expr = pp_expr (expr_needs_par t) env' [] t in 
@@ -330,33 +310,45 @@ and pp_one_pat env i (r,ids,t) =
     let projs = find_projections i in 
     pp_record_pat (projs, List.rev_map pr_id ids), expr
   with NoRecord -> 
-    let args = 
-      if ids = [] then (mt ()) 
-      else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in 
-    pp_global r ++ args, expr
+    (match List.rev ids with 
+      | [i1;i2] when is_infix r -> 
+	  pr_id i1 ++ str " " ++ str (get_infix r) ++ str " " ++ pr_id i2
+      | [] -> pp_global Cons r
+      | ids -> pp_global Cons r ++ str " " ++ pp_boxed_tuple pr_id ids), 
+    expr
   
-and pp_pat env i pv = 
-  prvect_with_sep (fun () -> (fnl () ++ str "  | ")) 
-    (fun x -> let s1,s2 = pp_one_pat env i x in 
-     hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) pv
-
-and pp_function env f t =
+and pp_pat env (info,factors) pv = 
+  prvecti 
+    (fun i x -> if List.mem i factors then mt () else 
+       let s1,s2 = pp_one_pat env info x in 
+       hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++
+       (if factors = [] && i = Array.length pv-1 then mt () 
+	else fnl () ++ str "  | ")) pv 
+  ++ 
+  match factors with 
+     | [] -> mt ()
+     | i::_ -> 
+	 let (_,ids,t) = pv.(i) in 
+	 let t = ast_lift (-List.length ids) t in 
+	 hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
+
+and pp_function env t =
   let bl,t' = collect_lams t in
   let bl,env' = push_vars bl env in
   match t' with 
-    | MLcase(i,MLrel 1,pv) when i=Standard -> 
+    | MLcase(i,MLrel 1,pv) when fst i=Standard -> 
 	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then 
-	  (f ++ pr_binding (List.rev (List.tl bl)) ++
-       	     str " = function" ++ fnl () ++
-	     v 0 (str "  | " ++ pp_pat env' i pv))
+	  pr_binding (List.rev (List.tl bl)) ++
+       	  str " = function" ++ fnl () ++
+	  v 0 (str "  | " ++ pp_pat env' i pv)
 	else
-          (f ++ pr_binding (List.rev bl) ++ 
-             str " = match " ++
-	     pr_id (List.hd bl) ++ str " with" ++ fnl () ++
-	     v 0 (str "  | " ++ pp_pat env' i pv))
-    | _ -> (f ++ pr_binding (List.rev bl) ++
-	      str " =" ++ fnl () ++ str "  " ++
-	      hov 2 (pp_expr false env' [] t'))
+          pr_binding (List.rev bl) ++ 
+          str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++
+	  v 0 (str "  | " ++ pp_pat env' i pv)
+    | _ -> 
+          pr_binding (List.rev bl) ++
+	  str " =" ++ fnl () ++ str "  " ++
+	  hov 2 (pp_expr false env' [] t')
 
 (*s names of the functions ([ids]) are already pushed in [env],
     and passed here just for convenience. *)
@@ -366,93 +358,111 @@ and pp_fix par env i (ids,bl) args =
     (v 0 (str "let rec " ++
 	  prvect_with_sep
       	    (fun () -> fnl () ++ str "and ")
-	    (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+	    (fun (fi,ti) -> pr_id fi ++ pp_function env ti)
 	    (array_map2 (fun id b -> (id,b)) ids bl) ++
 	  fnl () ++
 	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
 
 let pp_val e typ = 
-  str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++ 
-  str " **)"  ++ fnl2 ()
+  hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ 
+  str " **)")  ++ fnl2 ()
 
 (*s Pretty-printing of [Dfix] *)
 
-let rec pp_Dfix init i ((rv,c,t) as fix) = 
-  if i >= Array.length rv then mt () 
-  else 
-    if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix
+let pp_Dfix (rv,c,t) = 
+  let names = Array.map 
+    (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv
+  in 
+  let rec pp sep letand i = 
+    if i >= Array.length rv then mt ()
+    else if is_inline_custom rv.(i) then pp sep letand (i+1)
     else 
-      let e = pp_global rv.(i) in
-      (if init then mt () else fnl2 ()) ++
-      pp_val e t.(i) ++
-      str (if init then "let rec " else "and ") ++
-      (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i))
-       else pp_function (empty_env ()) e c.(i)) ++
-      pp_Dfix false (i+1) fix 
-	
+      let def = 
+	if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i))
+	else pp_function (empty_env ()) c.(i)
+      in 
+      sep () ++ pp_val names.(i) t.(i) ++ 
+      str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1) 
+  in pp mt "let rec " 0
+
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_equiv param_list = function 
-  | None -> mt ()
-  | Some ip_equiv -> 
-      str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv)
+let pp_equiv param_list name = function 
+  | NoEquiv, _ -> mt ()
+  | Equiv kn, i -> 
+      str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (kn,i))
+  | RenEquiv ren, _  ->
+      str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
 
 let pp_comment s = str "(* " ++ s ++ str " *)"
 
-let pp_one_ind prefix ip ip_equiv pl cv =
+let pp_one_ind prefix ip_equiv pl name cnames ctyps =
   let pl = rename_tvars keywords pl in
-  let pp_constructor (r,l) =
-    hov 2 (str "  | " ++ pp_global r ++
-	   match l with
-	     | [] -> mt () 
-	     | _  -> (str " of " ++ 
-		      prlist_with_sep 
-			(fun () -> spc () ++ str "* ") (pp_type true pl) l))
+  let pp_constructor i typs =
+    (if i=0 then mt () else fnl ()) ++ 
+    hov 5 (str "  | " ++ cnames.(i) ++
+	   (if typs = [] then mt () else str " of ") ++
+	   prlist_with_sep 
+	    (fun () -> spc () ++ str "* ") (pp_type true pl) typs)
   in
-  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))
+  pp_parameters pl ++ str prefix ++ name ++
+  pp_equiv pl name ip_equiv ++ str " =" ++
+  if Array.length ctyps = 0 then str " unit (* empty inductive *)" 
+  else fnl () ++ v 0 (prvecti pp_constructor ctyps)
 
 let pp_logical_ind packet = 
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ 
-  fnl () ++ pp_comment (str "with constructors : " ++ 
-			prvect_with_sep spc pr_id packet.ip_consnames)
+  fnl () ++
+  pp_comment (str "with constructors : " ++ 
+	      prvect_with_sep spc pr_id packet.ip_consnames) ++
+  fnl ()
 
 let pp_singleton kn packet = 
+  let name = pp_global Type (IndRef (kn,0)) in 
   let l = rename_tvars keywords packet.ip_vars in 
-  hov 2 (str "type " ++ pp_parameters l ++
-	 pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++
+  hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++
 	 pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++
 	 pp_comment (str "singleton inductive, whose constructor was " ++ 
 		     pr_id packet.ip_consnames.(0)))
 
 let pp_record kn projs ip_equiv packet = 
-  let l = List.combine projs packet.ip_types.(0) in 
+  let name = pp_global Type (IndRef (kn,0)) in
+  let projnames = List.map (pp_global Term) projs in 
+  let l = List.combine projnames packet.ip_types.(0) in 
   let pl = rename_tvars keywords packet.ip_vars in 
-  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ 
-  pp_equiv pl ip_equiv ++ str " = { "++
+  str "type " ++ pp_parameters pl ++ name ++ 
+  pp_equiv pl name ip_equiv ++ str " = { "++
   hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
-	   (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) 
+	   (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) 
   ++ str " }"
 
-let pp_coind ip pl = 
-  let r = IndRef ip in 
+let pp_coind pl name = 
   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 ++ name ++ str " = " ++ 
+  pp_parameters pl ++ str "__" ++ name ++ 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 names = 
+    Array.mapi (fun i p -> if p.ip_logical then mt () else 
+		  pp_global Type (IndRef (kn,i)))
+      ind.ind_packets
+  in 
+  let cnames = 
+    Array.mapi 
+      (fun i p -> if p.ip_logical then [||] else 
+	 Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1)))
+	   p.ip_types)
+      ind.ind_packets
+  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 ip_equiv = ind.ind_equiv, 0 in 
       let p = ind.ind_packets.(i) in 
       if is_custom (IndRef ip) then pp (i+1)
       else begin 
@@ -463,8 +473,9 @@ let pp_ind co kn ind =
 	  begin 
 	    init := (fnl () ++ str "and "); 
 	    s ++
-	    (if co then pp_coind ip p.ip_vars else mt ())
-	    ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++
+	    (if co then pp_coind p.ip_vars names.(i) else mt ()) ++
+	    pp_one_ind 
+	      prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++
 	    pp (i+1)
 	  end
       end
@@ -479,159 +490,248 @@ let pp_mind kn i =
     | Singleton -> pp_singleton kn i.ind_packets.(0)
     | Coinductive -> pp_ind true kn i
     | 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)
+	pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0)
     | Standard -> pp_ind false kn i
 
-let pp_decl mpl = 
-  local_mpl := mpl; 
-  function
+let pp_decl = function
+    | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
+    | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase"
     | Dind (kn,i) -> pp_mind kn i
-    | Dtype (r, l, t) ->
-	if is_inline_custom r then failwith "empty phrase"
-	else 
-          let pp_r = pp_global r in 
-	  let l = rename_tvars keywords l in 
-          let ids, def = try 
+    | Dtype (r, l, t) -> 
+        let name = pp_global Type r in 
+	let l = rename_tvars keywords l in 
+        let ids, def = 
+	  try 
 	    let ids,s = find_type_custom r in 
 	    pp_string_parameters ids, str "=" ++ spc () ++ str s 
-	  with not_found -> 
+	  with Not_found -> 
 	    pp_parameters l, 
 	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
 	    else str "=" ++ spc () ++ pp_type false l t
-	  in 
-	  hov 2 (str "type" ++ spc () ++ ids ++ pp_r ++ 
-		 spc () ++ def)
+	in 
+	hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
     | Dterm (r, a, t) -> 
-	if is_inline_custom r then failwith "empty phrase"
-	else 
-	  let e = pp_global r in 
-	  pp_val e t ++
-	  hov 0 
-	    (str "let " ++ 
-	     if is_custom r then 
-	       e ++ str " = " ++ str (find_custom r)
-	     else if is_projection r then 
-	       let s = prvecti (fun _ -> str) 
-			 (Array.make (projection_arity r) " _") in 
-	       e ++ s ++ str " x = x." ++ e
-	     else pp_function (empty_env ()) e a)
+	let def = 
+	  if is_custom r then str (" = " ^ find_custom r)
+	  else if is_projection r then 
+	    (prvect str (Array.make (projection_arity r) " _")) ++ 
+	    str " x = x."
+	  else pp_function (empty_env ()) a
+	in 
+	let name = pp_global Term r in 
+	let postdef = if is_projection r then name else mt () in 
+	pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef)
     | Dfix (rv,defs,typs) ->
-	pp_Dfix true 0 (rv,defs,typs)
-
-let pp_spec mpl = 
-  local_mpl := mpl; 
-  function 
-    | Sind (kn,i) -> pp_mind kn i
-    | Sval (r,t) -> 
-	if is_inline_custom r then failwith "empty phrase"
-	else 
-	  hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++
-		 pp_type false [] t)
-    | Stype (r,vl,ot) -> 
-	if is_inline_custom r then failwith "empty phrase"
-	else 
-	  let l = rename_tvars keywords vl in 
-	  let ids, def = 
-	    try 
-	      let ids, s = find_type_custom r in 
-	      pp_string_parameters ids,  str "= " ++ str s 
-	    with not_found -> 
-	      let ids = pp_parameters l in 
-	      match ot with 
-		| None -> ids, mt ()
-		| Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" 
-		| Some t -> ids, str "=" ++ spc () ++ pp_type false l t 
-	  in 
-	  hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def)
-
-let rec pp_specif mpl = function 
-  | (_,Spec s) -> pp_spec mpl s 
+	pp_Dfix (rv,defs,typs)
+
+let pp_alias_decl ren = function 
+  | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
+  | Dtype (r, l, _) -> 
+      let name = pp_global Type r in 
+      let l = rename_tvars keywords l in 
+      let ids = pp_parameters l in 
+      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ 
+	     str (ren^".") ++ name)
+  | Dterm (r, a, t) -> 
+      let name = pp_global Term r in
+      hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name)
+  | Dfix (rv, _, _) ->
+      prvecti (fun i r -> if is_inline_custom r then mt () else 
+		 let name = pp_global Term r in 
+		 hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++
+		 fnl ()) 
+	rv
+
+let pp_spec = function 
+  | Sval (r,_) when is_inline_custom r -> failwith "empty phrase"
+  | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
+  | Sind (kn,i) -> pp_mind kn i
+  | Sval (r,t) -> 
+      let def = pp_type false [] t in 
+      let name = pp_global Term r in 
+      hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def)
+  | Stype (r,vl,ot) -> 
+      let name = pp_global Type r in
+      let l = rename_tvars keywords vl in 
+      let ids, def = 
+	try 
+	  let ids, s = find_type_custom r in 
+	  pp_string_parameters ids,  str "= " ++ str s 
+	with Not_found -> 
+	  let ids = pp_parameters l in 
+	  match ot with 
+	    | None -> ids, mt ()
+	    | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" 
+	    | Some t -> ids, str "=" ++ spc () ++ pp_type false l t 
+      in 
+      hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
+
+let pp_alias_spec ren = function 
+  | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
+  | Stype (r,l,_) ->       
+      let name = pp_global Type r in 
+      let l = rename_tvars keywords l in 
+      let ids = pp_parameters l in 
+      hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ 
+	     str (ren^".") ++ name)
+  | Sval _ -> assert false
+	  
+let rec pp_specif = function 
+  | (_,Spec (Sval _ as s)) -> pp_spec s
+  | (l,Spec s) -> 
+      (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+	 hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++
+	 fnl () ++ str "end" ++ fnl () ++
+	 pp_alias_spec ren s
+       with Not_found -> pp_spec s)
   | (l,Smodule mt) -> 
-      hov 1 
-	(str "module " ++ 
-	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
-	 str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt)
+      let def = pp_module_type (Some l) mt in 
+      let def' = pp_module_type (Some l) mt in 
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
+      hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++
+      (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in
+	 fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def')
+       with Not_found -> Pp.mt ())
   | (l,Smodtype mt) -> 
-      hov 1
-	(str "module type " ++
-	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
-	 str " = " ++ fnl () ++ pp_module_type mpl None mt)
-
-and pp_module_type mpl ol = function 
+      let def = pp_module_type None mt in 
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in
+      hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
+      (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+	 fnl () ++ str ("module type "^ren^" = ") ++ name
+       with Not_found -> Pp.mt ())
+
+and pp_module_type ol = function 
   | MTident kn -> 
-      let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l)) 
+      pp_modname kn
   | MTfunsig (mbid, mt, mt') -> 
-      str "functor (" ++ 
-      P.pp_module mpl (MPbound mbid) ++
-      str ":" ++
-      pp_module_type mpl None mt ++
-      str ") ->" ++ fnl () ++
-      pp_module_type mpl None mt'
+      let name = pp_modname (MPbound mbid) in 
+      let typ = pp_module_type None mt in 
+      let def = pp_module_type None mt' in 
+      str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MTsig (msid, sign) ->
-      let mpl = match ol, mpl with 
-	| None, _ -> (MPself msid) :: mpl
-	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
-	| _ -> assert false 
-      in
-      let l = map_succeed (pp_specif mpl) sign in 
+      let tvm = top_visible_mp () in 
+      Option.iter (fun l -> add_subst msid (MPdot (tvm, l))) ol; 
+      let mp = MPself msid in
+      push_visible mp; 
+      let l = map_succeed pp_specif sign in 
+      pop_visible (); 
       str "sig " ++ fnl () ++ 
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
-      fnl () ++ str "end"
-
+	fnl () ++ str "end"
+  | MTwith(mt,ML_With_type(idl,vl,typ)) ->
+      let l = rename_tvars keywords vl in 
+      let ids = pp_parameters l in 
+      let mp_mt = msid_of_mt mt in
+      let mp = make_mp_with mp_mt idl in
+      let gr = ConstRef (
+	(make_con mp empty_dirpath
+	  (label_of_id ( 
+	    List.hd (List.rev idl))))) in
+	push_visible mp_mt;
+	let s = pp_module_type None mt ++
+	  str " with type " ++
+	  pp_global Type gr ++
+	  ids in
+	  pop_visible();
+	  s ++ str "=" ++ spc () ++
+	  pp_type false  vl typ
+  | MTwith(mt,ML_With_module(idl,mp)) ->
+      let mp_mt=msid_of_mt mt in
+	push_visible mp_mt;
+	let s = 
+	  pp_module_type None mt ++
+	    str " with module " ++
+	    (pp_modname
+	       (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+		  mp_mt idl))
+	  ++ str " = "  
+	in
+	  pop_visible ();
+	  s ++ (pp_modname mp)
+	    
+	    
 let is_short = function MEident _ | MEapply _ -> true | _ -> false
-
-let rec pp_structure_elem mpl = function 
-  | (_,SEdecl d) -> pp_decl mpl d
+  
+let rec pp_structure_elem = function 
+  | (l,SEdecl d) -> 
+       (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+	 hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++
+	 fnl () ++ str "end" ++ fnl () ++
+	 pp_alias_decl ren d 
+	with Not_found -> pp_decl d)
   | (l,SEmodule m) ->
+      let def = pp_module_expr (Some l) m.ml_mod_expr in 
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
       hov 1 
-	(str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ 
-	 (*i if you want signatures everywhere: i*)
-	 (*i str " :" ++ fnl () ++ i*)
-	 (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
-	 str " = " ++
-	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++
-	 pp_module_expr mpl (Some l) m.ml_mod_expr)
+	(str "module " ++ name ++ str " = " ++ 
+	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ 
+      (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+	 fnl () ++ str ("module "^ren^" = ") ++ name
+       with Not_found -> mt ())
   | (l,SEmodtype m) -> 
-      hov 1 
-	(str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++
-	 str " = " ++ fnl () ++ pp_module_type mpl None m)
-
-and pp_module_expr mpl ol = function 
-  | MEident mp' -> P.pp_module mpl mp'
+      let def = pp_module_type None m in 
+      let name = pp_modname (MPdot (top_visible_mp (), l)) in 
+      hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
+      (try 
+	 let ren = Common.check_duplicate (top_visible_mp ()) l in 
+         fnl () ++ str ("module type "^ren^" = ") ++ name
+       with Not_found -> mt ())
+
+and pp_module_expr ol = function 
+  | MEident mp' -> pp_modname mp'
   | MEfunctor (mbid, mt, me) -> 
-      str "functor (" ++ 
-      P.pp_module mpl (MPbound mbid) ++
-      str ":" ++
-      pp_module_type mpl None mt ++
-      str ") ->" ++ fnl () ++
-      pp_module_expr mpl None me
+      let name = pp_modname (MPbound mbid) in
+      let typ = pp_module_type None mt in 
+      let def = pp_module_expr None me in 
+      str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MEapply (me, me') -> 
-      pp_module_expr mpl None me ++ str "(" ++ 
-      pp_module_expr mpl None me' ++ str ")"
+      pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")"
   | MEstruct (msid, sel) -> 
-      let mpl = match ol, mpl with 
-	| None, _ -> (MPself msid) :: mpl
-	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
-	| _ -> assert false
-      in
-      let l = map_succeed (pp_structure_elem mpl) sel in 
+      let tvm = top_visible_mp () in 
+      let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
+      push_visible mp; 
+      let l = map_succeed pp_structure_elem sel in 
+      pop_visible (); 
       str "struct " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ 
       fnl () ++ str "end" 
 
 let pp_struct s =
-  let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in 
-  prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s
+  let pp mp s = 
+    push_visible mp; 
+    let p = pp_structure_elem s ++ fnl2 () in 
+    pop_visible (); p
+  in
+  prlist_strict 
+    (fun (mp,sel) -> prlist_strict identity (map_succeed (pp mp) sel)) s
 
 let pp_signature s = 
-  let pp mp s = pp_specif [mp] s ++ fnl2 () in 
-  prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s
-
-let pp_decl mpl d = 
-  try pp_decl mpl d with Failure "empty phrase" -> mt () 
-
-end
-
+  let pp mp s = 
+    push_visible mp; 
+    let p = pp_specif s ++ fnl2 () in 
+    pop_visible (); p
+  in 
+  prlist_strict
+    (fun (mp,sign) -> prlist_strict identity (map_succeed (pp mp) sign)) s
+
+let pp_decl d = 
+  try pp_decl d with Failure "empty phrase" -> mt ()
+
+let ocaml_descr = {
+  keywords = keywords;  
+  file_suffix = ".ml"; 
+  capital_file = false;  
+  preamble = preamble; 
+  pp_struct = pp_struct; 
+  sig_suffix = Some ".mli";  
+  sig_preamble = sig_preamble; 
+  pp_sig = pp_signature;
+  pp_decl = pp_decl; 
+}
 
 
diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli
index 8c521ccd..3d90e74c 100644
--- a/contrib/extraction/ocaml.mli
+++ b/contrib/extraction/ocaml.mli
@@ -6,49 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
-
-(*s Some utility functions to be reused in module [Haskell]. *)
-
-open Pp
-open Names
-open Libnames
-open Miniml
-
-val pp_par : bool -> std_ppcmds -> std_ppcmds
-val pp_abst : identifier list -> std_ppcmds
-val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds 
-val pr_binding : identifier list -> std_ppcmds
-
-val rename_id : identifier -> Idset.t -> identifier
-
-val lowercase_id : identifier -> identifier
-val uppercase_id : identifier -> identifier
-
-val pr_upper_id : identifier -> std_ppcmds
-
-type env = identifier list * Idset.t
-
-val rename_vars: Idset.t -> identifier list -> env
-val rename_tvars: Idset.t -> identifier list -> identifier list 
-val push_vars : identifier list -> env -> identifier list * env
-val get_db_name : int -> env -> identifier
-
-val keywords : Idset.t
-
-val preamble : 
-  extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-val preamble_sig : 
-  extraction_params -> module_path list -> bool*bool*bool -> std_ppcmds
-
-(*s Production of Ocaml syntax. We export both a functor to be used for 
-    extraction in the Coq toplevel and a function to extract some 
-    declarations to a file. *)
-
-module Make : functor(P : Mlpp_param) -> Mlpp
-
-
-
+(*i $Id: ocaml.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
 
+val ocaml_descr : Miniml.language_descr 
 
diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml
index 7004a202..600f64db 100644
--- a/contrib/extraction/scheme.ml
+++ b/contrib/extraction/scheme.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.ml 7651 2005-12-16 03:19:20Z letouzey $ i*)
+(*i $Id: scheme.ml 10233 2007-10-17 23:29:08Z letouzey $ i*)
 
 (*s Production of Scheme syntax. *)
 
@@ -18,7 +18,7 @@ open Libnames
 open Miniml
 open Mlutil
 open Table
-open Ocaml
+open Common
 
 (*s Scheme renaming issues. *)
 
@@ -29,17 +29,11 @@ let keywords =
       "error"; "delay"; "force"; "_"; "__"] 
     Idset.empty
 
-let preamble _ _ (mldummy,_,_) _ = 
-  str ";; This extracted scheme code relies on some additional macros" ++ 
-  fnl () ++
-  str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme" ++
-  fnl () ++
-  str "(load \"macros_extr.scm\")" ++
-  fnl () ++ fnl () ++
-  (if mldummy then 
-     str "(define __ (lambda (_) __))" 
-     ++ fnl () ++ fnl()
-   else mt ())
+let preamble _ _ usf = 
+  str ";; This extracted scheme code relies on some additional macros\n" ++ 
+  str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++
+  str "(load \"macros_extr.scm\")\n\n" ++
+  (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
 let pr_id id = 
   let s = string_of_id id in
@@ -60,14 +54,11 @@ let pp_apply st _ = function
   | [] -> st 
   | [a] -> hov 2 (paren (st ++ spc () ++ a))
   | args -> hov 2 (paren (str "@ " ++ st ++ 
-			  (prlist (fun x -> spc () ++ x) args))) 
+			  (prlist_strict (fun x -> spc () ++ x) args)))
 
-(*s The pretty-printing functor. *)
+(*s The pretty-printer for Scheme syntax *)
 
-module Make = functor(P : Mlpp_param) -> struct
-
-let pp_global r = P.pp_global [initial_path] r
-let empty_env () = [], P.globals()
+let pp_global k r = str (Common.pp_global k r)
 
 (*s Pretty-printing of expressions.  *)
 
@@ -95,17 +86,17 @@ let rec pp_expr env args =
 			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) 
 		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
     | MLglob r -> 
-	apply (pp_global r)
+	apply (pp_global Term r)
     | MLcons (i,r,args') ->
 	assert (args=[]);
 	let st = 
 	  str "`" ++ 
-	  paren (pp_global r ++ 
+	  paren (pp_global Cons r ++ 
 		 (if args' = [] then mt () else spc ()) ++
 		 prlist_with_sep spc (pp_cons_args env) args')
 	in 
 	if i = Coinductive then paren (str "delay " ++ st) else st 
-    | MLcase (i,t, pv) ->
+    | MLcase ((i,_),t, pv) ->
 	let e = 
 	  if i <> Coinductive then pp_expr env [] t 	
 	  else paren (str "force" ++ spc () ++ pp_expr env [] t)
@@ -125,7 +116,7 @@ let rec pp_expr env args =
 
 and pp_cons_args env = function 
   | MLcons (i,r,args) when i<>Coinductive -> 
-      paren (pp_global r ++ 
+      paren (pp_global Cons r ++ 
 	     (if args = [] then mt () else spc ()) ++
 	     prlist_with_sep spc (pp_cons_args env) args)
   | e -> str "," ++ pp_expr env [] e
@@ -137,7 +128,7 @@ and pp_one_pat env (r,ids,t) =
     if ids = [] then mt () 
     else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
   in 
-  (pp_global r ++ args), (pp_expr env' [] t)
+  (pp_global Cons r ++ args), (pp_expr env' [] t)
   
 and pp_pat env pv = 
   prvect_with_sep fnl  
@@ -160,11 +151,11 @@ and pp_fix env j (ids,bl) args =
 
 (*s Pretty-printing of a declaration. *)
 
-let pp_decl _ = function
+let pp_decl = function
   | Dind _ -> mt ()
   | Dtype _ -> mt () 
   | Dfix (rv, defs,_) ->
-      let ppv = Array.map pp_global rv in 
+      let ppv = Array.map (pp_global Term) rv in 
       prvect_with_sep fnl 
 	(fun (pi,ti) -> 
 	   hov 2 
@@ -177,23 +168,35 @@ let pp_decl _ = function
       if is_inline_custom r then mt () 
       else 
 	if is_custom r then 
-	  hov 2 (paren (str "define " ++ pp_global r ++ spc () ++ 
+	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ 
 			  str (find_custom r))) ++ fnl () ++ fnl () 
 	else 
-	  hov 2 (paren (str "define " ++ pp_global r ++ spc () ++
+	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
 			  pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl ()
 
-let pp_structure_elem mp = function 
-  | (l,SEdecl d) -> pp_decl mp d
+let pp_structure_elem = function 
+  | (l,SEdecl d) -> pp_decl d
   | (l,SEmodule m) -> 
       failwith "TODO: Scheme extraction of modules not implemented yet"
   | (l,SEmodtype m) -> 
       failwith "TODO: Scheme extraction of modules not implemented yet"
 
 let pp_struct = 
-  prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel)
-
-let pp_signature s = assert false
-
-end
-
+  let pp_sel (mp,sel) = 
+    push_visible mp; 
+    let p = prlist_strict pp_structure_elem sel in 
+    pop_visible (); p
+  in
+  prlist_strict pp_sel
+
+let scheme_descr = {
+  keywords = keywords;  
+  file_suffix = ".scm"; 
+  capital_file = false;  
+  preamble = preamble; 
+  pp_struct = pp_struct; 
+  sig_suffix = None;
+  sig_preamble = (fun _ _ _ -> mt ()); 
+  pp_sig = (fun _ -> mt ()); 
+  pp_decl = pp_decl; 
+}
diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli
index ef4a3a63..a88bb6db 100644
--- a/contrib/extraction/scheme.mli
+++ b/contrib/extraction/scheme.mli
@@ -6,22 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
-
-(*s Some utility functions to be reused in module [Haskell]. *)
-
-open Pp
-open Miniml
-open Names
-
-val keywords : Idset.t
-
-val preamble : 
-  extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-module Make : functor(P : Mlpp_param) -> Mlpp
-
-
-
-
+(*i $Id: scheme.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
 
+val scheme_descr : Miniml.language_descr 
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
index 6d39faee..abf461c1 100644
--- a/contrib/extraction/table.ml
+++ b/contrib/extraction/table.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.ml 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: table.ml 10348 2007-12-06 17:36:14Z aspiwack $ i*)
 
 open Names
 open Term
@@ -20,37 +20,49 @@ open Util
 open Pp
 open Miniml
 
-(*S Utilities concerning [module_path] and [kernel_names] *)
+(*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
 
-let occur_kn_in_ref kn =
- function
+let occur_kn_in_ref kn = function
   | IndRef (kn',_)
   | ConstructRef ((kn',_),_) -> kn = kn'
   | ConstRef _ -> false
   | VarRef _ -> assert false
-
-let modpath_of_r r = match r with 
-    | ConstRef kn -> con_modpath kn
-    | IndRef (kn,_)
-    | ConstructRef ((kn,_),_) -> modpath kn
-    | VarRef _ -> assert false
-
-let label_of_r r = match r with 
-    | ConstRef kn -> con_label kn
-    | IndRef (kn,_)
-    | ConstructRef ((kn,_),_) -> label kn
-    | VarRef _ -> assert false
-
-let current_toplevel () = fst (Lib.current_prefix ())
+      
+let modpath_of_r = function 
+  | ConstRef kn -> con_modpath kn
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) -> modpath kn
+  | VarRef _ -> assert false
+      
+let label_of_r = function 
+  | ConstRef kn -> con_label kn
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) -> label kn
+  | VarRef _ -> assert false
 
 let rec base_mp = function 
   | MPdot (mp,l) -> base_mp mp 
   | mp -> mp 
 
+let rec mp_length = function
+  | MPdot (mp, _) -> 1 + (mp_length mp)
+  | _ -> 1
+
 let is_modfile = function 
   | MPfile _ -> true 
   | _ -> false
 
+let string_of_modfile = function 
+  | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f)))
+  | _ -> assert false
+
+let rec modfile_of_mp = function 
+  | (MPfile _) as mp -> mp
+  | MPdot (mp,_) -> modfile_of_mp mp 
+  | _ -> raise Not_found
+
+let current_toplevel () = fst (Lib.current_prefix ())
+
 let is_toplevel mp = 
   mp = initial_path || mp = current_toplevel ()
 
@@ -60,8 +72,56 @@ let at_toplevel mp =
 let visible_kn kn = at_toplevel (base_mp (modpath kn))
 let visible_con kn = at_toplevel (base_mp (con_modpath kn))
 
+let rec prefixes_mp mp = match mp with 
+  | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
+  | _ -> MPset.singleton mp 
+
+let rec get_nth_label_mp n mp = match mp with 
+  | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp 
+  | _ -> failwith "get_nth_label: not enough MPdot"
+
+let get_nth_label n r = 
+  if n=0 then label_of_r r else get_nth_label_mp n (modpath_of_r r)
+
+let rec common_prefix prefixes_mp1 mp2 = 
+  if MPset.mem mp2 prefixes_mp1 then mp2 
+  else match mp2 with 
+    | MPdot (mp,_) -> common_prefix prefixes_mp1 mp 
+    | _ -> raise Not_found
+
+let common_prefix_from_list mp0 mpl = 
+  let prefixes_mp0 = prefixes_mp mp0 in 
+  let rec f = function 
+    | [] -> raise Not_found
+    | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l
+  in f mpl
+
+let rec parse_labels ll = function 
+  | MPdot (mp,l) -> parse_labels (l::ll) mp 
+  | mp -> mp,ll
+
+let labels_of_mp mp = parse_labels [] mp 
+
+let labels_of_ref r = 
+ let mp,_,l =
+  match r with
+     ConstRef con -> repr_con con
+   | IndRef (kn,_)
+   | ConstructRef ((kn,_),_) -> repr_kn kn
+   | VarRef _ -> assert false
+ in
+  parse_labels [l] mp
+
+let rec add_labels_mp mp = function 
+  | [] -> mp 
+  | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
+
+
 (*S The main tables: constants, inductives, records, ... *)
 
+(* Theses tables are not registered within coq save/undo mechanism 
+   since we reset their contents at each run of Extraction *)
+
 (*s Constants tables. *) 
 
 let terms = ref (Cmap.empty : ml_decl Cmap.t)
@@ -109,11 +169,26 @@ let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs
 let is_projection r = Refmap.mem r !projs
 let projection_arity r = Refmap.find r !projs
 
+(*s Table of used axioms *)
+
+let info_axioms = ref Refset.empty
+let log_axioms = ref Refset.empty
+let init_axioms () = info_axioms := Refset.empty; log_axioms := Refset.empty
+let add_info_axiom r = info_axioms := Refset.add r !info_axioms
+let add_log_axiom r = log_axioms := Refset.add r !log_axioms
+
+(*s Extraction mode: modular or monolithic *)
+
+let modular_ref = ref false
+
+let set_modular b = modular_ref := b
+let modular () = !modular_ref
+
 (*s Tables synchronization. *)
 
 let reset_tables () = 
   init_terms (); init_types (); init_inductives (); init_recursors (); 
-  init_projs ()
+  init_projs (); init_axioms ()
 
 (*s Printing. *)
 
@@ -146,21 +221,34 @@ let pr_long_global r =
 
 let err s = errorlabstrm "Extraction" s
 
+let warning_axioms () = 
+  let info_axioms = Refset.elements !info_axioms in 
+  if info_axioms = [] then () 
+  else begin
+    let s = if List.length info_axioms = 1 then "axiom" else "axioms" in 
+    msg_warning 
+      (str ("The following "^s^" must be realized in the extracted code:")
+       ++ hov 1 (spc () ++ prlist_with_sep spc pr_global info_axioms) 
+       ++ str "." ++ fnl ())
+  end;
+  let log_axioms = Refset.elements !log_axioms in 
+  if log_axioms = [] then ()
+  else begin
+    let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" 
+    in 
+    msg_warning
+      (str ("The following logical "^s^" encountered:") ++
+       hov 1 (spc () ++ prlist_with_sep spc pr_global log_axioms ++ str ".\n") ++
+       str "Having invalid logical axiom in the environment when extracting" ++
+       spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
+       fnl ())
+  end
+
 let error_axiom_scheme r i = 
   err (str "The type scheme axiom " ++ spc () ++
        pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ 
        str " type variable(s).") 
 
-let warning_info_ax r =
-  msg_warning (str "You must realize axiom " ++
-		  pr_global r ++ str " in the extracted code.")
-
-let warning_log_ax r = 
-  msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ 
-		  pr_global r ++ str "." ++ spc() ++ 
-		  str "Having false logical axiom in the environment when extracting" ++ 
-		  spc () ++ str "may lead to incorrect or non-terminating ML terms.")
-
 let check_inside_module () = 
   if Lib.is_modtype () then 
     err (str "You can't do that within a Module Type." ++ fnl () ++
@@ -186,15 +274,11 @@ let error_nb_cons () =
 
 let error_module_clash s = 
   err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ 
-       str "This is not allowed in ML. Please do some renaming first.")
+       str "This is not supported yet. Please do some renaming first.") 
 
 let error_unknown_module m = 
   err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") 
 
-let error_toplevel () = 
-  err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++
-       str "You should use Extraction Language Ocaml or Haskell before.") 
-
 let error_scheme () = 
   err (str "No Scheme modular extraction available yet.")
 
@@ -203,9 +287,13 @@ let error_not_visible r =
        str "For example, it may be inside an applied functor." ++
        str "Use Recursive Extraction to get the whole environment.")
 
-let error_MPfile_as_mod d = 
-  err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^
-	    "Extraction cannot currently deal with this situation.\n"))
+let error_MPfile_as_mod mp b = 
+  let s1 = if b then "asked" else "required" in 
+  let s2 = if b then "extract some objects of this module or\n" else "" in
+  err (str ("Extraction of file "^(string_of_modfile mp)^
+	    ".v as a module is "^s1^".\n"^
+	    "Monolithic Extraction cannot deal with this situation.\n"^
+	    "Please "^s2^"use (Recursive) Extraction Library instead.\n"))
 
 let error_record r = 
   err (str "Record " ++ pr_global r ++ str " has an anonymous field." ++ fnl () ++
@@ -216,8 +304,16 @@ let check_loaded_modfile mp = match base_mp mp with
       err (str ("Please load library "^(string_of_dirpath dp^" first.")))
   | _ -> ()
 
+let info_file f =   
+  Flags.if_verbose message 
+    ("The file "^f^" has been created by extraction.")
+
+
 (*S The Extraction auxiliary commands *)
 
+(* The objects defined below should survive an arbitrary time, 
+   so we register them to coq save/undo mechanism. *)
+
 (*s Extraction AutoInline *)
 
 let auto_inline_ref = ref true
@@ -305,7 +401,7 @@ let _ = declare_int_option
 
 (*s Extraction Lang *)
 
-type lang = Ocaml | Haskell | Scheme | Toplevel
+type lang = Ocaml | Haskell | Scheme
 
 let lang_ref = ref Ocaml
 
@@ -327,7 +423,6 @@ let _ = declare_summary "Extraction Lang"
 	  
 let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
 
-
 (*s Extraction Inline/NoInline *)
 
 let empty_inline_table = (Refset.empty,Refset.empty)
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
index c9a4e8da..ca02cb4d 100644
--- a/contrib/extraction/table.mli
+++ b/contrib/extraction/table.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.mli 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: table.mli 10245 2007-10-21 13:41:53Z letouzey $ i*)
 
 open Names
 open Libnames
@@ -14,39 +14,49 @@ open Miniml
 open Declarations
 
 val id_of_global : global_reference -> identifier
+val pr_long_global : global_reference -> Pp.std_ppcmds
+
 
 (*s Warning and Error messages. *)
 
+val warning_axioms : unit -> unit
 val error_axiom_scheme : global_reference -> int -> 'a
-val warning_info_ax : global_reference -> unit
-val warning_log_ax : global_reference -> unit
 val error_constant : global_reference -> 'a
 val error_inductive : global_reference -> 'a
 val error_nb_cons : unit -> 'a
 val error_module_clash : string -> 'a 
 val error_unknown_module : qualid -> 'a
-val error_toplevel : unit -> 'a
 val error_scheme : unit -> 'a
 val error_not_visible : global_reference -> 'a
-val error_MPfile_as_mod : dir_path -> 'a
+val error_MPfile_as_mod : module_path -> bool -> 'a
 val error_record : global_reference -> 'a 
 val check_inside_module : unit -> unit
 val check_inside_section : unit -> unit
 val check_loaded_modfile : module_path -> unit
 
-(*s utilities concerning [module_path]. *)
+val info_file : string -> unit
+
+(*s utilities about [module_path] and [kernel_names] and [global_reference] *)
 
 val occur_kn_in_ref : kernel_name -> global_reference -> bool
 val modpath_of_r : global_reference -> module_path
 val label_of_r : global_reference -> label
-
 val current_toplevel : unit -> module_path
 val base_mp : module_path -> module_path
-val is_modfile : module_path -> bool 
+val is_modfile : module_path -> bool
+val string_of_modfile : module_path -> string 
 val is_toplevel : module_path -> bool
 val at_toplevel : module_path -> bool 
 val visible_kn : kernel_name -> bool
 val visible_con : constant -> bool
+val mp_length : module_path -> int
+val prefixes_mp : module_path -> MPset.t
+val modfile_of_mp : module_path -> module_path
+val common_prefix_from_list : module_path -> module_path list -> module_path
+val add_labels_mp : module_path -> label list -> module_path
+val get_nth_label_mp : int -> module_path -> label
+val get_nth_label : int -> global_reference -> label
+val labels_of_ref : global_reference -> module_path * label list
 
 (*s Some table-related operations *)
 
@@ -66,6 +76,9 @@ val add_projection : int -> constant -> unit
 val is_projection : global_reference -> bool 
 val projection_arity : global_reference -> int
 
+val add_info_axiom : global_reference -> unit
+val add_log_axiom : global_reference -> unit
+
 val reset_tables : unit -> unit
 
 (*s AutoInline parameter *) 
@@ -95,9 +108,14 @@ val optims :  unit -> opt_flag
 
 (*s Target language. *)
 
-type lang = Ocaml | Haskell | Scheme | Toplevel
+type lang = Ocaml | Haskell | Scheme
 val lang : unit -> lang 
 
+(*s Extraction mode: modular or monolithic *)
+
+val set_modular : bool -> unit
+val modular : unit -> bool 
+
 (*s Table for custom inlining *) 
 
 val to_inline : global_reference -> bool
diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend
deleted file mode 100644
index 31d46eeb..00000000
--- a/contrib/extraction/test/.depend
+++ /dev/null
@@ -1,1136 +0,0 @@
-theories/Arith/arith.cmo: theories/Arith/arith.cmi 
-theories/Arith/arith.cmx: theories/Arith/arith.cmi 
-theories/Arith/between.cmo: theories/Arith/between.cmi 
-theories/Arith/between.cmx: theories/Arith/between.cmi 
-theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
-    theories/Arith/bool_nat.cmi 
-theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/Arith/peano_dec.cmx \
-    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
-    theories/Arith/bool_nat.cmi 
-theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
-theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi 
-theories/Arith/compare.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
-    theories/Arith/compare.cmi 
-theories/Arith/compare.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
-    theories/Arith/compare.cmi 
-theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Arith/div2.cmi 
-theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Arith/div2.cmi 
-theories/Arith/eqNat.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Arith/eqNat.cmi 
-theories/Arith/eqNat.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Arith/eqNat.cmi 
-theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
-    theories/Arith/euclid.cmi 
-theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
-    theories/Arith/euclid.cmi 
-theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Arith/even.cmi 
-theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Arith/even.cmi 
-theories/Arith/factorial.cmo: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Arith/factorial.cmi 
-theories/Arith/factorial.cmx: theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Arith/factorial.cmi 
-theories/Arith/gt.cmo: theories/Arith/gt.cmi 
-theories/Arith/gt.cmx: theories/Arith/gt.cmi 
-theories/Arith/le.cmo: theories/Arith/le.cmi 
-theories/Arith/le.cmx: theories/Arith/le.cmi 
-theories/Arith/lt.cmo: theories/Arith/lt.cmi 
-theories/Arith/lt.cmx: theories/Arith/lt.cmi 
-theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Arith/max.cmi 
-theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Arith/max.cmi 
-theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Arith/min.cmi 
-theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Arith/min.cmi 
-theories/Arith/minus.cmo: theories/Arith/minus.cmi 
-theories/Arith/minus.cmx: theories/Arith/minus.cmi 
-theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \
-    theories/Arith/mult.cmi 
-theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \
-    theories/Arith/mult.cmi 
-theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi 
-theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi 
-theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Arith/plus.cmi 
-theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Arith/plus.cmi 
-theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \
-    theories/Arith/wf_nat.cmi 
-theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \
-    theories/Arith/wf_nat.cmi 
-theories/Bool/boolEq.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Bool/boolEq.cmi 
-theories/Bool/boolEq.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Bool/boolEq.cmi 
-theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Bool/bool.cmi 
-theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Bool/bool.cmi 
-theories/Bool/bvector.cmo: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
-    theories/Bool/bvector.cmi 
-theories/Bool/bvector.cmx: theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
-    theories/Bool/bvector.cmi 
-theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi 
-theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi 
-theories/Bool/ifProp.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Bool/ifProp.cmi 
-theories/Bool/ifProp.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Bool/ifProp.cmi 
-theories/Bool/sumbool.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Bool/sumbool.cmi 
-theories/Bool/sumbool.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Bool/sumbool.cmi 
-theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi 
-theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi 
-theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
-    theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi 
-theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \
-    theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi 
-theories/FSets/decidableType.cmo: theories/Init/specif.cmi \
-    theories/FSets/decidableType.cmi 
-theories/FSets/decidableType.cmx: theories/Init/specif.cmx \
-    theories/FSets/decidableType.cmi 
-theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/FSets/int.cmi theories/FSets/fMapList.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi 
-theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/FSets/int.cmx theories/FSets/fMapList.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi 
-theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi 
-theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi 
-theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fMapInterface.cmi 
-theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \
-    theories/Lists/list.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fMapInterface.cmi 
-theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
-    theories/IntMap/map.cmi theories/Lists/list.cmi \
-    theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi 
-theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \
-    theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \
-    theories/IntMap/map.cmx theories/Lists/list.cmx \
-    theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \
-    theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi 
-theories/FSets/fMapList.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fMapList.cmi 
-theories/FSets/fMapList.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fMapList.cmi 
-theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/FSets/fMapPositive.cmi 
-theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/FSets/fMapPositive.cmi 
-theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi 
-theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi 
-theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi 
-theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi 
-theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \
-    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fMapWeakInterface.cmi 
-theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \
-    theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fMapWeakInterface.cmi 
-theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi 
-theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/FSets/decidableType.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi 
-theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi 
-theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi 
-theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
-    theories/Init/peano.cmi theories/FSets/orderedType.cmi \
-    theories/Lists/list.cmi theories/FSets/int.cmi \
-    theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
-    theories/FSets/fSetAVL.cmi 
-theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
-    theories/Init/peano.cmx theories/FSets/orderedType.cmx \
-    theories/Lists/list.cmx theories/FSets/int.cmx \
-    theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \
-    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
-    theories/FSets/fSetAVL.cmi 
-theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fSetBridge.cmi 
-theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fSetBridge.cmi 
-theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/Init/peano.cmi \
-    theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
-    theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi 
-theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/Init/peano.cmx \
-    theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \
-    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
-    theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi 
-theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fSetFacts.cmi 
-theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
-    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fSetFacts.cmi 
-theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi 
-theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi 
-theories/FSets/fSetList.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fSetList.cmi 
-theories/FSets/fSetList.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fSetList.cmi 
-theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
-    theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \
-    theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fSetProperties.cmi 
-theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
-    theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \
-    theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fSetProperties.cmi 
-theories/FSets/fSets.cmo: theories/FSets/fSets.cmi 
-theories/FSets/fSets.cmx: theories/FSets/fSets.cmi 
-theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fSetToFiniteSet.cmi 
-theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \
-    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
-    theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fSetToFiniteSet.cmi 
-theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi 
-theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi 
-theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \
-    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
-    theories/FSets/fSetWeakInterface.cmi 
-theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \
-    theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
-    theories/FSets/fSetWeakInterface.cmi 
-theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi 
-theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/FSets/decidableType.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi 
-theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi 
-theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi 
-theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \
-    theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi 
-theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \
-    theories/Setoids/setoid.cmx theories/Lists/list.cmx \
-    theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \
-    theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi 
-theories/FSets/int.cmo: theories/ZArith/zmax.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
-    theories/FSets/int.cmi 
-theories/FSets/int.cmx: theories/ZArith/zmax.cmx \
-    theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
-    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
-    theories/FSets/int.cmi 
-theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
-    theories/FSets/orderedTypeAlt.cmi 
-theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
-    theories/FSets/orderedTypeAlt.cmi 
-theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
-    theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \
-    theories/FSets/orderedTypeEx.cmi 
-theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \
-    theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
-    theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \
-    theories/FSets/orderedTypeEx.cmi 
-theories/FSets/orderedType.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/FSets/orderedType.cmi 
-theories/FSets/orderedType.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/FSets/orderedType.cmi 
-theories/Init/datatypes.cmo: theories/Init/datatypes.cmi 
-theories/Init/datatypes.cmx: theories/Init/datatypes.cmi 
-theories/Init/logic.cmo: theories/Init/logic.cmi 
-theories/Init/logic.cmx: theories/Init/logic.cmi 
-theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi 
-theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi 
-theories/Init/notations.cmo: theories/Init/notations.cmi 
-theories/Init/notations.cmx: theories/Init/notations.cmi 
-theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi 
-theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi 
-theories/Init/prelude.cmo: theories/Init/prelude.cmi 
-theories/Init/prelude.cmx: theories/Init/prelude.cmi 
-theories/Init/specif.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Init/specif.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmi 
-theories/Init/tactics.cmo: theories/Init/tactics.cmi 
-theories/Init/tactics.cmx: theories/Init/tactics.cmi 
-theories/Init/wf.cmo: theories/Init/wf.cmi 
-theories/Init/wf.cmx: theories/Init/wf.cmi 
-theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi 
-theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi 
-theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi 
-theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi 
-theories/IntMap/fset.cmo: theories/Init/specif.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi theories/IntMap/fset.cmi 
-theories/IntMap/fset.cmx: theories/Init/specif.cmx \
-    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
-    theories/IntMap/map.cmx theories/Init/datatypes.cmx \
-    theories/NArith/binNat.cmx theories/IntMap/fset.cmi 
-theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi theories/IntMap/lsort.cmi 
-theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
-    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
-    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
-    theories/Lists/list.cmx theories/Init/datatypes.cmx \
-    theories/NArith/binNat.cmx theories/IntMap/lsort.cmi 
-theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi 
-theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi 
-theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi 
-theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \
-    theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi 
-theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Arith/plus.cmi \
-    theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi 
-theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/Arith/plus.cmx \
-    theories/Arith/peano_dec.cmx theories/Init/peano.cmx \
-    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
-    theories/IntMap/map.cmx theories/Init/datatypes.cmx \
-    theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi 
-theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi 
-theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi 
-theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/IntMap/fset.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/mapfold.cmi 
-theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \
-    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
-    theories/IntMap/fset.cmx theories/Init/datatypes.cmx \
-    theories/IntMap/mapfold.cmi 
-theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndigits.cmi \
-    theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binNat.cmi \
-    theories/IntMap/mapiter.cmi 
-theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/NArith/ndigits.cmx \
-    theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binNat.cmx \
-    theories/IntMap/mapiter.cmi 
-theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/Lists/list.cmi theories/IntMap/fset.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/maplists.cmi 
-theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/NArith/ndec.cmx \
-    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
-    theories/Lists/list.cmx theories/IntMap/fset.cmx \
-    theories/Init/datatypes.cmx theories/IntMap/maplists.cmi 
-theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/IntMap/map.cmi 
-theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmx theories/IntMap/map.cmi 
-theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \
-    theories/IntMap/map.cmi theories/IntMap/fset.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
-    theories/IntMap/mapsubset.cmi 
-theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \
-    theories/IntMap/map.cmx theories/IntMap/fset.cmx \
-    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
-    theories/IntMap/mapsubset.cmi 
-theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi 
-theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/Lists/list.cmi 
-theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/Lists/listSet.cmi 
-theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/Lists/listSet.cmi 
-theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/monoList.cmi 
-theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/monoList.cmi 
-theories/Lists/setoidList.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/Lists/setoidList.cmi 
-theories/Lists/setoidList.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/Init/datatypes.cmx \
-    theories/Lists/setoidList.cmi 
-theories/Lists/streams.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/streams.cmi 
-theories/Lists/streams.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/streams.cmi 
-theories/Lists/theoryList.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/Lists/theoryList.cmi 
-theories/Lists/theoryList.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/Init/datatypes.cmx \
-    theories/Lists/theoryList.cmi 
-theories/Logic/berardi.cmo: theories/Logic/berardi.cmi 
-theories/Logic/berardi.cmx: theories/Logic/berardi.cmi 
-theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi 
-theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi 
-theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi 
-theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi 
-theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \
-    theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi 
-theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \
-    theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi 
-theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \
-    theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi 
-theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \
-    theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi 
-theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi 
-theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi 
-theories/Logic/classical.cmo: theories/Logic/classical.cmi 
-theories/Logic/classical.cmx: theories/Logic/classical.cmi 
-theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi 
-theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi 
-theories/Logic/classical_Pred_Type.cmo: \
-    theories/Logic/classical_Pred_Type.cmi 
-theories/Logic/classical_Pred_Type.cmx: \
-    theories/Logic/classical_Pred_Type.cmi 
-theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \
-    theories/Logic/classical_Prop.cmi 
-theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \
-    theories/Logic/classical_Prop.cmi 
-theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi 
-theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi 
-theories/Logic/classicalUniqueChoice.cmo: \
-    theories/Logic/classicalUniqueChoice.cmi 
-theories/Logic/classicalUniqueChoice.cmx: \
-    theories/Logic/classicalUniqueChoice.cmi 
-theories/Logic/decidable.cmo: theories/Logic/decidable.cmi 
-theories/Logic/decidable.cmx: theories/Logic/decidable.cmi 
-theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \
-    theories/Logic/diaconescu.cmi 
-theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \
-    theories/Logic/diaconescu.cmi 
-theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \
-    theories/Logic/eqdep_dec.cmi 
-theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \
-    theories/Logic/eqdep_dec.cmi 
-theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi 
-theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi 
-theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \
-    theories/Logic/eqdep.cmi 
-theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \
-    theories/Logic/eqdep.cmi 
-theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi 
-theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi 
-theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi 
-theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi 
-theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \
-    theories/Logic/proofIrrelevanceFacts.cmi 
-theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \
-    theories/Logic/proofIrrelevanceFacts.cmi 
-theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \
-    theories/Logic/proofIrrelevance.cmi 
-theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \
-    theories/Logic/proofIrrelevance.cmi 
-theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi 
-theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi 
-theories/NArith/binNat.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi 
-theories/NArith/binNat.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmi 
-theories/NArith/binPos.cmo: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
-theories/NArith/binPos.cmx: theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmi 
-theories/NArith/nArith.cmo: theories/NArith/nArith.cmi 
-theories/NArith/nArith.cmx: theories/NArith/nArith.cmi 
-theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
-    theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
-    theories/NArith/ndec.cmi 
-theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
-    theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \
-    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
-    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
-    theories/NArith/ndec.cmi 
-theories/NArith/ndigits.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
-    theories/Bool/bool.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/NArith/ndigits.cmi 
-theories/NArith/ndigits.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
-    theories/Bool/bool.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmx theories/NArith/ndigits.cmi 
-theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/NArith/ndist.cmi 
-theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/NArith/binNat.cmx theories/NArith/ndist.cmi 
-theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
-    theories/NArith/nnat.cmi 
-theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \
-    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
-    theories/NArith/nnat.cmi 
-theories/NArith/pnat.cmo: theories/NArith/pnat.cmi 
-theories/NArith/pnat.cmx: theories/NArith/pnat.cmi 
-theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \
-    theories/Init/specif.cmi theories/Setoids/setoid.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi 
-theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \
-    theories/Init/specif.cmx theories/Setoids/setoid.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi 
-theories/QArith/qArith.cmo: theories/QArith/qArith.cmi 
-theories/QArith/qArith.cmx: theories/QArith/qArith.cmi 
-theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \
-    theories/ZArith/binInt.cmi theories/QArith/qreals.cmi 
-theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \
-    theories/ZArith/binInt.cmx theories/QArith/qreals.cmi 
-theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \
-    theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi 
-theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \
-    theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi 
-theories/QArith/qring.cmo: theories/Init/specif.cmi \
-    theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \
-    theories/QArith/qring.cmi 
-theories/QArith/qring.cmx: theories/Init/specif.cmx \
-    theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \
-    theories/QArith/qring.cmi 
-theories/Relations/newman.cmo: theories/Relations/newman.cmi 
-theories/Relations/newman.cmx: theories/Relations/newman.cmi 
-theories/Relations/operators_Properties.cmo: \
-    theories/Relations/operators_Properties.cmi 
-theories/Relations/operators_Properties.cmx: \
-    theories/Relations/operators_Properties.cmi 
-theories/Relations/relation_Definitions.cmo: \
-    theories/Relations/relation_Definitions.cmi 
-theories/Relations/relation_Definitions.cmx: \
-    theories/Relations/relation_Definitions.cmi 
-theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Relations/relation_Operators.cmi 
-theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/Relations/relation_Operators.cmi 
-theories/Relations/relations.cmo: theories/Relations/relations.cmi 
-theories/Relations/relations.cmx: theories/Relations/relations.cmi 
-theories/Relations/rstar.cmo: theories/Relations/rstar.cmi 
-theories/Relations/rstar.cmx: theories/Relations/rstar.cmi 
-theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \
-    theories/Setoids/setoid.cmi 
-theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \
-    theories/Setoids/setoid.cmi 
-theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi 
-theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi 
-theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi 
-theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi 
-theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi 
-theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi 
-theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi 
-theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi 
-theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi 
-theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi 
-theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi 
-theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi 
-theories/Sets/image.cmo: theories/Sets/image.cmi 
-theories/Sets/image.cmx: theories/Sets/image.cmi 
-theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi 
-theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi 
-theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \
-    theories/Init/datatypes.cmi theories/Sets/integers.cmi 
-theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \
-    theories/Init/datatypes.cmx theories/Sets/integers.cmi 
-theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Sets/multiset.cmi 
-theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Sets/multiset.cmi 
-theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \
-    theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi 
-theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \
-    theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi 
-theories/Sets/permut.cmo: theories/Sets/permut.cmi 
-theories/Sets/permut.cmx: theories/Sets/permut.cmi 
-theories/Sets/powerset_Classical_facts.cmo: \
-    theories/Sets/powerset_Classical_facts.cmi 
-theories/Sets/powerset_Classical_facts.cmx: \
-    theories/Sets/powerset_Classical_facts.cmi 
-theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi 
-theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi 
-theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \
-    theories/Sets/ensembles.cmi theories/Sets/powerset.cmi 
-theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \
-    theories/Sets/ensembles.cmx theories/Sets/powerset.cmi 
-theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi 
-theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi 
-theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi 
-theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi 
-theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi 
-theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi 
-theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi 
-theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi 
-theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi 
-theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi 
-theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi 
-theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi 
-theories/Sets/uniset.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Sets/uniset.cmi 
-theories/Sets/uniset.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Sets/uniset.cmi 
-theories/Sorting/heap.cmo: theories/Init/specif.cmi \
-    theories/Sorting/sorting.cmi theories/Init/peano.cmi \
-    theories/Sets/multiset.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/Sorting/heap.cmi 
-theories/Sorting/heap.cmx: theories/Init/specif.cmx \
-    theories/Sorting/sorting.cmx theories/Init/peano.cmx \
-    theories/Sets/multiset.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/Sorting/heap.cmi 
-theories/Sorting/permutation.cmo: theories/Init/specif.cmi \
-    theories/Init/peano.cmi theories/Sets/multiset.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/Sorting/permutation.cmi 
-theories/Sorting/permutation.cmx: theories/Init/specif.cmx \
-    theories/Init/peano.cmx theories/Sets/multiset.cmx \
-    theories/Lists/list.cmx theories/Init/datatypes.cmx \
-    theories/Sorting/permutation.cmi 
-theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi 
-theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi 
-theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi 
-theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi 
-theories/Sorting/sorting.cmo: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Sorting/sorting.cmi 
-theories/Sorting/sorting.cmx: theories/Init/specif.cmx \
-    theories/Lists/list.cmx theories/Sorting/sorting.cmi 
-theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
-    theories/NArith/binPos.cmi theories/Strings/ascii.cmi 
-theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
-    theories/NArith/binPos.cmx theories/Strings/ascii.cmi 
-theories/Strings/string.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Strings/ascii.cmi \
-    theories/Strings/string.cmi 
-theories/Strings/string.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/Strings/ascii.cmx \
-    theories/Strings/string.cmi 
-theories/Wellfounded/disjoint_Union.cmo: \
-    theories/Wellfounded/disjoint_Union.cmi 
-theories/Wellfounded/disjoint_Union.cmx: \
-    theories/Wellfounded/disjoint_Union.cmi 
-theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi 
-theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi 
-theories/Wellfounded/inverse_Image.cmo: \
-    theories/Wellfounded/inverse_Image.cmi 
-theories/Wellfounded/inverse_Image.cmx: \
-    theories/Wellfounded/inverse_Image.cmi 
-theories/Wellfounded/lexicographic_Exponentiation.cmo: \
-    theories/Wellfounded/lexicographic_Exponentiation.cmi 
-theories/Wellfounded/lexicographic_Exponentiation.cmx: \
-    theories/Wellfounded/lexicographic_Exponentiation.cmi 
-theories/Wellfounded/lexicographic_Product.cmo: \
-    theories/Wellfounded/lexicographic_Product.cmi 
-theories/Wellfounded/lexicographic_Product.cmx: \
-    theories/Wellfounded/lexicographic_Product.cmi 
-theories/Wellfounded/transitive_Closure.cmo: \
-    theories/Wellfounded/transitive_Closure.cmi 
-theories/Wellfounded/transitive_Closure.cmx: \
-    theories/Wellfounded/transitive_Closure.cmi 
-theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi 
-theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi 
-theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi 
-theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi 
-theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \
-    theories/Wellfounded/well_Ordering.cmi 
-theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \
-    theories/Wellfounded/well_Ordering.cmi 
-theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi 
-theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi 
-theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \
-    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi 
-theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi 
-theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \
-    theories/ZArith/zabs.cmi 
-theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \
-    theories/ZArith/zabs.cmi 
-theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi 
-theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi 
-theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi 
-theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi 
-theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi 
-theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi 
-theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
-    theories/ZArith/zbinary.cmi 
-theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \
-    theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
-    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
-    theories/ZArith/zbinary.cmi 
-theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi 
-theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \
-    theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \
-    theories/Init/specif.cmx theories/Init/datatypes.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi 
-theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi 
-theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi 
-theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \
-    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi 
-theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \
-    theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi 
-theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi 
-theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \
-    theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi 
-theories/ZArith/zeven.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi 
-theories/ZArith/zeven.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi 
-theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi 
-theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi 
-theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi 
-theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi 
-theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi 
-theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi 
-theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi 
-theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi 
-theories/ZArith/zmin.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
-    theories/ZArith/zmin.cmi 
-theories/ZArith/zmin.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
-    theories/ZArith/zmin.cmi 
-theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
-    theories/ZArith/zmisc.cmi 
-theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \
-    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
-    theories/ZArith/zmisc.cmi 
-theories/ZArith/znat.cmo: theories/ZArith/znat.cmi 
-theories/ZArith/znat.cmx: theories/ZArith/znat.cmi 
-theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \
-    theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi 
-theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \
-    theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \
-    theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi 
-theories/ZArith/zorder.cmo: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
-    theories/ZArith/zorder.cmi 
-theories/ZArith/zorder.cmx: theories/Init/specif.cmx \
-    theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
-    theories/ZArith/zorder.cmi 
-theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi 
-theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi 
-theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \
-    theories/Init/specif.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi 
-theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \
-    theories/Init/specif.cmx theories/NArith/binPos.cmx \
-    theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi 
-theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi 
-theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi 
-theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
-theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Arith/compare.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
-theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi 
-theories/Arith/eqNat.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
-theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Arith/factorial.cmi: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi 
-theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi 
-theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi 
-theories/Bool/boolEq.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Bool/bvector.cmi: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi 
-theories/Bool/decBool.cmi: theories/Init/specif.cmi 
-theories/Bool/ifProp.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Bool/sumbool.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Bool/zerob.cmi: theories/Init/datatypes.cmi 
-theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/decidableType.cmi: theories/Init/specif.cmi 
-theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/FSets/int.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
-theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \
-    theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi 
-theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi 
-theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
-    theories/IntMap/map.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
-theories/FSets/fMapList.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
-theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \
-    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi 
-theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
-    theories/Init/peano.cmi theories/FSets/orderedType.cmi \
-    theories/Lists/list.cmi theories/FSets/int.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi 
-theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/Init/peano.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
-    theories/Bool/bool.cmi 
-theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetList.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi 
-theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
-    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \
-    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi 
-theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
-    theories/Init/datatypes.cmi 
-theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \
-    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
-    theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi 
-theories/FSets/int.cmi: theories/ZArith/zmax.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
-theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi 
-theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \
-    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
-    theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi theories/ZArith/binInt.cmi 
-theories/FSets/orderedType.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Init/peano.cmi: theories/Init/datatypes.cmi 
-theories/Init/specif.cmi: theories/Init/datatypes.cmi 
-theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi 
-theories/IntMap/fset.cmi: theories/Init/specif.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi 
-theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi 
-theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \
-    theories/IntMap/map.cmi 
-theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Arith/plus.cmi \
-    theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
-    theories/NArith/binNat.cmi 
-theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/IntMap/fset.cmi theories/Init/datatypes.cmi 
-theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndigits.cmi \
-    theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
-theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/NArith/ndec.cmi \
-    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
-    theories/Lists/list.cmi theories/IntMap/fset.cmi \
-    theories/Init/datatypes.cmi 
-theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi 
-theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \
-    theories/IntMap/map.cmi theories/IntMap/fset.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi 
-theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
-theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/Lists/monoList.cmi: theories/Init/datatypes.cmi 
-theories/Lists/setoidList.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi 
-theories/Lists/streams.cmi: theories/Init/datatypes.cmi 
-theories/Lists/theoryList.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi 
-theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \
-    theories/Logic/choiceFacts.cmi 
-theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \
-    theories/Logic/choiceFacts.cmi 
-theories/Logic/diaconescu.cmi: theories/Init/specif.cmi 
-theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi 
-theories/NArith/binNat.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
-theories/NArith/binPos.cmi: theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi 
-theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
-    theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
-    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
-theories/NArith/ndigits.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
-    theories/Bool/bool.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi 
-theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/NArith/binNat.cmi 
-theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
-theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \
-    theories/Init/specif.cmi theories/Setoids/setoid.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \
-    theories/ZArith/binInt.cmi 
-theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \
-    theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/QArith/qring.cmi: theories/Init/specif.cmi \
-    theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi 
-theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi 
-theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi 
-theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi 
-theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \
-    theories/Init/datatypes.cmi 
-theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi 
-theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \
-    theories/Sets/ensembles.cmi 
-theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \
-    theories/Sets/ensembles.cmi 
-theories/Sets/uniset.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi 
-theories/Sorting/heap.cmi: theories/Init/specif.cmi \
-    theories/Sorting/sorting.cmi theories/Init/peano.cmi \
-    theories/Sets/multiset.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi 
-theories/Sorting/permutation.cmi: theories/Init/specif.cmi \
-    theories/Init/peano.cmi theories/Sets/multiset.cmi \
-    theories/Lists/list.cmi theories/Init/datatypes.cmi 
-theories/Sorting/sorting.cmi: theories/Init/specif.cmi \
-    theories/Lists/list.cmi 
-theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
-    theories/NArith/binPos.cmi 
-theories/Strings/string.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/Strings/ascii.cmi 
-theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi 
-theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
-theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi 
-theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \
-    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
-theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
-    theories/Init/specif.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \
-    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \
-    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zeven.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zmin.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi 
-theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
-theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \
-    theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zorder.cmi: theories/Init/specif.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi 
-theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
-theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \
-    theories/Init/specif.cmi theories/NArith/binPos.cmi \
-    theories/ZArith/binInt.cmi 
diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile
deleted file mode 100644
index 65a54090..00000000
--- a/contrib/extraction/test/Makefile
+++ /dev/null
@@ -1,109 +0,0 @@
-# 
-#	General variables
-#
-
-TOPDIR=../../..
-
-# Files with axioms to be realized: can't be extracted directly
-
-AXIOMSVO:= \
-theories/Reals/% \
-theories/Num/%
-
-DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*))
-
-INCL:= $(patsubst %,-I %,$(DIRS))
-
-VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
-
-VO:= $(filter-out $(AXIOMSVO),$(VO))
-
-ML:= $(shell test -x v2ml && ./v2ml $(VO))
-
-MLI:= $(patsubst %.ml,%.mli,$(ML))
-
-CMO:= $(patsubst %.ml,%.cmo,$(ML))
-
-OSTDLIB:=$(shell (ocamlc -where))
-
-#
-#	General rules 
-#
-
-all: v2ml ml $(MLI) $(CMO)
-
-ml: $(ML)
-
-depend: #$(ML)
-	rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend
-
-tree:
-	mkdir -p $(DIRS)
-	cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories
-
-#%.mli:%.ml
-#	./make_mli $< > $@
-
-%.cmi:%.mli
-	ocamlc -c $(INCL) -nostdlib $<
-
-%.cmo:%.ml
-	ocamlc -c $(INCL) -nostdlib $<
-
-$(ML): ml2v
-	./extract $@
-
-clean: 
-	rm -f theories/*/*.ml* theories/*/*.cm*
-
-
-#
-#	Utilities
-#
-
-open: 
-	find theories -name "*".ml -exec ./qualify2open \{\} \;
-
-undo_open: 
-	find theories -name "*".ml -exec mv \{\}.orig \{\} \;
-
-ml2v: ml2v.ml
-	ocamlopt -o $@ $<
-
-v2ml: v2ml.ml
-	ocamlopt -o $@ $< 
-	$(MAKE)
-
-#
-#	Extraction of Reals
-#
-
-
-REALSAXIOMSVO:=theories/Reals/Rsyntax.vo
-
-REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo)
-REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO))
-REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO))
-REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML))
-
-reals: all realsml theories/Reals/addReals.cmo $(REALSCMO)
-
-realsml: $(REALSML)
-
-theories/Reals/addReals.ml: 
-	cp -f addReals theories/Reals/addReals.ml
-
-$(REALSML): 
-	./extract $@
-
-
-#
-#	The End
-#
-
-.PHONY: all tree clean reals realsml depend
-
-include .depend
-
-
-
diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell
deleted file mode 100644
index 6e1e15d1..00000000
--- a/contrib/extraction/test/Makefile.haskell
+++ /dev/null
@@ -1,416 +0,0 @@
-# 
-#	General variables
-#
-
-TOPDIR=../../..
-
-# Files with axioms to be realized: can't be extracted directly
-
-AXIOMSVO:= \
-theories/Init/Prelude.vo \
-theories/Reals/% \
-theories/Num/%
-
-DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
-
-INCL:= $(patsubst %,-i%,$(DIRS))
-
-VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
-
-VO:= $(filter-out $(AXIOMSVO),$(VO))
-
-HS:= $(shell test -x v2hs && ./v2hs $(VO))
-
-O:= $(patsubst %.hs,%.o,$(HS))
-
-#
-#	General rules 
-#
-
-all: v2hs hs $(O)
-
-hs: $(HS)
-
-tree:
-	mkdir -p $(DIRS)
-
-%.o:%.hs
-	ghc $(INCL) -c $<
-
-$(HS): hs2v
-	./extract.haskell $@
-
-clean: 
-	rm -f theories/*/*.h* theories/*/*.o
-
-
-#
-#	Utilities
-#
-
-hs2v: hs2v.ml
-	ocamlc -o $@ $<
-
-v2hs: v2hs.ml
-	ocamlc -o $@ $< 
-	$(MAKE) -f Makefile.haskell
-
-
-#
-#	The End
-#
-
-.PHONY: all tree clean depend
-
-# DO NOT DELETE: Beginning of Haskell dependencies
-theories/Arith/Between.o : theories/Arith/Between.hs
-theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs
-theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o
-theories/Arith/Bool_nat.o : theories/Init/Specif.o
-theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o
-theories/Arith/Bool_nat.o : theories/Init/Datatypes.o
-theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o
-theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs
-theories/Arith/Compare_dec.o : theories/Init/Specif.o
-theories/Arith/Compare_dec.o : theories/Init/Logic.o
-theories/Arith/Compare_dec.o : theories/Init/Datatypes.o
-theories/Arith/Compare.o : theories/Arith/Compare.hs
-theories/Arith/Compare.o : theories/Init/Specif.o
-theories/Arith/Compare.o : theories/Init/Datatypes.o
-theories/Arith/Compare.o : theories/Arith/Compare_dec.o
-theories/Arith/Div2.o : theories/Arith/Div2.hs
-theories/Arith/Div2.o : theories/Init/Specif.o
-theories/Arith/Div2.o : theories/Init/Peano.o
-theories/Arith/Div2.o : theories/Init/Datatypes.o
-theories/Arith/EqNat.o : theories/Arith/EqNat.hs
-theories/Arith/EqNat.o : theories/Init/Specif.o
-theories/Arith/EqNat.o : theories/Init/Datatypes.o
-theories/Arith/Euclid.o : theories/Arith/Euclid.hs
-theories/Arith/Euclid.o : theories/Arith/Wf_nat.o
-theories/Arith/Euclid.o : theories/Init/Specif.o
-theories/Arith/Euclid.o : theories/Arith/Minus.o
-theories/Arith/Euclid.o : theories/Init/Datatypes.o
-theories/Arith/Euclid.o : theories/Arith/Compare_dec.o
-theories/Arith/Even.o : theories/Arith/Even.hs
-theories/Arith/Even.o : theories/Init/Specif.o
-theories/Arith/Even.o : theories/Init/Datatypes.o
-theories/Arith/Gt.o : theories/Arith/Gt.hs
-theories/Arith/Le.o : theories/Arith/Le.hs
-theories/Arith/Lt.o : theories/Arith/Lt.hs
-theories/Arith/Max.o : theories/Arith/Max.hs
-theories/Arith/Max.o : theories/Init/Specif.o
-theories/Arith/Max.o : theories/Init/Logic.o
-theories/Arith/Max.o : theories/Init/Datatypes.o
-theories/Arith/Min.o : theories/Arith/Min.hs
-theories/Arith/Min.o : theories/Init/Specif.o
-theories/Arith/Min.o : theories/Init/Logic.o
-theories/Arith/Min.o : theories/Init/Datatypes.o
-theories/Arith/Minus.o : theories/Arith/Minus.hs
-theories/Arith/Minus.o : theories/Init/Datatypes.o
-theories/Arith/Mult.o : theories/Arith/Mult.hs
-theories/Arith/Mult.o : theories/Arith/Plus.o
-theories/Arith/Mult.o : theories/Init/Datatypes.o
-theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs
-theories/Arith/Peano_dec.o : theories/Init/Specif.o
-theories/Arith/Peano_dec.o : theories/Init/Datatypes.o
-theories/Arith/Plus.o : theories/Arith/Plus.hs
-theories/Arith/Plus.o : theories/Init/Specif.o
-theories/Arith/Plus.o : theories/Init/Logic.o
-theories/Arith/Plus.o : theories/Init/Datatypes.o
-theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs
-theories/Arith/Wf_nat.o : theories/Init/Wf.o
-theories/Arith/Wf_nat.o : theories/Init/Logic.o
-theories/Arith/Wf_nat.o : theories/Init/Datatypes.o
-theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs
-theories/Bool/BoolEq.o : theories/Init/Specif.o
-theories/Bool/BoolEq.o : theories/Init/Datatypes.o
-theories/Bool/Bool.o : theories/Bool/Bool.hs
-theories/Bool/Bool.o : theories/Init/Specif.o
-theories/Bool/Bool.o : theories/Init/Datatypes.o
-theories/Bool/DecBool.o : theories/Bool/DecBool.hs
-theories/Bool/DecBool.o : theories/Init/Specif.o
-theories/Bool/IfProp.o : theories/Bool/IfProp.hs
-theories/Bool/IfProp.o : theories/Init/Specif.o
-theories/Bool/IfProp.o : theories/Init/Datatypes.o
-theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs
-theories/Bool/Sumbool.o : theories/Init/Specif.o
-theories/Bool/Sumbool.o : theories/Init/Datatypes.o
-theories/Bool/Zerob.o : theories/Bool/Zerob.hs
-theories/Bool/Zerob.o : theories/Init/Datatypes.o
-theories/Init/Datatypes.o : theories/Init/Datatypes.hs
-theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs
-theories/Init/Logic.o : theories/Init/Logic.hs
-theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs
-theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs
-theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs
-theories/Init/Peano.o : theories/Init/Peano.hs
-theories/Init/Peano.o : theories/Init/Datatypes.o
-theories/Init/Specif.o : theories/Init/Specif.hs
-theories/Init/Specif.o : theories/Init/Logic.o
-theories/Init/Specif.o : theories/Init/Datatypes.o
-theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs
-theories/Init/Wf.o : theories/Init/Wf.hs
-theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs
-theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o
-theories/IntMap/Adalloc.o : theories/Init/Specif.o
-theories/IntMap/Adalloc.o : theories/IntMap/Map.o
-theories/IntMap/Adalloc.o : theories/Init/Logic.o
-theories/IntMap/Adalloc.o : theories/Init/Datatypes.o
-theories/IntMap/Adalloc.o : theories/IntMap/Addr.o
-theories/IntMap/Adalloc.o : theories/IntMap/Addec.o
-theories/IntMap/Addec.o : theories/IntMap/Addec.hs
-theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Addec.o : theories/Bool/Sumbool.o
-theories/IntMap/Addec.o : theories/Init/Specif.o
-theories/IntMap/Addec.o : theories/Init/Datatypes.o
-theories/IntMap/Addec.o : theories/IntMap/Addr.o
-theories/IntMap/Addr.o : theories/IntMap/Addr.hs
-theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Addr.o : theories/Init/Specif.o
-theories/IntMap/Addr.o : theories/Init/Datatypes.o
-theories/IntMap/Addr.o : theories/Bool/Bool.o
-theories/IntMap/Adist.o : theories/IntMap/Adist.hs
-theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Adist.o : theories/Arith/Min.o
-theories/IntMap/Adist.o : theories/Init/Datatypes.o
-theories/IntMap/Adist.o : theories/IntMap/Addr.o
-theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs
-theories/IntMap/Fset.o : theories/IntMap/Fset.hs
-theories/IntMap/Fset.o : theories/Init/Specif.o
-theories/IntMap/Fset.o : theories/IntMap/Map.o
-theories/IntMap/Fset.o : theories/Init/Logic.o
-theories/IntMap/Fset.o : theories/Init/Datatypes.o
-theories/IntMap/Fset.o : theories/IntMap/Addr.o
-theories/IntMap/Fset.o : theories/IntMap/Addec.o
-theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs
-theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Lsort.o : theories/Bool/Sumbool.o
-theories/IntMap/Lsort.o : theories/Init/Specif.o
-theories/IntMap/Lsort.o : theories/Lists/PolyList.o
-theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o
-theories/IntMap/Lsort.o : theories/IntMap/Map.o
-theories/IntMap/Lsort.o : theories/Init/Logic.o
-theories/IntMap/Lsort.o : theories/Init/Datatypes.o
-theories/IntMap/Lsort.o : theories/Bool/Bool.o
-theories/IntMap/Lsort.o : theories/IntMap/Addr.o
-theories/IntMap/Lsort.o : theories/IntMap/Addec.o
-theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs
-theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs
-theories/IntMap/Mapcanon.o : theories/Init/Specif.o
-theories/IntMap/Mapcanon.o : theories/IntMap/Map.o
-theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs
-theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o
-theories/IntMap/Mapcard.o : theories/Init/Specif.o
-theories/IntMap/Mapcard.o : theories/Arith/Plus.o
-theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o
-theories/IntMap/Mapcard.o : theories/Init/Peano.o
-theories/IntMap/Mapcard.o : theories/IntMap/Map.o
-theories/IntMap/Mapcard.o : theories/Init/Logic.o
-theories/IntMap/Mapcard.o : theories/Init/Datatypes.o
-theories/IntMap/Mapcard.o : theories/IntMap/Addr.o
-theories/IntMap/Mapcard.o : theories/IntMap/Addec.o
-theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs
-theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs
-theories/IntMap/Mapfold.o : theories/Init/Specif.o
-theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o
-theories/IntMap/Mapfold.o : theories/IntMap/Map.o
-theories/IntMap/Mapfold.o : theories/Init/Logic.o
-theories/IntMap/Mapfold.o : theories/IntMap/Fset.o
-theories/IntMap/Mapfold.o : theories/Init/Datatypes.o
-theories/IntMap/Mapfold.o : theories/IntMap/Addr.o
-theories/IntMap/Map.o : theories/IntMap/Map.hs
-theories/IntMap/Map.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Map.o : theories/Init/Specif.o
-theories/IntMap/Map.o : theories/Init/Peano.o
-theories/IntMap/Map.o : theories/Init/Datatypes.o
-theories/IntMap/Map.o : theories/IntMap/Addr.o
-theories/IntMap/Map.o : theories/IntMap/Addec.o
-theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs
-theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o
-theories/IntMap/Mapiter.o : theories/Init/Specif.o
-theories/IntMap/Mapiter.o : theories/Lists/PolyList.o
-theories/IntMap/Mapiter.o : theories/IntMap/Map.o
-theories/IntMap/Mapiter.o : theories/Init/Logic.o
-theories/IntMap/Mapiter.o : theories/Init/Datatypes.o
-theories/IntMap/Mapiter.o : theories/IntMap/Addr.o
-theories/IntMap/Mapiter.o : theories/IntMap/Addec.o
-theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs
-theories/IntMap/Maplists.o : theories/Bool/Sumbool.o
-theories/IntMap/Maplists.o : theories/Init/Specif.o
-theories/IntMap/Maplists.o : theories/Lists/PolyList.o
-theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o
-theories/IntMap/Maplists.o : theories/IntMap/Map.o
-theories/IntMap/Maplists.o : theories/Init/Logic.o
-theories/IntMap/Maplists.o : theories/IntMap/Fset.o
-theories/IntMap/Maplists.o : theories/Init/Datatypes.o
-theories/IntMap/Maplists.o : theories/Bool/Bool.o
-theories/IntMap/Maplists.o : theories/IntMap/Addr.o
-theories/IntMap/Maplists.o : theories/IntMap/Addec.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs
-theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Map.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o
-theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o
-theories/IntMap/Mapsubset.o : theories/Bool/Bool.o
-theories/Lists/ListSet.o : theories/Lists/ListSet.hs
-theories/Lists/ListSet.o : theories/Init/Specif.o
-theories/Lists/ListSet.o : theories/Lists/PolyList.o
-theories/Lists/ListSet.o : theories/Init/Logic.o
-theories/Lists/ListSet.o : theories/Init/Datatypes.o
-theories/Lists/PolyList.o : theories/Lists/PolyList.hs
-theories/Lists/PolyList.o : theories/Init/Specif.o
-theories/Lists/PolyList.o : theories/Init/Datatypes.o
-theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs
-theories/Lists/Streams.o : theories/Lists/Streams.hs
-theories/Lists/Streams.o : theories/Init/Datatypes.o
-theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs
-theories/Lists/TheoryList.o : theories/Init/Specif.o
-theories/Lists/TheoryList.o : theories/Lists/PolyList.o
-theories/Lists/TheoryList.o : theories/Bool/DecBool.o
-theories/Lists/TheoryList.o : theories/Init/Datatypes.o
-theories/Logic/Berardi.o : theories/Logic/Berardi.hs
-theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs
-theories/Logic/Classical.o : theories/Logic/Classical.hs
-theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs
-theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs
-theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs
-theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs
-theories/Logic/Decidable.o : theories/Logic/Decidable.hs
-theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs
-theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs
-theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs
-theories/Logic/JMeq.o : theories/Logic/JMeq.hs
-theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs
-theories/Relations/Newman.o : theories/Relations/Newman.hs
-theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs
-theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs
-theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs
-theories/Relations/Relation_Operators.o : theories/Init/Specif.o
-theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o
-theories/Relations/Relations.o : theories/Relations/Relations.hs
-theories/Relations/Rstar.o : theories/Relations/Rstar.hs
-theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs
-theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs
-theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs
-theories/Sets/Cpo.o : theories/Sets/Cpo.hs
-theories/Sets/Cpo.o : theories/Sets/Partial_Order.o
-theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs
-theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs
-theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs
-theories/Sets/Image.o : theories/Sets/Image.hs
-theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs
-theories/Sets/Integers.o : theories/Sets/Integers.hs
-theories/Sets/Integers.o : theories/Sets/Partial_Order.o
-theories/Sets/Integers.o : theories/Init/Datatypes.o
-theories/Sets/Multiset.o : theories/Sets/Multiset.hs
-theories/Sets/Multiset.o : theories/Init/Specif.o
-theories/Sets/Multiset.o : theories/Init/Peano.o
-theories/Sets/Multiset.o : theories/Init/Datatypes.o
-theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs
-theories/Sets/Permut.o : theories/Sets/Permut.hs
-theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs
-theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs
-theories/Sets/Powerset.o : theories/Sets/Powerset.hs
-theories/Sets/Powerset.o : theories/Sets/Partial_Order.o
-theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs
-theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs
-theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs
-theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs
-theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs
-theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs
-theories/Sets/Uniset.o : theories/Sets/Uniset.hs
-theories/Sets/Uniset.o : theories/Init/Specif.o
-theories/Sets/Uniset.o : theories/Init/Datatypes.o
-theories/Sets/Uniset.o : theories/Bool/Bool.o
-theories/Sorting/Heap.o : theories/Sorting/Heap.hs
-theories/Sorting/Heap.o : theories/Init/Specif.o
-theories/Sorting/Heap.o : theories/Sorting/Sorting.o
-theories/Sorting/Heap.o : theories/Lists/PolyList.o
-theories/Sorting/Heap.o : theories/Sets/Multiset.o
-theories/Sorting/Heap.o : theories/Init/Logic.o
-theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs
-theories/Sorting/Permutation.o : theories/Init/Specif.o
-theories/Sorting/Permutation.o : theories/Lists/PolyList.o
-theories/Sorting/Permutation.o : theories/Sets/Multiset.o
-theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs
-theories/Sorting/Sorting.o : theories/Init/Specif.o
-theories/Sorting/Sorting.o : theories/Lists/PolyList.o
-theories/Sorting/Sorting.o : theories/Init/Logic.o
-theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs
-theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs
-theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs
-theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs
-theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs
-theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs
-theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs
-theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs
-theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs
-theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o
-theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o
-theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs
-theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs
-theories/ZArith/Fast_integer.o : theories/Init/Peano.o
-theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o
-theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs
-theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Wf_Z.o : theories/Init/Specif.o
-theories/ZArith/Wf_Z.o : theories/Init/Peano.o
-theories/ZArith/Wf_Z.o : theories/Init/Logic.o
-theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o
-theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs
-theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zarith_aux.o : theories/Init/Specif.o
-theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o
-theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs
-theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs
-theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o
-theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o
-theories/ZArith/ZArith_dec.o : theories/Init/Specif.o
-theories/ZArith/ZArith_dec.o : theories/Init/Logic.o
-theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs
-theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs
-theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zbool.o : theories/Bool/Sumbool.o
-theories/ZArith/Zbool.o : theories/Init/Specif.o
-theories/ZArith/Zbool.o : theories/Init/Datatypes.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs
-theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o
-theories/ZArith/Zcomplements.o : theories/Init/Specif.o
-theories/ZArith/Zcomplements.o : theories/Init/Logic.o
-theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o
-theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs
-theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zdiv.o : theories/Init/Specif.o
-theories/ZArith/Zdiv.o : theories/Init/Logic.o
-theories/ZArith/Zdiv.o : theories/Init/Datatypes.o
-theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs
-theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs
-theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs
-theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zmisc.o : theories/Init/Specif.o
-theories/ZArith/Zmisc.o : theories/Init/Datatypes.o
-theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs
-theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zpower.o : theories/Init/Logic.o
-theories/ZArith/Zpower.o : theories/Init/Datatypes.o
-theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs
-theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zsqrt.o : theories/Init/Specif.o
-theories/ZArith/Zsqrt.o : theories/Init/Logic.o
-theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs
-# DO NOT DELETE: End of Haskell dependencies
diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals
deleted file mode 100644
index fb73d47b..00000000
--- a/contrib/extraction/test/addReals
+++ /dev/null
@@ -1,21 +0,0 @@
-open TypeSyntax
-open Fast_integer
-
-
-let total_order_T x y = 
-if x = y then InleftT RightT
-else if x < y then InleftT LeftT
-else InrightT 
-
-let rec int_to_positive i = 
-	if i = 1 then XH
-	else
-	  if (i mod 2) = 0 then XO (int_to_positive (i/2))
-	  else XI (int_to_positive (i/2))
-
-let rec int_to_Z i = 
-	if i = 0 then ZERO
-	else if i > 0 then POS (int_to_positive i)
-	else NEG (int_to_positive (-i))
-
-let my_ceil x = int_to_Z (succ (int_of_float (floor x)))
diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc
deleted file mode 100644
index e7204838..00000000
--- a/contrib/extraction/test/custom/Adalloc
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid
deleted file mode 100644
index a58e3940..00000000
--- a/contrib/extraction/test/custom/Euclid
+++ /dev/null
@@ -1 +0,0 @@
-Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec.
diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List
deleted file mode 100644
index ffee7dc9..00000000
--- a/contrib/extraction/test/custom/List
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline map.
diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet
deleted file mode 100644
index c9bea52a..00000000
--- a/contrib/extraction/test/custom/ListSet
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline set_add set_mem.
diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort
deleted file mode 100644
index 22ab18e3..00000000
--- a/contrib/extraction/test/custom/Lsort
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat. 
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map
deleted file mode 100644
index f024dbd7..00000000
--- a/contrib/extraction/test/custom/Map
+++ /dev/null
@@ -1,3 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
-
diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard
deleted file mode 100644
index 5932cf7b..00000000
--- a/contrib/extraction/test/custom/Mapcard
+++ /dev/null
@@ -1,4 +0,0 @@
-Require Import Plus.
-Extraction NoInline plus_is_one.
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter
deleted file mode 100644
index 22ab18e3..00000000
--- a/contrib/extraction/test/custom/Mapiter
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat. 
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/R_Ifp
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/R_sqr
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Ranalysis
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Raxioms
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rbase
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rbasic_fun
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rdefinitions
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v
deleted file mode 100644
index 45d0a224..00000000
--- a/contrib/extraction/test/custom/Reals.v
+++ /dev/null
@@ -1,17 +0,0 @@
-Require Import Reals. 
-Extract Inlined Constant R => float.
-Extract Inlined Constant R0 => "0.0".
-Extract Inlined Constant R1 => "1.0".
-Extract Inlined Constant Rplus => "(+.)".
-Extract Inlined Constant Rmult => "( *.)".
-Extract Inlined Constant Ropp => "(~-.)".
-Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)".
-Extract Inlined Constant Rlt => "(<)".
-Extract Inlined Constant up => "AddReals.my_ceil".
-Extract Inlined Constant total_order_T => "AddReals.total_order_T".
-Extract Inlined Constant sqrt => "sqrt".
-Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))".
-Extract Inlined Constant PI => "3.141593".
-Extract Inlined Constant cos => cos.
-Extract Inlined Constant sin => sin.
-Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)".
diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rfunctions
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rgeom
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rlimit
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rseries
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rsigma
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rtrigo
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec
deleted file mode 100644
index 2201419e..00000000
--- a/contrib/extraction/test/custom/ZArith_dec
+++ /dev/null
@@ -1 +0,0 @@
-Extraction Inline Dcompare_inf Zcompare_rec.
diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer
deleted file mode 100644
index e2b24953..00000000
--- a/contrib/extraction/test/custom/fast_integer
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline Zero_suivi_de Un_suivi_de.
diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e
deleted file mode 100644
index 88b6c90b..00000000
--- a/contrib/extraction/test/e
+++ /dev/null
@@ -1,17 +0,0 @@
-
-(* To trace Extraction, you can use this file via:  *)
-(*               Drop. #use "e";;                   *) 
-(*                                                  *)
-
-#use "include";;
-open Extraction;;
-open Miniml;;
-#trace extract_declaration;;
-go();;
-
-
-
-
-
-
-
diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract
deleted file mode 100755
index 83444be3..00000000
--- a/contrib/extraction/test/extract
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-rm -f /tmp/extr$$.v 
-vfile=`./ml2v $1`
-d=`dirname $vfile`
-n=`basename $vfile .v`
-if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
-echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v
-../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
-out=$?
-rm -f /tmp/extr$$.v
-exit $out
-
diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell
deleted file mode 100755
index d11bc706..00000000
--- a/contrib/extraction/test/extract.haskell
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-rm -f /tmp/extr$$.v 
-vfile=`./hs2v $1`
-d=`dirname $vfile`
-n=`basename $vfile .v`
-if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
-echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v
-../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
-out=$?
-rm -f /tmp/extr$$.v
-exit $out
-
diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml
deleted file mode 100644
index fd8b9b26..00000000
--- a/contrib/extraction/test/hs2v.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-let _ =
-  for j = 1 to ((Array.length Sys.argv)-1) do
-    let fml = Sys.argv.(j) in
-    let f = Filename.chop_extension fml in 
-    let fv = f ^ ".v" in
-    if Sys.file_exists ("../../../" ^ fv) then
-      print_string (fv^" ") 
-    else
-      let d = Filename.dirname f in
-      let b = String.uncapitalize (Filename.basename f) in
-      let fv = Filename.concat d (b ^ ".v ") in
-      print_string fv
-  done;
-  print_newline()
diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli
deleted file mode 100755
index 40ee496e..00000000
--- a/contrib/extraction/test/make_mli
+++ /dev/null
@@ -1,17 +0,0 @@
-#!/usr/bin/awk -We $0
-
-{ match($0,"^open") 
-  if (RLENGTH>0) state=1
-  match($0,"^type") 
-  if (RLENGTH>0) state=1 
-  match($0,"^\(\*\* ")
-  if (RLENGTH>0) state=2
-  match($0,"^let")
-  if (RLENGTH>0) state=0
-  match($0,"^and")
-  if ((RLENGTH>0) && (state==2)) state=0
-  if ((RLENGTH>0) && (state==1)) state=1		     
-  gsub("\(\*\* ","")
-  gsub("\*\*\)","")
-  if (state>0) print
-}  
diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml
deleted file mode 100644
index 363ea642..00000000
--- a/contrib/extraction/test/ml2v.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-let _ =
-  for j = 1 to ((Array.length Sys.argv)-1) do
-    let fml = Sys.argv.(j) in
-    let f = Filename.chop_extension fml in 
-    let fv = f ^ ".v" in
-    if Sys.file_exists ("../../../" ^ fv) then
-      print_string (fv^" ") 
-    else
-      let d = Filename.dirname f in
-      let b = String.capitalize (Filename.basename f) in
-      let fv = Filename.concat d (b ^ ".v ") in
-      print_string fv
-  done;
-  print_newline()
diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml
deleted file mode 100644
index 88632875..00000000
--- a/contrib/extraction/test/v2hs.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-let _ = 
-  for j = 1 to ((Array.length Sys.argv) -1) do 
-    let s = Sys.argv.(j) in
-    let b = Filename.chop_extension (Filename.basename s) in 
-    let b = String.capitalize b in
-    let d = Filename.dirname s in 
-    print_string (Filename.concat d (b ^ ".hs "))
-  done;	
-  print_newline()
diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml
deleted file mode 100644
index 245a1b1e..00000000
--- a/contrib/extraction/test/v2ml.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-let _ = 
-  for j = 1 to ((Array.length Sys.argv) -1) do 
-    let s = Sys.argv.(j) in
-    let b = Filename.chop_extension (Filename.basename s) in 
-    let b = String.uncapitalize b in
-    let d = Filename.dirname s in 
-    print_string (Filename.concat d (b ^ ".ml "))
-  done;	
-  print_newline()
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
index dab5a45c..dea79773 100644
--- a/contrib/field/field.ml4
+++ b/contrib/field/field.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *)
+(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *)
 
 open Names
 open Pp
@@ -159,7 +159,7 @@ let field g =
       | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
       | _ -> error "The statement is not built from Leibniz' equality" in
   let th = VConstr (lookup (pf_env g) typ) in
-  (interp_tac_gen [(id_of_string "FT",th)] (get_debug ())
+  (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ())
     <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
 
 (* Verifies that all the terms have the same type and gives the right theory *)
diff --git a/contrib/first-order/formula.ml b/contrib/firstorder/formula.ml
index 0be468aa..3e49cd9c 100644
--- a/contrib/first-order/formula.ml
+++ b/contrib/firstorder/formula.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
 
 open Hipattern
 open Names
@@ -120,7 +120,7 @@ type side = Hyp | Concl | Hint
 
 let no_atoms = (false,{positive=[];negative=[]})
 
-let dummy_id=VarRef (id_of_string "")
+let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
 
 let build_atoms gl metagen side cciterm =
   let trivial =ref false
diff --git a/contrib/first-order/formula.mli b/contrib/firstorder/formula.mli
index 8703045c..8703045c 100644
--- a/contrib/first-order/formula.mli
+++ b/contrib/firstorder/formula.mli
diff --git a/contrib/first-order/g_ground.ml4 b/contrib/firstorder/g_ground.ml4
index 366f563b..f7b0a546 100644
--- a/contrib/first-order/g_ground.ml4
+++ b/contrib/firstorder/g_ground.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
-(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *)
 
 open Formula
 open Sequent
@@ -97,23 +97,24 @@ let normalize_evaluables=
 	   (Tacexpr.InHypType id)) *)
 
 TACTIC EXTEND firstorder
-    [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> 
-      [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ]
-|   [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> 
-      [ gen_ground_tac true (option_map eval_tactic t) (Bases l) ]
+    [ "firstorder" tactic_opt(t) "using" ne_reference_list(l) ] -> 
+      [ gen_ground_tac true (Option.map eval_tactic t) (Ids l) ]
+|   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> 
+      [ gen_ground_tac true (Option.map eval_tactic t) (Bases l) ]
 |   [ "firstorder" tactic_opt(t) ] -> 
-      [ gen_ground_tac true (option_map eval_tactic t) Void ]
+      [ gen_ground_tac true (Option.map eval_tactic t) Void ]
 END
 
 TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (option_map eval_tactic t) Void ]
+     [ gen_ground_tac false (Option.map eval_tactic t) Void ]
 END
 
 
 let default_declarative_automation gls = 
-  tclORELSE 
-    (Cctac.congruence_tac !congruence_depth []) 
+  tclORELSE
+    (tclORELSE (Auto.h_trivial [] None) 
+    (Cctac.congruence_tac !congruence_depth []))
     (gen_ground_tac true 
        (Some (tclTHEN
 		default_solver
diff --git a/contrib/first-order/ground.ml b/contrib/firstorder/ground.ml
index bccac6df..f4661869 100644
--- a/contrib/first-order/ground.ml
+++ b/contrib/firstorder/ground.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *)
+(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *)
 
 open Formula
 open Sequent
diff --git a/contrib/first-order/ground.mli b/contrib/firstorder/ground.mli
index 621f99db..621f99db 100644
--- a/contrib/first-order/ground.mli
+++ b/contrib/firstorder/ground.mli
diff --git a/contrib/first-order/instances.ml b/contrib/firstorder/instances.ml
index 254d7b84..1432207d 100644
--- a/contrib/first-order/instances.ml
+++ b/contrib/firstorder/instances.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.ml 8654 2006-03-22 15:36:58Z msozeau $ i*)
+(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*)
 
 open Formula
 open Sequent
@@ -125,9 +125,9 @@ let mk_open_instance id gl m t=
   let rec raux n t=
     if n=0 then t else 
       match t with
-	  RLambda(loc,name,_,t0)->
+	  RLambda(loc,name,k,_,t0)->
 	    let t1=raux (n-1) t0 in
-	      RLambda(loc,name,RHole (dummy_loc,Evd.BinderType name),t1)
+	      RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1)
 	| _-> anomaly "can't happen" in
   let ntt=try 
     Pretyping.Default.understand evmap env (raux m rawt)
diff --git a/contrib/first-order/instances.mli b/contrib/firstorder/instances.mli
index 7667c89f..7667c89f 100644
--- a/contrib/first-order/instances.mli
+++ b/contrib/firstorder/instances.mli
diff --git a/contrib/first-order/rules.ml b/contrib/firstorder/rules.ml
index 6c51eda3..b8b56548 100644
--- a/contrib/first-order/rules.ml
+++ b/contrib/firstorder/rules.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
+(* $Id: rules.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Util
 open Names
@@ -78,7 +78,7 @@ let and_tac backtrack continue seq=
 
 let or_tac backtrack continue seq=
   tclORELSE 
-    (any_constructor (Some (tclCOMPLETE (wrap 0 true continue seq))))
+    (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
     backtrack
 
 let arrow_tac backtrack continue seq=
@@ -204,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq=
 let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
 
 let defined_connectives=lazy
-  [[],EvalConstRef (destConst (constant "not"));
-   [],EvalConstRef (destConst (constant "iff"))]
+  [all_occurrences,EvalConstRef (destConst (constant "not"));
+   all_occurrences,EvalConstRef (destConst (constant "iff"))]
 
 let normalize_evaluables=
   onAllClauses
@@ -213,4 +213,4 @@ let normalize_evaluables=
 	 None->unfold_in_concl (Lazy.force defined_connectives)
        | Some ((_,id),_)-> 
 	   unfold_in_hyp (Lazy.force defined_connectives) 
-	   (([],id),Tacexpr.InHypTypeOnly))
+	   ((Rawterm.all_occurrences_expr,id),Tacexpr.InHypTypeOnly))
diff --git a/contrib/first-order/rules.mli b/contrib/firstorder/rules.mli
index 3798d8d4..3798d8d4 100644
--- a/contrib/first-order/rules.mli
+++ b/contrib/firstorder/rules.mli
diff --git a/contrib/first-order/sequent.ml b/contrib/firstorder/sequent.ml
index 805700b0..c832d30f 100644
--- a/contrib/first-order/sequent.ml
+++ b/contrib/firstorder/sequent.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.ml 7925 2006-01-24 23:20:39Z herbelin $ *)
+(* $Id: sequent.ml 10824 2008-04-21 13:57:03Z msozeau $ *)
 
 open Term
 open Util
@@ -281,7 +281,7 @@ let create_with_auto_hints l depth gl=
 	searchtable_map dbname
       with Not_found-> 
 	error ("Firstorder: "^dbname^" : No such Hint database") in
-      Hint_db.iter g hdb in
+      Hint_db.iter g (snd hdb) in
     List.iter h l;
     !seqref
 
diff --git a/contrib/first-order/sequent.mli b/contrib/firstorder/sequent.mli
index 47fb74c7..47fb74c7 100644
--- a/contrib/first-order/sequent.mli
+++ b/contrib/firstorder/sequent.mli
diff --git a/contrib/first-order/unify.ml b/contrib/firstorder/unify.ml
index 1dd13cbe..1dd13cbe 100644
--- a/contrib/first-order/unify.ml
+++ b/contrib/firstorder/unify.ml
diff --git a/contrib/first-order/unify.mli b/contrib/firstorder/unify.mli
index 9fbe3dda..9fbe3dda 100644
--- a/contrib/first-order/unify.mli
+++ b/contrib/firstorder/unify.mli
diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v
index c3257b7d..6a9ab051 100644
--- a/contrib/fourier/Fourier_util.v
+++ b/contrib/fourier/Fourier_util.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier_util.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *)
 
 Require Export Rbase.
 Comments "Lemmas used by the tactic Fourier".
@@ -152,7 +152,7 @@ apply Rlt_irrefl.
 ring.
 Qed.
  
-Lemma Rlt_not_le : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
+Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
 intros n d H; try assumption.
 apply Rgt_not_le.
 replace 0 with (-0).
diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml
index f9518bcb..114d5f9c 100644
--- a/contrib/fourier/fourierR.ml
+++ b/contrib/fourier/fourierR.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourierR.ml 7760 2005-12-30 10:49:13Z herbelin $ *)
+(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
 
 
 
@@ -258,11 +258,11 @@ let fourier_lineq lineq1 =
    let nvar=ref (-1) in
    let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
    List.iter (fun f ->
-               Hashtbl.iter (fun x c ->
-				 try (Hashtbl.find hvar x;())
-				 with _-> nvar:=(!nvar)+1;
-   				          Hashtbl.add hvar x (!nvar))
-                            f.hflin.fhom)
+		Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin
+				nvar:=(!nvar)+1; 
+				Hashtbl.add hvar x (!nvar)
+			      end)
+                  f.hflin.fhom)
              lineq1;
    let sys= List.map (fun h->
                let v=Array.create ((!nvar)+1) r0 in
@@ -334,7 +334,7 @@ let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt")
 let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le")
 let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt")
 let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le")
-let coq_Rlt_not_le = lazy (constant_fourier "Rlt_not_le")
+let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp")
 
 (******************************************************************************
 Construction de la preuve en cas de succès de la méthode de Fourier,
@@ -404,7 +404,7 @@ let tac_zero_inf_false gl (n,d) =
 (* preuve que 0<=(-n)*(1/d) => False 
 *)
 let tac_zero_infeq_false gl (n,d) =
-     (tclTHEN (apply (get coq_Rlt_not_le))
+     (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
 	      (tac_zero_inf_pos gl (-n,d)))
 ;;
 
@@ -492,7 +492,7 @@ let rec fourier gl=
       in tac gl)
      with _ -> 
     (* les hypothèses *)
-    let hyps = List.map (fun (h,t)-> (mkVar h,(body_of_type t)))
+    let hyps = List.map (fun (h,t)-> (mkVar h,t))
                         (list_of_sign (pf_hyps gl)) in
     let lineq =ref [] in
     List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
@@ -503,8 +503,7 @@ let rec fourier gl=
     let res=fourier_lineq (!lineq) in
     let tac=ref tclIDTAC in
     if res=[]
-    then (print_string "Tactic Fourier fails.\n";
-		       flush stdout)
+    then Util.error "fourier failed"
     (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
     else (match res with
         [(cres,sres,lc)]->
diff --git a/contrib/recdef/Recdef.v b/contrib/funind/Recdef.v
index 2d206220..2d206220 100644
--- a/contrib/recdef/Recdef.v
+++ b/contrib/funind/Recdef.v
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
index 975cf60b..3d80bd00 100644
--- a/contrib/funind/functional_principles_proofs.ml
+++ b/contrib/funind/functional_principles_proofs.ml
@@ -47,7 +47,7 @@ let observe_tac_stream s tac g =
 let observe_tac s tac g = observe_tac_stream (str s) tac g
 
 (* let tclTRYD tac =  *)
-(*   if  !Options.debug  || do_observe () *)
+(*   if  !Flags.debug  || do_observe () *)
 (*   then (fun g -> try (\* do_observe_tac ""  *\)tac g with _ -> tclIDTAC g) *)
 (*   else tac *)
 
@@ -140,7 +140,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
       [tclTHENLIST 
       [	
 	(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
-	(* observe_tac "change_hyp_with_using rename " *) (h_rename prov_id hyp_id)
+	(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
       ]] g
 
 exception TOREMOVE
@@ -573,7 +573,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
 	  tclTHENLIST[
 	    forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args));
 	    thin [hid];
-	    (h_rename prov_hid hid)
+	    h_rename [prov_hid,hid]
 	  ] g
       )
       ( (*
@@ -637,7 +637,7 @@ let build_proof
 		    [
 		      h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
 		      thin dyn_infos.rec_hyps;
-		      pattern_option [[-1],t] None;
+		      pattern_option [(false,[1]),t] None;
 		      h_simplest_case t;
 		      (fun g' -> 
 			 let g'_nb_prod = nb_prod (pf_concl g') in 
@@ -882,7 +882,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
   let f_def = Global.lookup_constant (destConst f) in
   let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
   let f_body =
-    force (out_some f_def.const_body)
+    force (Option.get f_def.const_body)
   in
   let params,f_body_with_params = decompose_lam_n nb_params f_body in
   let (_,num),(_,_,bodies) = destFix f_body_with_params in
@@ -910,7 +910,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 	   let rec_id = pf_nth_hyp_id g 1 in
 	   tclTHENSEQ
 	     [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id);
-	      (* observe_tac "h_case" *) (h_case (mkVar rec_id,Rawterm.NoBindings));
+	      (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings));
 	      intros_reflexivity] g
 	)
       ]
@@ -933,8 +933,8 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
   let equation_lemma = 
     try 
       let finfos = find_Function_infos (destConst f) in 
-      mkConst (out_some finfos.equation_lemma)
-    with (Not_found | Failure "out_some" as e) -> 
+      mkConst (Option.get finfos.equation_lemma)
+    with (Not_found | Option.IsNone as e) -> 
       let f_id = id_of_label (con_label (destConst f)) in 
       (*i The next call to mk_equation_id is valid since we will construct the lemma
 	Ensures by: obvious
@@ -943,7 +943,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
       generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
       let _ =
 	match e with 
-	  | Failure "out_some" -> 
+	  | Option.IsNone -> 
 	      let finfos = find_Function_infos (destConst f) in 
 	      update_Function 
 		{finfos with
@@ -1141,7 +1141,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	    then
 	      (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
 	    else
-	      h_mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+	      h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
 		other_fix_infos
 	| _ -> anomaly "Not a valid information"
     in
@@ -1246,7 +1246,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 in
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
-		   [unfold_in_concl [([],Names.EvalConstRef fname)];
+		   [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
 		    let do_prove = 
 		      build_proof 
 			interactive_proof
@@ -1347,19 +1347,27 @@ let build_clause eqs =
   {
     Tacexpr.onhyps = 
       Some (List.map 
-	      (fun id -> ([],id),Tacexpr.InHyp)
+	      (fun id -> (Rawterm.all_occurrences_expr,id),Tacexpr.InHyp)
 	      eqs
 	   );
-    Tacexpr.onconcl = false; 
-    Tacexpr.concl_occs = [] 
+    Tacexpr.concl_occs = Rawterm.no_occurrences_expr 
   }
 
 let rec rewrite_eqs_in_eqs eqs = 
   match eqs with 
     | [] -> tclIDTAC
     | eq::eqs -> 
+	
 	  tclTHEN 
-	    (tclMAP (fun id -> tclTRY (Equality.general_rewrite_in true id (mkVar eq))) eqs)
+	    (tclMAP 
+	       (fun id gl -> 
+		  observe_tac 
+		    (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) 
+		    (tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false))
+		    gl
+	       ) 
+	       eqs
+	    )
 	    (rewrite_eqs_in_eqs eqs) 
 
 let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = 
@@ -1373,21 +1381,26 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 	    [ tclTHENSEQ 
 		[
 		  keep (tcc_hyps@eqs);
-		  
 		  apply (Lazy.force acc_inv);
 		  (fun g -> 
 		     if is_mes 
 		     then 
-		       unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g 
+		       unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g 
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
 		    (tclTHENLIST 
 		       [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
-			rewrite_eqs_in_eqs eqs;
-			(observe_tac "finishing"  
-			   (tclCOMPLETE (
-			      Eauto.gen_eauto false (false,5) [] (Some []))
+			observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
+			 (observe_tac "finishing using"
+			   (
+			    tclCOMPLETE(
+				    Eauto.eauto_with_bases
+				      false
+				      (true,5)
+				      [Lazy.force refl_equal]
+				      [empty_transparent_state, Auto.Hint_db.empty]
+				  )
 			   )
 			)
 		       ]
@@ -1445,7 +1458,7 @@ let prove_principle_for_gen
   let wf_tac = 
     if is_mes 
     then 
-      (fun b -> Recdef.tclUSER_if_not_mes b None)
+      (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None)
     else fun _ -> prove_with_tcc tcc_lemma_ref []
   in
   let real_rec_arg_num = rec_arg_num - princ_info.nparams in 
@@ -1502,16 +1515,16 @@ let prove_principle_for_gen
      | None -> anomaly ( "No tcc proof !!")
      | Some lemma -> lemma
   in
-  let rec list_diff del_list check_list =
-    match del_list with
-         [] ->
-           []
-      | f::r ->
-          if List.mem f check_list then
-               list_diff r check_list
-          else
-               f::(list_diff r check_list)
-  in
+(*   let rec list_diff del_list check_list = *)
+(*     match del_list with *)
+(*          [] -> *)
+(*            [] *)
+(*       | f::r -> *)
+(*           if List.mem f check_list then *)
+(*                list_diff r check_list *)
+(*           else *)
+(*                f::(list_diff r check_list) *)
+(*   in *)
   let tcc_list = ref [] in
   let start_tac gls = 
     let hyps = pf_ids_of_hyps gls in 
@@ -1527,7 +1540,7 @@ let prove_principle_for_gen
 	  Elim.h_decompose_and (mkVar hid);
 	  (fun g -> 
 	     let new_hyps = pf_ids_of_hyps g in 
-	     tcc_list := list_diff new_hyps (hid::hyps);
+	     tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
 	     if !tcc_list = []
 	     then 
 	       begin 
@@ -1593,14 +1606,15 @@ let prove_principle_for_gen
 (* 		  msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id  eqs); *)
 
 		  (* observe_tac "new_prove_with_tcc"  *)
-		    (new_prove_with_tcc 
+		    (new_prove_with_tcc  
 		       is_mes acc_inv fix_id  
-		       !tcc_list  
-		       ((List.map 
+		         
+		       (!tcc_list@(List.map 
 			   (fun (na,_,_) -> (Nameops.out_name na)) 
 			   (princ_info.args@princ_info.params)
-			)@ (acc_rec_arg_id::eqs))
+			)@ ([acc_rec_arg_id])) eqs
 		    )
+	       
 	       );
 	     is_valid = is_valid_hypothesis predicates_names
 	   }
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
index 8ad2e72b..16076479 100644
--- a/contrib/funind/functional_principles_types.ml
+++ b/contrib/funind/functional_principles_types.ml
@@ -115,7 +115,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     it_mkProd_or_LetIn 
       ~init:
       (it_mkProd_or_LetIn 
-	 ~init:(option_fold_right
+	 ~init:(Option.fold_right
 			   mkProd_or_LetIn
 			   princ_type_info.indarg
 			   princ_type_info.concl
@@ -384,7 +384,7 @@ let generate_functional_principle
 	  { const_entry_body = value;
 	    const_entry_type = None;
 	    const_entry_opaque = false;
-	    const_entry_boxed = Options.boxed_definitions()
+	    const_entry_boxed = Flags.boxed_definitions()
 	  }
 	in
 	ignore(
@@ -394,7 +394,7 @@ let generate_functional_principle
 	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
 	    )
 	);
-	Options.if_verbose 
+	Flags.if_verbose 
 	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) 
 	  name;
 	names := name :: !names
@@ -561,6 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
       (fun _ _ _ -> ())
   in      
   incr i;
+  let opacity = 
+    let finfos = find_Function_infos this_block_funs.(0) in 
+    try 
+      let equation =  Option.get finfos.equation_lemma in  
+      (Global.lookup_constant equation).Declarations.const_opaque 
+    with Option.IsNone -> (* non recursive definition *) 
+      false
+  in
+  let const = {const with const_entry_opaque = opacity } in 
   (* The others are just deduced *)
   if other_princ_types = [] 
   then
@@ -642,10 +651,12 @@ let build_scheme fas =
   in 
   List.iter2 
     (fun (princ_id,_,_) def_entry -> 
-       ignore (Declare.declare_constant 
-		 princ_id 
-		 (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
-       Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+       ignore 
+	 (Declare.declare_constant 
+	    princ_id 
+	    (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
+       Flags.if_verbose 
+	 (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
     )
     fas
     bodies_types
diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/g_indfun.ml4
index 9cee9edc..dae76f2d 100644
--- a/contrib/funind/indfun_main.ml4
+++ b/contrib/funind/g_indfun.ml4
@@ -29,20 +29,37 @@ let pr_bindings prc prlc = function
         Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | Rawterm.NoBindings -> mt ()
 
-
 let pr_with_bindings prc prlc (c,bl) =
   prc c ++ hv 0 (pr_bindings prc prlc bl)
 
-
 let pr_fun_ind_using  prc prlc _ opt_c = 
   match opt_c with
     | None -> mt ()
     | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b))
 
+(* Duplication of printing functions because "'a with_bindings" is
+   (internally) not uniform in 'a: indeed constr_with_bindings at the
+   "typed" level has type "open_constr with_bindings" instead of
+   "constr with_bindings"; hence, its printer cannot be polymorphic in
+   (prc,prlc)... *)
+
+let pr_with_bindings_typed prc prlc (c,bl) =
+  prc c ++ 
+  hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c))  bl)
+
+let pr_fun_ind_using_typed prc prlc _ opt_c = 
+  match opt_c with
+    | None -> mt ()
+    | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b))
+
 
 ARGUMENT EXTEND fun_ind_using
   TYPED AS constr_with_bindings_opt
-  PRINTED BY pr_fun_ind_using
+  PRINTED BY pr_fun_ind_using_typed
+  RAW_TYPED AS constr_with_bindings_opt
+  RAW_PRINTED BY pr_fun_ind_using
+  GLOB_TYPED AS constr_with_bindings_opt
+  GLOB_PRINTED BY pr_fun_ind_using
 | [ "using" constr_with_bindings(c) ] -> [ Some c ]
 | [ ] -> [ None ]
 END
@@ -131,7 +148,7 @@ END
 VERNAC ARGUMENT EXTEND binder2
     [ "(" ne_ident_list(idl) ":" lconstr(c)  ")"] ->
      [
-       LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,c) ]
+       LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) ]
 END
 
 
@@ -152,7 +169,7 @@ VERNAC ARGUMENT EXTEND rec_definition2
 	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id 
 	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" 
 	 in 
-	 (try ignore(Util.list_index (Name id) names - 1); annot
+	 (try ignore(Util.list_index0 (Name id) names); annot
 	  with Not_found ->  Util.user_err_loc
             (Util.dummy_loc,"Function",
              Pp.str "No argument named " ++ Nameops.pr_id id)
@@ -166,7 +183,7 @@ VERNAC ARGUMENT EXTEND rec_definition2
 	 | Some an ->
 	     check_exists_args an
      in
-     (id, ni, bl, type_, def) ]
+     ((Util.dummy_loc,id), ni, bl, type_, def) ]
       END
 
 
@@ -300,7 +317,7 @@ let mkEq typ c1 c2 =
 let poseq_unsafe idunsafe cstr gl =
   let typ = Tacmach.pf_type_of gl cstr in
   tclTHEN
-    (Tactics.letin_tac true (Name idunsafe) cstr allClauses)
+    (Tactics.letin_tac None (Name idunsafe) cstr allClauses)
     (tclTHENFIRST 
       (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) 
       Tactics.reflexivity)
@@ -446,25 +463,23 @@ VERNAC COMMAND EXTEND Showindinfo
 END
 
 VERNAC COMMAND EXTEND MergeFunind
-  [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> 
+  [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" 
+      "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(id) ] -> 
      [ 
-       let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in
-       let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in
-       let id1,args1 = 
-	 try 
-	   let hd,args = destApp c1 in
-	   if Term.isInd hd then hd , args 
-	   else raise (Util.error "Ill-formed (fst) argument")
-	 with Invalid_argument _ 
-	     -> Util.error ("Bad argument form for merging schemes") in
-       let id2,args2 = 
-	 try
- 	   let hd,args = destApp c2 in
-	   if isInd hd then hd , args 
-	   else raise (Util.error "Ill-formed (snd) argument")
-	 with Invalid_argument _ 
-	     -> Util.error ("Bad argument form for merging schemes") in
-       (* TOFO: enlever le ignore et declarer l'inductif *)
-       ignore(Merge.merge c1 c2 args1 args2 id)
+       let f1 = Constrintern.interp_constr Evd.empty (Global.env()) 
+	 (CRef (Libnames.Ident (Util.dummy_loc,id1))) in
+       let f2 = Constrintern.interp_constr Evd.empty (Global.env())
+	 (CRef (Libnames.Ident (Util.dummy_loc,id2))) in
+       let f1type = Typing.type_of (Global.env()) Evd.empty f1 in
+       let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
+       let ar1 = List.length (fst (decompose_prod f1type)) in
+       let ar2 = List.length (fst (decompose_prod f2type)) in
+       let _ = 
+	 if ar1 <> List.length cl1 then 
+	   Util.error ("not the right number of arguments for " ^ string_of_id id1) in
+       let _ = 
+	 if ar2 <> List.length cl2 then 
+	   Util.error ("not the right number of arguments for " ^ string_of_id id2) in
+       Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2)  id
      ]
 END
diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
index 82bee01f..a6cbb321 100644
--- a/contrib/funind/indfun.ml
+++ b/contrib/funind/indfun.ml
@@ -22,8 +22,8 @@ let is_rec_info scheme_info =
 
 let choose_dest_or_ind scheme_info =
     if is_rec_info scheme_info
-    then Tactics.new_induct
-    else Tactics.new_destruct
+    then Tactics.new_induct false
+    else Tactics.new_destruct false
 
 
 let functional_induction with_clean c princl pat =
@@ -48,8 +48,8 @@ let functional_induction with_clean c princl pat =
 			| InType -> finfo.rect_lemma
 		    in
 		    let princ =  (* then we get the principle *)
-		      try mkConst (out_some princ_option )
-		      with Failure "out_some" -> 
+		      try mkConst (Option.get princ_option )
+		      with Option.IsNone -> 
 			(*i If there is not default lemma defined then, 
 			  we cross our finger and try to find a lemma named f_ind 
 			  (or f_rec, f_rect) i*)
@@ -77,7 +77,7 @@ let functional_induction with_clean c princl pat =
 	if princ_infos.Tactics.farg_in_concl 
 	then [c] else [] 
       in
-      List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) 
+      List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) 
     in 
     let princ' = Some (princ,bindings) in 
     let princ_vars = 
@@ -120,7 +120,8 @@ let functional_induction with_clean c princl pat =
 	 princ_infos
 	 args_as_induction_constr
 	 princ'
-	 pat)
+	 pat
+         None)
       subst_and_reduce
       g
       
@@ -139,14 +140,14 @@ type newfixpoint_expr =
 let rec abstract_rawconstr c = function
   | [] -> c
   | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl)
-  | Topconstr.LocalRawAssum (idl,t)::bl ->
-      List.fold_right (fun x b -> Topconstr.mkLambdaC([x],t,b)) idl
+  | Topconstr.LocalRawAssum (idl,k,t)::bl ->
+      List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl
         (abstract_rawconstr c bl)
 
 let interp_casted_constr_with_implicits sigma env impls c  =
 (*   Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *)
   Constrintern.intern_gen false sigma env ~impls:([],impls) 
-    ~allow_soapp:false  ~ltacvars:([],[]) c
+    ~allow_patvar:false  ~ltacvars:([],[]) c
 
 
 (* 
@@ -160,7 +161,7 @@ let build_newrecursive
   in
   let (rec_sign,rec_impls) =
     List.fold_left
-      (fun (env,impls) (recname,_,bl,arityc,_) ->
+      (fun (env,impls) ((_,recname),_,bl,arityc,_) ->
         let arityc = Command.generalize_constr_expr arityc bl in
         let arity = Constrintern.interp_type sigma env0 arityc in
 	let impl =
@@ -213,7 +214,7 @@ let rec is_rec names =
     | RRec _ -> error "RRec not handled"
     | RIf(_,b,_,lhs,rhs) -> 
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
-    | RLetIn(_,na,t,b) | RLambda(_,na,t,b) | RProd(_,na,t,b)  -> 
+    | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b)  -> 
 	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
     | RLetTuple(_,nal,_,t,b) -> lookup names t || 
 	lookup 
@@ -224,7 +225,7 @@ let rec is_rec names =
 	  )
 	  b
     | RApp(_,f,args) -> List.exists (lookup names) (f::args)
-    | RCases(_,_,el,brl) -> 
+    | RCases(_,_,_,el,brl) -> 
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
   and lookup_br names (_,idl,_,rt) = 
@@ -266,7 +267,7 @@ let derive_inversion fix_names =
 	)
     with e -> 
       msg_warning 
-	(str "Cannot build functional inversion principle" ++ 
+	(str "Cannot built inversion information" ++ 
 	   if do_observe () then Cerrors.explain_exn e else mt ())
   with _ -> ()
 
@@ -297,7 +298,7 @@ let generate_principle  on_error
     is_general do_built fix_rec_l recdefs  interactive_proof 
     (continue_proof : int -> Names.constant array -> Term.constr array -> int -> 
       Tacmach.tactic) : unit =
-  let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in
+  let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in
   let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
   let funs_args = List.map fst fun_bodies in
   let funs_types =  List.map (function (_,_,_,types,_) -> types) fix_rec_l in
@@ -318,7 +319,7 @@ let generate_principle  on_error
 		 f_R_mut)
 	in
 	let fname_kn (fname,_,_,_,_) =
-	  let f_ref = Ident (dummy_loc,fname) in
+	  let f_ref = Ident fname in
 	  locate_with_msg
 	    (pr_reference f_ref++str ": Not an inductive type!")
 	    locate_constant
@@ -351,17 +352,17 @@ let generate_principle  on_error
 
 let register_struct is_rec fixpoint_exprl = 
   match fixpoint_exprl with 
-    | [(fname,_,bl,ret_type,body),_] when not is_rec -> 
+    | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> 
 	Command.declare_definition
 	  fname
-	  (Decl_kinds.Global,Options.boxed_definitions (),Decl_kinds.Definition)
+	  (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition)
 	  bl
 	  None
   	  body
 	  (Some ret_type)
 	  (fun _ _ -> ())
     | _ -> 
-	Command.build_recursive fixpoint_exprl (Options.boxed_definitions())
+	Command.build_recursive fixpoint_exprl (Flags.boxed_definitions())
 
 let generate_correction_proof_wf f_ref tcc_lemma_ref   
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
@@ -402,7 +403,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
 	 )
 	) 
     in
-    Topconstr.CApp (dummy_loc,(None,Topconstr.mkIdentC (id_of_string "eq")),
+    Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
 		    [(f_app_args,None);(body,None)])
   in
   let eq = Command.generalize_constr_expr unbounded_eq args in 
@@ -434,7 +435,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
       | None -> 
 	  begin
 	    match args with 
-	      | [Topconstr.LocalRawAssum ([(_,Name x)],t)] -> t,x 
+	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x 
 	      | _ -> error "Recursive argument must be specified" 
 	  end
       | Some wf_args -> 
@@ -442,7 +443,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
 	    match 
 	      List.find 
 		(function 
-		   | Topconstr.LocalRawAssum(l,t) -> 
+		   | Topconstr.LocalRawAssum(l,k,t) -> 
 		       List.exists 
 			 (function (_,Name id) -> id =  wf_args | _ -> false) 
 			 l 
@@ -450,7 +451,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
 		)
 		args 
 	    with 
-	      | Topconstr.LocalRawAssum(_,t)  ->	    t,wf_args
+	      | Topconstr.LocalRawAssum(_,k,t)  ->	    t,wf_args
 	      | _ -> assert false 
 	  with Not_found -> assert false 
   in
@@ -462,7 +463,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
   let fun_from_mes = 
     let applied_mes = 
       Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],wf_arg_type,applied_mes) 
+    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) 
   in
   let wf_rel_from_mes = 
     Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
@@ -475,7 +476,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
   let recdefs,rec_impls = build_newrecursive fixpoint_exprl in 
   let _is_struct = 
     match fixpoint_exprl with 
-      | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> 
+      | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> 
 	  let pre_hook = 
 	    generate_principle 
 	      on_error
@@ -488,7 +489,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	  if register_built 
 	  then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
 	  false
-      | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> 
+      | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> 
 	  let pre_hook = 
 	    generate_principle 
 	      on_error
@@ -503,20 +504,15 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	  true
       | _ -> 
 	  let fix_names = 
-	    List.map (function (name,_,_,_,_) -> name) fixpoint_exprl 
+	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl 
 	  in
 	  let is_one_rec = is_rec fix_names  in
 	  let old_fixpoint_exprl =  
 	    List.map
 	      (function
 		 | (name,Some (Struct id),args,types,body),_ -> 
-		     let names = 
-		       List.map
-			 snd
-			 (Topconstr.names_of_local_assums args) 
-		     in 
 		     let annot = 
-		       try Some (list_index (Name id) names - 1), Topconstr.CStructRec 
+		       try Some (dummy_loc, id), Topconstr.CStructRec 
 		       with Not_found -> 
 			 raise (UserError("",str "Cannot find argument " ++ 
 					    Ppconstr.pr_id id)) 
@@ -529,7 +525,8 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 			 (dummy_loc,"Function",
 			  Pp.str "the recursive argument needs to be specified in Function")
 		     else 
-		       (name,(Some 0, Topconstr.CStructRec),args,types,body),
+		       let loc, na = List.hd names in
+			 (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body),
 		     (None:Vernacexpr.decl_notation)
 		 | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> 
 		     error 
@@ -539,7 +536,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
 	  in
 	  (* ok all the expressions are structural *) 
 	  let fix_names = 
-	    List.map (function (name,_,_,_,_) -> name) fixpoint_exprl 
+	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl 
 	  in
 	  let is_rec = List.exists (is_rec fix_names) recdefs in
 	  if register_built then register_struct is_rec old_fixpoint_exprl;
@@ -570,11 +567,11 @@ let rec add_args id new_args b =
       CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
   | CProdN(loc,nal,b1) -> 
       CProdN(loc,
-	     List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, 
+	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, 
 	     add_args id new_args  b1)
   | CLambdaN(loc,nal,b1) -> 
       CLambdaN(loc,
-	       List.map (fun (nal,b2) -> (nal,add_args id new_args  b2)) nal, 
+	       List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args  b2)) nal, 
 	       add_args id new_args  b1)
   | CLetIn(loc,na,b1,b2) -> 
       CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
@@ -588,22 +585,22 @@ let rec add_args id new_args b =
   | CApp(loc,(pf,b),bl) -> 
       CApp(loc,(pf,add_args id new_args b), 
 	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
-  | CCases(loc,b_option,cel,cal) -> 
-      CCases(loc,option_map (add_args id new_args) b_option,
+  | CCases(loc,sty,b_option,cel,cal) -> 
+      CCases(loc,sty,Option.map (add_args id new_args) b_option,
 	     List.map (fun (b,(na,b_option)) -> 
 			 add_args id new_args b,
-			 (na,option_map (add_args id new_args) b_option)) cel, 
+			 (na,Option.map (add_args id new_args) b_option)) cel, 
 	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
 	    )
   | CLetTuple(loc,nal,(na,b_option),b1,b2) -> 
-      CLetTuple(loc,nal,(na,option_map (add_args id new_args) b_option),
+      CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option),
 		add_args id new_args b1,
 		add_args id new_args b2
 	       )
 		
   | CIf(loc,b1,(na,b_option),b2,b3) -> 
       CIf(loc,add_args id new_args b1, 
-	  (na,option_map (add_args id new_args) b_option),
+	  (na,Option.map (add_args id new_args) b_option),
 	  add_args id new_args b2,
 	  add_args id new_args b3
 	 )
@@ -644,13 +641,15 @@ let rec chop_n_arrow n t =
 	      let new_n =
 		let rec aux (n:int) = function 
 		    [] -> n
-		| (nal,t'')::nal_ta' -> 
+		| (nal,k,t'')::nal_ta' -> 
 		    let nal_l = List.length nal in 
 		    if n >= nal_l
 		    then 
 		      aux (n - nal_l) nal_ta'
 		    else 
-		      let new_t' = Topconstr.CProdN(dummy_loc,((snd (list_chop n nal)),t'')::nal_ta',t')
+		      let new_t' = 
+			Topconstr.CProdN(dummy_loc,
+					((snd (list_chop n nal)),k,t'')::nal_ta',t')
 		      in 
 		      raise (Stop new_t')
 		in
@@ -668,12 +667,12 @@ let rec get_args b t : Topconstr.local_binder list *
     | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
 	begin
 	  let n = 
-	    (List.fold_left (fun n (nal,_) -> 
+	    (List.fold_left (fun n (nal,_,_) -> 
 			       n+List.length nal) 0 nal_ta )
 	  in
 	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
-	  (List.map (fun (nal,ta) -> 
-		       (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' 
+	  (List.map (fun (nal,k,ta) -> 
+		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' 
 	end
     | _ -> [],b,t
 
@@ -711,26 +710,13 @@ let make_graph (f_ref:global_reference) =
 		let l = 
 		  List.map
 		    (fun (id,(n,recexp),bl,t,b) -> 
-		       let bl' =  
-			 List.flatten 
-			   (List.map 
-			      (function 
-				 | Topconstr.LocalRawDef (na,_)-> []
-				 | Topconstr.LocalRawAssum (nal,_) -> nal
-			      )
-			      bl
-			   )
-		       in 
-		       let rec_id = 
-			 match List.nth bl' (out_some n)  with 
-			   |(_,Name id) -> id | _ -> anomaly ""
-		       in
+		       let loc, rec_id = Option.get n in
 		       let new_args = 
 			 List.flatten 
 			   (List.map 
 			      (function
  				 | Topconstr.LocalRawDef (na,_)-> []
-			      	 | Topconstr.LocalRawAssum (nal,_) -> 
+			      	 | Topconstr.LocalRawAssum (nal,_,_) -> 
 				     List.map 
 				       (fun (loc,n) -> 
 					  CRef(Libnames.Ident(loc, Nameops.out_name n))) 
@@ -739,7 +725,7 @@ let make_graph (f_ref:global_reference) =
 			      nal_tas
 			   )
 		       in
-		       let b' = add_args id new_args b in 
+		       let b' = add_args (snd id) new_args b in 
 		       (id, Some (Struct rec_id),nal_tas@bl,t,b')
 		    )
 		    fixexprl
@@ -747,13 +733,13 @@ let make_graph (f_ref:global_reference) =
 		l
 	    | _ ->   
 		let id = id_of_label (con_label c) in 
-		[(id,None,nal_tas,t,b)]
+		[((dummy_loc,id),None,nal_tas,t,b)]
 	in
 	do_generate_principle error_error false false expr_list;
 	(* We register the infos *)
 	let mp,dp,_ = repr_con c in 
 	List.iter 
-	  (fun (id,_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) 
+	  (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) 
 	  expr_list
 
 
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
index 13b242d5..4010b49d 100644
--- a/contrib/funind/indfun_common.ml
+++ b/contrib/funind/indfun_common.ml
@@ -76,7 +76,7 @@ let chop_rlambda_n  =
       then List.rev acc,rt
       else
 	match rt with
-	  | Rawterm.RLambda(_,name,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
+	  | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
 	  | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
 	  | _ -> 
 	      raise (Util.UserError("chop_rlambda_n",
@@ -90,7 +90,7 @@ let chop_rprod_n  =
       then List.rev acc,rt
       else
 	match rt with
-	  | Rawterm.RProd(_,name,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
+	  | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
 	  | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
@@ -131,7 +131,7 @@ let coq_constant s =
     (Coqlib.init_modules @ Coqlib.arith_modules) s;;
 
 let constant sl s =
-  constr_of_reference
+  constr_of_global
     (Nametab.locate (make_qualid(Names.make_dirpath 
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
@@ -153,7 +153,7 @@ open Entries
 open Decl_kinds
 open Declare
 let definition_message id =
-  Options.if_verbose message ((string_of_id id) ^ " is defined")
+  Flags.if_verbose message ((string_of_id id) ^ " is defined")
 
 
 let save with_clean id const (locality,kind) hook =
@@ -237,24 +237,29 @@ let with_full_print f a =
   let old_implicit_args = Impargs.is_implicit_args ()
   and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
   and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
-  let old_rawprint = !Options.raw_print in 
-  Options.raw_print := true;
+  let old_rawprint = !Flags.raw_print in 
+  let old_dump = !Flags.dump in 
+  Flags.raw_print := true;
   Impargs.make_implicit_args false;
   Impargs.make_strict_implicit_args false;
   Impargs.make_contextual_implicit_args false;
+  Impargs.make_contextual_implicit_args false;
+  Flags.dump := false;
   try 
     let res = f a in 
     Impargs.make_implicit_args old_implicit_args;
     Impargs.make_strict_implicit_args old_strict_implicit_args;
     Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-    Options.raw_print := old_rawprint;
+    Flags.raw_print := old_rawprint;
+    Flags.dump := old_dump;
     res
   with  
     | e -> 
 	Impargs.make_implicit_args old_implicit_args;
 	Impargs.make_strict_implicit_args old_strict_implicit_args;
 	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
-	Options.raw_print := old_rawprint;
+	Flags.raw_print := old_rawprint;
+	Flags.dump := old_dump;
 	raise e
 
 
@@ -319,12 +324,12 @@ let subst_Function (_,subst,finfos) =
   in
   let function_constant' = do_subst_con finfos.function_constant in 
   let graph_ind' = do_subst_ind finfos.graph_ind in 
-  let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in 
-  let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in 
-  let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in 
-  let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in
-  let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in 
-  let prop_lemma' =  Util.option_smartmap do_subst_con finfos.prop_lemma in 
+  let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in 
+  let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in 
+  let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in 
+  let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in
+  let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in 
+  let prop_lemma' =  Option.smartmap do_subst_con finfos.prop_lemma in 
   if function_constant' == finfos.function_constant && 
     graph_ind' == finfos.graph_ind && 
     equation_lemma' == finfos.equation_lemma &&
@@ -354,12 +359,12 @@ let export_Function infos = Some infos
 let discharge_Function (_,finfos) = 
   let function_constant' = Lib.discharge_con finfos.function_constant
   and graph_ind' = Lib.discharge_inductive finfos.graph_ind 
-  and equation_lemma' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma 
-  and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma 
-  and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma 
-  and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma 
-  and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma
-  and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma
+  and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma 
+  and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma 
+  and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma 
+  and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma 
+  and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma
+  and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma
   in
   if function_constant' == finfos.function_constant && 
     graph_ind' == finfos.graph_ind && 
@@ -387,12 +392,12 @@ let pr_info f_info =
   str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
     str "function_constant_type := " ++ 
     (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
-    str "equation_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
-    str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
-    str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
-    str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
-    str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
-    str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
+    str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
+    str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
+    str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
+    str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
+    str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
+    str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
     str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () 
 
 let pr_table tb = 
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
index c7a3d164..63d44916 100644
--- a/contrib/funind/invfun.ml
+++ b/contrib/funind/invfun.ml
@@ -16,6 +16,7 @@ open Tacticals
 open Tactics
 open Indfun_common
 open Tacmach
+open Termops
 open Sign
 open Hiddentac
 
@@ -23,13 +24,13 @@ open Hiddentac
 
 let pr_binding prc  = 
   function
-    | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
-    | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
 
 let pr_bindings prc prlc = function
   | Rawterm.ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc prc l
+      Util.prlist_with_sep spc (fun (_,c) -> prc c) l
   | Rawterm.ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++ 
         Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
@@ -59,13 +60,13 @@ let observennl strm =
 
 
 let do_observe_tac s tac g =
- try    let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
- let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
- with e ->
-   let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
-   msgnl (str "observation "++ s++str " raised exception " ++ 
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
-   raise e;;
+  let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+  try    
+    let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
+  with e ->
+    msgnl (str "observation "++ s++str " raised exception " ++ 
+	     Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+    raise e;;
 
 
 let observe_tac s tac g =
@@ -314,7 +315,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 		 | None -> (id::pre_args,pre_tac)
 		 | Some b ->
 		     (pre_args,
-		      tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac
+		      tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
 		     )
 		     
 	     else (pre_args,pre_tac)
@@ -425,7 +426,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
+	     (dummy_loc,Rawterm.NamedHyp id,inj_open p)::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
@@ -435,7 +436,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in 
-	     (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid)
+	     (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
 	  (lemmas)))
@@ -461,14 +462,14 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       ]
       g
 
-(* [generalize_depedent_of x hyp g] 
+(* [generalize_dependent_of x hyp g] 
    generalize every hypothesis which depends of [x] but [hyp] 
 *)
-let generalize_depedent_of x hyp g = 
+let generalize_dependent_of x hyp g = 
   tclMAP 
     (function 
        | (id,None,t) when not (id = hyp) && 
-	   (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id]
+	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
        | _ -> tclIDTAC
     )
     (pf_hyps g)
@@ -490,12 +491,17 @@ and intros_with_rewrite_aux : tactic =
 	  | Prod(_,t,t') -> 
 	      begin 
 		match kind_of_term t with 
-		  | App(eq,args) when (eq_constr eq eq_ind) -> 
-		      if isVar args.(1)
+		  | App(eq,args) when (eq_constr eq eq_ind)  -> 
+ 		      if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
+		      then
+			let id = pf_get_new_id (id_of_string "y") g  in
+			tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
+
+		      else if isVar args.(1)
 		      then 			
 			let id = pf_get_new_id (id_of_string "y") g  in 
 			tclTHENSEQ [ h_intro id;
-				     generalize_depedent_of (destVar args.(1)) id; 
+				     generalize_dependent_of (destVar args.(1)) id; 
 				     tclTRY (Equality.rewriteLR (mkVar id));
 				     intros_with_rewrite
 				   ] 
@@ -513,7 +519,7 @@ and intros_with_rewrite_aux : tactic =
 		      Tauto.tauto g
 		  | Case(_,_,v,_) -> 
 		      tclTHENSEQ[
-			h_case (v,Rawterm.NoBindings);
+			h_case false (v,Rawterm.NoBindings);
 			intros_with_rewrite
 		      ] g
 		  | LetIn _ -> 
@@ -550,7 +556,7 @@ let rec reflexivity_with_destruct_cases g =
       match kind_of_term (snd (destApp (pf_concl g))).(2) with 
 	| Case(_,_,v,_) -> 
 	    tclTHENSEQ[
-	      h_case (v,Rawterm.NoBindings);
+	      h_case false (v,Rawterm.NoBindings);
 	      intros;
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases 
 	    ]
@@ -567,9 +573,9 @@ let rec reflexivity_with_destruct_cases g =
 	       match kind_of_term  (pf_type_of g (mkVar id)) with 
 		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> 
 		     if Equality.discriminable (pf_env g) (project g) t1 t2 
-		     then Equality.discr id g
+		     then Equality.discrHyp id g
 		     else if Equality.injectable (pf_env g) (project g) t1 t2
-		     then tclTHENSEQ [Equality.inj [] id;thin [id];intros_with_rewrite]  g
+		     then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite]  g
 		     else tclIDTAC g
 		 | _ -> tclIDTAC g
     )
@@ -665,8 +671,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
       if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
       then 
 	let eq_lemma = 
-	  try out_some (infos).equation_lemma
-	  with Failure "out_some"  -> anomaly "Cannot find equation lemma"
+	  try Option.get (infos).equation_lemma
+	  with Option.IsNone -> anomaly "Cannot find equation lemma"
 	in 
 	tclTHENSEQ[
 	  tclMAP h_intro ids;
@@ -682,7 +688,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	  h_generalize (List.map mkVar ids);
 	  thin ids
 	]
-      else unfold_in_concl [([],Names.EvalConstRef (destConst f))]
+      else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in 
@@ -706,7 +712,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(* we expand the definition of the function *)
         observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
 	(* introduce hypothesis with some rewrite *)
-        (intros_with_rewrite);
+        observe_tac "intros_with_rewrite" intros_with_rewrite;
 	(* The proof is (almost) complete *)
         observe_tac "reflexivity" (reflexivity_with_destruct_cases)
       ]
@@ -720,7 +726,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
 	h_intro graph_principle_id;
 	observe_tac "" (tclTHEN_i 
-	  (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
+	  (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
 	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
       ]
       g
@@ -769,7 +775,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	  Array.of_list 
 	    (List.map 
 	       (fun entry -> 
-		  (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type )
+		  (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type )
 	       )
 	       (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs))
 	    )
@@ -960,13 +966,13 @@ let invfun qhyp f  =
   in
   try 
     let finfos = find_Function_infos f in 
-    let f_correct = mkConst(out_some finfos.correctness_lemma) 
+    let f_correct = mkConst(Option.get finfos.correctness_lemma) 
     and kn = fst finfos.graph_ind
     in
     Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp 
   with 
     | Not_found ->  error "No graph found" 
-    | Failure "out_some"  -> error "Cannot use equivalence with graph!"
+    | Option.IsNone  -> error "Cannot use equivalence with graph!"
 
 
 let invfun qhyp f g = 
@@ -983,23 +989,23 @@ let invfun qhyp f g =
 		     try 
 		       if not (isConst f1) then failwith "";
 		       let finfos = find_Function_infos (destConst f1) in 
-		       let f_correct = mkConst(out_some finfos.correctness_lemma) 
+		       let f_correct = mkConst(Option.get finfos.correctness_lemma) 
 		       and kn = fst finfos.graph_ind
 		       in
 		       functional_inversion kn hid f1 f_correct g
-		     with | Failure "" | Failure "out_some" | Not_found -> 
+		     with | Failure "" | Option.IsNone | Not_found -> 
 		       try 
 			 let f2,_ = decompose_app args.(2) in 
 			 if not (isConst f2) then failwith "";
 			 let finfos = find_Function_infos (destConst f2) in 
-			 let f_correct = mkConst(out_some finfos.correctness_lemma) 
+			 let f_correct = mkConst(Option.get finfos.correctness_lemma) 
 			 and kn = fst finfos.graph_ind
 			 in
 			 functional_inversion kn hid  f2 f_correct g
 		       with
 			 | Failure "" -> 
 			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
-			 | Failure "out_some"  ->  
+			 | Option.IsNone  ->  
 			     if do_observe () 
 			     then
 			       error "Cannot use equivalence with graph for any side of the equality"
diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml
index 1b796a81..ec456aae 100644
--- a/contrib/funind/merge.ml
+++ b/contrib/funind/merge.ml
@@ -9,13 +9,16 @@
 (* Merging of induction principles. *)
 
 (*i $Id: i*)
-
+open Libnames
+open Tactics
+open Indfun_common
 open Util
 open Topconstr
 open Vernacexpr
 open Pp
 open Names
 open Term
+open Termops 
 open Declarations
 open Environ
 open Rawterm
@@ -25,6 +28,8 @@ open Rawtermops
 
 (** {2 Useful operations on constr and rawconstr} *)
 
+let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
+
 (** Substitutions in constr *)
 let compare_constr_nosub t1 t2 =
   if compare_constr (fun _ _ -> false) t1 t2 
@@ -110,6 +115,19 @@ let prNamedLDecl s lc =
     List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
     prstr "\n";
   end
+let prNamedRLDecl s lc = 
+  begin
+    prstr s; prstr "\n"; prstr "{§§ ";
+    List.iter 
+      (fun x -> 
+        match x with
+          | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp
+          | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy
+          | _ -> assert false
+        ) lc;
+    prstr " §§}\n";
+    prstr "\n";
+  end
 
 let showind (id:identifier) =
   let cstrid = Tacinterp.constr_of_id (Global.env()) id in
@@ -193,7 +211,7 @@ type linked_var =
     | Funres
 
 (** When merging two graphs, parameters may become regular arguments,
-    and thus be shifted. This type describe the result of computing
+    and thus be shifted. This type describes the result of computing
     the changes. *)
 type 'a shifted_params =
     {
@@ -237,39 +255,47 @@ type 'a merged_arg =
     | Arg_linked of 'a
     | Arg_funres
 
+(** Information about graph merging of two inductives. 
+   All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *)
+
 type merge_infos =
     {
-      ident:identifier; (* new inductive name *)
+      ident:identifier; (** new inductive name *)
       mib1: mutual_inductive_body;
       oib1: one_inductive_body; 
       mib2: mutual_inductive_body;
       oib2: one_inductive_body; 
-      (* Array of links of the first inductive (should be all stable) *)
+
+      (** Array of links of the first inductive (should be all stable) *)
       lnk1: int merged_arg array;
-      (* Array of links of the second inductive (point to the first ind param/args) *)
+
+      (** Array of links of the second inductive (point to the first ind param/args) *)
       lnk2: int merged_arg array;
-      (* number of rec params of ind1 which remai rec param in merge *)
-      nrecprms1: int;
-      (* number of other rec params of ind1 (which become non parm) *)
-      notherprms1:int;
-      (* number of functional result params of ind2 (which become non parm) *)
-      nfunresprms1:int;
-      (* list of decl of rec parms from ind1 which remain parms *)
+
+      (** rec params which remain rec param (ie not linked) *)
       recprms1: rel_declaration list;
-      (* List of other rec parms from ind1 *)
-      otherprms1: rel_declaration list; (* parms that became args *)
-      funresprms1: rel_declaration list; (* parms that are functional result args *)
-      (* number of rec params of ind2 which remain rec param in merge (and not linked) *)
+      recprms2: rel_declaration list;
+      nrecprms1: int; 
       nrecprms2: int;
-      (* number of other params of ind2 (which become non rec parm) *)
+
+      (** rec parms which became non parm (either linked to something
+         or because after a rec parm that became non parm) *)
+      otherprms1: rel_declaration list; 
+      otherprms2: rel_declaration list;      
+      notherprms1:int; 
       notherprms2:int;
-      (* number of functional result params of ind2 (which become non parm) *)
+
+      (** args which remain args in merge *)
+      args1:rel_declaration list; 
+      args2:rel_declaration list;
+      nargs1:int;
+      nargs2:int;
+
+      (** functional result args *)
+      funresprms1: rel_declaration list; 
+      funresprms2: rel_declaration list;
+      nfunresprms1:int;
       nfunresprms2:int;
-      (* list of decl of rec parms from ind2 which remain parms (and not linked) *)
-      recprms2: rel_declaration list;
-      (* List of other rec parms from ind2 (which are linked or become non parm) *)
-      otherprms2: rel_declaration list;      
-      funresprms2: rel_declaration list; (* parms that are functional result args *)
     }
 
 
@@ -288,7 +314,11 @@ let pr_merginfo x =
 
 let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
 
-let isArg_stable x = match x with Arg_stable _ -> true | _ -> false
+(* ?? prm_linked?? *)
+let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false
+
+let is_stable x = 
+  match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false
 
 let isArg_funres x = match x with Arg_funres -> true | _ -> false
 
@@ -346,6 +376,24 @@ let verify_inds mib1 mib2 =
   if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
   ()
 
+(*
+(** [build_raw_params prms_decl avoid] returns a list of variables
+    attributed to the list of decl [prms_decl], avoiding names in
+    [avoid]. *)
+let build_raw_params prms_decl avoid =
+  let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in
+  let _ = prNamedConstr "DUMMY" dummy_constr in
+  let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
+  let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in
+  let res,_ = raw_decompose_prod dummy_rawconstr in
+  let comblist = List.combine prms_decl res in
+  comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
+*)
+
+let ids_of_rawlist avoid rawl =
+    List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl)
+  
+
 
 (** {1 Merging function graphs} *)
 
@@ -366,6 +414,7 @@ let verify_inds mib1 mib2 =
    ones, they become non rec (and the following too). And functinal
    argument have to be shifted at the end *)
 let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
+  let _ = prstr "\nYOUHOU shift\n" in
   let linked_targets = revlinked lnk2 in
   let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
   let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
@@ -409,15 +458,29 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
   let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
   let bldprms arity_ctxt mlnk = 
     list_fold_lefti
-      (fun i (acc1,acc2,acc3) x -> 
+      (fun i (acc1,acc2,acc3,acc4) x -> 
+        prstr (pr_merginfo mlnk.(i));prstr "\n";
         match mlnk.(i) with
-          | Prm_stable _ -> x::acc1 , acc2 , acc3
-          | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3
-          | Arg_funres -> acc1 , acc2 , x::acc3
-          | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *)
-      ([],[],[]) arity_ctxt in
-  let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
-  let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
+          | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4
+          | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4
+          | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4
+          | Arg_funres -> acc1 , acc2 , acc3, x::acc4
+          | _ -> acc1 , acc2 , acc3, acc4)
+      ([],[],[],[]) arity_ctxt in
+(*  let arity_ctxt2 = 
+    build_raw_params oib2.mind_arity_ctxt 
+      (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*)
+  let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
+  let _ = prstr "\n\n\n" in
+  let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
+  let _ = prstr "\notherprms1:\n" in
+  let _ = 
+    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") 
+    otherprms1 in
+  let _ = prstr "\notherprms2:\n" in
+  let _ = 
+    List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") 
+    otherprms2 in
   {
     ident=id;
     mib1=mib1;
@@ -429,14 +492,18 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
     nrecprms1 = n_params1;
     recprms1 = recprms1;
     otherprms1 = otherprms1;
+    args1 = args1;
     funresprms1 = funresprms1;
     notherprms1 = Array.length mlnk1 - n_params1;
     nfunresprms1 = List.length funresprms1;
+    nargs1 = List.length args1;
     nrecprms2 = n_params2;
     recprms2 = recprms2;
     otherprms2 = otherprms2;
+    args2 = args2;
     funresprms2 = funresprms2;
     notherprms2 = Array.length mlnk2 - n_params2;
+    nargs2 = List.length args2;
     nfunresprms2 = List.length funresprms2;
   }
 
@@ -447,45 +514,61 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
 
 exception NoMerge
 
-(* lnk is an link array of *all* args (from 1 and 2) *)
-let merge_app c1 c2 id1 id2 shift filter_shift_stable = 
+let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = 
   let lnk = Array.append shift.lnk1 shift.lnk2 in
   match c1 , c2 with
     | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> 
+        let _ = prstr "\nICI1!\n";Pp.flush_all() in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
         RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
     | RApp(_,f1, arr1), RApp(_,f2,arr2)  -> raise NoMerge
-    | _ -> raise NoMerge
-
-let merge_app_unsafe c1 c2 shift filter_shift_stable = 
+    | RLetIn(_,nme,bdy,trm) , _ -> 
+        let _ = prstr "\nICI2!\n";Pp.flush_all() in 
+        let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
+        RLetIn(dummy_loc,nme,bdy,newtrm)
+    | _, RLetIn(_,nme,bdy,trm) -> 
+        let _ = prstr "\nICI3!\n";Pp.flush_all() in 
+        let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
+        RLetIn(dummy_loc,nme,bdy,newtrm)
+    | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
+           raise NoMerge
+
+let rec merge_app_unsafe c1 c2 shift filter_shift_stable = 
   let lnk = Array.append shift.lnk1 shift.lnk2 in
   match c1 , c2 with
     | RApp(_,f1, arr1), RApp(_,f2,arr2) -> 
         let args = filter_shift_stable lnk (arr1 @ arr2) in
         RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
-    | _ -> raise NoMerge
+          (* FIXME: what if the function appears in the body of the let? *)
+    | RLetIn(_,nme,bdy,trm) , _ -> 
+        let _ = prstr "\nICI2 '!\n";Pp.flush_all() in 
+        let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
+        RLetIn(dummy_loc,nme,bdy,newtrm)
+    | _, RLetIn(_,nme,bdy,trm) -> 
+        let _ = prstr "\nICI3 '!\n";Pp.flush_all() in 
+        let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
+        RLetIn(dummy_loc,nme,bdy,newtrm)
+    | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
 
 
 
 (* Heuristic when merging two lists of hypothesis: merge every rec
-   calls of nrach 1 with all rec calls of branch 2. *)
+   calls of branch 1 with all rec calls of branch 2. *)
 (* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-let onefoud = ref false (* Ugly *)
-
-let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) 
-    filter_shift_stable =
+let rec merge_rec_hyps shift accrec 
+    (ltyp:(Names.name * rawconstr option * rawconstr option) list) 
+    filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list =
+  let mergeonehyp t reldecl = 
+    match reldecl with
+      | (nme,x,Some (RApp(_,i,args) as ind)) 
+        -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable)
+      | (nme,Some _,None) -> error "letins with recursive calls not treated yet"
+      | (nme,None,Some _) -> assert false 
+      | (nme,None,None) | (nme,Some _,Some _) -> assert false in
   match ltyp with
     | [] -> []
-    | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> 
-        let _ = onefoud := true in
-        let rechyps = 
-          List.map 
-            (fun (nme,ind) -> 
-              match ind with
-                | RApp(_,i,args) -> 
-                    nme, merge_app_unsafe ind t shift filter_shift_stable
-                | _ -> assert false)
-            accrec in
+    | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> 
+        let rechyps = List.map (mergeonehyp t) accrec in
         rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
     | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
 
@@ -494,50 +577,58 @@ let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift =
   List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
 
 
-let find_app (nme:identifier) (ltyp: (name * rawconstr) list) = 
+let find_app (nme:identifier) ltyp = 
   try
     ignore
       (List.map
           (fun x -> 
             match x with
-              | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+              | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
               | _ -> ())
           ltyp);
     false
   with Found _ -> true
+
+let prnt_prod_or_letin nm letbdy typ = 
+  match letbdy , typ with
+    | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy
+    | None , Some tp -> prNamedRConstr (string_of_name nm) tp
+    | _ , _ -> assert false
+
         
-let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list)
-    concl1 (ltyp2:(name * rawconstr) list) concl2
-    : (name * rawconstr) list * rawconstr = 
+let rec merge_types shift accrec1 
+    (ltyp1:(name * rawconstr option * rawconstr option) list)
+    (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2
+    : (name * rawconstr option * rawconstr option) list * rawconstr = 
   let _ = prstr "MERGE_TYPES\n" in
   let _ = prstr "ltyp 1 : " in
-  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in
+  let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
   let _ = prstr "\nltyp 2 : " in
-  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in
+  let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in
   let _ = prstr "\n" in
-
-
   let res =
     match ltyp1 with
       | [] -> 
           let isrec1 = (accrec1<>[]) in
           let isrec2 = find_app ind2name ltyp2 in
-          let _ = if isrec2 then prstr "  ISREC2 TRUE" else prstr "  ISREC2 FALSE" in
-          let _ = if isrec1 then prstr "  ISREC1 TRUE\n" else prstr "  ISREC1 FALSE\n" in
           let rechyps =
             if isrec1 && isrec2 
-            then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable
+            then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *)
+              merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 
+                filter_shift_stable_right
+              @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2]
+                filter_shift_stable
             else if isrec1 
                 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
-            then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",concl2])
-              filter_shift_stable
+            then  
+              merge_rec_hyps shift accrec1 
+                (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable
             else if isrec2
-            then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2
+            then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
               filter_shift_stable_right
-            else [] in
+            else ltyp2 in
           let _ = prstr"\nrechyps : " in
-          let _ = List.iter 
-            (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps in
+          let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in
           let _ = prstr "MERGE CONCL :  " in
           let _ = prNamedRConstr "concl1" concl1 in
           let _ = prstr " with " in
@@ -548,15 +639,22 @@ let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list)
           let _ = prstr "FIN " in
           let _ = prNamedRConstr "concl" concl in
           let _ = prstr "\n" in
+
           rechyps , concl
-      | (nme,t1)as e ::lt1 -> 
-          match t1 with
+      | (nme,None, Some t1)as e ::lt1 -> 
+          (match t1 with
             | RApp(_,f,carr) when isVarf ind1name f -> 
                 merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 
             | _ -> 
                 let recres, recconcl2 =
                   merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
-                ((nme,t1) :: recres) , recconcl2
+                ((nme,None,Some t1) :: recres) , recconcl2)            
+      | (nme,Some bd, None) ::lt1 -> 
+          (* FIXME: what if ind1name appears in bd? *)
+          let recres, recconcl2 =
+            merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
+          ((nme,Some bd,None) :: recres) , recconcl2
+      | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false
   in
   res
 
@@ -578,9 +676,9 @@ let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
 
 let build_link_map allargs1 allargs2 lnk =
   let allargs1 =
-    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in
+    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in
   let allargs2 =
-    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs2)) in
+    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
   build_link_map_aux allargs1 allargs2 lnk
 
 
@@ -598,7 +696,7 @@ let build_link_map allargs1 allargs2 lnk =
 
     forall recparams1 (recparams2 without linked params),
      forall ordparams1 (ordparams2 without linked params),
-      H1a' -> H2a' -> ...  -> H2a' -> H2b' -> ... 
+      H1a' -> H2a' -> ...  -> H2a' -> H2b'(shifted) -> ... 
         -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
 
     where Hix' have been adapted, ie: 
@@ -621,21 +719,27 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
     shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
   let nargs2 =
     shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
-  let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in
-  let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 in  
+  let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in
+  let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in  
   (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
   let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
   let rest2 = change_vars linked_map rest2 in
-  let hyps1,concl1 = raw_decompose_prod rest1 in
-  let hyps2,concl2' = raw_decompose_prod rest2 in
+  let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in
+  let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in
   let ltyp,concl2 = 
     merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
-  let typ = raw_compose_prod concl2 (List.rev ltyp) in
+  let _ = prNamedRLDecl "ltyp result:" ltyp in
+  let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in
   let revargs1 = 
     list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
+  let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
+  let _ = prNamedRLDecl "ltyp revargs1" revargs1 in
   let revargs2 = 
     list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
-  let typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) in
+  let _ = prNamedRLDecl "ltyp allargs2" allargs2 in
+  let _ = prNamedRLDecl "ltyp revargs2" revargs2 in
+  let typwithprms =
+    raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in
   typwithprms
 
 
@@ -661,22 +765,16 @@ let merge_constructor_id id1 id2 shift:identifier =
     constructor [(name*type)]. These are translated to rawterms
     first, each of them having distinct var names. *)
 let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * types) list) 
-    (typcstr2:(identifier * types) list) : (identifier * rawconstr) list =
+    (typcstr1:(identifier * rawconstr) list) 
+    (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
   List.flatten 
     (List.map
-        (fun (id1,typ1) -> 
-          let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in
-          let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in
-          let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in
+        (fun (id1,rawtyp1) -> 
           List.map
-            (fun (id2,typ2) -> 
-              let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in
-              (* Avoid also rawtyp1 names *)
-              let avoid2 = Idset.union avoid idsoftyp1 in
-              let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in
+            (fun (id2,rawtyp2) -> 
               let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
               let newcstror_id = merge_constructor_id id1 id2 shift in
+              let _ = prstr "\n**************\n" in
               newcstror_id , typ)
             typcstr2)
         typcstr1)
@@ -685,22 +783,33 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
     inductive bodies [oib1] and [oib2], linking with [lnk], params
     info in [shift], avoiding identifiers in [avoid]. *)
 let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
-    (oib2:one_inductive_body) : (identifier * rawconstr) list =
-  let lcstr1 = Array.to_list oib1.mind_user_lc in
-  let lcstr2 = Array.to_list oib2.mind_user_lc in
+    (oib2:one_inductive_body) =
+  (* building rawconstr type of constructors *)
+  let mkrawcor nme avoid typ = 
+    (* first replace rel 1 by a varname *)
+    let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
+    Detyping.detype false (Idset.elements avoid) [] substindtyp in
+  let lcstr1: rawconstr list = 
+    Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
+  (* add  to avoid all indentifiers of lcstr1 *)
+  let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
+  let lcstr2 = 
+    Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
+  let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
+
+  let params1 = 
+    try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) 
+    with _ -> [] in
+  let params2 = 
+    try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) 
+    with _ -> [] in
+
   let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
   let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
+
   cstror_suffix_init();
-  merge_constructors shift avoid lcstr1 lcstr2
+  params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2
 
-(** [build_raw_params prms_decl avoid] returns a list of variables
-    attributed to the list of decl [prms_decl], avoiding names in
-    [avoid]. *)
-let build_raw_params prms_decl avoid =
-  let dummy_constr = compose_prod prms_decl mkProp in
-  let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
-  let res,_ = raw_decompose_prod dummy_rawconstr in
-  res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
 
 (** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
     inductive bodies [mib1] and [mib2] linking vars with
@@ -708,42 +817,35 @@ let build_raw_params prms_decl avoid =
     For the moment, inductives are supposed to be non mutual.
 *)
 let rec merge_mutual_inductive_body
-    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) 
-    (shift:merge_infos) =
+    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
   (* Mutual not treated, we take first ind body of each. *)
-  let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *)
-  let prms1 = (* rec uniform parms of mib1 *)
-    List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in
-
-  (* useless: *)
-  let prms1_named,avoid' = build_raw_params prms1 [] in
-  let prms2_named,avoid = build_raw_params prms1 avoid' in
-  let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in  
-  (* *** *)
-
-  merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) 
+  merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) 
 
   
+let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
+  Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x
 
-let merge_rec_params_and_arity params1 params2 shift (concl:constr) = 
-  let params = shift.recprms1 @ shift.recprms2 in
-  let resparams, _ =
+let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = 
+  let params = prms2 @ prms1 in
+  let resparams =
     List.fold_left
-      (fun (acc,env) (nme,_,tp) -> 
-        let typ = Constrextern.extern_constr false env tp in
-        let newenv = Environ.push_rel (nme,None,tp) env in
-        LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv)
-      ([],Global.env())
-      params in
+      (fun acc (nme,tp) -> 
+        let _ = prstr "param :" in
+        let _ = prNamedRConstr (string_of_name nme) tp in
+        let _ = prstr "  ;  " in
+        let typ = rawterm_to_constr_expr tp in
+        LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
+      [] params in
   let concl = Constrextern.extern_constr false (Global.env()) concl in
   let arity,_ = 
     List.fold_left 
       (fun (acc,env) (nm,_,c) -> 
         let typ = Constrextern.extern_constr false env c in
         let newenv = Environ.push_rel (nm,None,c) env in
-        CProdN (dummy_loc, [[(dummy_loc,nm)],typ] , acc) , newenv)
+        CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
       (concl,Global.env())
-      (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in  
+      (shift.funresprms2 @ shift.funresprms1 
+        @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in  
   resparams,arity
 
   
@@ -752,20 +854,37 @@ let merge_rec_params_and_arity params1 params2 shift (concl:constr) =
     induct_expr corresponding to the the list of constructor types
     [rawlist], named ident.
     FIXME: params et cstr_expr (arity) *)
-let rawterm_list_to_inductive_expr mib1 mib2 shift
+let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
     (rawlist:(identifier * rawconstr) list):inductive_expr =
-  let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
-    Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in
   let lident = dummy_loc, shift.ident in
   let bindlist , cstr_expr = (* params , arities *)
-    merge_rec_params_and_arity 
-      mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in
+    merge_rec_params_and_arity prms1 prms2 shift mkSet in
   let lcstor_expr : (bool * (lident * constr_expr)) list  = 
     List.map (* zeta_normalize t ? *)
       (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
       rawlist in  
   lident , bindlist , cstr_expr , lcstor_expr
 
+
+
+let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+  match rdecl with
+    | (nme,None,t) -> 
+        let traw = Detyping.detype false [] [] t in
+        RProd (dummy_loc,nme,Explicit,traw,t2)
+    | (_,Some _,_) -> assert false
+
+
+
+
+let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+  match rdecl with
+    | (nme,None,t) -> 
+        let traw = Detyping.detype false [] [] t in
+        RProd (dummy_loc,nme,Explicit,traw,t2)
+    | (_,Some _,_) -> assert false
+
+
 (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
     variables specified in [lnk]. Graphs are not supposed to be mutual
     inductives for the moment. *)
@@ -777,35 +896,124 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
   (* compute params that become ordinary args (because linked to ord. args) *)
   let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
-  let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
-  let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in
+  let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
+  let _ = prstr "\nrawlist : " in
+  let _ = 
+    List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
+  let _ = prstr "\nend rawlist\n" in
+(* FIX: retransformer en constr ici
+   let shift_prm = 
+    { shift_prm with
+      recprms1=prms1;
+      recprms1=prms1;    
+    } in *)
+  let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
   (* Declare inductive *)
   Command.build_mutual [(indexpr,None)] true (* means: not coinductive *)
 
 
-
-let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id =
-  let env = Global.env() in
-  let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in
-  let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in
-  let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *)
-    Array.mapi (fun i c -> Unlinked) args1 in
-  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *)
-  let lnk2 = (* args2 may be linked to args1 members. FIXME: same 
-                as above: vars may be linked inside args2?? *)
+(* Find infos on identifier id. *)
+let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
+  let kn_of_id x =
+    let f_ref = Libnames.Ident (dummy_loc,x) in
+    locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref)
+      locate_constant f_ref in
+    try find_Function_infos (kn_of_id id)
+    with Not_found ->
+      errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme")
+
+(** [merge id1 id2 args1 args2 id] builds and declares a new inductive
+    type called [id], representing the merged graphs of both graphs
+    [ind1] and [ind2]. identifiers occuring in both arrays [args1] and
+    [args2] are considered linked (i.e. are the same variable) in the
+    new graph.
+    
+    Warning: For the moment, repetitions of an id in [args1] or
+    [args2] are not supported. *)
+let merge (id1:identifier) (id2:identifier) (args1:identifier array) 
+    (args2:identifier array) id : unit =
+  let finfo1 = find_Function_infos_safe id1 in
+  let finfo2 = find_Function_infos_safe id2 in
+  (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
+  (* We add one arg (functional arg of the graph) *)
+  let lnk1 = Array.make (Array.length args1 + 1) Unlinked in
+  let lnk2' = (* args2 may be linked to args1 members. FIXME: same 
+                 as above: vars may be linked inside args2?? *)
     Array.mapi
       (fun i c -> 
         match array_find args1 (fun i x -> x=c) with
           | Some j -> Linked j
           | None -> Unlinked) 
       args2 in
-  let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *)
-  let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in
-  resa
-
-
-
+  (* We add one arg (functional arg of the graph) *)
+  let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in
+  (* setting functional results *)
+  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in 
+  let _ = lnk2.(Array.length lnk2 - 1) <- Funres in
+  merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id
+
+
+let remove_last_arg c =
+  let (x,y) = decompose_prod c in
+  let xnolast = List.rev (List.tl (List.rev x)) in
+  compose_prod xnolast y
+
+let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l)
+let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l))
+
+let remove_last_n_arg n c =
+  let (x,y) = decompose_prod c in
+  let xnolast = remove_n_last_list n x in
+  compose_prod xnolast y
+
+(* [funify_branches relinfo nfuns branch] returns the branch [branch]
+   of the relinfo [relinfo] modified to fit in a functional principle.
+   Things to do: 
+    - remove indargs from rel applications
+    - replace *variables only* corresponding to function (recursive)
+      results by the actual function application. *)
+let funify_branches relinfo nfuns branch = 
+  let mut_induct, induct = 
+    match relinfo.indref with
+      | None -> assert false
+      | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind
+      | _ -> assert false in
+  let is_dom c =
+    match kind_of_term c with
+      | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct
+      | _ -> false in
+  let _dom_i c =
+    assert (is_dom c);
+    match kind_of_term c with
+      | Ind((u,i)) | Construct((u,_),i) -> i
+      | _ -> assert false in
+  let _is_pred c shift = 
+    match kind_of_term c with
+      | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
+      | _ -> false in
+  (* FIXME: *)
+  (Anonymous,Some mkProp,mkProp)
+  
 
+let relprinctype_to_funprinctype relprinctype nfuns =
+  let relinfo = compute_elim_sig relprinctype in
+  assert (not relinfo.farg_in_concl);
+  assert (relinfo.indarg_in_concl);
+  (* first remove indarg and indarg_in_concl *)
+  let relinfo_noindarg = { relinfo with
+    indarg_in_concl = false; indarg = None;
+    concl = remove_last_arg (pop relinfo.concl); } in
+  (* the nfuns last induction arguments are functional ones: remove them *)
+  let relinfo_argsok = { relinfo_noindarg with
+    nargs = relinfo_noindarg.nargs - nfuns;
+    (* args is in reverse order, so remove fst *)
+    args = remove_n_fst_list nfuns relinfo_noindarg.args;
+    concl = popn nfuns relinfo_noindarg.concl
+  } in
+  let new_branches = 
+    List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in
+  let relinfo_branches = { relinfo_argsok with branches = new_branches } in
+  relinfo_branches
 
 (* @article{ bundy93rippling,
     author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill",
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
index b34a1097..08a97fd2 100644
--- a/contrib/funind/rawterm_to_relation.ml
+++ b/contrib/funind/rawterm_to_relation.ml
@@ -368,7 +368,7 @@ let raw_push_named (na,raw_value,raw_typ) env =
   match na with 
     | Anonymous -> env 
     | Name id -> 
-	let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in 
+	let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in 
 	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in 
 	Environ.push_named (id,value,typ) env
 
@@ -398,12 +398,12 @@ let add_pat_variables pat typ env : Environ.env =
 	   | Anonymous -> assert false
 	   | Name id ->
 	       let new_t =  substl ctxt t in
-	       let new_v = option_map (substl ctxt) v in
+	       let new_v = Option.map (substl ctxt) v in
 	       observe (str "for variable " ++ Ppconstr.pr_id id ++  fnl () ++
 			  str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++
 			  str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++
-			  option_fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
-			  option_fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
+			  Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
+			  Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
 		       );
 	       (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
       )
@@ -446,7 +446,7 @@ let rec pattern_to_term_and_type env typ  = function
       let patl_as_term =
 	List.map2 (pattern_to_term_and_type env)  (List.rev cs_args_types)  patternl
       in
-      mkRApp(mkRRef(Libnames.ConstructRef constr),
+      mkRApp(mkRRef(ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
 
@@ -586,7 +586,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	    | RProd _ -> error "Cannot apply a type"
 	end (* end of the application treatement *) 
 
-    | RLambda(_,n,t,b) ->
+    | RLambda(_,n,_,t,b) ->
 	(* we first compute the list of constructor 
 	   corresponding to the body of the function, 
 	   then the one corresponding to the type 
@@ -601,7 +601,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	let new_env = raw_push_named (new_n,None,t) env in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_lam new_n) t_res b_res
-    | RProd(_,n,t,b) ->
+    | RProd(_,n,_,t,b) ->
 	(* we first compute the list of constructor 
 	   corresponding to the body of the function, 
 	   then the one corresponding to the type 
@@ -627,7 +627,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	in
 	let b_res = build_entry_lc new_env funnames avoid b in
 	combine_results (combine_letin n) v_res b_res
-    | RCases(_,_,el,brl) -> 
+    | RCases(_,_,_,el,brl) -> 
 	(* we create the discrimination function 
 	   and treat the case itself 
 	*)
@@ -689,7 +689,7 @@ let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return =
 	build_entry_lc env funnames  avoid b
     | RDynamic _ -> error "Not handled RDynamic"
 and build_entry_lc_from_case env funname make_discr
-    (el:tomatch_tuple)
+    (el:tomatch_tuples)
     (brl:Rawterm.cases_clauses) avoid : 
     rawconstr build_entry_return = 
   match el with 
@@ -865,7 +865,7 @@ let is_res id =
 *)
 let rec rebuild_cons nb_args relname args crossed_types depth rt = 
   match rt with 
-    | RProd(_,n,t,b) -> 
+    | RProd(_,n,k,t,b) -> 
 	let not_free_in_t id = not (is_free_in id t) in 
 	let new_crossed_types = t::crossed_types in 
 	begin
@@ -928,7 +928,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
 			(Idset.filter not_free_in_t id_to_exclude)
 		  | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	end
-    | RLambda(_,n,t,b) ->
+    | RLambda(_,n,k,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
@@ -944,7 +944,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
 		then 
 		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
 		else
-		  RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
 	    | _ -> anomaly "Should not have an anonymous function here" 
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
 	  
@@ -1016,11 +1016,12 @@ let rec compute_cst_params relnames params = function
       compute_cst_params_from_app [] (params,rtl)
   | RApp(_,f,args) -> 
       List.fold_left (compute_cst_params relnames) params (f::args)
-  | RLambda(_,_,t,b) | RProd(_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> 
+  | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> 
       let t_params = compute_cst_params relnames params t in 
       compute_cst_params relnames t_params b
-  | RCases _ -> params  (* If there is still cases at this point they can only be 
-			discriminitation ones *)
+  | RCases _ ->
+      params  (* If there is still cases at this point they can only be 
+		 discriminitation ones *)
   | RSort _ -> params
   | RHole _ -> params
   | RIf _ | RRec _ | RCast _ | RDynamic _  ->
@@ -1153,7 +1154,7 @@ let do_build_inductive
 	 else
 	   Topconstr.CProdN
 	   (dummy_loc,
-	    [[(dummy_loc,n)],Constrextern.extern_rawconstr Idset.empty t],
+	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
 	    acc
 	   )
       )
@@ -1173,7 +1174,7 @@ let do_build_inductive
 	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
 	 else
 	 Topconstr.LocalRawAssum 
-	   ([(dummy_loc,n)], Constrextern.extern_rawconstr Idset.empty t)
+	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
       )
       rels_params
   in 
@@ -1181,8 +1182,8 @@ let do_build_inductive
     Array.map (List.map 
       (fun (id,t) -> 
 	 false,((dummy_loc,id),
-		Options.with_option
-		  Options.raw_print
+		Flags.with_option
+		  Flags.raw_print
 		  (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
 	       )
       ))
@@ -1218,7 +1219,7 @@ let do_build_inductive
 (*   in *)
   let _time2 = System.get_time () in 
   try 
-    with_full_print (Options.silently (Command.build_mutual rel_inds)) true
+    with_full_print (Flags.silently (Command.build_mutual rel_inds)) true
   with 
     | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
index 113ddd8b..92396af5 100644
--- a/contrib/funind/rawtermops.ml
+++ b/contrib/funind/rawtermops.ml
@@ -12,10 +12,10 @@ let idmap_is_empty m = m = Idmap.empty
 let mkRRef ref = RRef(dummy_loc,ref)
 let mkRVar id = RVar(dummy_loc,id)
 let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl)
-let mkRLambda(n,t,b) = RLambda(dummy_loc,n,t,b)
-let mkRProd(n,t,b) = RProd(dummy_loc,n,t,b)
+let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b)
+let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b)
 let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b)
-let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl)
+let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl)
 let mkRSort s = RSort(dummy_loc,s)
 let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
 let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
@@ -26,27 +26,59 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
 *)
 let raw_decompose_prod = 
   let rec raw_decompose_prod args = function 
-  | RProd(_,n,t,b) -> 
+  | RProd(_,n,k,t,b) -> 
       raw_decompose_prod ((n,t)::args) b 
   | rt -> args,rt
   in
   raw_decompose_prod []
 
+let raw_decompose_prod_or_letin = 
+  let rec raw_decompose_prod args = function 
+  | RProd(_,n,k,t,b) -> 
+      raw_decompose_prod ((n,None,Some t)::args) b 
+  | RLetIn(_,n,t,b) -> 
+      raw_decompose_prod ((n,Some t,None)::args) b 
+  | rt -> args,rt
+  in
+  raw_decompose_prod []
+
 let raw_compose_prod = 
   List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
 
+let raw_compose_prod_or_letin = 
+  List.fold_left (
+      fun concl decl -> 
+	match decl with 
+	  | (n,None,Some t) -> mkRProd(n,t,concl)
+	  | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
+	  | _ -> assert false)
+
 let raw_decompose_prod_n n = 
   let rec raw_decompose_prod i args c = 
     if i<=0 then args,c
     else
       match c with
-	| RProd(_,n,t,b) -> 
+	| RProd(_,n,_,t,b) -> 
 	    raw_decompose_prod (i-1) ((n,t)::args) b 
 	| rt -> args,rt
   in
   raw_decompose_prod n []
 
 
+let raw_decompose_prod_or_letin_n n = 
+  let rec raw_decompose_prod i args c = 
+    if i<=0 then args,c
+    else
+      match c with
+	| RProd(_,n,_,t,b) -> 
+	    raw_decompose_prod (i-1) ((n,None,Some t)::args) b 
+	| RLetIn(_,n,t,b) -> 
+	    raw_decompose_prod (i-1) ((n,Some t,None)::args) b 
+	| rt -> args,rt
+  in
+  raw_decompose_prod n []
+
+
 let raw_decompose_app = 
   let rec decompose_rapp acc rt =
 (*     msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
@@ -103,15 +135,17 @@ let change_vars =
 	       change_vars mapping rt',
 	       List.map (change_vars mapping) rtl
 	      )
-      | RLambda(loc,name,t,b) -> 
+      | RLambda(loc,name,k,t,b) -> 
 	  RLambda(loc,
 		  name,
+		  k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
-      | RProd(loc,name,t,b) -> 
+      | RProd(loc,name,k,t,b) -> 
 	  RProd(loc,
 		  name,
+	          k,
 		  change_vars mapping t,
 		  change_vars (remove_name_from_mapping mapping name) b
 		 )
@@ -125,12 +159,12 @@ let change_vars =
 	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in 
 	  RLetTuple(loc,
 		    nal,
-		    (na, option_map (change_vars mapping) rto), 
+		    (na, Option.map (change_vars mapping) rto), 
 		    change_vars mapping b, 
 		    change_vars new_mapping e
 		   )
-      | RCases(loc,infos,el,brl) -> 
-	  RCases(loc,
+      | RCases(loc,sty,infos,el,brl) -> 
+	  RCases(loc,sty,
 		 infos,
 		 List.map (fun (e,x) -> (change_vars mapping e,x)) el, 
 		 List.map (change_vars_br mapping) brl
@@ -138,7 +172,7 @@ let change_vars =
       | RIf(loc,b,(na,e_option),lhs,rhs) -> 
 	  RIf(loc,
 	      change_vars mapping b,
-	      (na,option_map (change_vars mapping) e_option),
+	      (na,Option.map (change_vars mapping) e_option),
 	      change_vars mapping lhs,
 	      change_vars mapping rhs
 	     )
@@ -229,21 +263,21 @@ let rec alpha_rt excluded rt =
   let new_rt = 
     match rt with   
       | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
-      | RLambda(loc,Anonymous,t,b) -> 
+      | RLambda(loc,Anonymous,k,t,b) -> 
 	  let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in 
 	  let new_excluded = new_id :: excluded in 
 	  let new_t = alpha_rt new_excluded t in 
 	  let new_b = alpha_rt new_excluded b in 
-	  RLambda(loc,Name new_id,new_t,new_b)
-      | RProd(loc,Anonymous,t,b) -> 
+	  RLambda(loc,Name new_id,k,new_t,new_b)
+      | RProd(loc,Anonymous,k,t,b) -> 
 	let new_t = alpha_rt excluded t in 
 	let new_b = alpha_rt excluded b in 
-	RProd(loc,Anonymous,new_t,new_b)
+	RProd(loc,Anonymous,k,new_t,new_b)
     | RLetIn(loc,Anonymous,t,b) -> 
 	let new_t = alpha_rt excluded t in 
 	let new_b = alpha_rt excluded b in 
 	RLetIn(loc,Anonymous,new_t,new_b)
-    | RLambda(loc,Name id,t,b) -> 
+    | RLambda(loc,Name id,k,t,b) -> 
 	let new_id = Nameops.next_ident_away id excluded in 
 	let t,b = 
 	  if new_id = id 
@@ -255,8 +289,8 @@ let rec alpha_rt excluded rt =
 	let new_excluded = new_id::excluded in 
 	let new_t = alpha_rt new_excluded t in 
 	let new_b = alpha_rt new_excluded b in 
-	RLambda(loc,Name new_id,new_t,new_b)
-    | RProd(loc,Name id,t,b) -> 
+	RLambda(loc,Name new_id,k,new_t,new_b)
+    | RProd(loc,Name id,k,t,b) -> 
 	let new_id = Nameops.next_ident_away id excluded in 
 	let new_excluded = new_id::excluded in 
 	let t,b = 
@@ -268,7 +302,7 @@ let rec alpha_rt excluded rt =
 	in
 	let new_t = alpha_rt new_excluded t in 
 	let new_b = alpha_rt new_excluded b in 
-	RProd(loc,Name new_id,new_t,new_b)
+	RProd(loc,Name new_id,k,new_t,new_b)
     | RLetIn(loc,Name id,t,b) -> 
 	let new_id = Nameops.next_ident_away id excluded in 
 	let t,b = 
@@ -306,20 +340,20 @@ let rec alpha_rt excluded rt =
 	  if idmap_is_empty mapping
 	  then rto,t,b
 	  else let replace = change_vars mapping in 
-	  (option_map replace rto, t,replace b)
+	  (Option.map replace rto, t,replace b)
 	in
 	let new_t = alpha_rt new_excluded new_t in 
 	let new_b = alpha_rt new_excluded new_b in 
-	let new_rto = option_map (alpha_rt new_excluded) new_rto  in
+	let new_rto = Option.map (alpha_rt new_excluded) new_rto  in
 	RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
-    | RCases(loc,infos,el,brl) -> 
+    | RCases(loc,sty,infos,el,brl) -> 
 	let new_el = 
 	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el 
 	in 
-	RCases(loc,infos,new_el,List.map (alpha_br excluded) brl) 
+	RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) 
     | RIf(loc,b,(na,e_o),lhs,rhs) -> 
 	RIf(loc,alpha_rt excluded b,
-	    (na,option_map (alpha_rt excluded) e_o),
+	    (na,Option.map (alpha_rt excluded) e_o),
 	    alpha_rt excluded lhs,
 	    alpha_rt excluded rhs
 	   )
@@ -357,17 +391,16 @@ let is_free_in id =
     | REvar _ -> false
     | RPatVar _ -> false
     | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
-    | RLambda(_,n,t,b) | RProd(_,n,t,b) | RLetIn(_,n,t,b) ->
+    | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) ->
 	let check_in_b =
 	  match n with
 	    | Name id' -> id_ord id' id <> 0
 	    | _ -> true
 	in
 	is_free_in t || (check_in_b && is_free_in b)
-    | RCases(_,_,el,brl) ->
+    | RCases(_,_,_,el,brl) ->
 	(List.exists (fun (e,_) -> is_free_in e) el) ||
 	  List.exists is_free_in_br brl
-
     | RLetTuple(_,nal,_,b,t) -> 
 	let check_in_nal = 
 	  not (List.exists (function Name id' -> id'= id | _ -> false) nal) 
@@ -428,17 +461,19 @@ let replace_var_by_term x_id term =
 	       replace_var_by_pattern rt',
 	       List.map replace_var_by_pattern rtl
 	      )
-      | RLambda(_,Name id,_,_) when id_ord id x_id == 0 -> rt
-      | RLambda(loc,name,t,b) -> 
+      | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | RLambda(loc,name,k,t,b) -> 
 	  RLambda(loc,
 		  name,
+		  k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | RProd(_,Name id,_,_) when id_ord id x_id == 0 -> rt
-      | RProd(loc,name,t,b) -> 
+      | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | RProd(loc,name,k,t,b) -> 
 	  RProd(loc,
 		  name,
+	          k,
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
@@ -455,19 +490,19 @@ let replace_var_by_term x_id term =
       | RLetTuple(loc,nal,(na,rto),def,b) -> 
 	  RLetTuple(loc,
 		    nal,
-		    (na,option_map replace_var_by_pattern rto),
+		    (na,Option.map replace_var_by_pattern rto),
 		    replace_var_by_pattern def,
 		    replace_var_by_pattern b
 		   )
-      | RCases(loc,infos,el,brl) -> 
-	  RCases(loc,
+      | RCases(loc,sty,infos,el,brl) -> 
+	  RCases(loc,sty,
 		 infos,
 		 List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, 
 		 List.map replace_var_by_pattern_br brl
 		)
       | RIf(loc,b,(na,e_option),lhs,rhs) -> 
 	  RIf(loc, replace_var_by_pattern b,
-	      (na,option_map replace_var_by_pattern e_option),
+	      (na,Option.map replace_var_by_pattern e_option),
 	      replace_var_by_pattern lhs,
 	      replace_var_by_pattern rhs
 	     )
@@ -558,15 +593,15 @@ let ids_of_rawterm c =
       | RVar (_,id) -> id::acc
       | RApp (loc,g,args) -> 
           ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
-      | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
-      | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
       | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
       | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
       | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc
       | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
       | RLetTuple (_,nal,(na,po),b,c) -> 
           List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
-      | RCases (loc,rtntypopt,tml,brchl) -> 
+      | RCases (loc,sty,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 _) -> []
@@ -590,15 +625,17 @@ let zeta_normalize =
 	       zeta_normalize_term rt',
 	       List.map zeta_normalize_term rtl
 	      )
-      | RLambda(loc,name,t,b) -> 
+      | RLambda(loc,name,k,t,b) -> 
 	  RLambda(loc,
 		  name,
+		  k,
 		  zeta_normalize_term t,
 		  zeta_normalize_term b
 		 )
-      | RProd(loc,name,t,b) -> 
+      | RProd(loc,name,k,t,b) -> 
 	  RProd(loc,
-		name, 		  
+		name, 		
+	        k,
 		zeta_normalize_term t,
 		zeta_normalize_term b
 		 )
@@ -608,19 +645,19 @@ let zeta_normalize =
       | RLetTuple(loc,nal,(na,rto),def,b) -> 
 	  RLetTuple(loc,
 		    nal,
-		    (na,option_map zeta_normalize_term rto),
+		    (na,Option.map zeta_normalize_term rto),
 		    zeta_normalize_term def,
 		    zeta_normalize_term b
 		   )
-      | RCases(loc,infos,el,brl) -> 
-	  RCases(loc,
+      | RCases(loc,sty,infos,el,brl) -> 
+	  RCases(loc,sty,
 		 infos,
 		 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, 
 		 List.map zeta_normalize_br brl
 		)
       | RIf(loc,b,(na,e_option),lhs,rhs) -> 
 	  RIf(loc, zeta_normalize_term b,
-	      (na,option_map zeta_normalize_term e_option),
+	      (na,Option.map zeta_normalize_term e_option),
 	      zeta_normalize_term lhs,
 	      zeta_normalize_term rhs
 	     )
@@ -659,24 +696,23 @@ let expand_as =
 	    with Not_found -> rt 
 	  end
       | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
-      | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b)
-      | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b)
+      | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b)
+      | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b)
       | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
       | RLetTuple(loc,nal,(na,po),v,b) ->
-	  RLetTuple(loc,nal,(na,option_map (expand_as map) po),
+	  RLetTuple(loc,nal,(na,Option.map (expand_as map) po),
 		    expand_as map v, expand_as map b)
       | RIf(loc,e,(na,po),br1,br2) ->
-	  RIf(loc,expand_as map e,(na,option_map (expand_as map) po),
+	  RIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
 	      expand_as map br1, expand_as map br2)
       | RRec _ ->  error "Not handled RRec"
       | RDynamic _ -> error "Not handled RDynamic"
       | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t))
       | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce)
-      | RCases(loc,po,el,brl) ->
-	  RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+      | RCases(loc,sty,po,el,brl) ->
+	  RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
-	    
   and expand_as_br map (loc,idl,cpl,rt) = 
-    (loc,idl,cpl,    expand_as (List.fold_left add_as map cpl) rt)
+    (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
   in
   expand_as Idmap.empty 
diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli
index 9647640c..358c6ba6 100644
--- a/contrib/funind/rawtermops.mli
+++ b/contrib/funind/rawtermops.mli
@@ -22,7 +22,7 @@ val mkRApp  : rawconstr*(rawconstr list) -> rawconstr
 val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr
 val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr
 val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr
-val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr
+val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr
 val mkRSort : rawsort -> rawconstr 
 val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
 val mkRCast : rawconstr* rawconstr -> rawconstr 
@@ -31,8 +31,14 @@ val mkRCast : rawconstr* rawconstr -> rawconstr
   These are analogous to the ones constrs
 *)
 val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_decompose_prod_or_letin : 
+  rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr
 val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_decompose_prod_or_letin_n : int -> rawconstr -> 
+  (Names.name*rawconstr option*rawconstr option) list * rawconstr
 val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list  ->  rawconstr 
+val raw_compose_prod_or_letin: rawconstr -> 
+  (Names.name*rawconstr option*rawconstr option) list  ->  rawconstr
 val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list)
 
 
diff --git a/contrib/recdef/recdef.ml4 b/contrib/funind/recdef.ml
index 40832677..c9bf2f1f 100644
--- a/contrib/recdef/recdef.ml4
+++ b/contrib/funind/recdef.ml
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
+(* $Id: recdef.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
+
 open Term
 open Termops
 open Environ
@@ -25,6 +27,7 @@ open Typing
 open Tacmach
 open Tactics
 open Nametab
+open Decls
 open Declare
 open Decl_kinds
 open Tacred
@@ -67,7 +70,8 @@ let h_intros l =
 
 let do_observe_tac s tac g =
   let goal = begin (Printer.pr_goal (sig_it g)) end in
- try let v = tac g in msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); v
+ try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++
+    (str s)++(str " ")++(str "finished")); v
  with e ->
    msgnl (str "observation "++str s++str " raised exception " ++ 
 	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
@@ -106,7 +110,7 @@ let (teq_id:identifier) = hyp_id 15 hyp_ids;;
 let (pmax_id:identifier) = hyp_id 16 hyp_ids;;
 let (hle_id:identifier) = hyp_id 17 hyp_ids;;
 
-let message s = if Options.is_verbose () then msgnl(str s);;
+let message s = if Flags.is_verbose () then msgnl(str s);;
 
 let def_of_const t =
    match (kind_of_term t) with
@@ -146,9 +150,9 @@ let rank_for_arg_list h =
   | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
   rank_aux 0;;
 
-let rec (find_call_occs:
-	   constr -> constr -> (constr list ->constr)*(constr  list list)) =
- fun f expr ->
+let rec (find_call_occs : int -> constr -> constr -> 
+  (constr list -> constr) * constr list list) =
+ fun nb_lam f expr ->
   match (kind_of_term expr) with
     App (g, args) when g = f -> 
       (fun l -> List.hd l), [Array.to_list args]
@@ -159,7 +163,7 @@ let rec (find_call_occs:
        | a::upper_tl ->
          (match find_aux upper_tl with
           (cf, ((arg1::args) as args_for_upper_tl)) -> 
-           (match find_call_occs f a with
+           (match find_call_occs nb_lam f a with
              cf2, (_ :: _ as other_args) ->
                let rec avoid_duplicates args =
                   match args with
@@ -183,7 +187,7 @@ let rec (find_call_occs:
                      other_args'@args_for_upper_tl
            | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
 	 | _, [] ->
-	   (match find_call_occs f a with
+	   (match find_call_occs nb_lam f a with
 	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
 	   | _, [] -> (fun x -> a::upper_tl), [])) in
      begin
@@ -192,33 +196,48 @@ let rec (find_call_occs:
 	 | cf, args ->
 	     (fun l -> mkApp (g, Array.of_list (cf l))), args
      end
-  | Rel(_) -> error "find_call_occs : Rel"
+  | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[])
   | Var(id) -> (fun l -> expr), []
   | Meta(_) -> error "find_call_occs : Meta"
   | Evar(_) -> error "find_call_occs : Evar"
-  | Sort(_)  -> error "find_call_occs : Sort"
-  | Cast(b,_,_) -> find_call_occs f b
+  | Sort(_)  -> (fun l -> expr), []
+  | Cast(b,_,_) -> find_call_occs nb_lam f b
   | Prod(_,_,_) -> error "find_call_occs : Prod"
-  | Lambda(_,_,_) -> error "find_call_occs : Lambda"
-  | LetIn(_,_,_,_) -> error "find_call_occs : let in"
+  | Lambda(na,t,b) -> 
+      begin
+	match find_call_occs (succ nb_lam) f b with 
+	  | _, [] ->  (* Lambda are authorized as long as they do not contain 
+			 recursives calls *)
+	      (fun l -> expr),[]
+	  | _ ->  error "find_call_occs : Lambda"
+      end
+  | LetIn(na,v,t,b) -> 
+      begin
+	match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with 
+	  | (_,[]),(_,[]) -> 
+	      ((fun l -> expr), [])
+	  | (_,[]),(cf,(_::_ as l)) -> 
+	      ((fun  l -> mkLetIn(na,v,t,cf l)),l)
+	  | (cf,(_::_ as l)),(_,[]) -> 
+	      ((fun l -> mkLetIn(na,cf l,t,b)), l)
+	  | _ -> error "find_call_occs : LetIn"
+      end
   | Const(_) -> (fun l -> expr), []
   | Ind(_) -> (fun l -> expr), []
   | Construct (_, _) -> (fun l -> expr), []
   | Case(i,t,a,r) ->
-      (match find_call_occs f a with
+      (match find_call_occs nb_lam f a with
 	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
-      | _ -> (fun l -> mkCase(i, t, a, r)),[])
+      | _ -> (fun l -> expr),[])
   | Fix(_) -> error "find_call_occs : Fix"
   | CoFix(_) -> error "find_call_occs : CoFix";;
 
-
-
 let coq_constant s =
   Coqlib.gen_constant_in_modules "RecursiveDefinition" 
     (Coqlib.init_modules @ Coqlib.arith_modules) s;;
 
 let constant sl s =
-  constr_of_reference
+  constr_of_global
     (locate (make_qualid(Names.make_dirpath 
 			   (List.map id_of_string (List.rev sl)))
 	       (id_of_string s)));;
@@ -257,8 +276,8 @@ let acc_inv_id = function () -> (coq_constant "Acc_inv")
 let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
 let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded")
 let max_ref = function () -> (find_reference ["Recdef"] "max")
-let iter = function () -> (constr_of_reference (delayed_force iter_ref))
-let max_constr = function () -> (constr_of_reference (delayed_force max_ref))
+let iter = function () -> (constr_of_global (delayed_force iter_ref))
+let max_constr = function () -> (constr_of_global (delayed_force max_ref))
 
 let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
 let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
@@ -268,44 +287,61 @@ let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
 let nat = function () -> (coq_constant "nat")
 let lt = function () -> (coq_constant "lt")
 
+(* This is simply an implementation of the case_eq tactic.  this code
+  should be replaced with the tactic defined in Ltac in Init/Tactics.v *)
 let  mkCaseEq a  : tactic =
      (fun g ->
-	(* commentaire de Yves: on pourra avoir des problemes si
-	   a n'est pas bien type dans l'environnement du but *)
        let type_of_a = pf_type_of g a in
-       (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])])
-	  (tclTHEN 
-	     (fun g2 ->
-		change_in_concl None 
-		  (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
-		  g2)
-	     (simplest_case a))) g);;
-
-let rec  mk_intros_and_continue (extra_eqn:bool)
-    cont_function (eqs:constr list) (expr:constr) g =
-  match kind_of_term expr with
-    | Lambda (n, _, b) -> 
-     	let n1 = 
-	  match n with
-      	      Name x -> x
-            | Anonymous -> ano_id
-	in
-     	let new_n = pf_get_new_id n1 g in
-	  tclTHEN (h_intro new_n)
-	    (mk_intros_and_continue extra_eqn cont_function eqs 
-	       (subst1 (mkVar new_n) b)) g
-    | _ -> 
- 	if extra_eqn then
+       tclTHENLIST
+         [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
+          (fun g2 ->
+	    change_in_concl None 
+	     (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
+		  g2);
+	  simplest_case a] g);;
+
+(* This is like the previous one except that it also rewrite on all
+  hypotheses except the ones given in the first argument.  All the
+  modified hypotheses are generalized in the process and should be
+  introduced back later; the result is the pair of the tactic and the
+  list of hypotheses that have been generalized and cleared. *)
+let mkDestructEq :
+  identifier list -> constr -> goal sigma -> tactic * identifier list =
+  fun not_on_hyp expr g ->
+  let hyps = pf_hyps g in 
+  let to_revert = 
+    Util.map_succeed 
+      (fun (id,_,t) -> 
+        if List.mem id not_on_hyp || not (Termops.occur_term expr t)
+        then failwith "is_expr_context";
+        id) hyps in
+  let to_revert_constr = List.rev_map mkVar to_revert in 
+  let type_of_expr = pf_type_of g expr in
+  let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
+           to_revert_constr in
+    tclTHENLIST
+     [h_generalize new_hyps;
+      (fun g2 ->
+	change_in_concl None 
+	  (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
+      simplest_case expr], to_revert
+
+let rec  mk_intros_and_continue thin_intros (extra_eqn:bool)
+    cont_function (eqs:constr list) nb_lam (expr:constr) g =
+  let finalize () =  	if extra_eqn then
 	  let teq = pf_get_new_id teq_id g in
 	    tclTHENLIST
 	      [ h_intro teq;
+		thin thin_intros;
+		h_intros thin_intros;
+		
 		tclMAP 
-		  (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) 
+		  (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) 
 		  (List.rev eqs);
 		(fun g1 -> 
 		   let ty_teq = pf_type_of g1 (mkVar teq) in 
 		   let teq_lhs,teq_rhs = 
-		     let _,args = destApp ty_teq in 
+		     let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in 
 		     args.(1),args.(2) 
 		   in
 	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
@@ -313,22 +349,44 @@ let rec  mk_intros_and_continue (extra_eqn:bool)
 	      ]
 	      g
 	else
-	  cont_function eqs expr g
-
+	  tclTHENSEQ[
+	    thin thin_intros;
+	    h_intros thin_intros;
+	    cont_function eqs expr 
+	  ] g
+  in
+  if nb_lam = 0 
+  then finalize () 
+  else
+    match kind_of_term expr with
+      | Lambda (n, _, b) -> 
+     	  let n1 = 
+	    match n with
+      		Name x -> x
+              | Anonymous -> ano_id
+	  in
+     	  let new_n = pf_get_new_id n1 g in
+	  tclTHEN (h_intro new_n)
+	    (mk_intros_and_continue thin_intros extra_eqn cont_function eqs 
+	       (pred nb_lam) (subst1 (mkVar new_n) b)) g
+      | _ -> 
+	  assert false 
+(* 	  finalize () *)
 let const_of_ref = function
     ConstRef kn -> kn
   | _ -> anomaly "ConstRef expected"
 
-let simpl_iter () =
+let simpl_iter clause =
   reduce 
-    (Lazy 
+    (Lazy
        {rBeta=true;rIota=true;rZeta= true; rDelta=false;
         rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
-    onConcl
+(*     (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *)
+    clause
 
 (* The boolean value is_mes expresses that the termination is expressed
   using a measure function instead of a well-founded relation. *)
-let tclUSER is_mes l g = 
+let tclUSER tac is_mes l g = 
   let clear_tac = 
     match l with 
       | None -> h_clear true []
@@ -338,8 +396,11 @@ let tclUSER is_mes l g =
     [
       clear_tac;
       if is_mes 
-      then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))]
-      else tclIDTAC
+      then tclTHEN
+             (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
+                                      (delayed_force ltof_ref))])
+             tac
+      else tac
     ]
     g
     
@@ -358,22 +419,22 @@ let base_leaf_terminate (func:global_reference) eqs expr =
 	   [k';h] -> k',h
 	 | _ -> assert false
      in
-     tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr]));
-		  observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O]));
-		  observe_tac "intro k" (h_intro k');
-                  observe_tac "case on k" 
-		      (tclTHENS 
-			 (simplest_case (mkVar k'))
-			 [(tclTHEN (h_intro h) 
-		     	     (tclTHEN (simplest_elim 
-					 (mkApp (delayed_force gt_antirefl,
-						 [| delayed_force coq_O |])))
-				default_auto)); tclIDTAC ]);
-                  intros;
-		  simpl_iter();
-		  unfold_constr func;
-                  list_rewrite true eqs;
-		  default_auto ] g);;
+     tclTHENLIST
+     [observe_tac "first split" (split (ImplicitBindings [expr]));
+      observe_tac "second split"
+        (split (ImplicitBindings [delayed_force coq_O]));
+      observe_tac "intro k" (h_intro k');
+      observe_tac "case on k" 
+        (tclTHENS (simplest_case (mkVar k'))
+        [(tclTHEN (h_intro h) 
+          (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
+					 [| delayed_force coq_O |])))
+            default_auto)); tclIDTAC ]);
+      intros;
+      simpl_iter onConcl;
+      unfold_constr func;
+      list_rewrite true eqs;
+      default_auto] g);;
 
 (* La fonction est donnee en premier argument a la 
    fonctionnelle suivie d'autres Lambdas et de Case ...
@@ -402,8 +463,7 @@ let rec compute_le_proofs = function
 	      apply_with_bindings
 		(le_trans,
 		 ExplicitBindings[dummy_loc,NamedHyp m_id,a])
-		g
-	   )
+		g)
 	   [compute_le_proofs tl; 
             tclORELSE (apply (delayed_force le_n)) assumption])
 
@@ -436,10 +496,10 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
 	   Nameops.out_name k_na,Nameops.out_name def_na
 	 in
 	 tclTHENS
-	   (general_rewrite_bindings false
+	   (general_rewrite_bindings false all_occurrences
 	      (mkVar eq,
 	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
-				dummy_loc, NamedHyp def_id, mkVar def]))
+				dummy_loc, NamedHyp def_id, mkVar def]) false)
 	   [list_cond_rewrite k def pmax eqs le_proofs;
             observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
       ) 
@@ -469,12 +529,12 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
 	     ];
 	   observe_tac "clearing k " (clear [k]);
 	   observe_tac "intros k h' def" (h_intros [k;h';def]);
-	   observe_tac "simple_iter" (simpl_iter());
+	   observe_tac "simple_iter" (simpl_iter onConcl);
 	   observe_tac "unfold functional" 
-	     (unfold_in_concl[([1],evaluable_of_global_reference func)]);
+	     (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
 	   observe_tac "rewriting equations" 
 	     (list_rewrite true eqs);
-           observe_tac "cond rewrite" (list_cond_rewrite  k def bound cond_eqs le_proofs);
+           observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite  k def bound cond_eqs le_proofs);
 	   observe_tac "refl equal" (apply (delayed_force refl_equal))] g
   | spec1::specs ->
       fun g ->
@@ -498,7 +558,7 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
 	     (mkVar pmax) ((mkVar pmax)::le_proofs)
 	     (heq::cond_eqs)] g;;
     
-let string_match  s =
+let string_match s =
   if String.length s < 3 then failwith "string_match";
   try 
     for i = 0 to 3  do
@@ -513,7 +573,7 @@ let retrieve_acc_var g =
     (fun id -> string_match (string_of_id id);id)
     hyps 
 
-let rec introduce_all_values is_mes acc_inv func context_fn
+let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
     eqs  hrec args values specs =
     (match args with
     [] -> 
@@ -530,16 +590,19 @@ let rec introduce_all_values is_mes acc_inv func context_fn
 	let hspec = next_global_ident_away true hspec_id ids in
 	let tac =  
 	  observe_tac "introduce_all_values" (
-	    introduce_all_values is_mes acc_inv func context_fn eqs
+	    introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
 	      hrec args
 	      (rec_res::values)(hspec::specs)) in
 	(tclTHENS
-	   (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))))
+	   (observe_tac "elim h_rec" 
+	      (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
+	   )
 	   [tclTHENLIST [h_intros [rec_res; hspec];
 			 tac]; 
 	    (tclTHENS
 		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
-		 [ observe_tac "h_assumption" h_assumption
+		 [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
+		    (observe_tac "h_assumption" h_assumption)
 		 ;
 		  tclTHENLIST
 		    [
@@ -547,6 +610,7 @@ let rec introduce_all_values is_mes acc_inv func context_fn
 		      observe_tac "user proof" 
 			(fun g ->  
 			   tclUSER
+			     concl_tac
 			     is_mes
 			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
 			     g
@@ -559,70 +623,61 @@ let rec introduce_all_values is_mes acc_inv func context_fn
     )
  
 	   
-let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr =
-  match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with
+let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
+  match find_call_occs 0 f_constr expr with
   | context_fn, args ->
       observe_tac "introduce_all_values" 
-	(introduce_all_values is_mes acc_inv func context_fn eqs  hrec args  [] [])
+	(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
 
-let proveterminate is_mes acc_inv (hrec:identifier)  
+let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)  
   (f_constr:constr) (func:global_reference) base_leaf rec_leaf = 
   let rec proveterminate (eqs:constr list) (expr:constr)  =
     try
       (*  let _ = msgnl (str "entering proveterminate") in *)
       let v =
-	match (kind_of_term expr) with
-	    Case (_, t, a, l) -> 
-	      (match find_call_occs f_constr a with
-		   _,[] ->
-      		     tclTHENS 
-		       (fun g ->
-			  (* let _ = msgnl(str "entering mkCaseEq") in *)
-			  let v = (mkCaseEq a) g in 
-			  (* let _ = msgnl (str "exiting mkCaseEq") in *)
-			  v
-		       )
-   	               (List.map 
-			  (mk_intros_and_continue true proveterminate eqs)
-			  (Array.to_list l)
-		       )
-		 | _, _::_ -> 
-		     (
-		       match find_call_occs  f_constr expr with
-	     		   _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
-			 | _, _:: _ -> 
-			     observe_tac "rec_leaf" 
-			       (rec_leaf is_mes acc_inv hrec  func eqs expr)
-		     )
-	      )
-	  | _ ->  (match find_call_occs  f_constr expr with
-	     	       _,[] -> 
-			 (try 
-			    observe_tac "base_leaf" (base_leaf func eqs expr)
-			  with e -> 
-			    (msgerrnl (str "failure in base case");raise e ))
-		     | _, _::_ -> 
-			 observe_tac "rec_leaf" 
-			   (rec_leaf is_mes acc_inv hrec  func eqs expr)
-		  ) in
-      (*  let _ = msgnl(str "exiting proveterminate") in *)
+        match (kind_of_term expr) with
+	  Case (ci, t, a, l) -> 
+	  (match find_call_occs 0 f_constr a with
+	    _,[] ->
+	    (fun g -> 
+	      let destruct_tac, rev_to_thin_intro =
+                mkDestructEq rec_arg_id a g in 
+		tclTHENS destruct_tac
+		  (list_map_i 
+		    (fun i -> mk_intros_and_continue 
+				(List.rev rev_to_thin_intro) 
+				true 
+				proveterminate 
+				eqs
+				ci.ci_cstr_nargs.(i))
+		    0 (Array.to_list l)) g)
+		  | _, _::_ -> 
+		    (match find_call_occs  0 f_constr expr with
+	     	      _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
+		    | _, _:: _ -> 
+		      observe_tac "rec_leaf" 
+		      (rec_leaf is_mes acc_inv hrec  func eqs expr)))
+	  | _ ->
+            (match find_call_occs  0 f_constr expr with
+	      _,[] -> 
+	      (try observe_tac "base_leaf" (base_leaf func eqs expr)
+	       with e -> (msgerrnl (str "failure in base case");raise e ))
+	    | _, _::_ -> 
+	      observe_tac "rec_leaf"
+	        (rec_leaf is_mes acc_inv hrec func eqs expr)) in
       v
-    with e -> 
-      begin 
-	msgerrnl(str "failure in proveterminate"); 
-	raise e
-      end
+    with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
   in 
   proveterminate 
 
-let hyp_terminates func = 
-  let a_arrow_b = arg_type (constr_of_reference func) in 
-  let rev_args,b = decompose_prod a_arrow_b in 
+let hyp_terminates nb_args func = 
+  let a_arrow_b = arg_type (constr_of_global func) in 
+  let rev_args,b = decompose_prod_n nb_args a_arrow_b in 
   let left = 
     mkApp(delayed_force iter, 
 	  Array.of_list 
 	    (lift 5 a_arrow_b:: mkRel 3::
-	       constr_of_reference func::mkRel 1::
+	       constr_of_global func::mkRel 1::
 	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
 	    )
 	 )
@@ -647,11 +702,10 @@ let hyp_terminates func =
 	     
 
 
-let tclUSER_if_not_mes is_mes names_to_suppress = 
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = 
   if is_mes 
-  then 
-    tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings))
-  else tclUSER is_mes names_to_suppress
+  then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
+  else tclUSER concl_tac is_mes names_to_suppress
 
 let termination_proof_header is_mes input_type ids args_id relation
     rec_arg_num rec_arg_id tac wf_tac : tactic = 
@@ -710,8 +764,7 @@ let termination_proof_header is_mes input_type ids args_id relation
 		 (* this gives the accessibility argument *)
 		 observe_tac 
 		   "apply wf_thm" 
-		   (h_apply ((mkApp(mkVar wf_thm,
-				    [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+		   (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
 		   )
 	       ]
 	     ;
@@ -720,13 +773,13 @@ let termination_proof_header is_mes input_type ids args_id relation
 	       [observe_tac "generalize" 
 		  (onNLastHyps (nargs+1)
 		     (fun (id,_,_) -> 
-			tclTHEN (generalize [mkVar id]) (h_clear false [id])
+			tclTHEN (h_generalize [mkVar id]) (h_clear false [id])
 		     ))
 	       ;
 		observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
 		h_intros args_id;
 		h_intro wf_rec_arg;
-		observe_tac "tac" (tac hrec acc_inv)
+		observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
 	       ]
 	   ]
 	) g  
@@ -743,18 +796,18 @@ let rec instantiate_lambda t l =
 ;;
 
 
-let whole_start is_mes func input_type relation rec_arg_num  : tactic = 
+let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic = 
   begin 
     fun g -> 
       let ids = ids_of_named_context (pf_hyps g) in
-      let func_body = (def_of_const (constr_of_reference func)) in
+      let func_body = (def_of_const (constr_of_global func)) 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_names_types,_ = decompose_lam_n nb_args body1 in 
       let n_ids,ids = 
 	List.fold_left 
 	  (fun (n_ids,ids) (n_name,_) -> 
@@ -777,30 +830,29 @@ let whole_start is_mes func input_type relation rec_arg_num  : tactic =
 	relation 
 	rec_arg_num
 	rec_arg_id
-	(fun hrec acc_inv g ->  
+	(fun rec_arg_id hrec acc_inv g ->  
            (proveterminate 
+	      [rec_arg_id]
 	      is_mes
 	      acc_inv 
 	      hrec
 	      (mkVar f_id)
 	      func
 	      base_leaf_terminate 
-	      rec_leaf_terminate
+	      (rec_leaf_terminate (mkVar f_id) concl_tac)
 	      []
 	      expr
 	   )
 	     g 
 	)
-	tclUSER_if_not_mes 
+	(tclUSER_if_not_mes concl_tac)
 	g 
   end
 
-
 let get_current_subgoals_types () = 
   let pts =  get_pftreestate () in 
   let _,subs = extract_open_pftreestate pts in 
-  List.map snd (List.sort (fun (x,_) (y,_) -> x -y )subs )
-
+  List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs )
 
 let build_and_l l = 
   let and_constr =  Coqlib.build_coq_and () in 
@@ -814,7 +866,7 @@ let build_and_l l =
 	let c,tac,nb = f pl in 
 	mk_and p1 c, 
 	tclTHENS
-	  (apply (constr_of_reference conj_constr)) 
+	  (apply (constr_of_global conj_constr)) 
 	  [tclIDTAC;
 	   tac
 	  ],nb+1
@@ -849,23 +901,24 @@ let build_new_goal_type () =
   res
   
 
-    
+    (*
 let prove_with_tcc lemma _ : tactic = 
   fun gls ->
     let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
     tclTHENSEQ 
       [
-	generalize [lemma];
+	h_generalize [lemma];
 	h_intro hid;
 	Elim.h_decompose_and (mkVar hid); 
 	gen_eauto(* default_eauto *) false (false,5) [] (Some [])
 	  (* 	      default_auto *)
       ]
       gls
+    *)
       
 	     
 
-let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal)   = 
+let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   = 
   let current_proof_name = get_current_proof_name () in
   let name = match goal_name with 
     | Some s -> s 
@@ -879,14 +932,58 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
   if occur_existential gls_type then
     Util.error "\"abstract\" cannot handle existentials";
   let hook _ _ = 
+    let opacity = 
+      let na_ref = Libnames.Ident (dummy_loc,na) in 
+      let na_global = Nametab.global na_ref in
+      match na_global with 
+	  ConstRef c -> 
+	    let cb = Global.lookup_constant c in 
+	    if cb.Declarations.const_opaque then true 
+	    else begin  match cb.const_body with None -> true | _ -> false end 
+	| _ -> anomaly "equation_lemma: not a constant"
+    in
     let lemma = mkConst (Lib.make_con na) in 
-    Array.iteri 
-      (fun i _ -> 
-	 by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i)))
-      (Array.make nb_goal ())
-    ;
-    ref := Some lemma ;
-    defined ();
+    ref_ := Some lemma ;
+    let lid = ref [] in 
+    let h_num = ref (-1) in 
+    Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
+    build_proof 
+      (  fun gls ->
+	   let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
+	   tclTHENSEQ 
+	     [
+	       h_generalize [lemma];
+	       h_intro hid;
+	       (fun g -> 
+		  let ids = pf_ids_of_hyps g in 
+		  tclTHEN
+		    (Elim.h_decompose_and (mkVar hid))
+		    (fun g -> 
+		       let ids' = pf_ids_of_hyps g in 
+		       lid := List.rev (list_subtract ids' ids);
+		       if !lid = [] then lid := [hid];
+(* 		       list_iter_i  *)
+(* 			 (fun i v ->  *)
+(* 			    msgnl (str "hyp" ++ int i ++ str " " ++  *)
+(* 				     Nameops.pr_id v ++ fnl () ++ fnl())) *)
+(* 			      !lid; *)
+		       tclIDTAC g
+		    )
+		    g
+	       ); 
+	     ] gls)
+      (fun g ->
+	 match kind_of_term (pf_concl g) with
+	   | App(f,_) when eq_constr f (well_founded ()) ->
+	       Auto.h_auto None [] (Some [])  g
+	   | _ ->
+	       incr h_num;
+	       tclTHEN
+		 (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
+		 e_assumption
+      		 g)
+;
+    Command.save_named opacity;
   in
   start_proof
     na
@@ -904,7 +1001,7 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
 	      (fun c -> 
 		 tclTHENSEQ
 		   [intros; 
-		    h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); 
+		    h_simplest_apply (interp_constr Evd.empty (Global.env()) c); 
 		    tclCOMPLETE Auto.default_auto
 		   ]
 	      )
@@ -913,11 +1010,13 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
 	g);
   try
     by tclIDTAC; (* raises UserError _ if the proof is complete *)
-    if Options.is_verbose () then (pp (Printer.pr_open_subgoals()))
+    if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
   with UserError _ -> 
     defined ()
   
-    
+;;    
+
+
 let com_terminate 
     tcc_lemma_name 
     tcc_lemma_ref 
@@ -926,21 +1025,29 @@ let com_terminate
     input_type
     relation 
     rec_arg_num
-    thm_name using_lemmas hook =
-  let (evmap, env) = Command.get_current_context() in
-  start_proof thm_name
-    (Global, Proof Lemma) (Environ.named_context_val env)
-    (hyp_terminates fonctional_ref) hook;
-  by (observe_tac "whole_start" (whole_start is_mes fonctional_ref
-				       input_type relation rec_arg_num ));
+    thm_name using_lemmas 
+    nb_args
+    hook =
+  let start_proof (tac_start:tactic) (tac_end:tactic) = 
+    let (evmap, env) = Command.get_current_context() in
+    start_proof thm_name
+      (Global, Proof Lemma) (Environ.named_context_val env)
+      (hyp_terminates nb_args fonctional_ref) hook;
+    by (observe_tac "starting_tac" tac_start);
+    by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
+				   input_type relation rec_arg_num ))
+    
+  in
+  start_proof tclIDTAC tclIDTAC;
   try 
     let new_goal_type = build_new_goal_type () in 
-    open_new_goal using_lemmas tcc_lemma_ref
+    open_new_goal start_proof using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
       (new_goal_type)
   with Failure "empty list of subgoals!" -> 
     (* a non recursive function declared with measure ! *)
     defined ()
+    
 
     
 
@@ -964,7 +1071,7 @@ let (value_f:constr list -> global_reference -> constr) =
     in
     let fun_body = 
       RCases
-	(d0,None,
+	(d0,RegularStyle,None,
 	 [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l),
 	  (Anonymous,None)],
 	 [d0, [v_id], [PatCstr(d0,(ind_of_ref 
@@ -978,7 +1085,7 @@ let (value_f:constr list -> global_reference -> constr) =
       List.fold_left2 
 	(fun acc x_id a -> 
 	   RLambda
-      	     (d0, Name x_id, RDynamic(d0, constr_in a),
+      	     (d0, Name x_id, Explicit, RDynamic(d0, constr_in a),
 	      acc
 	     ) 
 	)
@@ -1000,27 +1107,24 @@ let (declare_f : identifier -> logical_kind -> constr list -> global_reference -
   fun f_id kind input_type fterm_ref ->
     declare_fun f_id kind (value_f input_type fterm_ref);;
 
+let rec n_x_id ids n =
+  if n = 0 then []
+  else let x = next_global_ident_away true x_id ids in
+          x::n_x_id (x::ids) (n-1);;
+
 let start_equation (f:global_reference) (term_f:global_reference) 
   (cont_tactic:identifier list -> tactic) g =
   let ids = pf_ids_of_hyps g in
-  let terminate_constr = constr_of_reference term_f in 
+  let terminate_constr = constr_of_global term_f in 
   let nargs = nb_prod (type_of_const terminate_constr) in 
-  let x = 
-    let rec f ids n =
-      if n = 0 
-      then []
-      else 
-	let x = next_global_ident_away true x_id ids in 
-	x::f (x::ids) (n-1)
-    in
-    f ids nargs
-  in
+  let x = n_x_id ids nargs in
   tclTHENLIST [
     h_intros x;
-    observe_tac "unfold_constr f" (unfold_constr f);
-    observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))));
-    observe_tac "prove_eq" (cont_tactic x)] g
-;;
+    unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)];
+    observe_tac "simplest_case" 
+      (simplest_case (mkApp (terminate_constr,
+                             Array.of_list (List.map mkVar x))));
+    observe_tac "prove_eq" (cont_tactic x)] g;;
 
 let base_leaf_eq func eqs f_id g =
   let ids = pf_ids_of_hyps g in
@@ -1039,37 +1143,40 @@ let base_leaf_eq func eqs f_id g =
 	   (mkApp(mkVar heq1, 
 		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
 		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
-      simpl_iter();
-      unfold_in_concl [([1], evaluable_of_global_reference func)];
+      simpl_iter onConcl;
+      tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
       list_rewrite true eqs;
       apply (delayed_force refl_equal)] g;;
 
 let f_S t = mkApp(delayed_force coq_S, [|t|]);;
 
-let rec introduce_all_values_eq  cont_tac functional termine 
+
+let rec introduce_all_values_eq cont_tac functional termine 
     f p heq1 pmax bounds le_proofs eqs ids =
   function
       [] ->
+       let heq2 = next_global_ident_away true heq_id ids in
 	tclTHENLIST
-	  [tclTHENS
+	  [forward None (IntroIdentifier heq2)
+             (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
+           simpl_iter (onHyp heq2);
+           unfold_in_hyp [((true,[1]), evaluable_of_global_reference 
+                             (global_of_constr functional))]
+             ((all_occurrences_expr, heq2), Tacexpr.InHyp);
+           tclTHENS
 	     (fun gls -> 
-		let t_eq = compute_renamed_type gls (mkVar heq1) in 
-		let k_id,def_id = 
-		  let k_na,_,t = destProd t_eq in 
-		  let _,_,t  = destProd t in 
-		  let def_na,_,_ = destProd t in 
-		  Nameops.out_name k_na,Nameops.out_name def_na
+		let t_eq = compute_renamed_type gls (mkVar heq2) in 
+		let def_id = 
+		  let _,_,t  = destProd t_eq in let def_na,_,_ = destProd t in 
+		  Nameops.out_name def_na
 		in
-		general_rewrite_bindings false
-		(mkVar heq1,
-		 ExplicitBindings[dummy_loc,NamedHyp k_id,
-				  f_S(f_S(mkVar pmax));
-				  dummy_loc,NamedHyp def_id,
-				  f]) gls )
+		observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences
+		(mkVar heq2,
+		 ExplicitBindings[dummy_loc,NamedHyp def_id,
+				  f]) false) gls)
 	     [tclTHENLIST
-		[simpl_iter();
-		 unfold_constr (reference_of_constr functional);
-		 list_rewrite true eqs; cont_tac pmax le_proofs];
+		[observe_tac "list_rewrite" (list_rewrite true eqs);
+                 cont_tac pmax le_proofs];
 	      tclTHENLIST[apply (delayed_force le_lt_SS);
 			compute_le_proofs le_proofs]]]
     | arg::args ->
@@ -1102,8 +1209,9 @@ let rec introduce_all_values_eq  cont_tac functional termine
 		tclTHENLIST
 		  [cont_tac pmax' le_proofs';
 		   h_intros [heq;heq2];
-		   rewriteLR (mkVar heq2);
-		   tclTHENS
+		   observe_tac ("rewriteRL " ^ (string_of_id heq2))
+                     (tclTRY (rewriteLR (mkVar heq2)));
+		   tclTRY (tclTHENS
 		     ( fun g -> 
 			 let t_eq = compute_renamed_type g (mkVar heq) in 
 			 let k_id,def_id = 
@@ -1112,18 +1220,20 @@ let rec introduce_all_values_eq  cont_tac functional termine
 			   let def_na,_,_ = destProd t in 
 			   Nameops.out_name k_na,Nameops.out_name def_na
 			 in
-			 general_rewrite_bindings false
-			   (mkVar heq,
+			 let c_b = (mkVar heq,
 			    ExplicitBindings
 			      [dummy_loc, NamedHyp k_id,
 			       f_S(mkVar pmax');
-			       dummy_loc, NamedHyp def_id, f]) 
-			   g
+			       dummy_loc, NamedHyp def_id, f])
+			 in
+			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences
+								       c_b false))
+			     g
 		     )
 		     [tclIDTAC;
 		      tclTHENLIST
 			[apply (delayed_force le_lt_n_Sm);
-			 compute_le_proofs le_proofs']]])
+			 compute_le_proofs le_proofs']])])
 	     functional termine f p heq1 new_pmax
 	     (p'::bounds)((mkVar pmax)::le_proofs) eqs
              (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
@@ -1141,84 +1251,95 @@ let rec_leaf_eq termine f ids functional eqs expr fn args =
   let hle1 = next_global_ident_away true hle_id ids in
   let ids = hle1::ids in
     tclTHENLIST
-      [h_intros [v;hex];
+      [observe_tac "intros v hex" (h_intros [v;hex]);
        simplest_elim (mkVar hex);
        h_intros [p;heq1];
-       generalize [mkApp(delayed_force le_n,[|mkVar p|])];
+       h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
        h_intros [hle1];
-       introduce_all_values_eq
+       observe_tac "introduce_all_values_eq" (introduce_all_values_eq
 	 (fun _ _ -> tclIDTAC)
-	 functional termine f p heq1 p [] [] eqs ids args;
-       apply (delayed_force refl_equal)]
+	 functional termine f p heq1 p [] [] eqs ids args);
+       observe_tac "failing here" (apply (delayed_force refl_equal))]
 
 let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
-    (eqs:constr list)
-  (expr:constr) =
-  tclTRY
-    (match kind_of_term expr with
-      Case(_,t,a,l) ->
-	(match find_call_occs f a with
-	     _,[] -> 
-	       tclTHENS(mkCaseEq a)(* (simplest_case a) *)
-	  	 (List.map
-		    (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true
-		       (prove_eq  termine f functional) eqs expr))
-		    (Array.to_list l))
+    (eqs:constr list) (expr:constr) =
+(*   tclTRY *)
+  (match kind_of_term expr with
+     Case(ci,t,a,l) ->
+     (match find_call_occs 0 f a with
+	_,[] -> 
+	(fun g -> 
+	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in 
+	  tclTHENS
+            destruct_tac
+	    (list_map_i  
+	       (fun i -> mk_intros_and_continue
+                          (List.rev rev_to_thin_intro) true 
+			  (prove_eq termine f functional)  
+			  eqs ci.ci_cstr_nargs.(i))
+	       0 (Array.to_list l)) g)
 	   | _,_::_ ->
-               	(match find_call_occs f expr with
-	     _,[] -> base_leaf_eq functional eqs f
-	   | fn,args ->
-	       fun g ->
-		 let ids = ids_of_named_context (pf_hyps g) in
-	       rec_leaf_eq termine f ids
-		 (constr_of_reference functional)
-		 eqs expr fn args g))
+	      (match find_call_occs 0 f expr with
+		_,[] -> base_leaf_eq functional eqs f
+	      | fn,args ->
+	        fun g ->
+		  let ids = ids_of_named_context (pf_hyps g) in
+	          rec_leaf_eq termine f ids
+		    (constr_of_global functional)
+		    eqs expr fn args g))
        | _ -> 
-	   (match find_call_occs f expr with
+	   (match find_call_occs 0 f expr with
 		_,[] -> base_leaf_eq functional eqs f
 	      | fn,args ->
 		  fun g ->
 		    let ids = ids_of_named_context (pf_hyps g) in
 		    observe_tac "rec_leaf_eq" (rec_leaf_eq  
-		      termine f ids (constr_of_reference functional)
+		      termine f ids (constr_of_global functional)
 		      eqs expr fn args) g));;
 
 let (com_eqn : identifier ->
        global_reference -> global_reference -> global_reference
 	 -> constr -> unit) =
   fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
+    let opacity = 
+      match terminate_ref with 
+	| ConstRef c -> 	      
+	    let cb = Global.lookup_constant c in 
+	    if cb.Declarations.const_opaque then true 
+	    else begin match cb.const_body with None -> true | _ -> false end 
+	| _ -> anomaly "terminate_lemma: not a constant"
+    in 
     let (evmap, env) = Command.get_current_context() in
-    let f_constr = (constr_of_reference f_ref) in
+    let f_constr = (constr_of_global f_ref) in
     let equation_lemma_type = subst1 f_constr equation_lemma_type in
     (start_proof eq_name (Global, Proof Lemma)
        (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
      by
        (start_equation f_ref terminate_ref
-	  (fun x ->
+	  (fun  x ->
 	     prove_eq 
-	       (constr_of_reference terminate_ref)
+	       (constr_of_global terminate_ref)
 	       f_constr 
 	       functional_ref
 	       []
 	       (instantiate_lambda
-	       	  (def_of_const (constr_of_reference functional_ref))
+	       	  (def_of_const (constr_of_global functional_ref))
 	       	  (f_constr::List.map mkVar x)
 	       )
 	  )
        );
-(*      (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); 
-     Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript);
-*)
-     Options.silently defined (); 
+(*      (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
+(*      Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
+     Flags.silently (fun () ->Command.save_named opacity) () ;  
+(*      Pp.msgnl (str "eqn finished"); *)
+    
     );;
 
-
 let nf_zeta env =       
   Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
     env
     Evd.empty
 
-
 let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq 
     generate_induction_principle using_lemmas : unit =
   let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
@@ -1232,7 +1353,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let res = 
 (*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
 (*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
-(*     Pp.msgnl (str "eq' := " ++ Printer.pr_lconstr_env env eq' ++ fnl () ++str (string_of_int rec_arg_num)); *)
+(*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
     match kind_of_term eq' with 
       | App(e,[|_;_;eq_fix|]) -> 
 	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
@@ -1259,31 +1380,33 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
     let term_ref = Nametab.locate (make_short_qualid term_id) in
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
 (*     message "start second proof"; *)
-    let continue = ref true in 
+    let stop = ref false in 
     begin 
       try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
       with e -> 
 	begin 
 	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
-	  then (Pp.msgnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); continue := false)
-	  else (ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
-	  anomaly "Cannot create equation Lemma")
+	  then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e)
+	  else anomaly "Cannot create equation Lemma"
+	  ;
+(* 	  ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *)
+	  stop := true;
 	end
     end;
-    if !continue 
+    if not !stop
     then
-    let eq_ref = Nametab.locate (make_short_qualid equation_id ) in
-    let f_ref = destConst (constr_of_reference f_ref) 
-    and functional_ref = destConst (constr_of_reference functional_ref) 
-    and eq_ref = destConst (constr_of_reference eq_ref) in
-    generate_induction_principle f_ref tcc_lemma_constr
-     functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
-     if Options.is_verbose ()
-     then msgnl (h 1 (Ppconstr.pr_id function_name ++ 
-			spc () ++ str"is defined" )++ fnl () ++ 
-		   h 1 (Ppconstr.pr_id equation_id ++ 
-			  spc () ++ str"is defined" )
-		  )
+      let eq_ref = Nametab.locate (make_short_qualid equation_id ) in
+      let f_ref = destConst (constr_of_global f_ref) 
+      and functional_ref = destConst (constr_of_global functional_ref) 
+      and eq_ref = destConst (constr_of_global eq_ref) in
+      generate_induction_principle f_ref tcc_lemma_constr
+	functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
+      if Flags.is_verbose ()
+      then msgnl (h 1 (Ppconstr.pr_id function_name ++ 
+			 spc () ++ str"is defined" )++ fnl () ++ 
+		    h 1 (Ppconstr.pr_id equation_id ++ 
+			   spc () ++ str"is defined" )
+		 )
   in
   try 
     com_terminate 
@@ -1294,7 +1417,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       relation rec_arg_num
       term_id
       using_lemmas
-      hook 
+      (List.length res_vars)
+      hook
   with e -> 
     begin
       ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
@@ -1303,22 +1427,4 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
     end
 
 
-VERNAC COMMAND EXTEND RecursiveDefinition
-  [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
-     constr(proof) integer_opt(rec_arg_num) constr(eq) ] ->
-  [ 
-    warning "Recursive Definition is obsolete. Use Function instead";
-    ignore(proof);ignore(wf);
-    let rec_arg_num = 
-      match rec_arg_num with 
-	| None -> 1
-	| Some n -> n 
-    in
-    recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _  _ _ _ -> ()) []]
-| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
-     "[" ne_constr_list(proof) "]" constr(eq) ] ->
-  [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq  (fun  _ _  _ _ _ _ _ _ -> ()) []]
-END
-
-
 
diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4
deleted file mode 100644
index 5d19079b..00000000
--- a/contrib/funind/tacinv.ml4
+++ /dev/null
@@ -1,872 +0,0 @@
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*s FunInv Tactic: inversion following the shape of a function.  *)
-
-(* Deprecated: see indfun_main.ml4 instead *)
-
-(* Don't delete this file yet, it may be used for other purposes *)
-
-(*i*)
-open Termops
-open Equality
-open Names
-open Pp
-open Tacmach
-open Proof_type
-open Tacinterp
-open Tactics
-open Tacticals
-open Term
-open Util
-open Printer
-open Reductionops
-open Inductiveops
-open Coqlib
-open Refine
-open Typing
-open Declare
-open Decl_kinds
-open Safe_typing
-open Vernacinterp
-open Evd
-open Environ
-open Entries
-open Setoid_replace
-open Tacinvutils
-(*i*)
-
-module Smap = Map.Make(struct type t = constr let compare = compare end)
-let smap_to_list m = Smap.fold (fun c cb l -> (c,cb)::l) m []
-let merge_smap m1 m2 = Smap.fold (fun c cb m -> Smap.add c cb m) m1 m2
-let rec listsuf i l = if i<=0 then l else listsuf (i-1) (List.tl l)
-let rec listpref i l = if i<=0 then [] else List.hd l :: listpref (i-1) (List.tl l)
-let rec split3 l = 
-  List.fold_right (fun (e1,e2,e3) (a,b,c) -> (e1::a),(e2::b),(e3::c)) l ([],[],[])
-
-let mkthesort = mkProp (* would like to put Type here, but with which index? *)
-
-(*  this is the prefix used to name equality hypothesis generated by
-    case analysis*)
-let equality_hyp_string = "_eg_"
-
-(* bug de refine: on doit ssavoir sur quelle hypothese on se trouve. valeur
-   initiale au debut de l'appel a la fonction proofPrinc: 1. *)
-let nthhyp = ref 1
-
-let debug i = prstr ("DEBUG "^ string_of_int i ^"\n")
-let pr2constr = (fun c1 c2 -> prconstr c1; prstr " <---> "; prconstr c2)
-(* Operations on names *)
-let id_of_name = function
-    Anonymous -> id_of_string "H"
-  | Name id   -> id;;
-let string_of_name nme = string_of_id (id_of_name nme)
- (*end debugging *)
-
-(* Interpretation of constr's *)
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-(*s specific manipulations on constr *)
-let lift1_leqs leq=
- List.map 
-  (function (r,(typofg,g,d)) 
-      -> lift 1 r, (lift 1 typofg, lift 1 g , lift 1 d)) leq
-
-let lift1_relleqs leq= List.map (function (r,x) -> lift 1 r,x) leq
-
-(* WARNING: In the types, we don't lift the rels in the type. This is
-   intentional. Use with care. *)
-let lift1_lvars lvars= List.map 
- (function x,(nme,c) -> lift 1 x, (nme, (*lift 1*) c)) lvars
-
-let pop1_levar levars = List.map (function ev,tev -> ev, popn 1 tev) levars
-
-
-let rec add_n_dummy_prod t n = 
- if n<=0 then t
- else add_n_dummy_prod (mkNamedProd (id_of_string "DUMMY") mkthesort t) (n-1)
-
-(* [add_lambdas t gl [csr1;csr2...]] returns [[x1:type of csr1]
-   [x2:type of csr2] t [csr <- x1 ...]], names of abstracted variables
-   are not specified *)
-let rec add_lambdas t gl lcsr =
- match lcsr with
-  | [] -> t
-  | csr::lcsr' -> 
-     let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
-     lambda_id hyp_csr hyptyp (add_lambdas t gl lcsr')
-
-(* [add_pis t gl [csr1;csr2...]] returns ([x1] :type of [csr1]
-   [x2]:type of csr2) [t]*)
-let rec add_pis t gl lcsr =
- match lcsr with
-  | [] -> t
-  | csr::lcsr' -> 
-     let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
-     prod_id hyp_csr hyptyp (add_pis t gl lcsr')
-
-let mkProdEg teq eql eqr concl =
- mkProd (name_of_string "eg", mkEq teq eql eqr, lift 1 concl)
-
-let eqs_of_beqs x = 
- List.map (function (_,(a,b,c)) -> (Anonymous, mkEq a b c)) x
-
-
-let rec eqs_of_beqs_named_aux s i l =
- match l with 
-  | [] -> []
-  | (r,(a,b,c))::l' -> 
-     (Name(id_of_string (s^ string_of_int i)), mkEq a b c)
-     ::eqs_of_beqs_named_aux s (i-1) l'
-
-
-let eqs_of_beqs_named s l = eqs_of_beqs_named_aux s (List.length l) l
-
-let rec patternify ltypes c nme =
- match ltypes with
-  | [] -> c
-  | (mv,t)::ltypes' -> 
-     let c'= substitterm 0 mv (mkRel 1) c in
-     let tlift = lift (List.length ltypes') t in
-     let res = 
-      patternify ltypes' (mkLambda (newname_append nme "rec", tlift, c')) nme in
-     res
-
-let rec npatternify ltypes c =
- match ltypes with
-  | [] -> c
-  | (mv,nme,t)::ltypes' -> 
-     let c'= substitterm 0 mv (mkRel 1) c in
-     let tlift = lift (List.length ltypes') t in
-     let res = 
-      npatternify ltypes' (mkLambda (newname_append nme "", tlift, c')) in
-     res
-
-(* fait une application (c m1 m2...mn, où mi est une evar, on rend également
-   la liste des evar munies de leur type) *)
-let rec apply_levars c lmetav =
- match lmetav with
-  | [] -> [],c
-  | (i,typ) :: lmetav' -> 
-     let levars,trm = apply_levars c lmetav' in
-     let exkey = mknewexist() in
-     ((exkey,typ)::levars),  applistc trm [mkEvar exkey]
-      (* EXPERIMENT le refine est plus long si on met un cast:
-         ((exkey,typ)::levars), mkCast ((applistc trm [mkEvar exkey]),typ) *)
-
-
-let prod_change_concl c newconcl = 
- let lv,_ = decompose_prod c in prod_it  newconcl lv
-
-let lam_change_concl c newconcl = 
- let lv,_ = decompose_prod c in lam_it newconcl lv
-
-
-let rec mkAppRel c largs n =
- match largs with
-  | [] -> c
-  | arg::largs' -> 
-     let newc = mkApp (c,[|(mkRel n)|]) in mkAppRel newc largs' (n-1)
-
-let applFull c typofc =
- let lv,t = decompose_prod typofc in 
- let ltyp = List.map fst lv in 
- let res = mkAppRel c ltyp (List.length ltyp) in
- res
-
-(* Take two terms with same structure and return a map of deBruijn from the
-   first to the second. Only DeBruijn should be different between the two
-   terms. *)
-let rec build_rel_map typ type_of_b = 
- match (kind_of_term typ), (kind_of_term type_of_b) with
-    Evar _ , Evar _  -> Smap.empty
-  | Const c1, Const c2  when c1=c2 -> Smap.empty
-  | Ind c1, Ind c2 when c1=c2 -> Smap.empty
-  | Rel i, Rel j when i=j -> Smap.empty
-  | Rel i, Rel j -> Smap.add typ type_of_b Smap.empty
-  | Prod (name,c1,c2), Prod (nameb,c1b,c2b) -> 
-     let map1 = build_rel_map c1 c1b in
-     let map2 = build_rel_map (pop c2) (pop c2b) in
-     merge_smap map1 map2
-  | App (f,args), App (fb,argsb) when Array.length args = Array.length argsb ->
-     build_rel_map_list (Array.to_list args) (Array.to_list argsb)
-  | _,_ -> failwith ("Could not generate case annotation. "^
-    "Incompatibility between annotation and actual type")
-
-and build_rel_map_list ltyp ltype_of_b =
- List.fold_left2 (fun a b c -> merge_smap a (build_rel_map b c))
-  Smap.empty ltyp ltype_of_b
-
-
-(*s Use (and proof) of the principle *)
-
-(* This is the type of the argument of [proofPrinc] *)
-
-type mimickinfo =
-    {
-     concl: constr; (* conclusion voulue, cad (xi:ti)gl, ou gl est le but a
-                       prouver, et xi:ti correspondent aux arguments donnés à
-                       la tactique.  On enlèvera un produit à chaque fois
-                       qu'on rencontrera un binder, sans lift ou pop.
-                       Initialement: une seule conclusion, puis specifique à
-                       chaque branche. *)
-     absconcl: constr array; (* conclusions patternisées pour pouvoir être
-                                appliquées = un predicat pour chaque fixpt
-                                mutuel. *)
-     mimick: constr; (* le terme qu'on imite. On plongera  dedans au fur et
-                        à mesure, sans lift ni pop. *)
-     env: env; (* The global typing environment, we will add thing in it when
-                  going inside the term (push_rel, push_rec_types) *)
-     sigma: Evd.evar_map; 
-     nmefonc: constr array; (* la constante correspondant à la fonction
-                               appelée, permet de remplacer les appels
-                               recursifs par des appels à la constante
-                               correspondante (non pertinent (et inutile) si
-                               on permet l'appel de la tactique sur une terme
-                               donné directement (au lieu d'une constante
-                               comme pour l'instant)). *)
-     fonc: int * int; (* bornes des indices des variable correspondant aux
-                         appels récursifs (plusieurs car fixp.  mutuels),
-                         utile pour reconnaître les appels récursifs
-                         (ATTENTION: initialement vide, reste vide tant qu'on
-                         n'est pas dans un fix).  *)
-     doeqs: bool; (* this reference is to toggle building of equalities during
-                    the building of the principle (default is true) *)
-     fix: bool; (* did I already went through a fix or case constr? lambdas
-                  found before a case or a fix are treated as parameters of
-                  the induction principle *)
-     lst_vars: (constr*(name*constr)) list ; (* Variables rencontrées jusque là *)
-     lst_eqs: (Term.constr * (Term.constr * Term.constr * Term.constr)) list ; 
-                                   (* liste d'équations engendrées au cours du
-                                      parcours, cette liste grandit à chaque
-                                      case, et il faut lifter le tout à chaque
-                                      binder *)
-     lst_recs: constr list ; (* appels récursifs rencontrés jusque là *)
-    }
-
-(* This is the return type of [proofPrinc] *)
-type 'a funind = (* 'A = CONTR  OU  CONSTR ARRAY *)
-    {
-
-     princ:'a; (* le (ou les) principe(s) demandé(s), il contient des meta
-                  variables représentant soit des trous à prouver plus tard,
-                  soit les conclusions à compléter avant de rendre le terme
-                  (suivant qu'on utilise le principe pour faire refine ou
-                  functional scheme). Il y plusieurs conclusions si plusieurs
-                  fonction mutuellement récursives) voir la suite. *)
-     evarlist: (constr*Term.types) list; (* [(ev1,tev1);(ev2,tev2)...]]
-                                            l'ensemble des meta variables
-                                            correspondant à des trous. [evi]
-                                            est la meta variable, [tevi] est
-                                            son type. *)
-     hypnum: (int*int*int) list; (* [[(in,jn,kn)...]] sont les nombres
-                                    respectivement de variables, d'équations,
-                                    et d'hypothèses de récurrence pour le but
-                                    n. Permet de faire le bon nombre d'intros
-                                    et des rewrite au bons endroits dans la
-                                    suite. *)
-     mutfixmetas: constr array ; (* un tableau de meta variables correspondant
-                                    à chacun des prédicats mutuellement
-                                    récursifs construits. *)
-     conclarray: types array; (* un tableau contenant les conclusions
-                                 respectives de chacun des prédicats
-                                 mutuellement récursifs. Permet de finir la
-                                 construction du principe. *)
-     params:(constr*name*constr) list; (* [[(metavar,param,tparam)..]] la
-                                          liste des paramètres (les lambdas
-                                          au-dessus du fix) du fixpoint si
-                                          fixpoint il y a, le paramètre est
-                                          une meta var, dont on stocke le nom
-                                          et le type. TODO: utiliser la
-                                          structure adequat? *)
-    }
-
-
-
-let empty_funind_constr =
-    {
-     princ = mkProp;
-     evarlist = [];
-     hypnum = [];
-     mutfixmetas = [||];
-     conclarray = [||];
-     params = []
-    }
-
-let empty_funind_array =
-    { empty_funind_constr with
-     princ = [||];
-    }
-
-(* Replace the calls to the function (recursive calls) by calls to the
-   corresponding constant  *)
-let replace_reccalls mi b =
- let d,f = mi.fonc in 
- let res = ref b in
- let _ = for i = d to f do 
-   res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in
- !res
- 
-
-
-(* collects all information of match branches stored in [l] *)
-let rec collect_cases l =
- match l with
-  | [||] -> empty_funind_array
-  | arr -> 
-     let x = arr.(0) in
-     let resrec = collect_cases (Array.sub arr 1 (Array.length arr - 1)) in
-     { x with
-      princ= Array.append [|x.princ|] resrec.princ;
-      evarlist = x.evarlist@resrec.evarlist;
-      hypnum = x.hypnum@resrec.hypnum;
-     }
-
-let collect_pred l = 
- let l1,l2,l3 = split3 l in
- Array.of_list l1 , Array.of_list l2 , Array.of_list l3
-
-
-(* [build_pred n tarr] builds the right predicates for each element of [tarr]
-   (of type: [type array] of size [n]). Return the list of triples: 
-   (?i , 
-   fun (x1:t1) ... (xn:tn) => (?i x1...xn) ,
-   forall (x1:t1) ... (xn:tn), (?i x1...xn)),
-   where ti's are deduced from elements of tarr, which are of the form:
-   t1 -> t2 -> ... -> tn -> <nevermind>. *)
-let rec build_pred n tarr =
- if n >= Array.length tarr (* iarr *) then []
- else
-   let ftyp = Array.get tarr n in
-   let gl = mknewmeta() in
-   let gl_app = applFull gl ftyp in
-   let pis = prod_change_concl ftyp gl_app in
-   let gl_abstr = lam_change_concl ftyp gl_app in
-   (gl,gl_abstr,pis):: build_pred (n+1) tarr
-
-
-let heq_prefix = "H_eq_"
-
-type kind_of_hyp = Var | Eq  (*| Rec*)
-
-(* the main function, build the principle by exploring the term and reproduce
-   the same structure. *)
-let rec proofPrinc mi: constr funind =
- match kind_of_term mi.mimick with
-    (* Fixpoint: we reproduce the Fix, fonc becomes (1,nbofmutf) to point on
-       the name of recursive calls *) 
-  | Fix((iarr,i),(narr,tarr,carr)) -> 
-     (* We construct the right predicates for each mutual fixpt *)
-     let evararr,newabsconcl,pisarr = collect_pred (build_pred 0 tarr) in
-     let newenv = push_rec_types (narr,tarr,carr) mi.env in
-     let anme',aappel_rec,llevar,llposeq = 
-      collect_fix mi 0 iarr narr carr pisarr newabsconcl newenv in
-     let anme = Array.map (fun nme -> newname_append nme "_ind") anme' in
-     { 
-      princ = mkFix((iarr,i),(anme, pisarr,aappel_rec));
-      evarlist= pop1_levar llevar; (* llevar are put outside the fix, so we pop 1 *)
-      hypnum = llposeq;
-      mutfixmetas = evararr;
-      conclarray = pisarr;
-      params = []
-     }
-  (* <pcase> Cases b of arrPt end.*)
-  | Case (cinfo, pcase, b, arrPt) -> 
-     let prod_pcase,_ = decompose_lam pcase in
-     let _nmeb,_ = List.hd prod_pcase in
-     let newb'= apply_leqtrpl_t b mi.lst_eqs in
-     let type_of_b = Typing.type_of mi.env mi.sigma b in
-     (* Replace the recursive calls to the function by calls to the constant *)
-     let newb = replace_reccalls mi newb' in     
-     let cases = collect_cases (Array.mapi (fold_proof mi b type_of_b newb) arrPt) in
-     (* the match (case) annotation must be transformed, see [build_pcase] below *)
-     let newpcase = build_pcase mi pcase b type_of_b newb in
-     let trm' = mkCase (cinfo,newpcase,newb, cases.princ) in
-    { cases with
-     princ = if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) else trm';
-     params = [] (* FIX: fix parms here (fixpt inside a match)*)
-    }
-
-
-  | Lambda(nme, typ, cstr) ->
-     let _, _, cconcl = destProd mi.concl in
-     let d,f=mi.fonc in
-     let newenv = push_rel (nme,None,typ) mi.env in
-     let newlst_var = (* if this lambda is a param, then don't add it here *)
-      if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars mi.lst_vars
-      else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars mi.lst_vars in
-     let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv;
-      fonc = (if d > 0 then d+1 else 0) , (if f > 0 then f+1 else 0);
-      lst_vars = newlst_var ; lst_eqs = lift1_leqs mi.lst_eqs;
-      lst_recs = lift1L mi.lst_recs} in
-     let resrec = proofPrinc newmi in
-     (* are we inside a fixpoint or a case? then this is a normal lambda *)
-     if mi.fix 
-     then { resrec with princ = mkLambda (nme,typ,resrec.princ) ; params = [] }
-     else (* otherwise this is a parameter *)
-       let metav = mknewmeta() in
-       let substmeta t = popn 1 (substitterm 0 (mkRel 1) metav t) in
-       { resrec with
-        princ = substmeta resrec.princ;
-        evarlist = List.map (fun (ev,tev) -> ev, substmeta tev) resrec.evarlist;
-        conclarray = Array.map substmeta resrec.conclarray;
-        params = (metav,nme,typ) :: resrec.params
-       }
-
-
-  | LetIn(nme,cstr1, typ, cstr) ->
-     failwith ("I don't deal with let ins yet. "^
-				 "Please expand them before applying this function.")
-
-  | u -> 
-     let varrels = List.rev (List.map fst mi.lst_vars) in
-     let varnames = List.map snd mi.lst_vars in
-     let nb_vars = List.length varnames in
-     let nb_eqs = List.length mi.lst_eqs in
-     let _eqrels = List.map fst mi.lst_eqs in
-     (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs
-        trouvés dans les let in et les Cases avec ceux trouves dans u (ie
-        mi.mimick). *)
-     (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *)
-     let terms_recs = mi.lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in
-     (*c construction du terme: application successive des variables, des
-       egalites et des appels rec, a la variable existentielle correspondant a
-       l'hypothese de recurrence en cours. *)
-     (* d'abord, on fabrique les types des appels recursifs en replacant le nom
-        de des fonctions par les predicats dans [terms_recs]: [(f_i t u v)]
-        devient [(P_i t u v)] *)
-     (* TODO optimiser ici: *)
-     let appsrecpred = exchange_reli_arrayi_L mi.absconcl mi.fonc terms_recs in
-     let typeofhole''  = prod_it_anonym_lift mi.concl appsrecpred in
-     let typeofhole    = prodn nb_vars varnames typeofhole'' in
-     (* Un bug de refine m'oblige à mettre ici un H (meta variable à ce point,
-        mais remplacé par H avant le refine) au lieu d'un '?', je mettrai les
-        '?'  à la fin comme ça [(([H1,H2,H3...] ...) ? ? ?)] *)
-     let newmeta = mknewmeta() in
-     let concl_with_var = applistc newmeta varrels in
-     let conclrecs = applistc concl_with_var terms_recs in
-     { empty_funind_constr with
-      princ = conclrecs;
-      evarlist = [ newmeta , typeofhole ];
-      hypnum = [ nb_vars , List.length terms_recs , nb_eqs ];
-      conclarray = mi.absconcl;
-     }
-
-     
-(* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant
-   l'annotation de type du case [pcase] contient des lambdas supplémentaires
-   en tête. Je les récupère dans la variable [suppllam_pcase]. Le problème est
-   que la conclusion de l'annotation du nouveauacse doit faire référence à ces
-   variables plutôt qu'à celle de l'exterieur. Ce qui suit permet de changer
-   les reference de newpcase' pour pointer vers les lambda du piquant. On
-   procède comme suit: on repère les rels qui pointent à l'interieur de
-   l'annotation dans la fonction initiale et on les relie à celle du type
-   voulu pour le case, pour ça ([build_rel_map]) on parcourt en même temps le
-   dernier lambda du piquant ([typ]) (qui contient le type de l'argument du
-   case) et le type attendu pour le case ([type_of_b]) et on construit un
-   map. Ensuite on remplace les rels correspondant dans la preuve construite
-   en suivant le map. *)
-     
-and build_pcase mi pcase b type_of_b newb =
-     let prod_pcase,_ = decompose_lam pcase in
-     let nme,typ = List.hd prod_pcase in
-     (* je remplace b par rel1 (apres avoir lifte un coup) dans la future
-        annotation du futur case: ensuite je mettrai un lambda devant *)
-     let typeof_case'' = substitterm 0 (lift 1 b) (mkRel 1) (lift 1 mi.concl) in
-     let suppllam_pcase = List.tl prod_pcase in
-     let suppllam_pcasel = List.length suppllam_pcase  in
-     let rel_smap = 
-      if suppllam_pcasel=0 then Smap.empty else (* FIX: is this test necessary ? *)
-        build_rel_map (lift suppllam_pcasel type_of_b) typ in
-     let newpcase''' =  
-      Smap.fold (fun e e' acc -> substitterm 0 e (lift 1 e') acc)
-       rel_smap typeof_case'' in
-     let neweq = mkEq (lift (suppllam_pcasel + 1) type_of_b) 
-      (lift (suppllam_pcasel + 1) newb) (mkRel 1) in
-     let newpcase'' = 
-      if mi.doeqs 
-      then mkProd (name_of_string "eg", neweq, lift 1 newpcase''') 
-      else newpcase''' in
-     (* construction du dernier lambda du piquant. *)
-     let newpcase' = mkLambda (newname_append nme "_ind" ,typ, newpcase'') in
-     (* ajout des lambdas supplémentaires (type dépendant) du piquant. *)
-     lamn suppllam_pcasel suppllam_pcase newpcase'
-
-
-(* [fold_proof mi b typeofb newb l n] rend le resultat de l'appel recursif sur
-   cstr (correpsondant au ième elt de [arrPt] ci-dessus et donc au ième
-   constructeur de [typeofb]), appele avec les bons arguments: [mi.concl]
-   devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] est le nombre d'arguments
-   du constructeur considéré, et [concl'] est [mi.concl] ou l'on a réécrit [b]
-   en ($c_n$ [rel1]...). *)
-and fold_proof mi b type_of_b newb i cstr = 
- let new_lst_recs = mi.lst_recs @ hdMatchSub_cpl b mi.fonc in
- (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3
-    x2 x1... ], sans quoi les annotations ne sont plus coherentes *)
- let cstr_appl,nargs = nth_dep_constructor type_of_b i in
- let concl'' = 
-  substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in
- let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in
- let concl_dummy = add_n_dummy_prod concl'' nargs in
- let lsteqs_rew = apply_eq_leqtrpl mi.lst_eqs neweq in
- let new_lsteqs = (mkRel (-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in
- let a',a'' = decompose_lam_n nargs cstr in
- let newa'' = 
-  if mi.doeqs 
-  then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') 
-  else a'' in
- let newmimick = lamn nargs a' newa'' in
- let b',b'' = decompose_prod_n nargs concl_dummy in
- let newb'' = 
-  if mi.doeqs 
-  then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'')
-  else b'' in
- let newconcl = prodn nargs b' newb'' in
- let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true; 
-  lst_eqs= new_lsteqs; lst_recs = new_lst_recs} in
- proofPrinc newmi 
-
-
-and collect_fix mi n iarr narr carr pisarr newabsconcl newenv =
- if n >= Array.length iarr then [||],[||],[],[]
- else
-   let nme = Array.get narr n in
-   let c = Array.get carr n in
-   (* rappelle sur le sous-terme, on ajoute un niveau de
-      profondeur (lift) parce que Fix est un binder. *)
-   let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl;
-    mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true;
-    lst_vars=lift1_lvars mi.lst_vars; lst_eqs=lift1_leqs mi.lst_eqs; 
-    lst_recs= lift1L mi.lst_recs;} in
-   let resrec = proofPrinc newmi  in
-   let lnme,lappel_rec,llevar,llposeq = 
-    collect_fix mi (n+1) iarr narr carr pisarr newabsconcl newenv in
-   Array.append [|nme|] lnme , Array.append [|resrec.princ|] lappel_rec
-    , (resrec.evarlist@llevar) , (resrec.hypnum@llposeq)
-
-let mkevarmap_aux ex = let x,y = ex in	(mkevarmap_from_listex x),y
-
-
-(* TODO: deal with any term, not only a constant. *)
-let interp_fonc_tacarg fonctac gl =
- (* [fonc] is the constr corresponding to fontact not unfolded,
-    if [fonctac] is a (qualified) name then this is a [const] ?. *)
-(*  let fonc = constr_of_Constr fonctac in *)
- (* TODO: replace the [with _ -> ] by something more precise in
-    the following. *)
- (* [def_fonc] is the definition of fonc. TODO: We should do this only
-    if [fonc] is a const, and take [fonc] otherwise.*)
- try fonctac, pf_const_value gl (destConst fonctac)
- with _ -> failwith ("don't know how to deal with this function "
- ^"(DEBUG:is it a constante?)")
-
-
-
-
-(* [invfun_proof fonc  def_fonc  gl_abstr pis]  builds  the principle,
-   following  the shape  of   [def_fonc],    [fonc]  is the      constant
-   corresponding to [def_func] (or a reduced form of  it ?), gl_abstr and
-   pis are the goal to be proved, of the form [x,y...]g and (x.y...)g.
-
-   This function calls the big function proofPrinc. *)
-
-let invfun_proof fonc def_fonc gl_abstr pis env sigma =
- let mi = {concl=pis; absconcl=gl_abstr; mimick=def_fonc; env=env;
- sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false ; 
- lst_vars = []; lst_eqs = []; lst_recs = []} in
- proofPrinc mi
-
-(* Do intros [i] times, then do rewrite on all introduced hyps which are called
-   like [heq_prefix], FIX: have another filter than the name. *)
-let rec iterintro i = 
- if i<=0 then tclIDTAC else 
-   tclTHEN
-    (tclTHEN 
-     intro
-     (iterintro (i-1)))
-    (fun gl -> 
-     (tclREPEAT 
-      (tclNTH_HYP i
-       (fun hyp -> 
-        let hypname = (string_of_id (destVar hyp)) in
-        let sub = 
-         try String.sub hypname 0 (String.length heq_prefix)
-         with _ -> "" (* different than [heq_prefix] *) in
-        if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 (str "Cannot rewrite"))
-      )) gl)
-
-
-(* 
-       (fun hyp gl -> 
-        let _ = prstr ("nthhyp= "^ string_of_int i) in
-        if isConst hyp && ((name_of_const hyp)==heq_prefix) then
-          let _ = prstr "YES\n" in
-          rewriteLR hyp gl 
-        else 
-          let _ = prstr "NO\n" in
-          tclIDTAC gl)
- *)
-    
-(* [invfun_basic C listargs_ids gl dorew lposeq] builds the tactic
-   which:
-   \begin{itemize}
-   \item Do refine on C (the induction principle),
-   \item try to Clear listargs_ids
-   \item if boolean dorew is true, then intro all new hypothesis, and
-   try rewrite on those hypothesis that are equalities.
-   \end{itemize}
-*)
-
-let invfun_basic open_princ_proof_applied listargs_ids gl dorew lposeq =
- (tclTHEN_i
-  (tclTHEN
-   (tclTHEN
-    (* Refine on the right term (following the sheme of the
-       given function) *)
-    (fun gl -> refine open_princ_proof_applied gl)
-    (* Clear the hypothesis given as arguments of the tactic
-       (because they are generalized) *)
-    (tclTHEN simpl_in_concl (tclTRY (clear listargs_ids))))
-   (* Now we introduce the created hypothesis, and try rewrite on
-      equalities due to case analysis *)
-   (fun gl ->  (tclIDTAC gl)))
-		(fun i gl -> 
-   if not dorew then tclIDTAC gl
-   else
-     (* d,m,f correspond respectively to vars, induction hyps and
-        equalities*)
-     let d,m,f = List.nth lposeq (i-1) in
-     tclTHEN (iterintro (d)) (tclDO m (tclTRY intro)) gl)
- )
- gl
-
-
-
-
-(* This function trys to reduce instanciated arguments, provided they
-   are of the form [(C t u v...)] where [C] is a constructor, and
-   provided that the argument is not the argument of a fixpoint (i.e. the
-   argument corresponds to a simple lambda) . *)
-let rec applistc_iota cstr lcstr env sigma = 
- match lcstr with
-  | [] -> cstr,[]
-  | arg::lcstr' -> 
-     let arghd = 
-      if isApp arg then let x,_ = destApp arg in x else arg in
-     if isConstruct arghd (* of the form [(C ...)]*)
-     then 
-        applistc_iota (Tacred.nf env sigma (nf_beta (applistc cstr [arg])))
-         lcstr' env sigma
-     else 
-       try 
-        let nme,typ,suite = destLambda cstr in
-        let c, l = applistc_iota suite lcstr' env sigma in
-        mkLambda (nme,typ,c), arg::l
-       with _ -> cstr,arg::lcstr' (* the arg does not correspond to a lambda*)
-
-
-
-(* TODO: ne plus mettre les sous-but à l'exterieur, mais à l'intérieur (le bug
-   de refine est normalement resolu). Ca permettra 2 choses: d'une part que
-   les preuves soient plus simple, et d'autre part de fabriquer un terme de
-   refine qui pourra s'aapliquer SANS FAIRE LES INTROS AVANT, ce qui est bcp
-   mieux car fonctionne comme induction et plus comme inversion (pas de perte
-   de connexion entre les hypothèse et les variables). *)
-
-(*s Tactic that makes induction and case analysis following the shape
-  of a function (idf) given with arguments (listargs) *)
-let invfun c l dorew gl = 
-(* \begin{itemize}
-    \item [fonc] = the constant corresponding to the function
-    (necessary for equalities of the form [(f x1 x2 ...)=...] where
-    [f] is the recursive function).
-    \item [def_fonc] = body of the function, where let ins have
-    been expanded. *)
- let fonc, def_fonc' = interp_fonc_tacarg c gl in
- let def_fonc'',listargs' = 
-  applistc_iota def_fonc' l (pf_env gl) (project gl)  in
- let def_fonc = expand_letins def_fonc'' in
- (* quantifies on previously generalized arguments. 
-    [(x1:T1)...g[arg1 <- x1 ...]] *)
- let pis = add_pis (pf_concl gl) gl listargs' in
- (* princ_proof builds the principle *)
- let _ = resetmeta() in
- let pr = invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in
- (* Generalize the goal. [[x1:T1][x2:T2]... g[arg1 <- x1 ...]]. *)
- let gl_abstr' = add_lambdas (pf_concl gl) gl listargs' in
- (* apply parameters immediately *)
- let gl_abstr = 
-  applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev pr.params)) in
- (* we apply args of the fix now, the parameters will be applied later *)
- let princ_proof_applied_args = 
-  applistc pr.princ (listsuf (List.length pr.params) listargs') in
- (* parameters are still there so patternify must not take them -> lift *)
- let princ_proof_applied_lift = 
-  lift (List.length pr.evarlist) princ_proof_applied_args in
- let princ_applied_hyps'' = patternify (List.rev pr.evarlist)
-  princ_proof_applied_lift (Name (id_of_string "Hyp"))  in
- (* if there was a fix, we will not add "Q" as in funscheme, so we make a pop,
-    TODO: find were we made the lift in proofPrinc instead and supress it here,
-    and add lift in funscheme. *)
- let princ_applied_hyps' = 
-  if Array.length pr.mutfixmetas > 0 then popn 1 princ_applied_hyps''
-  else princ_applied_hyps'' in 
- (* if there is was fix, we have to replace the meta representing the
-    predicate of the goal by the abstracted goal itself. *)
- let princ_applied_hyps = 
-  if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) 
-    (substit_red 0 (pr.mutfixmetas.(0)) gl_abstr princ_applied_hyps')
-  else princ_applied_hyps' (* No Fixpoint *) in
- let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in
- (* Same thing inside levar *)
- let newlevar' = 
-  if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) 
-    List.map (fun (x,y) -> x,substit_red 0 (pr.mutfixmetas.(0)) gl_abstr y) pr.evarlist 
-  else pr.evarlist
- in
- (* replace params metavar by real args *)
- let rec replace_parms lparms largs t = 
-  match lparms, largs with
-     [], _ -> t
-   | ((p,_,_)::lp), (a::la) -> let t'= substitterm 0 p a t in replace_parms lp la t'
-   | _, _ -> error "problem with number of args." in
- let princ_proof_applied = replace_parms pr.params listargs' princ_applied_hyps in
- let _ = prNamedLConstr "levar:" (List.map fst newlevar') in
- let _ = prNamedLConstr "levar types:" (List.map snd newlevar') in
- let _ = prNamedConstr "princ_proof_applied" princ_proof_applied in
- (* replace also in levar *)
- let newlevar = 
-  List.rev (List.map (fun (x,y) -> x, replace_parms pr.params listargs' y) newlevar') in
-(*
- (* replace params metavar by abstracted variables *)
-  let princ_proof_params = npatternify (List.rev pr.params) princ_applied_hyps in
- (* we apply now the real parameters *)
- let princ_proof_applied = 
-  applistc princ_proof_params (listpref (List.length pr.params) listargs') in
-*)
- let princ_applied_evars = apply_levars princ_proof_applied newlevar in
- let open_princ_proof_applied = princ_applied_evars in
- let _ = prNamedConstr "princ_applied_evars" (snd princ_applied_evars) in
- let _ = prNamedLConstr "evars" (List.map snd (fst princ_applied_evars)) in
- let listargs_ids = List.map destVar (List.filter isVar listargs') in
- (* debug: impression du but*)
- let lgl = Evd.to_list (sig_sig gl) in
- let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in
- let _ = prstr "fin gl \n\n" in
- invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids 
-  gl dorew pr.hypnum
-
-(* function must be a constant, all arguments must be given. *)
-let invfun_verif c l dorew gl =
- if not (isConst c) then error "given function is not a constant"
- else 
-   let x,_ = decompose_prod (pf_type_of gl c) in
-   if List.length x = List.length l then 
-     try invfun c l dorew gl
-     with UserError (x,y) -> raise (UserError (x,y))
-   else error "wrong number of arguments for the function"
-
-
-
-
-(* Construction of the functional scheme. *)
-let buildFunscheme fonc mutflist =
- let def_fonc = expand_letins (def_of_const fonc) in
- let ftyp = type_of (Global.env ()) Evd.empty fonc in
- let _ = resetmeta() in
- let gl = mknewmeta() in
- let gl_app = applFull gl ftyp in
- let pis = prod_change_concl ftyp gl_app in
- (* Here we call the function invfun_proof, that effectively 
-    builds the scheme *)
-(*  let princ_proof,levar,_,evararr,absc,parms =  *)
- let _ = prstr "Recherche du principe... lancement de invfun_proof\n" in
- let pr = invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in
- (* parameters are still there (unboud rel), and patternify must not take them
-  -> lift*)
- let princ_proof_lift = lift (List.length pr.evarlist) pr.princ in
- let princ_proof_hyps = 
-  patternify (List.rev pr.evarlist) princ_proof_lift (Name (id_of_string "Hyp"))  in
- let rec princ_replace_metas ev abs i t = 
-  if i>= Array.length ev then t
-  else (* fix? *)
-    princ_replace_metas ev abs (i+1)
-     (mkLambda (
-      (Name (id_of_string ("Q"^(string_of_int i)))),
-      prod_change_concl (lift 0 abs.(i)) mkthesort,
-      (substitterm 0 ev.(i) (mkRel 1) (lift 0 t))))
- in
- let rec princ_replace_params params t = 
-  List.fold_left (
-   fun acc (ev,nam,typ) -> 
-    mkLambda (Name (id_of_name nam) , typ, 
-    substitterm 0 ev (mkRel 1) (lift 0 acc)))
-   t (List.rev params) in
- if Array.length pr.mutfixmetas = 0 (* Is there a Fixpoint? *)
-	then (* No Fixpoint *)
-   princ_replace_params pr.params (mkLambda ((Name (id_of_string "Q")), 
-		 prod_change_concl ftyp mkthesort,
-   (substitterm 0 gl (mkRel 1) princ_proof_hyps)))
-	else (* there is a fix -> add parameters + replace metas *)
-   let princ_rpl = 
-    princ_replace_metas pr.mutfixmetas pr.conclarray 0 princ_proof_hyps in
-   princ_replace_params pr.params princ_rpl
-
-
-    
-(* Declaration of the functional scheme. *)
-let declareFunScheme f fname mutflist =
- let _ = prstr "Recherche du perincipe...\n" in
- let id_to_cstr id = 
-  try constr_of_id (Global.env()) id 
-  with
-     Not_found -> error (string_of_id id ^ " not found in the environment") in
- let flist = if mutflist=[] then [f] else mutflist in
- let fcstrlist = Array.of_list (List.map id_to_cstr flist) in
- let idf = id_to_cstr f in
- let scheme = buildFunscheme idf fcstrlist in
-  let _ = prstr "Principe:" in
-  let _ = prconstr scheme in
- let ce = { 
-  const_entry_body = scheme;
-  const_entry_type = None;
-  const_entry_opaque = false;
-  const_entry_boxed = true } in
- let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition Scheme)) in
- ()
-
-
-
-TACTIC EXTEND functional_induction
-  [ "old" "functional" "induction" constr(c)  ne_constr_list(l) ] 
-     -> [ invfun_verif c l true ]
-END
-
-VERNAC COMMAND EXTEND FunctionalScheme
- [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" 
-    ident(c) "with" ne_ident_list(l) ] 
-  -> [ declareFunScheme c na l ]
-| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ]
-  -> [ declareFunScheme c na [] ]
-END
-
-
-
-
-
-(* 
-*** Local Variables: ***
-*** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" ***
-*** tuareg-default-indent:1 ***
-*** tuareg-begin-indent:1 ***
-*** tuareg-let-indent:1 ***
-*** tuareg-match-indent:-1 ***
-*** tuareg-try-indent:1 ***
-*** tuareg-with-indent:1 ***
-*** tuareg-if-then-else-inden:1 ***
-*** fill-column: 78 ***
-*** indent-tabs-mode: nil ***
-***  test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" ***
-*** End: ***
-*)
-          
-
diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml
deleted file mode 100644
index ce775e0b..00000000
--- a/contrib/funind/tacinvutils.ml
+++ /dev/null
@@ -1,284 +0,0 @@
-(* tacinvutils.ml *)
-(*s utilities *)
-
-(*i*)
-open Names
-open Util
-open Term
-open Termops
-open Coqlib
-open Pp
-open Printer
-open Inductiveops
-open Environ
-open Declarations
-open Nameops
-open Evd
-open Sign
-open Reductionops
-(*i*)
-
-(*s printing of constr -- debugging *)
-
-(* comment this line to see debug msgs *)
-let msg x = () ;; let pr_lconstr c = str ""
-  (* uncomment this to see debugging *)
-let prconstr c =  msg (str"  " ++ pr_lconstr c ++ str"\n")
-let prlistconstr lc = List.iter prconstr lc
-let prstr s = msg(str s)
-
-let prchr () = msg (str" (ret) \n")
-let prNamedConstr s c = 
-  begin
-    msg(str "");
-    msg(str(s^"==>\n ") ++ pr_lconstr c ++ str "\n<==\n");
-    msg(str "");
-  end
-
-let prNamedLConstr_aux lc = 
-  List.iter (prNamedConstr "#>") lc
-
-let prNamedLConstr s lc = 
-  begin
-    prstr s;
-    prNamedLConstr_aux lc
-  end
-
-
-(* FIXME: ref 1, pas bon, si? *)
-let evarcpt = ref 0
-let metacpt = ref 0
-let mknewexist ()= 
-  begin
-    evarcpt := !evarcpt+1;
-    !evarcpt,[||]
-  end
-
-let resetexist ()= evarcpt := 0
-
-let mknewmeta ()= 
-  begin
-    metacpt := !metacpt+1;
-    mkMeta (!metacpt)
-  end
-
-let resetmeta () = metacpt := 0
-
-let  rec mkevarmap_from_listex lex =
-  match lex with
-	 | [] -> Evd.empty
-	 | ((ex,_),typ)::lex' -> 
-(*		  let _ = prstr "mkevarmap" in
-		  let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in
-		  let _ = prstr "OF TYPE: " in
-		  let _ = prconstr typ in*)
-		  let info = {
-			 evar_concl = typ;
-			 evar_hyps = empty_named_context_val;
-			 evar_body = Evar_empty;
-		         evar_extra = None} in
-		  Evd.add (mkevarmap_from_listex lex') ex info
-
-let mkEq typ c1 c2 = 
-  mkApp (build_coq_eq(),[| typ; c1; c2|])
-
-let mkRefl typ c1 = 
-  mkApp ((build_coq_eq_data()).refl, [| typ; c1|])
-
-let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
-
-
-(* Operations on names *)
-let id_of_name = function
-    Anonymous -> id_of_string "H"
-  | Name id   -> id;;
-let string_of_name nme = string_of_id (id_of_name nme)
-let name_of_string str = Name (id_of_string str)
-let newname_append nme str = 
-  Name(id_of_string ((string_of_id (id_of_name nme))^str))
-
-(* Substitutions in constr *)
-
-let compare_constr_nosub t1 t2 =
-  if compare_constr (fun _ _ -> false) t1 t2 
-  then true
-  else false
-
-let rec compare_constr' t1 t2 =
-  if compare_constr_nosub t1 t2 
-  then true
-  else (compare_constr (compare_constr') t1 t2)
-
-let rec substitterm prof t by_t in_u =
-  if (compare_constr' (lift prof t) in_u)
-  then (lift prof by_t)
-  else map_constr_with_binders succ 
-    (fun i -> substitterm i t by_t) prof in_u
-
-
-let apply_eqtrpl eq t =
-  let r,(tb,b,by_t) = eq in
-  substitterm 0 b by_t t
-
-let apply_eqtrpl_lt lt eq =  List.map (apply_eqtrpl eq) lt
-
-let apply_leqtrpl_t t leq =
-  List.fold_left (fun x y -> apply_eqtrpl y x) t leq
-
-
-let apply_refl_term eq t =
-  let _,arr = destApp eq in
-  let reli= (Array.get arr 1) in
-  let by_t= (Array.get arr 2) in
-  substitterm 0 reli by_t t
-
-let apply_eq_leqtrpl leq eq =
-  List.map 
-    (function (r,(tb,b,t)) ->
-		r,(tb, 
-		(if isRel b then b else (apply_refl_term eq b)), apply_refl_term eq t))
-	 leq
-
-
-
-(* [(a b c) a] -> true *)
-let constr_head_match u t=
-  if isApp u 
-  then 
-	 let uhd,args= destApp u in
-    uhd=t
-  else false
-
-(* My operations on constr *)
-let lift1L l = (List.map (lift 1) l)
-let mkArrow_lift t1 t2 = mkArrow t1 (lift 1 t2)
-let mkProd_liftc nme c1 c2 = mkProd (nme,c1,(lift 1 c2))
-(* prod_it_lift x [a1 a2 ...] *)
-let prod_it_lift ini lcpl =
-  List.fold_right (function a,b -> (fun c -> mkProd_liftc a b c)) ini lcpl;;
-
-let prod_it_anonym_lift trm lst = List.fold_right mkArrow_lift lst trm
-
-let lam_it_anonymous trm lst =
-  List.fold_right 
-	 (fun elt res -> mkLambda(Name(id_of_string "Hrec"),elt,res)) lst trm
-
-let lambda_id id typeofid cstr =
-  let cstr' = mkNamedLambda (id_of_string "FUNX") typeofid cstr in
-  substitterm 0 id (mkRel 0) cstr'
-
-let prod_id id typeofid cstr =
-  let cstr' = mkNamedProd (id_of_string "FUNX") typeofid cstr in
-  substitterm 0 id (mkRel 0) cstr'
-
-
-
-
-
-let nth_dep_constructor indtype n =
-  let sigma = Evd.empty and env = Global.env() in
-  let indtypedef = find_rectype env sigma indtype in
-  let indfam,_ = dest_ind_type indtypedef in
-  let arr_cstr_summary = get_constructors env indfam in
-  let cstr_sum = Array.get arr_cstr_summary n in
-  build_dependent_constructor cstr_sum,  cstr_sum.cs_nargs
-
-
-let rec buildrefl_from_eqs eqs = 
-  match eqs with 
-    | []  ->  []
-    | cstr::eqs' -> 
-        let eq,args = destApp cstr in
-        (mkRefl (Array.get args 0) (Array.get args 2))
-	:: (buildrefl_from_eqs eqs')
-
-
-
-
-(* list of occurrences of a term inside another *)
-(* Cofix will be wrong, not sure Fix is correct too *)
-let rec hdMatchSub u t=
-  let subres = 
-    match kind_of_term u with
-      | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub (lift 1 cstr) t
-      | Fix (_,(lna,tl,bl))  -> 
-	  Array.fold_left 
-	    (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) t) 
-	    [] bl
-      | LetIn _  -> assert false
-	  (* Correct? *)
-      | _ -> fold_constr (fun l cstr -> l @ hdMatchSub cstr t) [] u
-  in 
-  if constr_head_match u t then u :: subres else subres
-
-
-(* let hdMatchSub_list u lt = List.flatten (List.map (hdMatchSub u) lt) *)
-let hdMatchSub_cpl u (d,f) = 
-  let res = ref [] in
-  begin
-    for i = d to f do res := hdMatchSub u (mkRel i) @ !res done;
-    !res
-  end
-
-
-(* destApplication raises an exception if [t] is not an application *)      
-let exchange_hd_prod subst_hd t =
-  let hd,args= destApplication t in mkApp (subst_hd,args)
-
-(* substitute t by by_t in head of products inside in_u, reduces each
-	product found  *)
-let rec substit_red prof t by_t in_u =
-  if constr_head_match in_u (lift prof t) 
-  then
-    let x = whd_beta (exchange_hd_prod (lift prof by_t) in_u) in
-    x
-  else
-    map_constr_with_binders succ (fun i u -> substit_red i t by_t u) prof in_u
-
-(* [exchange_reli_arrayi t=(reli x y ...) tarr (d,f)] exchange each
-	reli by tarr.(f-i). *) 
-let exchange_reli_arrayi tarr (d,f) t =
-  let hd,args= destApp t in 
-  let i = destRel hd in
-  let res = whd_beta (mkApp (tarr.(f-i) ,args)) in
-  res
-
-let exchange_reli_arrayi_L tarr (d,f) = 
-  List.map (exchange_reli_arrayi tarr (d,f))
-
-
-(* expand all letins in a term, before building the principle. *)
-let rec expand_letins mimick =
-  match kind_of_term mimick with
-    | LetIn(nme,cstr1, typ, cstr) ->
-        let cstr' = substitterm 0 (mkRel 1) (lift 1 cstr1) cstr in
-        expand_letins (pop cstr')
-    | x -> map_constr expand_letins mimick
-	  
-
-(* Valeur d'une constante, or identity *)
-let def_of_const t =
-  match kind_of_term t with
-    | Const sp -> 
-		  (try 
-			 match Global.lookup_constant sp with
-              {const_body=Some c} -> force c
- 				|_ -> assert false
-			 with _ -> assert false)
-    | _ -> t
-
-(* nom d'une constante. Must be a constante. x*)
-let name_of_const t =
-    match (kind_of_term t) with
-        Const cst -> Names.string_of_label (Names.con_label cst)
-		|_ -> assert false
- ;;
-
-
-(*i
-***  Local Variables:
-***  compile-command: "make -k tacinvutils.cmo"
-***  test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v"
-***  End:
-i*)
-
diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli
deleted file mode 100644
index 64b21213..00000000
--- a/contrib/funind/tacinvutils.mli
+++ /dev/null
@@ -1,80 +0,0 @@
-(* tacinvutils.ml *)
-(*s utilities *)
-
-(*i*)
-open Termops
-open Equality
-open Names
-open Pp
-open Tacmach
-open Proof_type
-open Tacinterp
-open Tactics
-open Tacticals
-open Term
-open Util
-open Printer
-open Reductionops
-open Inductiveops
-open Coqlib
-open Refine
-open Evd
-(*i*)
-
-(* printing debugging *)
-val prconstr: constr -> unit
-val prlistconstr: constr list  -> unit
-val prNamedConstr:string -> constr -> unit
-val prNamedLConstr:string -> constr list -> unit
-val prstr: string -> unit 
-
-
-val mknewmeta: unit -> constr
-val mknewexist: unit -> existential
-val resetmeta: unit -> unit (* safe *)
-val resetexist: unit -> unit (* be careful with this one *)
-val mkevarmap_from_listex: (Term.existential * Term.types) list -> evar_map
-val mkEq: types -> constr -> constr -> constr
-(* let mkEq typ c1 c2 =   mkApp (build_coq_eq_data.eq(),[| typ; c1; c2|]) *)
-val mkRefl: types -> constr -> constr
-val buildrefl_from_eqs: constr list -> constr list
-(* typ c1 =  mkApp ((constant ["Coq"; "Init"; "Logic"] "refl_equal"), [| typ; c1|]) *)
-
-val nth_dep_constructor: constr -> int -> (constr*int)
-
-val prod_it_lift:  (name*constr) list -> constr -> constr
-val prod_it_anonym_lift: constr -> constr list -> constr
-val lam_it_anonymous: constr -> constr list -> constr
-val lift1L: (constr list) -> constr list
-val popn: int -> constr -> constr
-val lambda_id: constr -> constr -> constr -> constr
-val prod_id: constr -> constr -> constr -> constr
-
-
-val name_of_string : string -> name
-val newname_append: name -> string -> name
-
-val apply_eqtrpl: constr*(constr*constr*constr) -> constr -> constr
-val substitterm: int -> constr -> constr -> constr -> constr
-val apply_leqtrpl_t: 
-  constr -> (constr*(constr*constr*constr)) list -> constr
-val apply_eq_leqtrpl: 
-  (constr*(constr*constr*constr)) list -> constr -> (constr*(constr*constr*constr)) list
-(* val apply_leq_lt: constr list -> constr list -> constr list *)
-
-val hdMatchSub: constr -> constr -> constr list
-val hdMatchSub_cpl: constr -> int*int -> constr list
-val exchange_hd_prod: constr -> constr -> constr
-val exchange_reli_arrayi_L: constr array  -> int*int -> constr list -> constr list
-val substit_red: int -> constr -> constr -> constr -> constr
-val expand_letins: constr -> constr
-
-val def_of_const: constr -> constr
-val name_of_const: constr -> string
-
-(*i
- *** Local Variables: ***
- *** compile-command: "make -C ../.. contrib/funind/tacinvutils.cmi" ***
- *** End: ***
-i*)
-
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT
index 2fb11c6b..23aeb6bb 100644
--- a/contrib/interface/COPYRIGHT
+++ b/contrib/interface/COPYRIGHT
@@ -1,8 +1,9 @@
 (*****************************************************************************)
 (*                                                                           *)
-(*            Coq support for the Pcoq Graphical Interface of Coq            *)
+(*      Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq       *)
 (*                                                                           *)
 (*        Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team)        *)
+(*        Copyright (C) 2006,2007 Lionel Elie Mamane                         *)
 (*                                                                           *)
 (*****************************************************************************)
 
@@ -10,6 +11,9 @@ The current directory contrib/interface implements Coq support for the
 Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot
 with contributions from Loïc Pottier and Laurence Rideau.
 
+Modifications by Lionel Elie Mamane <lionel@mamane.lu> for
+generalising the protocol to suit other Coq interfaces.
+
 The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq)
 is developed by the Lemme team at INRIA Sophia-Antipolis (see
 http://www-sop.inria.fr/lemme)
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
index ef1d095e..32338523 100644
--- a/contrib/interface/ascent.mli
+++ b/contrib/interface/ascent.mli
@@ -113,7 +113,6 @@ and ct_COMMAND =
   | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT
   | CT_no_inline of ct_ID_NE_LIST
   | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE
-  | CT_opaque of ct_ID_NE_LIST
   | CT_open_scope of ct_ID
   | CT_print
   | CT_print_about of ct_ID
@@ -189,13 +188,13 @@ and ct_COMMAND =
   | CT_show_script
   | CT_show_tree
   | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT
+  | CT_strategy of ct_LEVEL_LIST
   | CT_suspend
   | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT
   | CT_tactic_definition of ct_TAC_DEF_NE_LIST
   | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID
   | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT
   | CT_time of ct_COMMAND
-  | CT_transparent of ct_ID_NE_LIST
   | CT_undo of ct_INT_OPT
   | CT_unfocus
   | CT_unset_option of ct_TABLE
@@ -204,6 +203,12 @@ and ct_COMMAND =
   | CT_user_vernac of ct_ID * ct_VARG_LIST
   | CT_variable of ct_VAR * ct_BINDER_NE_LIST
   | CT_write_module of ct_ID * ct_STRING_OPT
+and ct_LEVEL_LIST =
+    CT_level_list of (ct_LEVEL * ct_ID_LIST) list
+and ct_LEVEL =
+    CT_Opaque
+  | CT_Level of ct_INT
+  | CT_Expand
 and ct_COMMAND_LIST =
     CT_command_list of ct_COMMAND * ct_COMMAND list
 and ct_COMMENT =
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
index dc27cf98..6ec0fac4 100644
--- a/contrib/interface/blast.ml
+++ b/contrib/interface/blast.ml
@@ -151,7 +151,7 @@ let pp_string x =
 let unify_e_resolve  (c,clenv) gls = 
   let clenv' = connect_clenv gls clenv in
   let _ = clenv_unique_resolver false clenv' gls in
-  vernac_e_resolve_constr c gls
+    Hiddentac.h_simplest_eapply c gls
 
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl = 
@@ -161,33 +161,36 @@ let rec e_trivial_fail_db db_list local_db goal =
 	  let d = pf_last_hyp g' in
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
           (e_trivial_fail_db db_list
-	     (Hint_db.add_list hintl local_db) g'))) ::
+	     (add_hint_list hintl local_db) g'))) ::
     (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
   in 
   tclFIRST (List.map tclCOMPLETE tacl) goal 
 
 and e_my_find_search db_list local_db hdc concl = 
   let hdc = head_of_constr_reference hdc in
+  let flags = Auto.auto_unif_flags in
   let hintl =
     if occur_existential concl then 
-      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+      list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x))
+	(Hint_db.map_all hdc db)) (local_db::db_list)
     else 
-      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+      list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x)) 
+	(Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
   in 
   let tac_of_hint = 
-    fun ({pri=b; pat = p; code=t} as _patac) -> 
+    fun (st, ({pri=b; pat = p; code=t} as _patac)) -> 
       (b, 
        let tac =
 	 match t with
-	   | Res_pf (term,cl) -> unify_resolve (term,cl)
+	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
 	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
 	   | Give_exact (c) -> e_give_exact_constr c
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
                tclTHEN (unify_e_resolve (term,cl)) 
 		 (e_trivial_fail_db db_list local_db)
-	   | Unfold_nth c -> unfold_in_concl [[],c]
+	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
 	   | Extern tacast -> Auto.conclPattern concl 
-	       (out_some p) tacast
+	       (Option.get p) tacast
        in 
        (free_try tac,fmt_autotactic t))
        (*i
@@ -227,8 +230,8 @@ module MySearchProblem = struct
     depth : int; (*r depth of search before failing *)
     tacres : goal list sigma * validation;
     last_tactic : std_ppcmds;
-    dblist : Auto.Hint_db.t list;
-    localdb :  Auto.Hint_db.t list }
+    dblist : Auto.hint_db list;
+    localdb :  Auto.hint_db list }
 		 
   let success s = (sig_it (fst s.tacres)) = []
 
@@ -242,9 +245,6 @@ module MySearchProblem = struct
 	with e when Logic.catchable_exception e ->
 	  filter_tactics (glls,v) tacl
 
-  let rec list_addn n x l = 
-    if n = 0 then l else x :: (list_addn (pred n) x l)
-
   (* Ordering of states is lexicographic on depth (greatest first) then
      number of remaining goals. *)
   let compare s s' =
@@ -279,7 +279,7 @@ module MySearchProblem = struct
 	     let hintl = 
 	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
 	     in
-             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+             let ldb = add_hint_list hintl (List.hd s.localdb) in
 	     { depth = s.depth; tacres = res; 
 	       last_tactic = pp; dblist = s.dblist;
 	       localdb = ldb :: List.tl s.localdb })
@@ -337,7 +337,7 @@ let e_breadth_search debug n db_list local_db gl =
   with Not_found -> error "EAuto: breadth first search failed"
 
 let e_search_auto debug (n,p) db_list gl = 
-  let local_db = make_local_hint_db [] gl in 
+  let local_db = make_local_hint_db true [] gl in 
   if n = 0 then 
     e_depth_search debug p db_list local_db gl
   else 
@@ -357,7 +357,7 @@ let full_eauto debug n gl =
   let dbnames = current_db_names () in
   let dbnames =  list_subtract dbnames ["v62"] in
   let db_list = List.map searchtable_map dbnames in
-  let _local_db = make_local_hint_db [] gl in
+  let _local_db = make_local_hint_db true [] gl in
   tclTRY (e_search_auto debug n db_list) gl
 
 let my_full_eauto n gl = full_eauto false (n,0) gl
@@ -375,7 +375,7 @@ let rec trivial_fail_db db_list local_db gl =
     tclTHEN intro 
       (fun g'->
 	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+	 in trivial_fail_db db_list (add_hint_list hintl local_db) g')
   in
   tclFIRST 
     (assumption::intro_tac::
@@ -383,27 +383,29 @@ let rec trivial_fail_db db_list local_db gl =
 	(trivial_resolve db_list local_db (pf_concl gl)))) gl
 
 and my_find_search db_list local_db hdc concl =
+  let flags = Auto.auto_unif_flags in
   let tacl = 
     if occur_existential concl then 
-      list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
+      list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x) 
+	(Hint_db.map_all hdc db)) (local_db::db_list)
     else 
-      list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
-      	(local_db::db_list)
+      list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x)
+	(Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
   in
   List.map 
-    (fun ({pri=b; pat=p; code=t} as _patac) -> 
+    (fun (st, {pri=b; pat=p; code=t} as _patac) -> 
        (b,
 	match t with
-	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
+	  | Res_pf (term,cl)  -> unify_resolve st (term,cl)
 	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
 	  | Give_exact c  -> exact_check c
 	  | Res_pf_THEN_trivial_fail (term,cl) -> 
 	      tclTHEN 
-		(unify_resolve (term,cl)) 
+		(unify_resolve st (term,cl)) 
 		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_in_concl [[],c]
+	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
 	  | Extern tacast -> 
-	      conclPattern concl (out_some p) tacast))
+	      conclPattern concl (Option.get p) tacast))
     tacl
 
 and trivial_resolve db_list local_db cl = 
@@ -470,11 +472,12 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 	   try 
 	     [make_apply_entry (pf_env g') (project g')
 		(true,false) 
-		(mkVar hid,body_of_type htyp)]
+		None
+		(mkVar hid,htyp)]
 	   with Failure _ -> [] 
 	 in
          (free_try
-	  (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d])
+	  (search_gen decomp n db_list (add_hint_list hintl local_db) [d])
 	  g'))
   in
   let rec_tacs = 
@@ -497,7 +500,7 @@ let full_auto n gl =
   let dbnames = list_subtract dbnames ["v62"] in
   let db_list = List.map searchtable_map dbnames in
   let hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db [] gl) hyps) gl
+  tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl
   
 let default_full_auto gl = full_auto !default_search_depth gl
 (************************************************************************)
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
index 730e055b..a4dc0eac 100644
--- a/contrib/interface/centaur.ml4
+++ b/contrib/interface/centaur.ml4
@@ -1,11 +1,28 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
+(*
+ * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu>
+ * to implement the following features
+ * - Terms (optionally) as pretty-printed string and not trees
+ * - (Optionally) give most commands their usual Coq semantics
+ * - Add the backtracking information to the status message.
+ * in the following time period
+ * - May-November 2006
+ * and
+ * - Make use of new Command.save_hook to generate dependencies at
+ *   save-time.
+ * in
+ *  - June 2007
+ *)
+
 (*Toplevel loop for the communication between Coq and Centaur *)
 open Names;;
 open Nameops;;
 open Util;;
 open Term;;
 open Pp;;
+open Ppconstr;;
+open Prettyp;;
 open Libnames;;
 open Libobject;;
 open Library;;
@@ -43,6 +60,7 @@ open Showproof;;
 open Showproof_ct;;
 open Tacexpr;;
 open Vernacexpr;;
+open Printer;;
 
 let pcoq_started = ref None;;
 
@@ -51,6 +69,11 @@ let if_pcoq f a =
 
 let text_proof_flag = ref "en";;
 
+let pcoq_history = ref true;;
+
+let assert_pcoq_history f a =
+  if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";;
+
 let current_proof_name () = 
   try 
     string_of_id (get_current_proof_name ())
@@ -85,10 +108,33 @@ let kill_proof_node index =
  History.border_length (current_proof_name());;
 
 
+type vtp_tree =
+  | P_rl of ct_RULE_LIST
+  | P_r of ct_RULE
+  | P_s_int of ct_SIGNED_INT_LIST
+  | P_pl of ct_PREMISES_LIST
+  | P_cl of ct_COMMAND_LIST
+  | P_t of ct_TACTIC_COM
+  | P_text of ct_TEXT
+  | P_ids of ct_ID_LIST;;
+
+let print_tree t = 
+  (match t with
+  | P_rl x -> fRULE_LIST x
+  | P_r x -> fRULE x
+  | P_s_int x -> fSIGNED_INT_LIST x
+  | P_pl x -> fPREMISES_LIST x
+  | P_cl x -> fCOMMAND_LIST x
+  | P_t x -> fTACTIC_COM x
+  | P_text x -> fTEXT x
+  | P_ids x -> fID_LIST x)
+  ++ (str "e\nblabla\n");;
+
+
 (*Message functions, the text of these messages is recognized by the protocols *)
 (*of CtCoq                                                                     *)
 let ctf_header message_name request_id =
- fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++
+ str "message" ++ fnl() ++ str message_name ++ fnl() ++
  int request_id ++ fnl();;
 
 let ctf_acknowledge_command request_id command_count opt_exn =
@@ -97,14 +143,20 @@ let ctf_acknowledge_command request_id command_count opt_exn =
       let g_count =
         List.length 
           (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in
-        g_count, (min g_count !current_goal_index)
+        g_count, !current_goal_index
     else
-      (0, 0) in
+      (0, 0)
+  and statnum = Lib.current_command_label ()
+  and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0
+  and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in
    (ctf_header "acknowledge" request_id ++
     int command_count ++ fnl() ++
     int goal_count ++ fnl () ++
     int goal_index ++ fnl () ++
     str (current_proof_name()) ++ fnl() ++
+    int statnum ++ fnl() ++
+    print_tree (P_ids pending) ++
+    int dpth ++ fnl() ++
     (match opt_exn with
       Some e -> Cerrors.explain_exn e
     | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());;
@@ -126,6 +178,8 @@ let ctf_PathGoalMessage () =
 
 let ctf_GoalReqIdMessage = ctf_header "single_goal_state";;
 
+let ctf_GoalsReqIdMessage = ctf_header "goals_state";;
+
 let ctf_NewStateMessage = ctf_header "fresh_state";;
 
 let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++
@@ -153,39 +207,16 @@ let ctf_ResetIdentMessage request_id s =
  ctf_header "reset_ident" request_id ++ str s ++ fnl () ++
   str  "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
 
-type vtp_tree =
-  | P_rl of ct_RULE_LIST
-  | P_r of ct_RULE
-  | P_s_int of ct_SIGNED_INT_LIST
-  | P_pl of ct_PREMISES_LIST
-  | P_cl of ct_COMMAND_LIST
-  | P_t of ct_TACTIC_COM
-  | P_text of ct_TEXT
-  | P_ids of ct_ID_LIST;;
-
-let print_tree t = 
-  (match t with
-  | P_rl x -> fRULE_LIST x
-  | P_r x -> fRULE x
-  | P_s_int x -> fSIGNED_INT_LIST x
-  | P_pl x -> fPREMISES_LIST x
-  | P_cl x -> fCOMMAND_LIST x
-  | P_t x -> fTACTIC_COM x
-  | P_text x -> fTEXT x
-  | P_ids x -> fID_LIST x);
-  print_string "e\nblabla\n";;
-
-
 
 let break_happened = ref false;;
 
 let output_results stream vtp_tree =
     let _ = Sys.signal Sys.sigint
        (Sys.Signal_handle(fun i -> (break_happened := true;()))) in
-    msg stream;
-    match vtp_tree with
-      Some t -> print_tree t
-    | None -> ();;
+    msg (stream ++
+    (match vtp_tree with
+       Some t -> print_tree t
+     | None -> mt()));;
 
 let output_results_nl stream =
     let _ = Sys.signal Sys.sigint
@@ -221,20 +252,18 @@ let print_past_goal index =
 
 let show_nth n =
   try
-    let pf = proof_of_pftreestate (get_pftreestate()) in
-    if (!text_proof_flag<>"off") then
-       (if n=0
-	   then output_results (ctf_TextMessage !global_request_id)
-                               (Some (P_text (show_proof !text_proof_flag [])))
-           else			       
-	   let path = History.get_nth_open_path (current_proof_name()) n in
-	   output_results (ctf_TextMessage !global_request_id)
-                          (Some (P_text (show_proof !text_proof_flag path))))
-    else
-      output_results (ctf_GoalReqIdMessage !global_request_id)
-      (let goal = List.nth (fst (frontier pf))
-                   (n - 1) in
-      (Some (P_r (translate_goal goal))))
+    output_results (ctf_GoalReqIdMessage !global_request_id
+		    ++ pr_nth_open_subgoal n)
+      None
+  with
+  | Invalid_argument s -> 
+       error "No focused proof (No proof-editing in progress)";;
+
+let show_subgoals () =
+  try
+    output_results (ctf_GoalReqIdMessage !global_request_id
+		    ++ pr_open_subgoals ())
+      None
   with
   | Invalid_argument s -> 
        error "No focused proof (No proof-editing in progress)";;
@@ -275,39 +304,24 @@ let ctf_EmptyGoalMessage id =
   fnl () ++ str "Empty Goal is a no-op.  Fun oh fun." ++ fnl ();;
 
 
-let print_check judg =
- let {uj_val=value; uj_type=typ} = judg in
- let value_ct_ast = 
-     (try translate_constr false (Global.env()) value 
-      with UserError(f,str) ->
-           raise(UserError(f,Printer.pr_lconstr value ++
-			      fnl () ++ str ))) in
- let type_ct_ast =
-     (try translate_constr false (Global.env()) typ
-      with UserError(f,str) ->
-           raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
- ((ctf_SearchResults !global_request_id),
- (Some  (P_pl
-  (CT_premises_list
-  [CT_coerce_TYPED_FORMULA_to_PREMISE
-    (CT_typed_formula(value_ct_ast,type_ct_ast)
-    )]))));;
-
-let ct_print_eval ast red_fun env judg =
-((if refining() then traverse_to []);
-let {uj_val=value; uj_type=typ} = judg in
-let nvalue = red_fun value
-(* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
-and ntyp = nf_betaiota typ in
-(ctf_SearchResults !global_request_id,
- Some (P_pl
-  (CT_premises_list
-  [CT_eval_result
-    (xlate_formula ast,
-    translate_constr false env nvalue,
-    translate_constr false env ntyp)]))));;
-
-
+let print_check env judg =
+ ((ctf_SearchResults !global_request_id) ++
+    print_judgment env judg,
+  None);;
+
+let ct_print_eval red_fun env evmap ast judg =
+  (if refining() then traverse_to []);
+  let {uj_val=value; uj_type=typ} = judg in
+  let nvalue = (red_fun env evmap) value
+    (* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
+  and ntyp = nf_betaiota typ in
+    print_tree
+      (P_pl
+	 (CT_premises_list
+	    [CT_eval_result
+	       (xlate_formula ast,
+		translate_constr false env nvalue,
+		translate_constr false env ntyp)]));;
 
 let pbp_tac_pcoq =
     pbp_tac (function (x:raw_tactic_expr) -> 
@@ -330,6 +344,7 @@ let dad_tac_pcoq =
 </cpa> *)
 
 let search_output_results () =
+  (* LEM: See comments for pcoq_search *)
   output_results
        (ctf_SearchResults !global_request_id)
        (Some (P_pl (CT_premises_list
@@ -393,7 +408,7 @@ let inspect n =
              	oname, Lib.Leaf lobj ->
 		  (match oname, object_tag lobj with
                        (sp,_), "VARIABLE" ->
-			 let (_, _, v) = get_variable (basename sp) in
+			 let (_, _, v) = Global.lookup_named (basename sp) in
 			   add_search2 (Nametab.locate (qualid_of_sp sp)) v
 		     | (sp,kn), "CONSTANT" ->
 			 let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in
@@ -491,19 +506,19 @@ VERNAC COMMAND EXTEND OutputGoal
 END
 
 VERNAC COMMAND EXTEND OutputGoal
-  [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ]
+  [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ]
 END
 
 VERNAC COMMAND EXTEND KillProofAfter
-| [ "Kill" "Proof" "after"  natural(n) ] -> [ kill_node_verbose n ]
+| [ "Kill" "Proof" "after"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
 END
 
 VERNAC COMMAND EXTEND KillProofAt
-| [ "Kill" "Proof" "at"  natural(n) ] -> [ kill_node_verbose n ]
+| [ "Kill" "Proof" "at"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
 END
 
 VERNAC COMMAND EXTEND KillSubProof
-  [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ]
+  [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ]
 END
 
 VERNAC COMMAND EXTEND PcoqReset
@@ -515,18 +530,17 @@ VERNAC COMMAND EXTEND PcoqResetInitial
 END
 
 let start_proof_hook () =
-  History.start_proof (current_proof_name());
+  if !pcoq_history then History.start_proof (current_proof_name());
   current_goal_index := 1
 
 let solve_hook n =
-  let name = current_proof_name () in
-  let old_n_count = History.border_length name in
-  let pf = proof_of_pftreestate (get_pftreestate ()) in
-  let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
-  begin
-    current_goal_index := n;
-    History.push_command name  n n_goals
-  end
+  current_goal_index := n;
+  if !pcoq_history then
+    let name = current_proof_name () in
+    let old_n_count = History.border_length name in
+    let pf = proof_of_pftreestate (get_pftreestate ()) in
+    let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
+      History.push_command name n n_goals
 
 let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s)
 
@@ -535,6 +549,12 @@ let interp_search_about_item = function
   | SearchString s -> GlobSearchString s
 
 let pcoq_search s l =
+  (* LEM: I don't understand why this is done in this way (redoing the
+   *      match on s here) instead of making the code in
+   *      parsing/search.ml call the right function instead of
+   *      "plain_display". Investigates this later.
+   * TODO
+   *)
   ctv_SEARCH_LIST:=[];
   begin match s with
   | SearchAbout sl -> 
@@ -581,27 +601,25 @@ let hyp_search_pattern c l =
       (Some
 	 (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
 let pcoq_print_name ref =
-  let results = xlate_vernac_list (name_to_ast ref) in
   output_results 
-    (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ())
-    (Some (P_cl results))
+    (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref )
+    None
 
-let pcoq_print_check j =
-  let a,b = print_check j in output_results a b
+let pcoq_print_check env j =
+  let a,b = print_check env j in output_results a b
 
-let pcoq_print_eval redfun env c j =
-  let strm, vtp = ct_print_eval c redfun env j in
-  output_results strm vtp;;
+let pcoq_print_eval redfun env evmap c j =
+  output_results
+    (ctf_SearchResults !global_request_id
+     ++ Prettyp.print_eval redfun env evmap c j)
+    None;;
 
 open Vernacentries
 
 let pcoq_show_goal = function
   | Some n -> show_nth n
-  | None ->
-      if !pcoq_started = Some true (* = debug *) then
-	msg (Printer.pr_open_subgoals ())
-      else errorlabstrm "show_goal"
-	(str "Show must be followed by an integer in Centaur mode");;
+  | None -> show_subgoals ()
+;;
 
 let pcoq_hook = {
   start_proof = start_proof_hook;
@@ -614,6 +632,165 @@ let pcoq_hook = {
   show_goal = pcoq_show_goal
 }
 
+let pcoq_term_pr = {
+  pr_constr_expr   = (fun c -> str "pcoq_constr_expr\n"  ++ (default_term_pr.pr_constr_expr   c));
+  (* In future translate_constr false (Global.env())
+   * Except with right bool/env which I'll get :)
+   *)
+  pr_lconstr_expr  = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr  c) ++ str ")");
+  pr_pattern_expr  = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_pattern_expr  c));
+  pr_lpattern_expr = (fun c -> str "pcoq_constr_expr\n"  ++ (default_term_pr.pr_lpattern_expr c))
+}
+
+let start_pcoq_trees () =
+  set_term_pr pcoq_term_pr
+
+(* BEGIN functions for object_pr *)
+
+(* These functions in general mirror what name_to_ast does in a subcase,
+   and then print the corresponding object as a PCoq tree. *)
+
+let object_to_ast_template object_to_ast_list sp =
+  let l = object_to_ast_list sp in
+    VernacList (List.map (fun x -> (dummy_loc, x)) l)
+
+let pcoq_print_object_template object_to_ast_list sp =
+  let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in
+    print_tree (P_cl results)
+
+(* This function mirror what print_check does *)
+
+let pcoq_print_typed_value_in_env env (value, typ) =
+ let value_ct_ast = 
+     (try translate_constr false (Global.env()) value 
+      with UserError(f,str) ->
+           raise(UserError(f,Printer.pr_lconstr value ++
+			      fnl () ++ str ))) in
+ let type_ct_ast =
+     (try translate_constr false (Global.env()) typ
+      with UserError(f,str) ->
+           raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
+   print_tree
+     (P_pl
+	(CT_premises_list
+	   [CT_coerce_TYPED_FORMULA_to_PREMISE
+	      (CT_typed_formula(value_ct_ast,type_ct_ast)
+	      )]))
+;;
+
+(* This function mirrors what show_nth does *)
+
+let pcoq_pr_subgoal n gl =
+  try
+    print_tree
+      (if (!text_proof_flag<>"off") then
+	   (* This is a horrendeous hack; it ignores the "gl" argument
+              and just takes the currently focused proof. This will bite
+	      us back one day.
+	      TODO: Fix this.
+	   *)
+	   (
+	    if not !pcoq_history then error "Text mode requires Pcoq history tracking.";
+	    if n=0
+	    then (P_text (show_proof !text_proof_flag []))
+	    else
+		let path = History.get_nth_open_path (current_proof_name()) n in
+		  (P_text (show_proof !text_proof_flag path)))
+       else
+	   (let goal = List.nth gl (n - 1) in
+	      (P_r (translate_goal goal))))
+  with
+  | Invalid_argument _
+  | Failure "nth"
+  | Not_found           -> error "No such goal";;
+
+let pcoq_pr_subgoals close_cmd evar gl =
+  (*LEM: TODO: we should check for evar emptiness or not, and do something *)
+  try
+    print_tree
+      (if (!text_proof_flag<>"off") then
+	   raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented"))
+       else
+	   (P_rl (translate_goals gl)))
+  with
+  | Invalid_argument _
+  | Failure "nth"
+  | Not_found           -> error "No such goal";;
+
+
+(*  END functions for object_pr  *)
+
+let pcoq_object_pr = {
+  print_inductive           = pcoq_print_object_template inductive_to_ast_list;
+  (* TODO: Check what that with_infos means, and adapt accordingly *)
+  print_constant_with_infos = pcoq_print_object_template constant_to_ast_list;
+  print_section_variable    = pcoq_print_object_template variable_to_ast_list;
+  print_syntactic_def       = pcoq_print_object_template (fun x -> errorlabstrm "print"
+      (str "printing of syntax definitions not implemented in PCoq syntax"));
+  (* TODO: These are placeholders only; write them *)
+  print_module              = (fun x y -> str "pcoq_print_module not implemented");
+  print_modtype             = (fun x   -> str "pcoq_print_modtype not implemented");
+  print_named_decl          = (fun x   -> str "pcoq_print_named_decl not implemented");
+  (* TODO: Find out what the first argument x (a bool) is about and react accordingly *)
+  print_leaf_entry          = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list);
+  print_library_entry       = (fun x y -> Some (str "pcoq_print_library_entry not implemented"));
+  print_context             = (fun x y z -> str "pcoq_print_context not implemented");
+  print_typed_value_in_env  = pcoq_print_typed_value_in_env;
+  Prettyp.print_eval        = ct_print_eval;
+};;
+
+let pcoq_printer_pr = {
+ pr_subgoals = pcoq_pr_subgoals;
+ pr_subgoal  = pcoq_pr_subgoal;
+ pr_goal     = (fun x   -> str "pcoq_pr_goal not implemented");
+};;
+
+
+let start_pcoq_objects () =
+  set_object_pr pcoq_object_pr;
+  set_printer_pr pcoq_printer_pr
+
+let start_default_objects () =
+  set_object_pr default_object_pr;
+  set_printer_pr default_printer_pr
+
+let full_name_of_ref r =
+  (match r with
+     | VarRef _ -> str "VAR"
+     | ConstRef _ -> str "CST"
+     | IndRef _ -> str "IND"
+     | ConstructRef _ -> str "CSR")
+  ++ str " " ++ (pr_sp (Nametab.sp_of_global r))
+    (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *)
+
+let string_of_ref =
+  (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*)
+  Depends.o Libnames.string_of_path Nametab.sp_of_global
+
+let print_depends compute_depends ptree =
+  output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl())
+		    (str "This object depends on:" ++ fnl())
+		    (compute_depends ptree))
+                 None
+
+let output_depends compute_depends ptree =
+  (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *)
+  output_results (ctf_header "depends" !global_request_id ++
+		    print_tree (P_ids (CT_id_list (List.map
+						     (fun x -> CT_ident (string_of_ref x))
+						     (compute_depends ptree)))))
+                 None
+
+let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' =
+  Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[]));
+  Command.set_declare_assumption_hook (print_depends  (fun (c:types) -> Depends.depends_of_constr c []));
+  Command.set_start_hook (print_depends    (fun c -> Depends.depends_of_constr c []));
+  Command.set_save_hook  (print_depends''  (Depends.depends_of_pftreestate Depends.depends_of_pftree));
+  Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt []))
+
+let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends
+
+let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends
 
 TACTIC EXTEND pbp
 | [ "pbp" ident_opt(idopt) natural_list(nl) ] -> 
@@ -635,7 +812,6 @@ let start_pcoq_mode debug =
 (* <\cpa> 
     start_dad();
 </cpa> *)
-    declare_in_coq();
 (* The following ones are added to enable rich comments in pcoq *)
 (* TODO ...
     add_tactic "Image" (fun _ -> tclIDTAC);
@@ -649,6 +825,8 @@ let start_pcoq_mode debug =
       List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes;
 *)
     set_pcoq_hook pcoq_hook;
+    start_pcoq_objects();
+    Flags.print_emacs := false; Pp.make_pp_nonemacs(); 
   end;;
 
 
@@ -681,3 +859,23 @@ END
 VERNAC COMMAND EXTEND StartPcoqDebug
 | [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ]
 END
+
+VERNAC COMMAND EXTEND StartPcoqTerms
+| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ]
+END
+
+VERNAC COMMAND EXTEND StartPcoqObjects
+| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ]
+END
+
+VERNAC COMMAND EXTEND StartDefaultObjects
+| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ]
+END
+
+VERNAC COMMAND EXTEND StartDependencyDumps
+| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ]
+END
+
+VERNAC COMMAND EXTEND StopPcoqHistory
+| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ]
+END
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
index 890bb3ce..aad3a765 100644
--- a/contrib/interface/debug_tac.ml4
+++ b/contrib/interface/debug_tac.ml4
@@ -113,7 +113,7 @@ let count_subgoals2
 let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function
     TacThens (a,l) ->
       (fun report_holder -> checked_thens report_holder a l)
-  | TacThen (a,b) ->
+  | TacThen (a,[||],b,[||]) ->
       (fun report_holder -> checked_then report_holder a b)
   | t ->
       (fun report_holder g ->
@@ -279,7 +279,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) =
       	| Failed n -> TacId []
       	| Tree_fail r -> reconstruct_success_tac a r
       	| Mismatch (n,p) -> a)
-  | TacThen (a,b) ->
+  | TacThen (a,[||],b,[||]) ->
       (function
 	  Report_node(true, n, l) -> tac
 	| Report_node(false, n, rl) ->
@@ -340,7 +340,7 @@ Tacinterp.add_tactic "OnThen" on_then;;
 
 let rec clean_path tac l = 
   match tac, l with
-  | TacThen (a,b), fst::tl ->
+  | TacThen (a,[||],b,[||]), fst::tl ->
       fst::(clean_path (if fst = 1 then a else b) tl)
   | TacThens (a,l), 1::tl ->
       1::(clean_path a tl)
@@ -390,7 +390,7 @@ let rec report_error
 	  | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path))::
 	      (fold_num (n + 1) tl) in
 	fold_num 1 l)
-    | TacThen (a,b) ->
+    | TacThen (a,[||],b,[||]) ->
 	let the_count = ref 1 in
 	tclTHEN
 	  (fun g ->
@@ -398,7 +398,7 @@ let rec report_error
 	      report_error a the_goal the_ast returned_path (1::path) g
 	    with
 	      e ->
-		(the_ast := TacThen (!the_ast, b);
+		(the_ast := TacThen (!the_ast,[||], b,[||]);
 		 raise e))
 	  (fun g ->
 	    try
diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml
new file mode 100644
index 00000000..dd40c5cc
--- /dev/null
+++ b/contrib/interface/depends.ml
@@ -0,0 +1,454 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant                                  *)
+(* <O___,, *                                                            *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *      GNU Lesser General Public License Version 2.1,        *)
+(*         *      or (at your option) any later version.                *)
+(************************************************************************)
+
+(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *)
+
+(* This is distributed in the hope that it will be useful,           *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
+(* Lesser General Public License for more details.                   *)
+
+(* You should have received a copy of the GNU Lesser General Public    *)
+(* License along with this library; if not, write to the Free Software *)
+(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,          *)
+(* MA  02110-1301, USA                                                 *)
+
+
+(* LEM TODO: a .mli file *)
+
+open Refiner
+open Proof_type
+open Rawterm
+open Term
+open Libnames
+open Util
+open Tacexpr
+open Entries
+
+(* DBG utilities, to be removed *)
+let print_bool b = print_string (string_of_bool b)
+let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter()
+let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O"
+(* End utilities, to be removed *)
+
+let explore_tree pfs =
+  print_string "explore_tree called\n";
+  print_string "pfs is a top: ";
+  (* We expect yes. *)
+  print_string (if (is_top_pftreestate pfs) then "yes" else "no");
+  print_newline();
+  let rec explain_tree (pt:proof_tree) =
+    match pt.ref with
+      | None -> "none"
+      | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
+      | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
+      | Some (Decl_proof _, _) -> "Decl_proof"
+      | Some (Daimon, _) -> "Daimon"
+  and explain_compound cr =
+    match cr with
+      | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")"
+      | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")"
+  and explain_prim = function
+    | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c))
+    | Intro identifier -> "Intro"
+    | Intro_replacing identifier -> "Intro_replacing"
+    | Cut (bool, identifier, types) -> "Cut"
+    | FixRule (identifier, int, l) -> "FixRule"
+    | Cofix (identifier, l) -> "Cofix"
+    | Convert_concl (types, cast_kind) -> "Convert_concl"
+    | Convert_hyp named_declaration -> "Convert_hyp"
+    | Thin identifier_list -> "Thin"
+    | ThinBody identifier_list -> "ThinBody"
+    | Move (bool, identifier, identifier') -> "Move"
+    | Rename (identifier, identifier') -> "Rename"
+    | Change_evars -> "Change_evars"
+  in
+  let pt = proof_of_pftreestate pfs in
+    (* We expect 0 *)
+    print_string "Number of open subgoals: ";
+    print_int pt.open_subgoals;
+    print_newline();
+    print_string "First rule is a ";
+    print_string (explain_tree pt);
+    print_newline()
+
+
+let o f g x = f (g x)
+let fst_of_3 (x, _, _) = x
+let snd_of_3 (_, x, _) = x
+let trd_of_3 (_, _, x) = x
+
+(* TODO: These for now return a Libnames.global_reference, but a
+   prooftree will also depend on things like tactic declarations, etc
+   so we may need a new type for that. *)
+let rec depends_of_hole_kind hk acc = match hk with
+  | Evd.ImplicitArg (gr,_)            -> gr::acc
+  | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc
+  | Evd.BinderType _
+  | Evd.QuestionMark _
+  | Evd.CasesType
+  | Evd.InternalHole
+  | Evd.GoalEvar
+  | Evd.ImpossibleCase  -> acc
+
+let depends_of_'a_cast_type depends_of_'a act acc = match act with
+  | CastConv (ck, a) -> depends_of_'a a acc
+  | CastCoerce       -> acc
+
+let depends_of_'a_bindings depends_of_'a ab acc = match ab with
+  | ImplicitBindings al  -> list_union_map depends_of_'a al acc
+  | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc
+  | NoBindings -> acc
+
+let depends_of_'a_with_bindings depends_of_'a (a, ab) acc =
+  depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc)
+
+(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *)
+(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *)
+
+let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with
+  | ElimOnConstr a -> depends_of_'a a acc
+  | ElimOnIdent _ ->
+      (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.)
+       * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-(
+
+       * Plan: Load all section variables before anything in that
+       * section and call the user's proof script "brittle" and refuse
+       * to handle if it breaks because of that
+       *)
+      acc
+  | ElimOnAnonHyp _ -> acc
+
+let depends_of_'a_or_var depends_of_'a aov acc = match aov with
+  | ArgArg a -> depends_of_'a a acc
+  | ArgVar _ -> acc
+
+let depends_of_'a_with_occurences depends_of_'a (_,a) acc =
+  depends_of_'a a acc
+
+let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with
+  (* TODO: dirty assumption that the 'b doesn't make any dependency *)
+  | Red _
+  | Hnf
+  | Cbv _
+  | Lazy _
+  | Unfold _
+  | ExtraRedExpr _
+  | CbvVm           -> acc
+  | Simpl awoo ->
+      Option.fold_right
+	(depends_of_'a_with_occurences depends_of_'a)
+	awoo
+	acc
+  | Fold al -> list_union_map depends_of_'a al acc
+  | Pattern awol ->
+      list_union_map
+	(depends_of_'a_with_occurences depends_of_'a)
+	awol
+	acc
+
+let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with
+  (* TODO: dirty assumption that the 'b doesn't make any dependency *)
+  | NonDepInversion _       -> acc
+  | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc
+  | InversionUsing (a, _)   -> depends_of_'a a acc
+
+let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc
+
+let depends_of_named_vals nvs acc =
+  (* TODO: I'm stopping here because I have noooo idea what to do with values... *)
+  acc
+
+let depends_of_inductive ind acc = (IndRef ind)::acc
+
+let rec depends_of_constr c acc = match kind_of_term c with
+  | Rel       _                -> acc
+  | Var       id               -> (VarRef id)::acc
+  | Meta      _                -> acc
+  | Evar      ev               -> depends_of_'a_pexistential depends_of_constr ev acc
+  | Sort      _                -> acc
+  | Cast      (c, _, t)        -> depends_of_constr c (depends_of_constr t acc)
+  | Prod      (_, t, t')       -> depends_of_constr t (depends_of_constr t' acc)
+  | Lambda    (_, t, c)        -> depends_of_constr t (depends_of_constr c acc)
+  | LetIn     (_, c, t, c')    -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc))
+  | App       (c, ca)          -> depends_of_constr c (array_union_map depends_of_constr ca acc)
+  | Const     cnst             -> (ConstRef cnst)::acc
+  | Ind       ind              -> (IndRef ind)::acc
+  | Construct cons             -> (ConstructRef cons)::acc
+  | Case      (_, c, c', ca)   -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc))
+  | Fix       (_, (_, ta, ca))
+  | CoFix     (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc)
+and depends_of_evar_map evm acc =
+  Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc
+and depends_of_evar_info evi acc =
+  (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *)
+  depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc))
+and depends_of_evar_body evb acc = match evb with
+  | Evd.Evar_empty -> acc
+  | Evd.Evar_defined c -> depends_of_constr c acc
+and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc
+and depends_of_named_context_val ncv acc =
+  depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc)
+and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc)
+
+
+
+let depends_of_open_constr (evm,c) acc =
+  depends_of_constr c (depends_of_evar_map evm acc)
+
+let rec depends_of_rawconstr rc acc = match rc with
+  | RRef (_,r)         -> r::acc
+  | RVar (_, id)       -> (VarRef id)::acc
+  | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc
+  | RPatVar _          -> acc
+  | RApp (_, rc, rcl)  -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc)
+  | RLambda (_, _, _, rct, rcb)
+  | RProd   (_, _, _, rct, rcb)
+  | RLetIn  (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc)
+  | RCases  (_, _, rco, tmt, cc) ->
+      (* LEM TODO: handle the cc *)
+      (Option.fold_right depends_of_rawconstr rco
+         (list_union_map
+	    (fun (rc, pp) acc ->
+	       Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp)
+	       (depends_of_rawconstr rc acc))
+	    tmt
+	    acc))
+  | RLetTuple (_,_,(_,rco),rc0,rc1) ->
+     depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc))
+  | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in
+      dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc))))
+  | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in
+      dorca rca0 (dorca rca1 (array_union_map
+				(list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc)))
+				rdla
+				acc))
+  | RSort _ -> acc
+  | RHole (_, hk) -> depends_of_hole_kind hk acc
+  | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc)
+  | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*)
+and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l
+
+let depends_of_rawconstr_and_expr (rc, _) acc =
+  (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *)
+  depends_of_rawconstr rc acc
+
+let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac =
+  (* TODO:
+   * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies
+   *)
+  let rec depends_of_tacexpr texp acc = match texp with
+    | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc
+    | TacThen (tac0, taca0, tac1, taca1) ->
+	depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc)))
+    | TacThens (tac, tacl) ->
+	depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc)
+    | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc
+    | TacComplete tac -> depends_of_tacexpr tac acc
+    | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc
+    | TacTry tac -> depends_of_tacexpr tac acc
+    | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc)
+    | TacDo (_, tac) -> depends_of_tacexpr tac acc
+    | TacRepeat tac -> depends_of_tacexpr tac acc
+    | TacProgress tac -> depends_of_tacexpr tac acc
+    | TacAbstract (tac, _) -> depends_of_tacexpr tac acc
+    | TacId _
+    | TacFail _ -> acc
+    | TacInfo tac -> depends_of_tacexpr tac acc
+    | TacLetIn (_, igtal, tac) ->
+	depends_of_tacexpr
+	  tac
+	  (list_union_map
+	     (fun x y -> depends_of_tac_arg (snd x) y)
+	     igtal
+	     acc)
+    | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet"
+    | TacMatchContext (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet"
+    | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc
+    | TacArg tacarg -> depends_of_tac_arg tacarg acc
+  and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with
+      (* Basic tactics *)
+    | TacIntroPattern _
+    | TacIntrosUntil _
+    | TacIntroMove _
+    | TacAssumption  -> acc
+    | TacExact          c
+    | TacExactNoCheck   c
+    | TacVmCastNoCheck  c  -> depends_of_'constr c acc
+    | TacApply (_, _, cb) -> depends_of_'constr_with_bindings cb acc
+    | TacElim (_, cwb, cwbo) ->
+	depends_of_'constr_with_bindings cwb
+	  (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
+    | TacElimType c -> depends_of_'constr c acc
+    | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc
+    | TacCaseType c -> depends_of_'constr c acc
+    | TacFix _
+    | TacMutualFix _
+    | TacCofix _
+    | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet"
+    | TacCut c -> depends_of_'constr c acc
+    | TacAssert (taco, _, c) ->
+	Option.fold_right depends_of_'tac taco (depends_of_'constr c acc)
+    | TacGeneralize cl ->
+	list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl)
+	acc
+    | TacGeneralizeDep c -> depends_of_'constr c acc
+    | TacLetTac (_,c,_,_) -> depends_of_'constr c acc
+
+    (* Derived basic tactics *)
+    | TacSimpleInduction _
+    | TacSimpleDestruct  _
+    | TacDoubleInduction _ -> acc
+    | TacNewInduction (_, cwbial, cwbo, _, _)
+    | TacNewDestruct (_, cwbial, cwbo, _, _) ->
+	list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings)
+	  cwbial
+	  (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
+    | TacDecomposeAnd c
+    | TacDecomposeOr  c -> depends_of_'constr c acc
+    | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc)
+    | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc
+    | TacLApply c -> depends_of_'constr c acc
+
+    (* Automation tactics *)
+    | TacTrivial (cl, bs) -> 
+	(* TODO: Maybe make use of bs: list of hint bases to be used. *)
+	list_union_map depends_of_'constr cl acc
+    | TacAuto (_, cs, bs) ->
+	(* TODO: Maybe make use of bs: list of hint bases to be used.
+           None -> all ("with *")
+           Some list -> a list, "core" added implicitly *)
+	list_union_map depends_of_'constr cs acc
+    | TacAutoTDB _     -> acc
+    | TacDestructHyp _ -> acc
+    | TacDestructConcl -> acc
+    | TacSuperAuto _ -> (* TODO: this reference thing is scary*)
+	acc
+    | TacDAuto     _ -> acc
+
+    (* Context management *)
+    | TacClear     _
+    | TacClearBody _
+    | TacMove      _
+    | TacRename    _ 
+    | TacRevert    _ -> acc
+
+    (* Constructors *)
+    | TacLeft        (_,cb)
+    | TacRight       (_,cb)
+    | TacSplit       (_, _, cb)
+    | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc
+    | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc
+
+    (* Conversion *)
+    | TacReduce  (reg,_) ->
+	depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc
+    | TacChange (cwoo, c, _) ->
+	depends_of_'constr
+	  c
+	  (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc)
+
+    (* Equivalence relations *)
+    | TacReflexivity
+    | TacSymmetry     _ -> acc
+    | TacTransitivity c -> depends_of_'constr c acc
+
+    (* Equality and inversion *)
+    | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc
+    | TacInversion (is, _)  -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc
+
+    (* For ML extensions *)
+    | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented"
+
+    (* For syntax extensions *)
+    | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented"
+  and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet"
+  and depends_of_tac_arg ta acc = match ta with
+    | TacDynamic (_,d)  -> failwith "Don't know what to do with a Dyn in tac_arg"
+    | TacVoid           -> acc
+    | MetaIdArg  _      -> failwith "Don't know what to do with a MetaIdArg in tac_arg"
+    | ConstrMayEval  me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval"
+    | IntroPattern   _  -> acc
+    | Reference     ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
+    | Integer       _   -> acc
+    | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
+	list_union_map depends_of_tac_arg l acc
+    | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc
+    | TacFreshId     _  -> acc
+    | Tacexp       tac  ->
+	depends_of_'tac tac acc
+  in
+    depends_of_tacexpr
+
+let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc =
+  depends_of_gen_tactic_expr
+    depends_of_rawconstr_and_expr
+    (depends_of_'a_or_var depends_of_inductive)
+    depends_of_glob_tactic_expr
+    gte
+    acc
+
+let rec depends_of_tacexpr te acc =
+  depends_of_gen_tactic_expr
+    depends_of_open_constr
+    depends_of_inductive
+    depends_of_glob_tactic_expr
+    te
+    acc
+
+let depends_of_compound_rule cr acc = match cr with
+  | Tactic (texp, _) -> depends_of_tacexpr texp acc
+  | Proof_instr (b, instr) ->
+      (* TODO: What is the boolean b? Should check. *)
+      failwith "Dependency calculation of Proof_instr not implemented yet"
+and depends_of_prim_rule pr acc = match pr with
+  | Refine c                     -> depends_of_constr c acc
+  | Intro id                     -> acc
+  | Intro_replacing id           -> acc
+  | Cut (_, _, t)                -> depends_of_constr t acc (* TODO: check what 2nd argument contains *)
+  | FixRule (_, _, l)            -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *)
+  | Cofix (_, l)                 -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *)
+  | Convert_concl (t, _)         -> depends_of_constr t acc
+  | Convert_hyp (_, None, t)     -> depends_of_constr t acc
+  | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc)
+  | Thin _                       -> acc
+  | ThinBody _                   -> acc
+  | Move _                       -> acc
+  | Rename _                     -> acc
+  | Change_evars                 -> acc
+
+let rec depends_of_pftree pt acc =
+  match pt.ref with
+    | None -> acc
+    | Some (Prim   pr    , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l  acc)
+    | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc))
+    | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc
+    | Some (Daimon,        l) -> list_union_map depends_of_pftree l acc
+
+let rec depends_of_pftree_head pt acc =
+  match pt.ref with
+    | None -> acc
+    | Some (Prim   pr    , l) -> depends_of_prim_rule pr acc
+    | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc)
+    | Some (Decl_proof _ , l) -> acc
+    | Some (Daimon,        l) -> acc
+
+let depends_of_pftreestate depends_of_pftree pfs =
+(*   print_string "depends_of_pftreestate called\n"; *)
+(*   explore_tree pfs; *)
+  let pt = proof_of_pftreestate pfs in
+    assert (is_top_pftreestate pfs);
+    assert (pt.open_subgoals = 0);
+    depends_of_pftree pt []
+
+let depends_of_definition_entry de ~acc =
+  Option.fold_right
+    depends_of_constr
+    de.const_entry_type
+    (depends_of_constr de.const_entry_body acc)
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
index 9a503cfb..6b17e739 100644
--- a/contrib/interface/name_to_ast.ml
+++ b/contrib/interface/name_to_ast.ml
@@ -28,7 +28,7 @@ let convert_env =
     let convert_binder env (na, b, c) =
       match b with 
        | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b)
-       | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in
+       | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in
     let rec cvrec env = function
        [] -> []
      | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in
@@ -134,14 +134,14 @@ let implicits_to_ast_list implicits =
 
 let make_variable_ast name typ implicits =
   (VernacAssumption
-    ((Local,Definitional),
-     [false,([dummy_loc,name], constr_to_ast (body_of_type typ))]))
+    ((Local,Definitional),false,(*inline flag*)
+     [false,([dummy_loc,name], constr_to_ast typ)]))
   ::(implicits_to_ast_list implicits);;
     
 
 let make_definition_ast name c typ implicits =
-  VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None,
-    (constr_to_ast c), Some (constr_to_ast (body_of_type typ))),
+  VernacDefinition ((Global,false,Definition), (dummy_loc,name), 
+		   DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)),
     (fun _ _ -> ()))
   ::(implicits_to_ast_list implicits);;
 
@@ -158,7 +158,7 @@ let constant_to_ast_list kn =
 	make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l)
 
 let variable_to_ast_list sp =
-  let (id, c, v) = get_variable sp in
+  let (id, c, v) = Global.lookup_named sp in
   let l = implicits_of_global (VarRef sp) in
     (match c with
 	 None -> 
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
index b8c2d7dc..f9e83b5e 100644
--- a/contrib/interface/name_to_ast.mli
+++ b/contrib/interface/name_to_ast.mli
@@ -1 +1,5 @@
 val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;;
+val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;;
+val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;;
+val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;;
+val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;;
diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml
index 8cca7614..bf8614b4 100644
--- a/contrib/interface/parse.ml
+++ b/contrib/interface/parse.ml
@@ -21,18 +21,19 @@ type parsed_tree =
   | P_i of ct_INT;;
 
 let print_parse_results n msg =
-  print_string "message\nparsed\n";
-  print_int n;
-  print_string "\n";
-  (match msg with
-  | P_cl x -> fCOMMAND_LIST x
-  | P_c x -> fCOMMAND x
-  | P_t x -> fTACTIC_COM x
-  | P_f x -> fFORMULA x
-  | P_id x -> fID x
-  | P_s x -> fSTRING x
-  | P_i x -> fINT x);
-  print_string "e\nblabla\n";
+  Pp.msg
+  ( str "message\nparsed\n" ++
+    int n ++
+    str "\n" ++
+    (match msg with
+     | P_cl x -> fCOMMAND_LIST x
+     | P_c x -> fCOMMAND x
+     | P_t x -> fTACTIC_COM x
+     | P_f x -> fFORMULA x
+     | P_id x -> fID x
+     | P_s x -> fSTRING x
+     | P_i x -> fINT x) ++
+    str "e\nblabla\n");
   flush stdout;;
 
 let ctf_SyntaxErrorMessage reqid pps =
@@ -329,7 +330,7 @@ let add_path_action reqid string_arg =
 
 let print_version_action () =
   msgnl (mt ());
-  msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");;
+  msgnl (str "$Id: parse.ml 9476 2007-01-10 15:44:44Z lmamane $");;
 
 let load_syntax_action reqid module_name =
  msg (str "loading " ++ str module_name ++ str "... ");
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
index d2f71bfc..06b957d9 100644
--- a/contrib/interface/pbp.ml
+++ b/contrib/interface/pbp.ml
@@ -156,29 +156,29 @@ let make_pbp_pattern x =
 let rec make_then = function
   | [] -> TacId []
   | [t] -> t
-  | t1::t2::l -> make_then (TacThen (t1,t2)::l)
+  | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l)
 
 let make_pbp_atomic_tactic = function
   | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption))
   | PbpTryAssumption (Some a) ->
       TacTry (TacAtom (zz, TacExact (make_var a)))
   | PbpExists x -> 
-      TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x]))
+      TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x]))
   | PbpGeneralize (h,args) ->
       let l = List.map make_pbp_pattern args in
-      TacAtom (zz, TacGeneralize [make_app (make_var h) l])
-  | PbpLeft -> TacAtom (zz, TacLeft NoBindings)
-  | PbpRight -> TacAtom (zz, TacRight NoBindings)
+      TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous])
+  | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings))
+  | PbpRight -> TacAtom (zz, TacRight (false,NoBindings))
   | PbpIntros l -> TacAtom (zz, TacIntroPattern l)
   | PbpLApply h -> TacAtom (zz, TacLApply (make_var h))
-  | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings))
+  | PbpApply h -> TacAtom (zz, TacApply (true,false,(make_var h,NoBindings)))
   | PbpElim (hyp_name, names) ->
       let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in
       TacAtom
-	(zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None))
+	(zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None))
   | PbpTryClear l -> 
       TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l)))
-  | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));;
+  | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));;
 
 let rec make_pbp_tactic = function
   | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl)
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
index 4bec7350..953fb5e7 100644
--- a/contrib/interface/showproof.ml
+++ b/contrib/interface/showproof.ml
@@ -166,7 +166,7 @@ let rule_to_ntactic r =
    let rt =
      (match r with
        Nested(Tactic (t,_),_) -> t
-     | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h)
+     | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h))
      | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
    if rule_is_complex r
    then (match rt with
@@ -1183,8 +1183,8 @@ let rec natural_ntree ig ntree =
 	    TacIntroPattern _ -> natural_intros ig lh g gs ltree
 	  | TacIntroMove _ -> natural_intros ig lh g gs ltree
 	  | TacFix (_,n) -> natural_fix ig lh g gs n ltree
-	  | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree
-	  | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree
+	  | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree
+	  | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree
 	  | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree
 	  | TacRight _ -> natural_right ig lh g gs ltree
 	  | TacLeft _ -> natural_left ig lh g gs ltree
@@ -1202,17 +1202,18 @@ let rec natural_ntree ig ntree =
 	  | TacExtend (_,"InductionIntro",[a]) -> 
               let id=(out_gen wit_ident a) in
               natural_induction ig lh g gs ge id ltree true
-	  | TacApply (c,_) -> natural_apply ig lh g gs c ltree
-	  | TacExact c -> natural_exact ig lh g gs c ltree
-	  | TacCut c -> natural_cut ig lh g gs c ltree
+	  | TacApply (_,false,(c,_)) -> natural_apply ig lh g gs (snd c) ltree
+	  | TacExact c -> natural_exact ig lh g gs (snd c) ltree
+	  | TacCut c -> natural_cut ig lh g gs (snd c) ltree
 	  | TacExtend (_,"CutIntro",[a]) ->
 	      let _c = out_gen wit_constr a in
 	      natural_cutintro ig lh g gs a ltree
-	  | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false
+	  | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false
 	  | TacExtend (_,"CaseIntro",[a]) ->
 	      let c = out_gen wit_constr a in
 	      natural_case ig lh g gs ge c ltree true
-	  | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false
+	  | TacElim (_,(c,_),_) ->
+	      natural_elim ig lh g gs ge (snd c) ltree false
 	  | TacExtend (_,"ElimIntro",[a]) ->
 	      let c = out_gen wit_constr a in
 	      natural_elim ig lh g gs ge c ltree true
@@ -1611,7 +1612,7 @@ and natural_fix ig lh g gs narg ltree =
    | _ -> assert false
 and natural_reduce ig lh g gs ge mode la ltree =
   match la with
-    {onhyps=Some[];onconcl=true} -> 
+    {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> 
       spv
         [  (natural_lhyp lh ig.ihsg);
           (show_goal2 lh ig g gs ""); 
@@ -1619,7 +1620,7 @@ and natural_reduce ig lh g gs ge mode la ltree =
 		  {ihsg=All_subgoals_hyp;isgintro="simpl"})
              ltree)
         ]
-  | {onhyps=Some[hyp]; onconcl=false} ->
+  | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr ->
       spv
         [  (natural_lhyp lh ig.ihsg);
           (show_goal2 lh ig g gs ""); 
@@ -1651,7 +1652,7 @@ and natural_split ig lh g gs ge la ltree =
   | _ -> assert false
 and natural_generalize ig lh g gs ge la ltree =
   match la with
-    [arg] ->
+    [(_,(_,arg)),_] ->
       let _env= (gLOB ge) in
       let arg1= (*dbize env*) arg in
       let _type_arg=type_of (Global.env()) Evd.empty arg in
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
index 6e4782be..559860b2 100644
--- a/contrib/interface/translate.ml
+++ b/contrib/interface/translate.ml
@@ -75,3 +75,6 @@ let translate_path l =
 (*translates a path and a goal into a centaur-tree --> RULE *)
 let translate_goal (g:goal) =
  CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);;
+
+let translate_goals (gl: goal list) =
+ CT_rule_list (List.map translate_goal gl);;
diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli
index 65d8331b..34841fc4 100644
--- a/contrib/interface/translate.mli
+++ b/contrib/interface/translate.mli
@@ -5,6 +5,7 @@ open Environ;;
 open Term;;
 
 val translate_goal : goal -> ct_RULE;;
+val translate_goals : goal list -> ct_RULE_LIST;;
 (* The boolean argument indicates whether names from the environment should *)
 (*  be avoided (same interpretation as for prterm_env and ast_of_constr)    *)
 val translate_constr : bool -> env -> constr -> ct_FORMULA;;
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
index 166a0cbf..551ad3a3 100644
--- a/contrib/interface/vtp.ml
+++ b/contrib/interface/vtp.ml
@@ -1,103 +1,108 @@
 open Ascent;;
+open Pp;;
+
+(* LEM: This is actually generated automatically *)
 
 let fNODE s n =
-    print_string "n\n";
-    print_string ("vernac$" ^ s);
-    print_string "\n";
-    print_int n;
-    print_string "\n";;
+    (str "n\n") ++
+    (str ("vernac$" ^ s)) ++
+    (str "\n") ++
+    (int n) ++
+    (str "\n");;
 
 let fATOM s1 =
-    print_string "a\n";
-    print_string ("vernac$" ^ s1);
-    print_string "\n";;
+    (str "a\n") ++
+    (str ("vernac$" ^ s1)) ++
+    (str "\n");;
 
-let f_atom_string = print_string;;
-let f_atom_int = print_int;;
+let f_atom_string = str;;
+let f_atom_int = int;;
 let rec fAST = function
 | CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x
 | CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x
 | CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x
 | CT_astnode(x1, x2) ->
-   fID x1;
-   fAST_LIST x2;
+   fID x1 ++
+   fAST_LIST x2 ++
    fNODE "astnode" 2
 | CT_astpath(x1) ->
-   fID_LIST x1;
+   fID_LIST x1 ++
    fNODE "astpath" 1
 | CT_astslam(x1, x2) ->
-   fID_OPT x1;
-   fAST x2;
+   fID_OPT x1 ++
+   fAST x2 ++
    fNODE "astslam" 2
 and fAST_LIST = function
 | CT_ast_list l ->
-   (List.iter fAST l);
+   (List.fold_left (++) (mt()) (List.map fAST l)) ++
    fNODE "ast_list" (List.length l)
 and fBINARY = function
-| CT_binary x -> fATOM "binary";
-   (f_atom_int x);
-   print_string "\n"and fBINDER = function
+| CT_binary x -> fATOM "binary" ++
+   (f_atom_int x) ++
+   str "\n"
+and fBINDER = function
 | CT_coerce_DEF_to_BINDER x -> fDEF x
 | CT_binder(x1, x2) ->
-   fID_OPT_NE_LIST x1;
-   fFORMULA x2;
+   fID_OPT_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "binder" 2
 | CT_binder_coercion(x1, x2) ->
-   fID_OPT_NE_LIST x1;
-   fFORMULA x2;
+   fID_OPT_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "binder_coercion" 2
 and fBINDER_LIST = function
 | CT_binder_list l ->
-   (List.iter fBINDER l);
+   (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
    fNODE "binder_list" (List.length l)
 and fBINDER_NE_LIST = function
 | CT_binder_ne_list(x,l) ->
-   fBINDER x;
-   (List.iter fBINDER l);
+   fBINDER x ++
+   (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
    fNODE "binder_ne_list" (1 + (List.length l))
 and fBINDING = function
 | CT_binding(x1, x2) ->
-   fID_OR_INT x1;
-   fFORMULA x2;
+   fID_OR_INT x1 ++
+   fFORMULA x2 ++
    fNODE "binding" 2
 and fBINDING_LIST = function
 | CT_binding_list l ->
-   (List.iter fBINDING l);
+   (List.fold_left (++) (mt()) (List.map fBINDING l)) ++
    fNODE "binding_list" (List.length l)
 and fBOOL = function
 | CT_false -> fNODE "false" 0
 | CT_true -> fNODE "true" 0
 and fCASE = function
-| CT_case x -> fATOM "case";
-   (f_atom_string x);
-   print_string "\n"and fCLAUSE = function
+| CT_case x -> fATOM "case" ++
+   (f_atom_string x) ++
+   str "\n"
+and fCLAUSE = function
 | CT_clause(x1, x2) ->
-   fHYP_LOCATION_LIST_OR_STAR x1;
-   fSTAR_OPT x2;
+   fHYP_LOCATION_LIST_OR_STAR x1 ++
+   fSTAR_OPT x2 ++
    fNODE "clause" 2
 and fCOERCION_OPT = function
 | CT_coerce_NONE_to_COERCION_OPT x -> fNONE x
 | CT_coercion_atm -> fNODE "coercion_atm" 0
 and fCOFIXTAC = function
 | CT_cofixtac(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "cofixtac" 2
 and fCOFIX_REC = function
 | CT_cofix_rec(x1, x2, x3, x4) ->
-   fID x1;
-   fBINDER_LIST x2;
-   fFORMULA x3;
-   fFORMULA x4;
+   fID x1 ++
+   fBINDER_LIST x2 ++
+   fFORMULA x3 ++
+   fFORMULA x4 ++
    fNODE "cofix_rec" 4
 and fCOFIX_REC_LIST = function
 | CT_cofix_rec_list(x,l) ->
-   fCOFIX_REC x;
-   (List.iter fCOFIX_REC l);
+   fCOFIX_REC x ++
+   (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++
    fNODE "cofix_rec_list" (1 + (List.length l))
 and fCOFIX_TAC_LIST = function
 | CT_cofix_tac_list l ->
-   (List.iter fCOFIXTAC l);
+   (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++
    fNODE "cofix_tac_list" (List.length l)
 and fCOMMAND = function
 | CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x
@@ -105,479 +110,476 @@ and fCOMMAND = function
 | CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x
 | CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x
 | CT_abort(x1) ->
-   fID_OPT_OR_ALL x1;
+   fID_OPT_OR_ALL x1 ++
    fNODE "abort" 1
 | CT_abstraction(x1, x2, x3) ->
-   fID x1;
-   fFORMULA x2;
-   fINT_LIST x3;
+   fID x1 ++
+   fFORMULA x2 ++
+   fINT_LIST x3 ++
    fNODE "abstraction" 3
 | CT_add_field(x1, x2, x3, x4) ->
-   fFORMULA x1;
-   fFORMULA x2;
-   fFORMULA x3;
-   fFORMULA_OPT x4;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
+   fFORMULA x3 ++
+   fFORMULA_OPT x4 ++
    fNODE "add_field" 4
 | CT_add_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1;
-   fID x2;
+   fNATURAL_FEATURE x1 ++
+   fID x2 ++
    fNODE "add_natural_feature" 2
 | CT_addpath(x1, x2) ->
-   fSTRING x1;
-   fID_OPT x2;
+   fSTRING x1 ++
+   fID_OPT x2 ++
    fNODE "addpath" 2
 | CT_arguments_scope(x1, x2) ->
-   fID x1;
-   fID_OPT_LIST x2;
+   fID x1 ++
+   fID_OPT_LIST x2 ++
    fNODE "arguments_scope" 2
 | CT_bind_scope(x1, x2) ->
-   fID x1;
-   fID_NE_LIST x2;
+   fID x1 ++
+   fID_NE_LIST x2 ++
    fNODE "bind_scope" 2
 | CT_cd(x1) ->
-   fSTRING_OPT x1;
+   fSTRING_OPT x1 ++
    fNODE "cd" 1
 | CT_check(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "check" 1
 | CT_class(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "class" 1
 | CT_close_scope(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "close_scope" 1
 | CT_coercion(x1, x2, x3, x4, x5) ->
-   fLOCAL_OPT x1;
-   fIDENTITY_OPT x2;
-   fID x3;
-   fID x4;
-   fID x5;
+   fLOCAL_OPT x1 ++
+   fIDENTITY_OPT x2 ++
+   fID x3 ++
+   fID x4 ++
+   fID x5 ++
    fNODE "coercion" 5
 | CT_cofix_decl(x1) ->
-   fCOFIX_REC_LIST x1;
+   fCOFIX_REC_LIST x1 ++
    fNODE "cofix_decl" 1
 | CT_compile_module(x1, x2, x3) ->
-   fVERBOSE_OPT x1;
-   fID x2;
-   fSTRING_OPT x3;
+   fVERBOSE_OPT x1 ++
+   fID x2 ++
+   fSTRING_OPT x3 ++
    fNODE "compile_module" 3
 | CT_declare_module(x1, x2, x3, x4) ->
-   fID x1;
-   fMODULE_BINDER_LIST x2;
-   fMODULE_TYPE_CHECK x3;
-   fMODULE_EXPR x4;
+   fID x1 ++
+   fMODULE_BINDER_LIST x2 ++
+   fMODULE_TYPE_CHECK x3 ++
+   fMODULE_EXPR x4 ++
    fNODE "declare_module" 4
 | CT_define_notation(x1, x2, x3, x4) ->
-   fSTRING x1;
-   fFORMULA x2;
-   fMODIFIER_LIST x3;
-   fID_OPT x4;
+   fSTRING x1 ++
+   fFORMULA x2 ++
+   fMODIFIER_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "define_notation" 4
 | CT_definition(x1, x2, x3, x4, x5) ->
-   fDEFN x1;
-   fID x2;
-   fBINDER_LIST x3;
-   fDEF_BODY x4;
-   fFORMULA_OPT x5;
+   fDEFN x1 ++
+   fID x2 ++
+   fBINDER_LIST x3 ++
+   fDEF_BODY x4 ++
+   fFORMULA_OPT x5 ++
    fNODE "definition" 5
 | CT_delim_scope(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "delim_scope" 2
 | CT_delpath(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "delpath" 1
 | CT_derive_depinversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1;
-   fID x2;
-   fFORMULA x3;
-   fSORT_TYPE x4;
+   fINV_TYPE x1 ++
+   fID x2 ++
+   fFORMULA x3 ++
+   fSORT_TYPE x4 ++
    fNODE "derive_depinversion" 4
 | CT_derive_inversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1;
-   fINT_OPT x2;
-   fID x3;
-   fID x4;
+   fINV_TYPE x1 ++
+   fINT_OPT x2 ++
+   fID x3 ++
+   fID x4 ++
    fNODE "derive_inversion" 4
 | CT_derive_inversion_with(x1, x2, x3, x4) ->
-   fINV_TYPE x1;
-   fID x2;
-   fFORMULA x3;
-   fSORT_TYPE x4;
+   fINV_TYPE x1 ++
+   fID x2 ++
+   fFORMULA x3 ++
+   fSORT_TYPE x4 ++
    fNODE "derive_inversion_with" 4
 | CT_explain_proof(x1) ->
-   fINT_LIST x1;
+   fINT_LIST x1 ++
    fNODE "explain_proof" 1
 | CT_explain_prooftree(x1) ->
-   fINT_LIST x1;
+   fINT_LIST x1 ++
    fNODE "explain_prooftree" 1
 | CT_export_id(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "export_id" 1
 | CT_extract_to_file(x1, x2) ->
-   fSTRING x1;
-   fID_NE_LIST x2;
+   fSTRING x1 ++
+   fID_NE_LIST x2 ++
    fNODE "extract_to_file" 2
 | CT_extraction(x1) ->
-   fID_OPT x1;
+   fID_OPT x1 ++
    fNODE "extraction" 1
 | CT_fix_decl(x1) ->
-   fFIX_REC_LIST x1;
+   fFIX_REC_LIST x1 ++
    fNODE "fix_decl" 1
 | CT_focus(x1) ->
-   fINT_OPT x1;
+   fINT_OPT x1 ++
    fNODE "focus" 1
 | CT_go(x1) ->
-   fINT_OR_LOCN x1;
+   fINT_OR_LOCN x1 ++
    fNODE "go" 1
 | CT_guarded -> fNODE "guarded" 0
 | CT_hint_destruct(x1, x2, x3, x4, x5, x6) ->
-   fID x1;
-   fINT x2;
-   fDESTRUCT_LOCATION x3;
-   fFORMULA x4;
-   fTACTIC_COM x5;
-   fID_LIST x6;
+   fID x1 ++
+   fINT x2 ++
+   fDESTRUCT_LOCATION x3 ++
+   fFORMULA x4 ++
+   fTACTIC_COM x5 ++
+   fID_LIST x6 ++
    fNODE "hint_destruct" 6
 | CT_hint_extern(x1, x2, x3, x4) ->
-   fINT x1;
-   fFORMULA x2;
-   fTACTIC_COM x3;
-   fID_LIST x4;
+   fINT x1 ++
+   fFORMULA x2 ++
+   fTACTIC_COM x3 ++
+   fID_LIST x4 ++
    fNODE "hint_extern" 4
 | CT_hintrewrite(x1, x2, x3, x4) ->
-   fORIENTATION x1;
-   fFORMULA_NE_LIST x2;
-   fID x3;
-   fTACTIC_COM x4;
+   fORIENTATION x1 ++
+   fFORMULA_NE_LIST x2 ++
+   fID x3 ++
+   fTACTIC_COM x4 ++
    fNODE "hintrewrite" 4
 | CT_hints(x1, x2, x3) ->
-   fID x1;
-   fID_NE_LIST x2;
-   fID_LIST x3;
+   fID x1 ++
+   fID_NE_LIST x2 ++
+   fID_LIST x3 ++
    fNODE "hints" 3
 | CT_hints_immediate(x1, x2) ->
-   fFORMULA_NE_LIST x1;
-   fID_LIST x2;
+   fFORMULA_NE_LIST x1 ++
+   fID_LIST x2 ++
    fNODE "hints_immediate" 2
 | CT_hints_resolve(x1, x2) ->
-   fFORMULA_NE_LIST x1;
-   fID_LIST x2;
+   fFORMULA_NE_LIST x1 ++
+   fID_LIST x2 ++
    fNODE "hints_resolve" 2
 | CT_hyp_search_pattern(x1, x2) ->
-   fFORMULA x1;
-   fIN_OR_OUT_MODULES x2;
+   fFORMULA x1 ++
+   fIN_OR_OUT_MODULES x2 ++
    fNODE "hyp_search_pattern" 2
 | CT_implicits(x1, x2) ->
-   fID x1;
-   fID_LIST_OPT x2;
+   fID x1 ++
+   fID_LIST_OPT x2 ++
    fNODE "implicits" 2
 | CT_import_id(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "import_id" 1
 | CT_ind_scheme(x1) ->
-   fSCHEME_SPEC_LIST x1;
+   fSCHEME_SPEC_LIST x1 ++
    fNODE "ind_scheme" 1
 | CT_infix(x1, x2, x3, x4) ->
-   fSTRING x1;
-   fID x2;
-   fMODIFIER_LIST x3;
-   fID_OPT x4;
+   fSTRING x1 ++
+   fID x2 ++
+   fMODIFIER_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "infix" 4
 | CT_inline(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "inline" 1
 | CT_inspect(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "inspect" 1
 | CT_kill_node(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "kill_node" 1
 | CT_load(x1, x2) ->
-   fVERBOSE_OPT x1;
-   fID_OR_STRING x2;
+   fVERBOSE_OPT x1 ++
+   fID_OR_STRING x2 ++
    fNODE "load" 2
 | CT_local_close_scope(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "local_close_scope" 1
 | CT_local_define_notation(x1, x2, x3, x4) ->
-   fSTRING x1;
-   fFORMULA x2;
-   fMODIFIER_LIST x3;
-   fID_OPT x4;
+   fSTRING x1 ++
+   fFORMULA x2 ++
+   fMODIFIER_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "local_define_notation" 4
 | CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) ->
-   fID x1;
-   fINT x2;
-   fDESTRUCT_LOCATION x3;
-   fFORMULA x4;
-   fTACTIC_COM x5;
-   fID_LIST x6;
+   fID x1 ++
+   fINT x2 ++
+   fDESTRUCT_LOCATION x3 ++
+   fFORMULA x4 ++
+   fTACTIC_COM x5 ++
+   fID_LIST x6 ++
    fNODE "local_hint_destruct" 6
 | CT_local_hint_extern(x1, x2, x3, x4) ->
-   fINT x1;
-   fFORMULA x2;
-   fTACTIC_COM x3;
-   fID_LIST x4;
+   fINT x1 ++
+   fFORMULA x2 ++
+   fTACTIC_COM x3 ++
+   fID_LIST x4 ++
    fNODE "local_hint_extern" 4
 | CT_local_hints(x1, x2, x3) ->
-   fID x1;
-   fID_NE_LIST x2;
-   fID_LIST x3;
+   fID x1 ++
+   fID_NE_LIST x2 ++
+   fID_LIST x3 ++
    fNODE "local_hints" 3
 | CT_local_hints_immediate(x1, x2) ->
-   fFORMULA_NE_LIST x1;
-   fID_LIST x2;
+   fFORMULA_NE_LIST x1 ++
+   fID_LIST x2 ++
    fNODE "local_hints_immediate" 2
 | CT_local_hints_resolve(x1, x2) ->
-   fFORMULA_NE_LIST x1;
-   fID_LIST x2;
+   fFORMULA_NE_LIST x1 ++
+   fID_LIST x2 ++
    fNODE "local_hints_resolve" 2
 | CT_local_infix(x1, x2, x3, x4) ->
-   fSTRING x1;
-   fID x2;
-   fMODIFIER_LIST x3;
-   fID_OPT x4;
+   fSTRING x1 ++
+   fID x2 ++
+   fMODIFIER_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "local_infix" 4
 | CT_local_open_scope(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "local_open_scope" 1
 | CT_local_reserve_notation(x1, x2) ->
-   fSTRING x1;
-   fMODIFIER_LIST x2;
+   fSTRING x1 ++
+   fMODIFIER_LIST x2 ++
    fNODE "local_reserve_notation" 2
 | CT_locate(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "locate" 1
 | CT_locate_file(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "locate_file" 1
 | CT_locate_lib(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "locate_lib" 1
 | CT_locate_notation(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "locate_notation" 1
 | CT_mind_decl(x1, x2) ->
-   fCO_IND x1;
-   fIND_SPEC_LIST x2;
+   fCO_IND x1 ++
+   fIND_SPEC_LIST x2 ++
    fNODE "mind_decl" 2
 | CT_ml_add_path(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "ml_add_path" 1
 | CT_ml_declare_modules(x1) ->
-   fSTRING_NE_LIST x1;
+   fSTRING_NE_LIST x1 ++
    fNODE "ml_declare_modules" 1
 | CT_ml_print_modules -> fNODE "ml_print_modules" 0
 | CT_ml_print_path -> fNODE "ml_print_path" 0
 | CT_module(x1, x2, x3, x4) ->
-   fID x1;
-   fMODULE_BINDER_LIST x2;
-   fMODULE_TYPE_CHECK x3;
-   fMODULE_EXPR x4;
+   fID x1 ++
+   fMODULE_BINDER_LIST x2 ++
+   fMODULE_TYPE_CHECK x3 ++
+   fMODULE_EXPR x4 ++
    fNODE "module" 4
 | CT_module_type_decl(x1, x2, x3) ->
-   fID x1;
-   fMODULE_BINDER_LIST x2;
-   fMODULE_TYPE_OPT x3;
+   fID x1 ++
+   fMODULE_BINDER_LIST x2 ++
+   fMODULE_TYPE_OPT x3 ++
    fNODE "module_type_decl" 3
 | CT_no_inline(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "no_inline" 1
 | CT_omega_flag(x1, x2) ->
-   fOMEGA_MODE x1;
-   fOMEGA_FEATURE x2;
+   fOMEGA_MODE x1 ++
+   fOMEGA_FEATURE x2 ++
    fNODE "omega_flag" 2
-| CT_opaque(x1) ->
-   fID_NE_LIST x1;
-   fNODE "opaque" 1
 | CT_open_scope(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "open_scope" 1
 | CT_print -> fNODE "print" 0
 | CT_print_about(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_about" 1
 | CT_print_all -> fNODE "print_all" 0
 | CT_print_classes -> fNODE "print_classes" 0
 | CT_print_ltac id ->
-   fID id;
+   fID id ++
    fNODE "print_ltac" 1
 | CT_print_coercions -> fNODE "print_coercions" 0
 | CT_print_grammar(x1) ->
-   fGRAMMAR x1;
+   fGRAMMAR x1 ++
    fNODE "print_grammar" 1
 | CT_print_graph -> fNODE "print_graph" 0
 | CT_print_hint(x1) ->
-   fID_OPT x1;
+   fID_OPT x1 ++
    fNODE "print_hint" 1
 | CT_print_hintdb(x1) ->
-   fID_OR_STAR x1;
+   fID_OR_STAR x1 ++
    fNODE "print_hintdb" 1
 | CT_print_rewrite_hintdb(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_rewrite_hintdb" 1
 | CT_print_id(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_id" 1
 | CT_print_implicit(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_implicit" 1
 | CT_print_loadpath -> fNODE "print_loadpath" 0
 | CT_print_module(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_module" 1
 | CT_print_module_type(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_module_type" 1
 | CT_print_modules -> fNODE "print_modules" 0
 | CT_print_natural(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_natural" 1
 | CT_print_natural_feature(x1) ->
-   fNATURAL_FEATURE x1;
+   fNATURAL_FEATURE x1 ++
    fNODE "print_natural_feature" 1
 | CT_print_opaqueid(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_opaqueid" 1
 | CT_print_path(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "print_path" 2
 | CT_print_proof(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_proof" 1
 | CT_print_scope(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_scope" 1
 | CT_print_setoids -> fNODE "print_setoids" 0
 | CT_print_scopes -> fNODE "print_scopes" 0
 | CT_print_section(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "print_section" 1
 | CT_print_states -> fNODE "print_states" 0
 | CT_print_tables -> fNODE "print_tables" 0
 | CT_print_universes(x1) ->
-   fSTRING_OPT x1;
+   fSTRING_OPT x1 ++
    fNODE "print_universes" 1
 | CT_print_visibility(x1) ->
-   fID_OPT x1;
+   fID_OPT x1 ++
    fNODE "print_visibility" 1
 | CT_proof(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "proof" 1
 | CT_proof_no_op -> fNODE "proof_no_op" 0
 | CT_proof_with(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "proof_with" 1
 | CT_pwd -> fNODE "pwd" 0
 | CT_quit -> fNODE "quit" 0
 | CT_read_module(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "read_module" 1
 | CT_rec_ml_add_path(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "rec_ml_add_path" 1
 | CT_recaddpath(x1, x2) ->
-   fSTRING x1;
-   fID_OPT x2;
+   fSTRING x1 ++
+   fID_OPT x2 ++
    fNODE "recaddpath" 2
 | CT_record(x1, x2, x3, x4, x5, x6) ->
-   fCOERCION_OPT x1;
-   fID x2;
-   fBINDER_LIST x3;
-   fFORMULA x4;
-   fID_OPT x5;
-   fRECCONSTR_LIST x6;
+   fCOERCION_OPT x1 ++
+   fID x2 ++
+   fBINDER_LIST x3 ++
+   fFORMULA x4 ++
+   fID_OPT x5 ++
+   fRECCONSTR_LIST x6 ++
    fNODE "record" 6
 | CT_remove_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1;
-   fID x2;
+   fNATURAL_FEATURE x1 ++
+   fID x2 ++
    fNODE "remove_natural_feature" 2
 | CT_require(x1, x2, x3) ->
-   fIMPEXP x1;
-   fSPEC_OPT x2;
-   fID_NE_LIST_OR_STRING x3;
+   fIMPEXP x1 ++
+   fSPEC_OPT x2 ++
+   fID_NE_LIST_OR_STRING x3 ++
    fNODE "require" 3
 | CT_reserve(x1, x2) ->
-   fID_NE_LIST x1;
-   fFORMULA x2;
+   fID_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "reserve" 2
 | CT_reserve_notation(x1, x2) ->
-   fSTRING x1;
-   fMODIFIER_LIST x2;
+   fSTRING x1 ++
+   fMODIFIER_LIST x2 ++
    fNODE "reserve_notation" 2
 | CT_reset(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "reset" 1
 | CT_reset_section(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "reset_section" 1
 | CT_restart -> fNODE "restart" 0
 | CT_restore_state(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "restore_state" 1
 | CT_resume(x1) ->
-   fID_OPT x1;
+   fID_OPT x1 ++
    fNODE "resume" 1
 | CT_save(x1, x2) ->
-   fTHM_OPT x1;
-   fID_OPT x2;
+   fTHM_OPT x1 ++
+   fID_OPT x2 ++
    fNODE "save" 2
 | CT_scomments(x1) ->
-   fSCOMMENT_CONTENT_LIST x1;
+   fSCOMMENT_CONTENT_LIST x1 ++
    fNODE "scomments" 1
 | CT_search(x1, x2) ->
-   fID x1;
-   fIN_OR_OUT_MODULES x2;
+   fID x1 ++
+   fIN_OR_OUT_MODULES x2 ++
    fNODE "search" 2
 | CT_search_about(x1, x2) ->
-   fID_OR_STRING_NE_LIST x1;
-   fIN_OR_OUT_MODULES x2;
+   fID_OR_STRING_NE_LIST x1 ++
+   fIN_OR_OUT_MODULES x2 ++
    fNODE "search_about" 2
 | CT_search_pattern(x1, x2) ->
-   fFORMULA x1;
-   fIN_OR_OUT_MODULES x2;
+   fFORMULA x1 ++
+   fIN_OR_OUT_MODULES x2 ++
    fNODE "search_pattern" 2
 | CT_search_rewrite(x1, x2) ->
-   fFORMULA x1;
-   fIN_OR_OUT_MODULES x2;
+   fFORMULA x1 ++
+   fIN_OR_OUT_MODULES x2 ++
    fNODE "search_rewrite" 2
 | CT_section_end(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "section_end" 1
 | CT_section_struct(x1, x2, x3) ->
-   fSECTION_BEGIN x1;
-   fSECTION_BODY x2;
-   fCOMMAND x3;
+   fSECTION_BEGIN x1 ++
+   fSECTION_BODY x2 ++
+   fCOMMAND x3 ++
    fNODE "section_struct" 3
 | CT_set_natural(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "set_natural" 1
 | CT_set_natural_default -> fNODE "set_natural_default" 0
 | CT_set_option(x1) ->
-   fTABLE x1;
+   fTABLE x1 ++
    fNODE "set_option" 1
 | CT_set_option_value(x1, x2) ->
-   fTABLE x1;
-   fSINGLE_OPTION_VALUE x2;
+   fTABLE x1 ++
+   fSINGLE_OPTION_VALUE x2 ++
    fNODE "set_option_value" 2
 | CT_set_option_value2(x1, x2) ->
-   fTABLE x1;
-   fID_OR_STRING_NE_LIST x2;
+   fTABLE x1 ++
+   fID_OR_STRING_NE_LIST x2 ++
    fNODE "set_option_value2" 2
 | CT_sethyp(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "sethyp" 1
 | CT_setundo(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "setundo" 1
 | CT_show_existentials -> fNODE "show_existentials" 0
 | CT_show_goal(x1) ->
-   fINT_OPT x1;
+   fINT_OPT x1 ++
    fNODE "show_goal" 1
 | CT_show_implicit(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "show_implicit" 1
 | CT_show_intro -> fNODE "show_intro" 0
 | CT_show_intros -> fNODE "show_intros" 0
@@ -587,97 +589,103 @@ and fCOMMAND = function
 | CT_show_script -> fNODE "show_script" 0
 | CT_show_tree -> fNODE "show_tree" 0
 | CT_solve(x1, x2, x3) ->
-   fINT x1;
-   fTACTIC_COM x2;
-   fDOTDOT_OPT x3;
+   fINT x1 ++
+   fTACTIC_COM x2 ++
+   fDOTDOT_OPT x3 ++
    fNODE "solve" 3
+| CT_strategy(CT_level_list x1) ->
+   List.fold_left (++) (mt())
+     (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++
+   fNODE "strategy" (List.length x1)
 | CT_suspend -> fNODE "suspend" 0
 | CT_syntax_macro(x1, x2, x3) ->
-   fID x1;
-   fFORMULA x2;
-   fINT_OPT x3;
+   fID x1 ++
+   fFORMULA x2 ++
+   fINT_OPT x3 ++
    fNODE "syntax_macro" 3
 | CT_tactic_definition(x1) ->
-   fTAC_DEF_NE_LIST x1;
+   fTAC_DEF_NE_LIST x1 ++
    fNODE "tactic_definition" 1
 | CT_test_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1;
-   fID x2;
+   fNATURAL_FEATURE x1 ++
+   fID x2 ++
    fNODE "test_natural_feature" 2
 | CT_theorem_struct(x1, x2) ->
-   fTHEOREM_GOAL x1;
-   fPROOF_SCRIPT x2;
+   fTHEOREM_GOAL x1 ++
+   fPROOF_SCRIPT x2 ++
    fNODE "theorem_struct" 2
 | CT_time(x1) ->
-   fCOMMAND x1;
+   fCOMMAND x1 ++
    fNODE "time" 1
-| CT_transparent(x1) ->
-   fID_NE_LIST x1;
-   fNODE "transparent" 1
 | CT_undo(x1) ->
-   fINT_OPT x1;
+   fINT_OPT x1 ++
    fNODE "undo" 1
 | CT_unfocus -> fNODE "unfocus" 0
 | CT_unset_option(x1) ->
-   fTABLE x1;
+   fTABLE x1 ++
    fNODE "unset_option" 1
 | CT_unsethyp -> fNODE "unsethyp" 0
 | CT_unsetundo -> fNODE "unsetundo" 0
 | CT_user_vernac(x1, x2) ->
-   fID x1;
-   fVARG_LIST x2;
+   fID x1 ++
+   fVARG_LIST x2 ++
    fNODE "user_vernac" 2
 | CT_variable(x1, x2) ->
-   fVAR x1;
-   fBINDER_NE_LIST x2;
+   fVAR x1 ++
+   fBINDER_NE_LIST x2 ++
    fNODE "variable" 2
 | CT_write_module(x1, x2) ->
-   fID x1;
-   fSTRING_OPT x2;
+   fID x1 ++
+   fSTRING_OPT x2 ++
    fNODE "write_module" 2
+and fLEVEL = function
+| CT_Opaque -> fNODE "opaque" 0
+| CT_Level n -> fINT n ++ fNODE "level" 1
+| CT_Expand -> fNODE "expand" 0
 and fCOMMAND_LIST = function
 | CT_command_list(x,l) ->
-   fCOMMAND x;
-   (List.iter fCOMMAND l);
+   fCOMMAND x ++
+   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
    fNODE "command_list" (1 + (List.length l))
 and fCOMMENT = function
-| CT_comment x -> fATOM "comment";
-   (f_atom_string x);
-   print_string "\n"and fCOMMENT_S = function
+| CT_comment x -> fATOM "comment" ++
+   (f_atom_string x) ++
+   str "\n"
+and fCOMMENT_S = function
 | CT_comment_s l ->
-   (List.iter fCOMMENT l);
+   (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++
    fNODE "comment_s" (List.length l)
 and fCONSTR = function
 | CT_constr(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "constr" 2
 | CT_constr_coercion(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "constr_coercion" 2
 and fCONSTR_LIST = function
 | CT_constr_list l ->
-   (List.iter fCONSTR l);
+   (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++
    fNODE "constr_list" (List.length l)
 and fCONTEXT_HYP_LIST = function
 | CT_context_hyp_list l ->
-   (List.iter fPREMISE_PATTERN l);
+   (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++
    fNODE "context_hyp_list" (List.length l)
 and fCONTEXT_PATTERN = function
 | CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x
 | CT_context(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "context" 2
 and fCONTEXT_RULE = function
 | CT_context_rule(x1, x2, x3) ->
-   fCONTEXT_HYP_LIST x1;
-   fCONTEXT_PATTERN x2;
-   fTACTIC_COM x3;
+   fCONTEXT_HYP_LIST x1 ++
+   fCONTEXT_PATTERN x2 ++
+   fTACTIC_COM x3 ++
    fNODE "context_rule" 3
 | CT_def_context_rule(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "def_context_rule" 1
 and fCONVERSION_FLAG = function
 | CT_beta -> fNODE "beta" 0
@@ -687,49 +695,52 @@ and fCONVERSION_FLAG = function
 | CT_zeta -> fNODE "zeta" 0
 and fCONVERSION_FLAG_LIST = function
 | CT_conversion_flag_list l ->
-   (List.iter fCONVERSION_FLAG l);
+   (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++
    fNODE "conversion_flag_list" (List.length l)
 and fCONV_SET = function
 | CT_unf l ->
-   (List.iter fID l);
+   (List.fold_left (++) (mt()) (List.map fID l)) ++
    fNODE "unf" (List.length l)
 | CT_unfbut l ->
-   (List.iter fID l);
+   (List.fold_left (++) (mt()) (List.map fID l)) ++
    fNODE "unfbut" (List.length l)
 and fCO_IND = function
-| CT_co_ind x -> fATOM "co_ind";
-   (f_atom_string x);
-   print_string "\n"and fDECL_NOTATION_OPT = function
+| CT_co_ind x -> fATOM "co_ind" ++
+   (f_atom_string x) ++
+   str "\n"
+and fDECL_NOTATION_OPT = function
 | CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x
 | CT_decl_notation(x1, x2, x3) ->
-   fSTRING x1;
-   fFORMULA x2;
-   fID_OPT x3;
+   fSTRING x1 ++
+   fFORMULA x2 ++
+   fID_OPT x3 ++
    fNODE "decl_notation" 3
 and fDEF = function
 | CT_def(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "def" 2
 and fDEFN = function
-| CT_defn x -> fATOM "defn";
-   (f_atom_string x);
-   print_string "\n"and fDEFN_OR_THM = function
+| CT_defn x -> fATOM "defn" ++
+   (f_atom_string x) ++
+   str "\n"
+and fDEFN_OR_THM = function
 | CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x
 | CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x
 and fDEF_BODY = function
 | CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x
 | CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x
 | CT_type_of(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "type_of" 1
 and fDEF_BODY_OPT = function
 | CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x
 | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x
 and fDEP = function
-| CT_dep x -> fATOM "dep";
-   (f_atom_string x);
-   print_string "\n"and fDESTRUCTING = function
+| CT_dep x -> fATOM "dep" ++
+   (f_atom_string x) ++
+   str "\n"
+and fDESTRUCTING = function
 | CT_coerce_NONE_to_DESTRUCTING x -> fNONE x
 | CT_destructing -> fNODE "destructing" 0
 and fDESTRUCT_LOCATION = function
@@ -741,54 +752,54 @@ and fDOTDOT_OPT = function
 | CT_dotdot -> fNODE "dotdot" 0
 and fEQN = function
 | CT_eqn(x1, x2) ->
-   fMATCH_PATTERN_NE_LIST x1;
-   fFORMULA x2;
+   fMATCH_PATTERN_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "eqn" 2
 and fEQN_LIST = function
 | CT_eqn_list l ->
-   (List.iter fEQN l);
+   (List.fold_left (++) (mt()) (List.map fEQN l)) ++
    fNODE "eqn_list" (List.length l)
 and fEVAL_CMD = function
 | CT_eval(x1, x2, x3) ->
-   fINT_OPT x1;
-   fRED_COM x2;
-   fFORMULA x3;
+   fINT_OPT x1 ++
+   fRED_COM x2 ++
+   fFORMULA x3 ++
    fNODE "eval" 3
 and fFIXTAC = function
 | CT_fixtac(x1, x2, x3) ->
-   fID x1;
-   fINT x2;
-   fFORMULA x3;
+   fID x1 ++
+   fINT x2 ++
+   fFORMULA x3 ++
    fNODE "fixtac" 3
 and fFIX_BINDER = function
 | CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x
 | CT_fix_binder(x1, x2, x3, x4) ->
-   fID x1;
-   fINT x2;
-   fFORMULA x3;
-   fFORMULA x4;
+   fID x1 ++
+   fINT x2 ++
+   fFORMULA x3 ++
+   fFORMULA x4 ++
    fNODE "fix_binder" 4
 and fFIX_BINDER_LIST = function
 | CT_fix_binder_list(x,l) ->
-   fFIX_BINDER x;
-   (List.iter fFIX_BINDER l);
+   fFIX_BINDER x ++
+   (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++
    fNODE "fix_binder_list" (1 + (List.length l))
 and fFIX_REC = function
 | CT_fix_rec(x1, x2, x3, x4, x5) ->
-   fID x1;
-   fBINDER_NE_LIST x2;
-   fID_OPT x3;
-   fFORMULA x4;
-   fFORMULA x5;
+   fID x1 ++
+   fBINDER_NE_LIST x2 ++
+   fID_OPT x3 ++
+   fFORMULA x4 ++
+   fFORMULA x5 ++
    fNODE "fix_rec" 5
 and fFIX_REC_LIST = function
 | CT_fix_rec_list(x,l) ->
-   fFIX_REC x;
-   (List.iter fFIX_REC l);
+   fFIX_REC x ++
+   (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++
    fNODE "fix_rec_list" (1 + (List.length l))
 and fFIX_TAC_LIST = function
 | CT_fix_tac_list l ->
-   (List.iter fFIXTAC l);
+   (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++
    fNODE "fix_tac_list" (List.length l)
 and fFORMULA = function
 | CT_coerce_BINARY_to_FORMULA x -> fBINARY x
@@ -797,90 +808,90 @@ and fFORMULA = function
 | CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x
 | CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x
 | CT_appc(x1, x2) ->
-   fFORMULA x1;
-   fFORMULA_NE_LIST x2;
+   fFORMULA x1 ++
+   fFORMULA_NE_LIST x2 ++
    fNODE "appc" 2
 | CT_arrowc(x1, x2) ->
-   fFORMULA x1;
-   fFORMULA x2;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
    fNODE "arrowc" 2
 | CT_bang(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "bang" 1
 | CT_cases(x1, x2, x3) ->
-   fMATCHED_FORMULA_NE_LIST x1;
-   fFORMULA_OPT x2;
-   fEQN_LIST x3;
+   fMATCHED_FORMULA_NE_LIST x1 ++
+   fFORMULA_OPT x2 ++
+   fEQN_LIST x3 ++
    fNODE "cases" 3
 | CT_cofixc(x1, x2) ->
-   fID x1;
-   fCOFIX_REC_LIST x2;
+   fID x1 ++
+   fCOFIX_REC_LIST x2 ++
    fNODE "cofixc" 2
 | CT_elimc(x1, x2, x3, x4) ->
-   fCASE x1;
-   fFORMULA_OPT x2;
-   fFORMULA x3;
-   fFORMULA_LIST x4;
+   fCASE x1 ++
+   fFORMULA_OPT x2 ++
+   fFORMULA x3 ++
+   fFORMULA_LIST x4 ++
    fNODE "elimc" 4
 | CT_existvarc -> fNODE "existvarc" 0
 | CT_fixc(x1, x2) ->
-   fID x1;
-   fFIX_BINDER_LIST x2;
+   fID x1 ++
+   fFIX_BINDER_LIST x2 ++
    fNODE "fixc" 2
 | CT_if(x1, x2, x3, x4) ->
-   fFORMULA x1;
-   fRETURN_INFO x2;
-   fFORMULA x3;
-   fFORMULA x4;
+   fFORMULA x1 ++
+   fRETURN_INFO x2 ++
+   fFORMULA x3 ++
+   fFORMULA x4 ++
    fNODE "if" 4
 | CT_inductive_let(x1, x2, x3, x4) ->
-   fFORMULA_OPT x1;
-   fID_OPT_NE_LIST x2;
-   fFORMULA x3;
-   fFORMULA x4;
+   fFORMULA_OPT x1 ++
+   fID_OPT_NE_LIST x2 ++
+   fFORMULA x3 ++
+   fFORMULA x4 ++
    fNODE "inductive_let" 4
 | CT_labelled_arg(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "labelled_arg" 2
 | CT_lambdac(x1, x2) ->
-   fBINDER_NE_LIST x1;
-   fFORMULA x2;
+   fBINDER_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "lambdac" 2
 | CT_let_tuple(x1, x2, x3, x4) ->
-   fID_OPT_NE_LIST x1;
-   fRETURN_INFO x2;
-   fFORMULA x3;
-   fFORMULA x4;
+   fID_OPT_NE_LIST x1 ++
+   fRETURN_INFO x2 ++
+   fFORMULA x3 ++
+   fFORMULA x4 ++
    fNODE "let_tuple" 4
 | CT_letin(x1, x2) ->
-   fDEF x1;
-   fFORMULA x2;
+   fDEF x1 ++
+   fFORMULA x2 ++
    fNODE "letin" 2
 | CT_notation(x1, x2) ->
-   fSTRING x1;
-   fFORMULA_LIST x2;
+   fSTRING x1 ++
+   fFORMULA_LIST x2 ++
    fNODE "notation" 2
 | CT_num_encapsulator(x1, x2) ->
-   fNUM_TYPE x1;
-   fFORMULA x2;
+   fNUM_TYPE x1 ++
+   fFORMULA x2 ++
    fNODE "num_encapsulator" 2
 | CT_prodc(x1, x2) ->
-   fBINDER_NE_LIST x1;
-   fFORMULA x2;
+   fBINDER_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "prodc" 2
 | CT_proj(x1, x2) ->
-   fFORMULA x1;
-   fFORMULA_NE_LIST x2;
+   fFORMULA x1 ++
+   fFORMULA_NE_LIST x2 ++
    fNODE "proj" 2
 and fFORMULA_LIST = function
 | CT_formula_list l ->
-   (List.iter fFORMULA l);
+   (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
    fNODE "formula_list" (List.length l)
 and fFORMULA_NE_LIST = function
 | CT_formula_ne_list(x,l) ->
-   fFORMULA x;
-   (List.iter fFORMULA l);
+   fFORMULA x ++
+   (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
    fNODE "formula_ne_list" (1 + (List.length l))
 and fFORMULA_OPT = function
 | CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x
@@ -893,44 +904,46 @@ and fGRAMMAR = function
 and fHYP_LOCATION = function
 | CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x
 | CT_intype(x1, x2) ->
-   fID x1;
-   fINT_LIST x2;
+   fID x1 ++
+   fINT_LIST x2 ++
    fNODE "intype" 2
 | CT_invalue(x1, x2) ->
-   fID x1;
-   fINT_LIST x2;
+   fID x1 ++
+   fINT_LIST x2 ++
    fNODE "invalue" 2
 and fHYP_LOCATION_LIST_OR_STAR = function
 | CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x
 | CT_hyp_location_list l ->
-   (List.iter fHYP_LOCATION l);
+   (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++
    fNODE "hyp_location_list" (List.length l)
 and fID = function
-| CT_ident x -> fATOM "ident";
-   (f_atom_string x);
-   print_string "\n"| CT_metac(x1) ->
-   fINT x1;
+| CT_ident x -> fATOM "ident" ++
+   (f_atom_string x) ++
+   str "\n"
+| CT_metac(x1) ->
+   fINT x1 ++
    fNODE "metac" 1
-| CT_metaid x -> fATOM "metaid";
-   (f_atom_string x);
-   print_string "\n"and fIDENTITY_OPT = function
+| CT_metaid x -> fATOM "metaid" ++
+   (f_atom_string x) ++
+   str "\n"
+and fIDENTITY_OPT = function
 | CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x
 | CT_identity -> fNODE "identity" 0
 and fID_LIST = function
 | CT_id_list l ->
-   (List.iter fID l);
+   (List.fold_left (++) (mt()) (List.map fID l)) ++
    fNODE "id_list" (List.length l)
 and fID_LIST_LIST = function
 | CT_id_list_list l ->
-   (List.iter fID_LIST l);
+   (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++
    fNODE "id_list_list" (List.length l)
 and fID_LIST_OPT = function
 | CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x
 | CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x
 and fID_NE_LIST = function
 | CT_id_ne_list(x,l) ->
-   fID x;
-   (List.iter fID l);
+   fID x ++
+   (List.fold_left (++) (mt()) (List.map fID l)) ++
    fNODE "id_ne_list" (1 + (List.length l))
 and fID_NE_LIST_OR_STAR = function
 | CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x
@@ -943,12 +956,12 @@ and fID_OPT = function
 | CT_coerce_NONE_to_ID_OPT x -> fNONE x
 and fID_OPT_LIST = function
 | CT_id_opt_list l ->
-   (List.iter fID_OPT l);
+   (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
    fNODE "id_opt_list" (List.length l)
 and fID_OPT_NE_LIST = function
 | CT_id_opt_ne_list(x,l) ->
-   fID_OPT x;
-   (List.iter fID_OPT l);
+   fID_OPT x ++
+   (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
    fNODE "id_opt_ne_list" (1 + (List.length l))
 and fID_OPT_OR_ALL = function
 | CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x
@@ -968,8 +981,8 @@ and fID_OR_STRING = function
 | CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x
 and fID_OR_STRING_NE_LIST = function
 | CT_id_or_string_ne_list(x,l) ->
-   fID_OR_STRING x;
-   (List.iter fID_OR_STRING l);
+   fID_OR_STRING x ++
+   (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++
    fNODE "id_or_string_ne_list" (1 + (List.length l))
 and fIMPEXP = function
 | CT_coerce_NONE_to_IMPEXP x -> fNONE x
@@ -977,40 +990,41 @@ and fIMPEXP = function
 | CT_import -> fNODE "import" 0
 and fIND_SPEC = function
 | CT_ind_spec(x1, x2, x3, x4, x5) ->
-   fID x1;
-   fBINDER_LIST x2;
-   fFORMULA x3;
-   fCONSTR_LIST x4;
-   fDECL_NOTATION_OPT x5;
+   fID x1 ++
+   fBINDER_LIST x2 ++
+   fFORMULA x3 ++
+   fCONSTR_LIST x4 ++
+   fDECL_NOTATION_OPT x5 ++
    fNODE "ind_spec" 5
 and fIND_SPEC_LIST = function
 | CT_ind_spec_list l ->
-   (List.iter fIND_SPEC l);
+   (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++
    fNODE "ind_spec_list" (List.length l)
 and fINT = function
-| CT_int x -> fATOM "int";
-   (f_atom_int x);
-   print_string "\n"and fINTRO_PATT = function
+| CT_int x -> fATOM "int" ++
+   (f_atom_int x) ++
+   str "\n"
+and fINTRO_PATT = function
 | CT_coerce_ID_to_INTRO_PATT x -> fID x
 | CT_disj_pattern(x,l) ->
-   fINTRO_PATT_LIST x;
-   (List.iter fINTRO_PATT_LIST l);
+   fINTRO_PATT_LIST x ++
+   (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++
    fNODE "disj_pattern" (1 + (List.length l))
 and fINTRO_PATT_LIST = function
 | CT_intro_patt_list l ->
-   (List.iter fINTRO_PATT l);
+   (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++
    fNODE "intro_patt_list" (List.length l)
 and fINTRO_PATT_OPT = function
 | CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x
 | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x
 and fINT_LIST = function
 | CT_int_list l ->
-   (List.iter fINT l);
+   (List.fold_left (++) (mt()) (List.map fINT l)) ++
    fNODE "int_list" (List.length l)
 and fINT_NE_LIST = function
 | CT_int_ne_list(x,l) ->
-   fINT x;
-   (List.iter fINT l);
+   fINT x ++
+   (List.fold_left (++) (mt()) (List.map fINT l)) ++
    fNODE "int_ne_list" (1 + (List.length l))
 and fINT_OPT = function
 | CT_coerce_INT_to_INT_OPT x -> fINT x
@@ -1028,21 +1042,21 @@ and fINV_TYPE = function
 and fIN_OR_OUT_MODULES = function
 | CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x
 | CT_in_modules(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "in_modules" 1
 | CT_out_modules(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "out_modules" 1
 and fLET_CLAUSE = function
 | CT_let_clause(x1, x2, x3) ->
-   fID x1;
-   fTACTIC_OPT x2;
-   fLET_VALUE x3;
+   fID x1 ++
+   fTACTIC_OPT x2 ++
+   fLET_VALUE x3 ++
    fNODE "let_clause" 3
 and fLET_CLAUSES = function
 | CT_let_clauses(x,l) ->
-   fLET_CLAUSE x;
-   (List.iter fLET_CLAUSE l);
+   fLET_CLAUSE x ++
+   (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++
    fNODE "let_clauses" (1 + (List.length l))
 and fLET_VALUE = function
 | CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x
@@ -1051,120 +1065,121 @@ and fLOCAL_OPT = function
 | CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x
 | CT_local -> fNODE "local" 0
 and fLOCN = function
-| CT_locn x -> fATOM "locn";
-   (f_atom_string x);
-   print_string "\n"and fMATCHED_FORMULA = function
+| CT_locn x -> fATOM "locn" ++
+   (f_atom_string x) ++
+   str "\n"
+and fMATCHED_FORMULA = function
 | CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x
 | CT_formula_as(x1, x2) ->
-   fFORMULA x1;
-   fID_OPT x2;
+   fFORMULA x1 ++
+   fID_OPT x2 ++
    fNODE "formula_as" 2
 | CT_formula_as_in(x1, x2, x3) ->
-   fFORMULA x1;
-   fID_OPT x2;
-   fFORMULA x3;
+   fFORMULA x1 ++
+   fID_OPT x2 ++
+   fFORMULA x3 ++
    fNODE "formula_as_in" 3
 | CT_formula_in(x1, x2) ->
-   fFORMULA x1;
-   fFORMULA x2;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
    fNODE "formula_in" 2
 and fMATCHED_FORMULA_NE_LIST = function
 | CT_matched_formula_ne_list(x,l) ->
-   fMATCHED_FORMULA x;
-   (List.iter fMATCHED_FORMULA l);
+   fMATCHED_FORMULA x ++
+   (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++
    fNODE "matched_formula_ne_list" (1 + (List.length l))
 and fMATCH_PATTERN = function
 | CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x
 | CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x
 | CT_pattern_app(x1, x2) ->
-   fMATCH_PATTERN x1;
-   fMATCH_PATTERN_NE_LIST x2;
+   fMATCH_PATTERN x1 ++
+   fMATCH_PATTERN_NE_LIST x2 ++
    fNODE "pattern_app" 2
 | CT_pattern_as(x1, x2) ->
-   fMATCH_PATTERN x1;
-   fID_OPT x2;
+   fMATCH_PATTERN x1 ++
+   fID_OPT x2 ++
    fNODE "pattern_as" 2
 | CT_pattern_delimitors(x1, x2) ->
-   fNUM_TYPE x1;
-   fMATCH_PATTERN x2;
+   fNUM_TYPE x1 ++
+   fMATCH_PATTERN x2 ++
    fNODE "pattern_delimitors" 2
 | CT_pattern_notation(x1, x2) ->
-   fSTRING x1;
-   fMATCH_PATTERN_LIST x2;
+   fSTRING x1 ++
+   fMATCH_PATTERN_LIST x2 ++
    fNODE "pattern_notation" 2
 and fMATCH_PATTERN_LIST = function
 | CT_match_pattern_list l ->
-   (List.iter fMATCH_PATTERN l);
+   (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
    fNODE "match_pattern_list" (List.length l)
 and fMATCH_PATTERN_NE_LIST = function
 | CT_match_pattern_ne_list(x,l) ->
-   fMATCH_PATTERN x;
-   (List.iter fMATCH_PATTERN l);
+   fMATCH_PATTERN x ++
+   (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
    fNODE "match_pattern_ne_list" (1 + (List.length l))
 and fMATCH_TAC_RULE = function
 | CT_match_tac_rule(x1, x2) ->
-   fCONTEXT_PATTERN x1;
-   fLET_VALUE x2;
+   fCONTEXT_PATTERN x1 ++
+   fLET_VALUE x2 ++
    fNODE "match_tac_rule" 2
 and fMATCH_TAC_RULES = function
 | CT_match_tac_rules(x,l) ->
-   fMATCH_TAC_RULE x;
-   (List.iter fMATCH_TAC_RULE l);
+   fMATCH_TAC_RULE x ++
+   (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++
    fNODE "match_tac_rules" (1 + (List.length l))
 and fMODIFIER = function
 | CT_entry_type(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "entry_type" 2
 | CT_format(x1) ->
-   fSTRING x1;
+   fSTRING x1 ++
    fNODE "format" 1
 | CT_lefta -> fNODE "lefta" 0
 | CT_nona -> fNODE "nona" 0
 | CT_only_parsing -> fNODE "only_parsing" 0
 | CT_righta -> fNODE "righta" 0
 | CT_set_item_level(x1, x2) ->
-   fID_NE_LIST x1;
-   fINT_OR_NEXT x2;
+   fID_NE_LIST x1 ++
+   fINT_OR_NEXT x2 ++
    fNODE "set_item_level" 2
 | CT_set_level(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "set_level" 1
 and fMODIFIER_LIST = function
 | CT_modifier_list l ->
-   (List.iter fMODIFIER l);
+   (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++
    fNODE "modifier_list" (List.length l)
 and fMODULE_BINDER = function
 | CT_module_binder(x1, x2) ->
-   fID_NE_LIST x1;
-   fMODULE_TYPE x2;
+   fID_NE_LIST x1 ++
+   fMODULE_TYPE x2 ++
    fNODE "module_binder" 2
 and fMODULE_BINDER_LIST = function
 | CT_module_binder_list l ->
-   (List.iter fMODULE_BINDER l);
+   (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++
    fNODE "module_binder_list" (List.length l)
 and fMODULE_EXPR = function
 | CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x
 | CT_module_app(x1, x2) ->
-   fMODULE_EXPR x1;
-   fMODULE_EXPR x2;
+   fMODULE_EXPR x1 ++
+   fMODULE_EXPR x2 ++
    fNODE "module_app" 2
 and fMODULE_TYPE = function
 | CT_coerce_ID_to_MODULE_TYPE x -> fID x
 | CT_module_type_with_def(x1, x2, x3) ->
-   fMODULE_TYPE x1;
-   fID_LIST x2;
-   fFORMULA x3;
+   fMODULE_TYPE x1 ++
+   fID_LIST x2 ++
+   fFORMULA x3 ++
    fNODE "module_type_with_def" 3
 | CT_module_type_with_mod(x1, x2, x3) ->
-   fMODULE_TYPE x1;
-   fID_LIST x2;
-   fID x3;
+   fMODULE_TYPE x1 ++
+   fID_LIST x2 ++
+   fID x3 ++
    fNODE "module_type_with_mod" 3
 and fMODULE_TYPE_CHECK = function
 | CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x
 | CT_only_check(x1) ->
-   fMODULE_TYPE x1;
+   fMODULE_TYPE x1 ++
    fNODE "only_check" 1
 and fMODULE_TYPE_OPT = function
 | CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x
@@ -1176,12 +1191,14 @@ and fNATURAL_FEATURE = function
 and fNONE = function
 | CT_none -> fNODE "none" 0
 and fNUM = function
-| CT_int_encapsulator x -> fATOM "int_encapsulator";
-   (f_atom_string x);
-   print_string "\n"and fNUM_TYPE = function
-| CT_num_type x -> fATOM "num_type";
-   (f_atom_string x);
-   print_string "\n"and fOMEGA_FEATURE = function
+| CT_int_encapsulator x -> fATOM "int_encapsulator" ++
+   (f_atom_string x) ++
+   str "\n"
+and fNUM_TYPE = function
+| CT_num_type x -> fATOM "num_type" ++
+   (f_atom_string x) ++
+   str "\n"
+and fOMEGA_FEATURE = function
 | CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x
 | CT_flag_action -> fNODE "flag_action" 0
 | CT_flag_system -> fNODE "flag_system" 0
@@ -1195,13 +1212,13 @@ and fORIENTATION = function
 | CT_rl -> fNODE "rl" 0
 and fPATTERN = function
 | CT_pattern_occ(x1, x2) ->
-   fINT_LIST x1;
-   fFORMULA x2;
+   fINT_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "pattern_occ" 2
 and fPATTERN_NE_LIST = function
 | CT_pattern_ne_list(x,l) ->
-   fPATTERN x;
-   (List.iter fPATTERN l);
+   fPATTERN x ++
+   (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++
    fNODE "pattern_ne_list" (1 + (List.length l))
 and fPATTERN_OPT = function
 | CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x
@@ -1209,146 +1226,147 @@ and fPATTERN_OPT = function
 and fPREMISE = function
 | CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x
 | CT_eval_result(x1, x2, x3) ->
-   fFORMULA x1;
-   fFORMULA x2;
-   fFORMULA x3;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
+   fFORMULA x3 ++
    fNODE "eval_result" 3
 | CT_premise(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "premise" 2
 and fPREMISES_LIST = function
 | CT_premises_list l ->
-   (List.iter fPREMISE l);
+   (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++
    fNODE "premises_list" (List.length l)
 and fPREMISE_PATTERN = function
 | CT_premise_pattern(x1, x2) ->
-   fID_OPT x1;
-   fCONTEXT_PATTERN x2;
+   fID_OPT x1 ++
+   fCONTEXT_PATTERN x2 ++
    fNODE "premise_pattern" 2
 and fPROOF_SCRIPT = function
 | CT_proof_script l ->
-   (List.iter fCOMMAND l);
+   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
    fNODE "proof_script" (List.length l)
 and fRECCONSTR = function
 | CT_defrecconstr(x1, x2, x3) ->
-   fID_OPT x1;
-   fFORMULA x2;
-   fFORMULA_OPT x3;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
+   fFORMULA_OPT x3 ++
    fNODE "defrecconstr" 3
 | CT_defrecconstr_coercion(x1, x2, x3) ->
-   fID_OPT x1;
-   fFORMULA x2;
-   fFORMULA_OPT x3;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
+   fFORMULA_OPT x3 ++
    fNODE "defrecconstr_coercion" 3
 | CT_recconstr(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "recconstr" 2
 | CT_recconstr_coercion(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "recconstr_coercion" 2
 and fRECCONSTR_LIST = function
 | CT_recconstr_list l ->
-   (List.iter fRECCONSTR l);
+   (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++
    fNODE "recconstr_list" (List.length l)
 and fREC_TACTIC_FUN = function
 | CT_rec_tactic_fun(x1, x2, x3) ->
-   fID x1;
-   fID_OPT_NE_LIST x2;
-   fTACTIC_COM x3;
+   fID x1 ++
+   fID_OPT_NE_LIST x2 ++
+   fTACTIC_COM x3 ++
    fNODE "rec_tactic_fun" 3
 and fREC_TACTIC_FUN_LIST = function
 | CT_rec_tactic_fun_list(x,l) ->
-   fREC_TACTIC_FUN x;
-   (List.iter fREC_TACTIC_FUN l);
+   fREC_TACTIC_FUN x ++
+   (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++
    fNODE "rec_tactic_fun_list" (1 + (List.length l))
 and fRED_COM = function
 | CT_cbv(x1, x2) ->
-   fCONVERSION_FLAG_LIST x1;
-   fCONV_SET x2;
+   fCONVERSION_FLAG_LIST x1 ++
+   fCONV_SET x2 ++
    fNODE "cbv" 2
 | CT_fold(x1) ->
-   fFORMULA_LIST x1;
+   fFORMULA_LIST x1 ++
    fNODE "fold" 1
 | CT_hnf -> fNODE "hnf" 0
 | CT_lazy(x1, x2) ->
-   fCONVERSION_FLAG_LIST x1;
-   fCONV_SET x2;
+   fCONVERSION_FLAG_LIST x1 ++
+   fCONV_SET x2 ++
    fNODE "lazy" 2
 | CT_pattern(x1) ->
-   fPATTERN_NE_LIST x1;
+   fPATTERN_NE_LIST x1 ++
    fNODE "pattern" 1
 | CT_red -> fNODE "red" 0
 | CT_cbvvm -> fNODE "vm_compute" 0
 | CT_simpl(x1) ->
-   fPATTERN_OPT x1;
+   fPATTERN_OPT x1 ++
    fNODE "simpl" 1
 | CT_unfold(x1) ->
-   fUNFOLD_NE_LIST x1;
+   fUNFOLD_NE_LIST x1 ++
    fNODE "unfold" 1
 and fRETURN_INFO = function
 | CT_coerce_NONE_to_RETURN_INFO x -> fNONE x
 | CT_as_and_return(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "as_and_return" 2
 | CT_return(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "return" 1
 and fRULE = function
 | CT_rule(x1, x2) ->
-   fPREMISES_LIST x1;
-   fFORMULA x2;
+   fPREMISES_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "rule" 2
 and fRULE_LIST = function
 | CT_rule_list l ->
-   (List.iter fRULE l);
+   (List.fold_left (++) (mt()) (List.map fRULE l)) ++
    fNODE "rule_list" (List.length l)
 and fSCHEME_SPEC = function
 | CT_scheme_spec(x1, x2, x3, x4) ->
-   fID x1;
-   fDEP x2;
-   fFORMULA x3;
-   fSORT_TYPE x4;
+   fID x1 ++
+   fDEP x2 ++
+   fFORMULA x3 ++
+   fSORT_TYPE x4 ++
    fNODE "scheme_spec" 4
 and fSCHEME_SPEC_LIST = function
 | CT_scheme_spec_list(x,l) ->
-   fSCHEME_SPEC x;
-   (List.iter fSCHEME_SPEC l);
+   fSCHEME_SPEC x ++
+   (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++
    fNODE "scheme_spec_list" (1 + (List.length l))
 and fSCOMMENT_CONTENT = function
 | CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x
 | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x
 and fSCOMMENT_CONTENT_LIST = function
 | CT_scomment_content_list l ->
-   (List.iter fSCOMMENT_CONTENT l);
+   (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++
    fNODE "scomment_content_list" (List.length l)
 and fSECTION_BEGIN = function
 | CT_section(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "section" 1
 and fSECTION_BODY = function
 | CT_section_body l ->
-   (List.iter fCOMMAND l);
+   (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
    fNODE "section_body" (List.length l)
 and fSIGNED_INT = function
 | CT_coerce_INT_to_SIGNED_INT x -> fINT x
 | CT_minus(x1) ->
-   fINT x1;
+   fINT x1 ++
    fNODE "minus" 1
 and fSIGNED_INT_LIST = function
 | CT_signed_int_list l ->
-   (List.iter fSIGNED_INT l);
+   (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++
    fNODE "signed_int_list" (List.length l)
 and fSINGLE_OPTION_VALUE = function
 | CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x
 | CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x
 and fSORT_TYPE = function
-| CT_sortc x -> fATOM "sortc";
-   (f_atom_string x);
-   print_string "\n"and fSPEC_LIST = function
+| CT_sortc x -> fATOM "sortc" ++
+   (f_atom_string x) ++
+   str "\n"
+and fSPEC_LIST = function
 | CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x
 | CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x
 and fSPEC_OPT = function
@@ -1360,12 +1378,13 @@ and fSTAR_OPT = function
 | CT_coerce_NONE_to_STAR_OPT x -> fNONE x
 | CT_coerce_STAR_to_STAR_OPT x -> fSTAR x
 and fSTRING = function
-| CT_string x -> fATOM "string";
-   (f_atom_string x);
-   print_string "\n"and fSTRING_NE_LIST = function
+| CT_string x -> fATOM "string" ++
+   (f_atom_string x) ++
+   str "\n"
+and fSTRING_NE_LIST = function
 | CT_string_ne_list(x,l) ->
-   fSTRING x;
-   (List.iter fSTRING l);
+   fSTRING x ++
+   (List.fold_left (++) (mt()) (List.map fSTRING l)) ++
    fNODE "string_ne_list" (1 + (List.length l))
 and fSTRING_OPT = function
 | CT_coerce_NONE_to_STRING_OPT x -> fNONE x
@@ -1373,8 +1392,8 @@ and fSTRING_OPT = function
 and fTABLE = function
 | CT_coerce_ID_to_TABLE x -> fID x
 | CT_table(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "table" 2
 and fTACTIC_ARG = function
 | CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x
@@ -1384,429 +1403,429 @@ and fTACTIC_ARG = function
 | CT_void -> fNODE "void" 0
 and fTACTIC_ARG_LIST = function
 | CT_tactic_arg_list(x,l) ->
-   fTACTIC_ARG x;
-   (List.iter fTACTIC_ARG l);
+   fTACTIC_ARG x ++
+   (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++
    fNODE "tactic_arg_list" (1 + (List.length l))
 and fTACTIC_COM = function
 | CT_abstract(x1, x2) ->
-   fID_OPT x1;
-   fTACTIC_COM x2;
+   fID_OPT x1 ++
+   fTACTIC_COM x2 ++
    fNODE "abstract" 2
 | CT_absurd(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "absurd" 1
 | CT_any_constructor(x1) ->
-   fTACTIC_OPT x1;
+   fTACTIC_OPT x1 ++
    fNODE "any_constructor" 1
 | CT_apply(x1, x2) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
    fNODE "apply" 2
 | CT_assert(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "assert" 2
 | CT_assumption -> fNODE "assumption" 0
 | CT_auto(x1) ->
-   fINT_OPT x1;
+   fINT_OPT x1 ++
    fNODE "auto" 1
 | CT_auto_with(x1, x2) ->
-   fINT_OPT x1;
-   fID_NE_LIST_OR_STAR x2;
+   fINT_OPT x1 ++
+   fID_NE_LIST_OR_STAR x2 ++
    fNODE "auto_with" 2
 | CT_autorewrite(x1, x2) ->
-   fID_NE_LIST x1;
-   fTACTIC_OPT x2;
+   fID_NE_LIST x1 ++
+   fTACTIC_OPT x2 ++
    fNODE "autorewrite" 2
 | CT_autotdb(x1) ->
-   fINT_OPT x1;
+   fINT_OPT x1 ++
    fNODE "autotdb" 1
 | CT_case_type(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "case_type" 1
 | CT_casetac(x1, x2) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
    fNODE "casetac" 2
 | CT_cdhyp(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "cdhyp" 1
 | CT_change(x1, x2) ->
-   fFORMULA x1;
-   fCLAUSE x2;
+   fFORMULA x1 ++
+   fCLAUSE x2 ++
    fNODE "change" 2
 | CT_change_local(x1, x2, x3) ->
-   fPATTERN x1;
-   fFORMULA x2;
-   fCLAUSE x3;
+   fPATTERN x1 ++
+   fFORMULA x2 ++
+   fCLAUSE x3 ++
    fNODE "change_local" 3
 | CT_clear(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "clear" 1
 | CT_clear_body(x1) ->
-   fID_NE_LIST x1;
+   fID_NE_LIST x1 ++
    fNODE "clear_body" 1
 | CT_cofixtactic(x1, x2) ->
-   fID_OPT x1;
-   fCOFIX_TAC_LIST x2;
+   fID_OPT x1 ++
+   fCOFIX_TAC_LIST x2 ++
    fNODE "cofixtactic" 2
 | CT_condrewrite_lr(x1, x2, x3, x4) ->
-   fTACTIC_COM x1;
-   fFORMULA x2;
-   fSPEC_LIST x3;
-   fID_OPT x4;
+   fTACTIC_COM x1 ++
+   fFORMULA x2 ++
+   fSPEC_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "condrewrite_lr" 4
 | CT_condrewrite_rl(x1, x2, x3, x4) ->
-   fTACTIC_COM x1;
-   fFORMULA x2;
-   fSPEC_LIST x3;
-   fID_OPT x4;
+   fTACTIC_COM x1 ++
+   fFORMULA x2 ++
+   fSPEC_LIST x3 ++
+   fID_OPT x4 ++
    fNODE "condrewrite_rl" 4
 | CT_constructor(x1, x2) ->
-   fINT x1;
-   fSPEC_LIST x2;
+   fINT x1 ++
+   fSPEC_LIST x2 ++
    fNODE "constructor" 2
 | CT_contradiction -> fNODE "contradiction" 0
 | CT_contradiction_thm(x1, x2) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
    fNODE "contradiction_thm" 2
 | CT_cut(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "cut" 1
 | CT_cutrewrite_lr(x1, x2) ->
-   fFORMULA x1;
-   fID_OPT x2;
+   fFORMULA x1 ++
+   fID_OPT x2 ++
    fNODE "cutrewrite_lr" 2
 | CT_cutrewrite_rl(x1, x2) ->
-   fFORMULA x1;
-   fID_OPT x2;
+   fFORMULA x1 ++
+   fID_OPT x2 ++
    fNODE "cutrewrite_rl" 2
 | CT_dauto(x1, x2) ->
-   fINT_OPT x1;
-   fINT_OPT x2;
+   fINT_OPT x1 ++
+   fINT_OPT x2 ++
    fNODE "dauto" 2
 | CT_dconcl -> fNODE "dconcl" 0
 | CT_decompose_list(x1, x2) ->
-   fID_NE_LIST x1;
-   fFORMULA x2;
+   fID_NE_LIST x1 ++
+   fFORMULA x2 ++
    fNODE "decompose_list" 2
 | CT_decompose_record(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "decompose_record" 1
 | CT_decompose_sum(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "decompose_sum" 1
 | CT_depinversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1;
-   fID_OR_INT x2;
-   fINTRO_PATT_OPT x3;
-   fFORMULA_OPT x4;
+   fINV_TYPE x1 ++
+   fID_OR_INT x2 ++
+   fINTRO_PATT_OPT x3 ++
+   fFORMULA_OPT x4 ++
    fNODE "depinversion" 4
 | CT_deprewrite_lr(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "deprewrite_lr" 1
 | CT_deprewrite_rl(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "deprewrite_rl" 1
 | CT_destruct(x1) ->
-   fID_OR_INT x1;
+   fID_OR_INT x1 ++
    fNODE "destruct" 1
 | CT_dhyp(x1) ->
-   fID x1;
+   fID x1 ++
    fNODE "dhyp" 1
 | CT_discriminate_eq(x1) ->
-   fID_OR_INT_OPT x1;
+   fID_OR_INT_OPT x1 ++
    fNODE "discriminate_eq" 1
 | CT_do(x1, x2) ->
-   fID_OR_INT x1;
-   fTACTIC_COM x2;
+   fID_OR_INT x1 ++
+   fTACTIC_COM x2 ++
    fNODE "do" 2
 | CT_eapply(x1, x2) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
    fNODE "eapply" 2
 | CT_eauto(x1, x2) ->
-   fID_OR_INT_OPT x1;
-   fID_OR_INT_OPT x2;
+   fID_OR_INT_OPT x1 ++
+   fID_OR_INT_OPT x2 ++
    fNODE "eauto" 2
 | CT_eauto_with(x1, x2, x3) ->
-   fID_OR_INT_OPT x1;
-   fID_OR_INT_OPT x2;
-   fID_NE_LIST_OR_STAR x3;
+   fID_OR_INT_OPT x1 ++
+   fID_OR_INT_OPT x2 ++
+   fID_NE_LIST_OR_STAR x3 ++
    fNODE "eauto_with" 3
 | CT_elim(x1, x2, x3) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
-   fUSING x3;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
+   fUSING x3 ++
    fNODE "elim" 3
 | CT_elim_type(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "elim_type" 1
 | CT_exact(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "exact" 1
 | CT_exact_no_check(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "exact_no_check" 1
 | CT_vm_cast_no_check(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "vm_cast_no_check" 1
 | CT_exists(x1) ->
-   fSPEC_LIST x1;
+   fSPEC_LIST x1 ++
    fNODE "exists" 1
 | CT_fail(x1, x2) ->
-   fID_OR_INT x1;
-   fSTRING_OPT x2;
+   fID_OR_INT x1 ++
+   fSTRING_OPT x2 ++
    fNODE "fail" 2
 | CT_first(x,l) ->
-   fTACTIC_COM x;
-   (List.iter fTACTIC_COM l);
+   fTACTIC_COM x ++
+   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
    fNODE "first" (1 + (List.length l))
 | CT_firstorder(x1) ->
-   fTACTIC_OPT x1;
+   fTACTIC_OPT x1 ++
    fNODE "firstorder" 1
 | CT_firstorder_using(x1, x2) ->
-   fTACTIC_OPT x1;
-   fID_NE_LIST x2;
+   fTACTIC_OPT x1 ++
+   fID_NE_LIST x2 ++
    fNODE "firstorder_using" 2
 | CT_firstorder_with(x1, x2) ->
-   fTACTIC_OPT x1;
-   fID_NE_LIST x2;
+   fTACTIC_OPT x1 ++
+   fID_NE_LIST x2 ++
    fNODE "firstorder_with" 2
 | CT_fixtactic(x1, x2, x3) ->
-   fID_OPT x1;
-   fINT x2;
-   fFIX_TAC_LIST x3;
+   fID_OPT x1 ++
+   fINT x2 ++
+   fFIX_TAC_LIST x3 ++
    fNODE "fixtactic" 3
 | CT_formula_marker(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "formula_marker" 1
 | CT_fresh(x1) ->
-   fSTRING_OPT x1;
+   fSTRING_OPT x1 ++
    fNODE "fresh" 1
 | CT_generalize(x1) ->
-   fFORMULA_NE_LIST x1;
+   fFORMULA_NE_LIST x1 ++
    fNODE "generalize" 1
 | CT_generalize_dependent(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "generalize_dependent" 1
 | CT_idtac(x1) ->
-   fSTRING_OPT x1;
+   fSTRING_OPT x1 ++
    fNODE "idtac" 1
 | CT_induction(x1) ->
-   fID_OR_INT x1;
+   fID_OR_INT x1 ++
    fNODE "induction" 1
 | CT_info(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "info" 1
 | CT_injection_eq(x1) ->
-   fID_OR_INT_OPT x1;
+   fID_OR_INT_OPT x1 ++
    fNODE "injection_eq" 1
 | CT_instantiate(x1, x2, x3) ->
-   fINT x1;
-   fFORMULA x2;
-   fCLAUSE x3;
+   fINT x1 ++
+   fFORMULA x2 ++
+   fCLAUSE x3 ++
    fNODE "instantiate" 3
 | CT_intro(x1) ->
-   fID_OPT x1;
+   fID_OPT x1 ++
    fNODE "intro" 1
 | CT_intro_after(x1, x2) ->
-   fID_OPT x1;
-   fID x2;
+   fID_OPT x1 ++
+   fID x2 ++
    fNODE "intro_after" 2
 | CT_intros(x1) ->
-   fINTRO_PATT_LIST x1;
+   fINTRO_PATT_LIST x1 ++
    fNODE "intros" 1
 | CT_intros_until(x1) ->
-   fID_OR_INT x1;
+   fID_OR_INT x1 ++
    fNODE "intros_until" 1
 | CT_inversion(x1, x2, x3, x4) ->
-   fINV_TYPE x1;
-   fID_OR_INT x2;
-   fINTRO_PATT_OPT x3;
-   fID_LIST x4;
+   fINV_TYPE x1 ++
+   fID_OR_INT x2 ++
+   fINTRO_PATT_OPT x3 ++
+   fID_LIST x4 ++
    fNODE "inversion" 4
 | CT_left(x1) ->
-   fSPEC_LIST x1;
+   fSPEC_LIST x1 ++
    fNODE "left" 1
 | CT_let_ltac(x1, x2) ->
-   fLET_CLAUSES x1;
-   fLET_VALUE x2;
+   fLET_CLAUSES x1 ++
+   fLET_VALUE x2 ++
    fNODE "let_ltac" 2
 | CT_lettac(x1, x2, x3) ->
-   fID_OPT x1;
-   fFORMULA x2;
-   fCLAUSE x3;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
+   fCLAUSE x3 ++
    fNODE "lettac" 3
 | CT_match_context(x,l) ->
-   fCONTEXT_RULE x;
-   (List.iter fCONTEXT_RULE l);
+   fCONTEXT_RULE x ++
+   (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
    fNODE "match_context" (1 + (List.length l))
 | CT_match_context_reverse(x,l) ->
-   fCONTEXT_RULE x;
-   (List.iter fCONTEXT_RULE l);
+   fCONTEXT_RULE x ++
+   (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
    fNODE "match_context_reverse" (1 + (List.length l))
 | CT_match_tac(x1, x2) ->
-   fTACTIC_COM x1;
-   fMATCH_TAC_RULES x2;
+   fTACTIC_COM x1 ++
+   fMATCH_TAC_RULES x2 ++
    fNODE "match_tac" 2
 | CT_move_after(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "move_after" 2
 | CT_new_destruct(x1, x2, x3) ->
-   (List.iter fFORMULA_OR_INT x1); (* Julien F. Est-ce correct? *)
-   fUSING x2;
-   fINTRO_PATT_OPT x3;
+   (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *)
+   fUSING x2 ++
+   fINTRO_PATT_OPT x3 ++
    fNODE "new_destruct" 3
 | CT_new_induction(x1, x2, x3) ->
-   (List.iter fFORMULA_OR_INT x1); (* Pierre C. Est-ce correct? *)
-   fUSING x2;
-   fINTRO_PATT_OPT x3;
+   (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *)
+   fUSING x2 ++
+   fINTRO_PATT_OPT x3 ++
    fNODE "new_induction" 3
 | CT_omega -> fNODE "omega" 0
 | CT_orelse(x1, x2) ->
-   fTACTIC_COM x1;
-   fTACTIC_COM x2;
+   fTACTIC_COM x1 ++
+   fTACTIC_COM x2 ++
    fNODE "orelse" 2
 | CT_parallel(x,l) ->
-   fTACTIC_COM x;
-   (List.iter fTACTIC_COM l);
+   fTACTIC_COM x ++
+   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
    fNODE "parallel" (1 + (List.length l))
 | CT_pose(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "pose" 2
 | CT_progress(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "progress" 1
 | CT_prolog(x1, x2) ->
-   fFORMULA_LIST x1;
-   fINT x2;
+   fFORMULA_LIST x1 ++
+   fINT x2 ++
    fNODE "prolog" 2
 | CT_rec_tactic_in(x1, x2) ->
-   fREC_TACTIC_FUN_LIST x1;
-   fTACTIC_COM x2;
+   fREC_TACTIC_FUN_LIST x1 ++
+   fTACTIC_COM x2 ++
    fNODE "rec_tactic_in" 2
 | CT_reduce(x1, x2) ->
-   fRED_COM x1;
-   fCLAUSE x2;
+   fRED_COM x1 ++
+   fCLAUSE x2 ++
    fNODE "reduce" 2
 | CT_refine(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "refine" 1
 | CT_reflexivity -> fNODE "reflexivity" 0
 | CT_rename(x1, x2) ->
-   fID x1;
-   fID x2;
+   fID x1 ++
+   fID x2 ++
    fNODE "rename" 2
 | CT_repeat(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "repeat" 1
 | CT_replace_with(x1, x2,x3,x4) ->
-   fFORMULA x1;
-   fFORMULA x2;
-   fCLAUSE x3;
-   fTACTIC_OPT x4;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
+   fCLAUSE x3 ++
+   fTACTIC_OPT x4 ++
    fNODE "replace_with" 4
 | CT_rewrite_lr(x1, x2, x3) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
-   fCLAUSE x3;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
+   fCLAUSE x3 ++
    fNODE "rewrite_lr" 3
 | CT_rewrite_rl(x1, x2, x3) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
-   fCLAUSE x3;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
+   fCLAUSE x3 ++
    fNODE "rewrite_rl" 3
 | CT_right(x1) ->
-   fSPEC_LIST x1;
+   fSPEC_LIST x1 ++
    fNODE "right" 1
 | CT_ring(x1) ->
-   fFORMULA_LIST x1;
+   fFORMULA_LIST x1 ++
    fNODE "ring" 1
 | CT_simple_user_tac(x1, x2) ->
-   fID x1;
-   fTACTIC_ARG_LIST x2;
+   fID x1 ++
+   fTACTIC_ARG_LIST x2 ++
    fNODE "simple_user_tac" 2
 | CT_simplify_eq(x1) ->
-   fID_OR_INT_OPT x1;
+   fID_OR_INT_OPT x1 ++
    fNODE "simplify_eq" 1
 | CT_specialize(x1, x2, x3) ->
-   fINT_OPT x1;
-   fFORMULA x2;
-   fSPEC_LIST x3;
+   fINT_OPT x1 ++
+   fFORMULA x2 ++
+   fSPEC_LIST x3 ++
    fNODE "specialize" 3
 | CT_split(x1) ->
-   fSPEC_LIST x1;
+   fSPEC_LIST x1 ++
    fNODE "split" 1
 | CT_subst(x1) ->
-   fID_LIST x1;
+   fID_LIST x1 ++
    fNODE "subst" 1
 | CT_superauto(x1, x2, x3, x4) ->
-   fINT_OPT x1;
-   fID_LIST x2;
-   fDESTRUCTING x3;
-   fUSINGTDB x4;
+   fINT_OPT x1 ++
+   fID_LIST x2 ++
+   fDESTRUCTING x3 ++
+   fUSINGTDB x4 ++
    fNODE "superauto" 4
 | CT_symmetry(x1) ->
-   fCLAUSE x1;
+   fCLAUSE x1 ++
    fNODE "symmetry" 1
 | CT_tac_double(x1, x2) ->
-   fID_OR_INT x1;
-   fID_OR_INT x2;
+   fID_OR_INT x1 ++
+   fID_OR_INT x2 ++
    fNODE "tac_double" 2
 | CT_tacsolve(x,l) ->
-   fTACTIC_COM x;
-   (List.iter fTACTIC_COM l);
+   fTACTIC_COM x ++
+   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
    fNODE "tacsolve" (1 + (List.length l))
 | CT_tactic_fun(x1, x2) ->
-   fID_OPT_NE_LIST x1;
-   fTACTIC_COM x2;
+   fID_OPT_NE_LIST x1 ++
+   fTACTIC_COM x2 ++
    fNODE "tactic_fun" 2
 | CT_then(x,l) ->
-   fTACTIC_COM x;
-   (List.iter fTACTIC_COM l);
+   fTACTIC_COM x ++
+   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
    fNODE "then" (1 + (List.length l))
 | CT_transitivity(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "transitivity" 1
 | CT_trivial -> fNODE "trivial" 0
 | CT_trivial_with(x1) ->
-   fID_NE_LIST_OR_STAR x1;
+   fID_NE_LIST_OR_STAR x1 ++
    fNODE "trivial_with" 1
 | CT_truecut(x1, x2) ->
-   fID_OPT x1;
-   fFORMULA x2;
+   fID_OPT x1 ++
+   fFORMULA x2 ++
    fNODE "truecut" 2
 | CT_try(x1) ->
-   fTACTIC_COM x1;
+   fTACTIC_COM x1 ++
    fNODE "try" 1
 | CT_use(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "use" 1
 | CT_use_inversion(x1, x2, x3) ->
-   fID_OR_INT x1;
-   fFORMULA x2;
-   fID_LIST x3;
+   fID_OR_INT x1 ++
+   fFORMULA x2 ++
+   fID_LIST x3 ++
    fNODE "use_inversion" 3
 | CT_user_tac(x1, x2) ->
-   fID x1;
-   fTARG_LIST x2;
+   fID x1 ++
+   fTARG_LIST x2 ++
    fNODE "user_tac" 2
 and fTACTIC_OPT = function
 | CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x
 | CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x
 and fTAC_DEF = function
 | CT_tac_def(x1, x2) ->
-   fID x1;
-   fTACTIC_COM x2;
+   fID x1 ++
+   fTACTIC_COM x2 ++
    fNODE "tac_def" 2
 and fTAC_DEF_NE_LIST = function
 | CT_tac_def_ne_list(x,l) ->
-   fTAC_DEF x;
-   (List.iter fTAC_DEF l);
+   fTAC_DEF x ++
+   (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++
    fNODE "tac_def_ne_list" (1 + (List.length l))
 and fTARG = function
 | CT_coerce_BINDING_to_TARG x -> fBINDING x
@@ -1824,81 +1843,83 @@ and fTARG = function
 | CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x
 and fTARG_LIST = function
 | CT_targ_list l ->
-   (List.iter fTARG l);
+   (List.fold_left (++) (mt()) (List.map fTARG l)) ++
    fNODE "targ_list" (List.length l)
 and fTERM_CHANGE = function
 | CT_check_term(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "check_term" 1
 | CT_inst_term(x1, x2) ->
-   fID x1;
-   fFORMULA x2;
+   fID x1 ++
+   fFORMULA x2 ++
    fNODE "inst_term" 2
 and fTEXT = function
 | CT_coerce_ID_to_TEXT x -> fID x
 | CT_text_formula(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "text_formula" 1
 | CT_text_h l ->
-   (List.iter fTEXT l);
+   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
    fNODE "text_h" (List.length l)
 | CT_text_hv l ->
-   (List.iter fTEXT l);
+   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
    fNODE "text_hv" (List.length l)
 | CT_text_op l ->
-   (List.iter fTEXT l);
+   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
    fNODE "text_op" (List.length l)
 | CT_text_path(x1) ->
-   fSIGNED_INT_LIST x1;
+   fSIGNED_INT_LIST x1 ++
    fNODE "text_path" 1
 | CT_text_v l ->
-   (List.iter fTEXT l);
+   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
    fNODE "text_v" (List.length l)
 and fTHEOREM_GOAL = function
 | CT_goal(x1) ->
-   fFORMULA x1;
+   fFORMULA x1 ++
    fNODE "goal" 1
 | CT_theorem_goal(x1, x2, x3, x4) ->
-   fDEFN_OR_THM x1;
-   fID x2;
-   fBINDER_LIST x3;
-   fFORMULA x4;
+   fDEFN_OR_THM x1 ++
+   fID x2 ++
+   fBINDER_LIST x3 ++
+   fFORMULA x4 ++
    fNODE "theorem_goal" 4
 and fTHM = function
-| CT_thm x -> fATOM "thm";
-   (f_atom_string x);
-   print_string "\n"and fTHM_OPT = function
+| CT_thm x -> fATOM "thm" ++
+   (f_atom_string x) ++
+   str "\n"
+and fTHM_OPT = function
 | CT_coerce_NONE_to_THM_OPT x -> fNONE x
 | CT_coerce_THM_to_THM_OPT x -> fTHM x
 and fTYPED_FORMULA = function
 | CT_typed_formula(x1, x2) ->
-   fFORMULA x1;
-   fFORMULA x2;
+   fFORMULA x1 ++
+   fFORMULA x2 ++
    fNODE "typed_formula" 2
 and fUNFOLD = function
 | CT_coerce_ID_to_UNFOLD x -> fID x
 | CT_unfold_occ(x1, x2) ->
-   fID x1;
-   fINT_NE_LIST x2;
+   fID x1 ++
+   fINT_NE_LIST x2 ++
    fNODE "unfold_occ" 2
 and fUNFOLD_NE_LIST = function
 | CT_unfold_ne_list(x,l) ->
-   fUNFOLD x;
-   (List.iter fUNFOLD l);
+   fUNFOLD x ++
+   (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++
    fNODE "unfold_ne_list" (1 + (List.length l))
 and fUSING = function
 | CT_coerce_NONE_to_USING x -> fNONE x
 | CT_using(x1, x2) ->
-   fFORMULA x1;
-   fSPEC_LIST x2;
+   fFORMULA x1 ++
+   fSPEC_LIST x2 ++
    fNODE "using" 2
 and fUSINGTDB = function
 | CT_coerce_NONE_to_USINGTDB x -> fNONE x
 | CT_usingtdb -> fNODE "usingtdb" 0
 and fVAR = function
-| CT_var x -> fATOM "var";
-   (f_atom_string x);
-   print_string "\n"and fVARG = function
+| CT_var x -> fATOM "var" ++
+   (f_atom_string x) ++
+   str "\n"
+and fVARG = function
 | CT_coerce_AST_to_VARG x -> fAST x
 | CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x
 | CT_coerce_BINDER_to_VARG x -> fBINDER x
@@ -1916,7 +1937,7 @@ and fVAR = function
 | CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x
 and fVARG_LIST = function
 | CT_varg_list l ->
-   (List.iter fVARG l);
+   (List.fold_left (++) (mt()) (List.map fVARG l)) ++
    fNODE "varg_list" (List.length l)
 and fVERBOSE_OPT = function
 | CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x
diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli
index fe30b317..d7bd8db5 100644
--- a/contrib/interface/vtp.mli
+++ b/contrib/interface/vtp.mli
@@ -1,15 +1,16 @@
 open Ascent;;
+open Pp;;
 
-val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;;
-val fCOMMAND : ct_COMMAND -> unit;;
-val fTACTIC_COM : ct_TACTIC_COM -> unit;;
-val fFORMULA : ct_FORMULA -> unit;;
-val fID : ct_ID -> unit;;
-val fSTRING : ct_STRING -> unit;;
-val fINT : ct_INT -> unit;;
-val fRULE_LIST : ct_RULE_LIST -> unit;;
-val fRULE : ct_RULE -> unit;;
-val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;;
-val fPREMISES_LIST : ct_PREMISES_LIST -> unit;;
-val fID_LIST : ct_ID_LIST -> unit;;
-val fTEXT : ct_TEXT -> unit;;
\ No newline at end of file
+val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;;
+val fCOMMAND : ct_COMMAND -> std_ppcmds;;
+val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;;
+val fFORMULA : ct_FORMULA -> std_ppcmds;;
+val fID : ct_ID -> std_ppcmds;;
+val fSTRING : ct_STRING -> std_ppcmds;;
+val fINT : ct_INT -> std_ppcmds;;
+val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;;
+val fRULE : ct_RULE -> std_ppcmds;;
+val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;;
+val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;;
+val fID_LIST : ct_ID_LIST -> std_ppcmds;;
+val fTEXT : ct_TEXT -> std_ppcmds;;
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
index df03a579..7d1f57fe 100644
--- a/contrib/interface/xlate.ml
+++ b/contrib/interface/xlate.ml
@@ -15,12 +15,6 @@ open Libnames;;
 open Goptions;;
 
 
-let in_coq_ref = ref false;;
-
-let declare_in_coq () = in_coq_ref:=true;;
-
-let in_coq () = !in_coq_ref;;
-
 (* // Verify whether this is dead code, as of coq version 7 *)
 (* The following three sentences have been added to cope with a change 
 of strategy from the Coq team in the way rules construct ast's.  The
@@ -203,6 +197,10 @@ let xlate_int_or_var_opt_to_int_opt = function
   | Some (ArgVar _) -> xlate_error "int_or_var: TODO"
   | None ->  CT_coerce_NONE_to_INT_OPT CT_none
 
+let apply_or_by_notation f = function
+  | AN x -> f x
+  | ByNotation _ -> xlate_error "TODO: ByNotation"
+
 let tac_qualid_to_ct_ID ref = 
   CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
 
@@ -307,14 +305,10 @@ let make_fix_struct (n,bl) =
   let names = names_of_local_assums bl in
   let nn = List.length names in
   if nn = 1 || n = None then ctv_ID_OPT_NONE
-  else 
-    let n = out_some n in 
-    if n < nn then xlate_id_opt(List.nth names n)
-    else xlate_error "unexpected result of parsing for Fixpoint";;
-
+  else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));;
 
 let rec xlate_binder = function
-    (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+    (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
 and xlate_return_info = function
 | (Some Anonymous, None) | (None, None) ->
    CT_coerce_NONE_to_RETURN_INFO CT_none
@@ -327,7 +321,7 @@ and xlate_formula_opt =
     | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e)
 
 and  xlate_binder_l = function
-    LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+    LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
   | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n,
 						       xlate_formula v))
 and 
@@ -336,7 +330,7 @@ and
   | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, 
                                      List.map xlate_match_pattern l)
 and  translate_one_equation = function
-    (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
+    (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
   | _ -> xlate_error "TODO: disjunctive multiple patterns"
 and 
   xlate_binder_ne_list = function
@@ -379,8 +373,8 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
 		 (xlate_formula f, List.map xlate_formula_expl l'))
    | CApp(_, (_,f), l) -> 
        CT_appc(xlate_formula f, xlate_formula_expl_ne_list l)
-   | CCases (_, _, [], _) -> assert false
-   | CCases (_, ret_type, tm::tml, eqns)->
+   | CCases (_, _, _, [], _) -> assert false
+   | CCases (_, _, ret_type, tm::tml, eqns)->
        CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm,
 					   List.map xlate_matched_formula tml),
 		xlate_formula_opt ret_type,
@@ -418,23 +412,16 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
        CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s))
    | CPatVar (_, (true, s)) ->
        xlate_error "Second order variable not supported"
-   | CEvar (_, _) -> xlate_error "CEvar not supported"
+   | CEvar _ -> xlate_error "CEvar not supported"
    | CCoFix (_, (_, id), lm::lmi) -> 
-     let strip_mutcorec (fid, bl,arf, ardef) =
+     let strip_mutcorec ((_, fid), bl,arf, ardef) =
 	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
                       xlate_formula arf, xlate_formula ardef) in
         CT_cofixc(xlate_ident id,
 	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)))
    | CFix (_, (_, id), lm::lmi) ->       
-     let strip_mutrec (fid, (n, ro), bl, arf, ardef) =
-        let (struct_arg,bl,arf,ardef) =
-	 (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
-	 (* By the way, how could [bl = []] happen in V8 syntax ?  *)
-         if bl = [] then
-	   let n = out_some n in 
-           let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
-           (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
-         else (make_fix_struct (n, bl),bl,arf,ardef) in
+     let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) =
+        let struct_arg = make_fix_struct (n, bl) in
         let arf = xlate_formula arf in
         let ardef = xlate_formula ardef in
 	match xlate_binder_list bl with
@@ -461,7 +448,7 @@ and xlate_matched_formula = function
       CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f)
 and xlate_formula_expl = function
     (a, None) -> xlate_formula a
-  | (a, Some (_,ExplByPos i)) -> 
+  | (a, Some (_,ExplByPos (i, _))) -> 
       xlate_error "explicitation of implicit by rank not supported"
   | (a, Some (_,ExplByName i)) ->
       CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a)
@@ -477,24 +464,31 @@ let (xlate_ident_or_metaid:
     AI (_, x) -> xlate_ident x
   | MetaId(_, x) -> CT_metaid x;;
 
+let nums_of_occs (b,nums) =
+  if b then nums
+  else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums
+
 let xlate_hyp = function
   | AI (_,id) -> xlate_ident id
   | MetaId _ -> xlate_error "MetaId should occur only in quotations"
 
 let xlate_hyp_location =
  function
-  | (nums, AI (_,id)), InHypTypeOnly ->
-      CT_intype(xlate_ident id, nums_or_var_to_int_list nums)
-  | (nums, AI (_,id)), InHypValueOnly ->
-      CT_invalue(xlate_ident id, nums_or_var_to_int_list nums)
-  | ([], AI (_,id)), InHyp ->
+  | (occs, AI (_,id)), InHypTypeOnly ->
+      CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
+  | (occs, AI (_,id)), InHypValueOnly ->
+      CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
+  | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr ->
       CT_coerce_UNFOLD_to_HYP_LOCATION 
 	(CT_coerce_ID_to_UNFOLD (xlate_ident id))
-  | (a::l, AI (_,id)), InHyp ->
+  | ((_,a::l as occs), AI (_,id)), InHyp ->
+      let nums = nums_of_occs occs in
+      let a = List.hd nums and l = List.tl nums in
       CT_coerce_UNFOLD_to_HYP_LOCATION 
 	(CT_unfold_occ (xlate_ident id, 
 			CT_int_ne_list(num_or_var_to_int a, 
                                        nums_or_var_to_int_list_aux l)))
+  | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *)
   | (_, MetaId _),_ -> 
       xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)"
 
@@ -507,7 +501,7 @@ let xlate_clause cls =
       | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in
   CT_clause
     (hyps_info, 
-     if cls.onconcl then 
+     if cls.concl_occs <> no_occurrences_expr then 
        CT_coerce_STAR_to_STAR_OPT CT_star
      else
        CT_coerce_NONE_to_STAR_OPT CT_none)
@@ -606,14 +600,15 @@ let strip_targ_intropatt =
     | _ -> xlate_error "strip_targ_intropatt";;
 
 let get_flag r =
-  let conv_flags, red_ids = 
+  let conv_flags, red_ids =
+    let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in
     if r.rDelta then
-      [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst)
+      [CT_delta], CT_unfbut csts
     else
       (if r.rConst = []
       then (* probably useless: just for compatibility *) []
       else [CT_delta]),
-      CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in
+      CT_unf csts in
   let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in
   let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in
   let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in
@@ -633,6 +628,8 @@ let rec xlate_intro_pattern =
   | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" )
   | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c)
   | IntroAnonymous -> xlate_error "TODO: IntroAnonymous"
+  | IntroFresh _ -> xlate_error "TODO: IntroFresh"
+  | IntroRewrite _ -> xlate_error "TODO: IntroRewrite"
 
 let compute_INV_TYPE = function
    FullInversionClear -> CT_inv_clear
@@ -663,7 +660,8 @@ let xlate_largs_to_id_opt largs =
     | _ -> assert false;;
 
 let xlate_int_or_constr = function
-    ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
+    ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
+  | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings"
   | ElimOnIdent(_,i) ->
       CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
       	(CT_coerce_ID_to_ID_OR_INT(xlate_ident i))
@@ -676,9 +674,13 @@ let xlate_using = function
   | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);;
 
 let xlate_one_unfold_block = function
-    ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid)
-  | (n::nums, qid) ->
-      CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums)
+    ((true,[]),qid) -> 
+      CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid)
+  | (((_,_::_) as occs), qid) ->
+      let l = nums_of_occs occs in
+      CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, 
+                    nums_or_var_to_int_ne_list (List.hd l) (List.tl l))
+  | ((false,[]), qid) -> xlate_error "Unused"
 ;;
 
 let xlate_with_names = function
@@ -739,7 +741,8 @@ and xlate_red_tactic =
   | CbvVm -> CT_cbvvm
   | Hnf -> CT_hnf
   | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE
-  | Simpl (Some (l,c)) -> 
+  | Simpl (Some (occs,c)) -> 
+      let l = nums_of_occs occs in
       CT_simpl 
 	(CT_coerce_PATTERN_to_PATTERN_OPT
 	   (CT_pattern_occ
@@ -758,9 +761,9 @@ and xlate_red_tactic =
   | Fold formula_list -> 
       CT_fold(CT_formula_list(List.map xlate_formula formula_list))
   | Pattern l ->
-     let pat_list = List.map (fun (nums,c) ->
+     let pat_list = List.map (fun (occs,c) ->
           CT_pattern_occ
-           (CT_int_list (nums_or_var_to_int_list_aux nums),
+           (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)),
             xlate_formula c)) l in
      (match pat_list with
       | first :: others -> CT_pattern (CT_pattern_ne_list (first, others))
@@ -770,21 +773,23 @@ and xlate_red_tactic =
 and xlate_local_rec_tac = function 
  (* TODO LATER: local recursive tactics and global ones should be handled in
     the same manner *)
-  | ((_,x),(argl,tac)) ->
+  | ((_,x),Tacexp (TacFun (argl,tac))) ->
       let fst, rest = xlate_largs_to_id_opt argl in
 	CT_rec_tactic_fun(xlate_ident x,
 			  CT_id_opt_ne_list(fst, rest),
 			  xlate_tactic tac)
+  | _ -> xlate_error "TODO: more general argument of 'let rec in'"
 
 and xlate_tactic =
  function
    | TacFun (largs, t) ->
        let fst, rest =  xlate_largs_to_id_opt largs in
        CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t)
-   | TacThen (t1,t2) -> 
+   | TacThen (t1,[||],t2,[||]) -> 
        (match xlate_tactic t1 with
             CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2])
 	  | t -> CT_then (t,[xlate_tactic t2]))
+   | TacThen _ -> xlate_error "TacThen generalization TODO"
    | TacThens(t1,[]) -> assert false
    | TacThens(t1,t::l) ->
        let ct = xlate_tactic t in
@@ -831,36 +836,31 @@ and xlate_tactic =
    | TacMatchContext (false,true,rule1::rules) ->
          CT_match_context_reverse(xlate_context_rule rule1,
                           List.map xlate_context_rule rules)
-   | TacLetIn (l, t) ->
+   | TacLetIn (false, l, t) ->
        let cvt_clause =
          function
-             ((_,s),None,ConstrMayEval v) ->
+             ((_,s),ConstrMayEval v) ->
                  CT_let_clause(xlate_ident s,
 			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
                                CT_coerce_DEF_BODY_to_LET_VALUE
                                (formula_to_def_body v))
-           | ((_,s),None,Tacexp t) -> 
+           | ((_,s),Tacexp t) -> 
                  CT_let_clause(xlate_ident s,
 			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
                                CT_coerce_TACTIC_COM_to_LET_VALUE
                                (xlate_tactic t))
-           | ((_,s),None,t) -> 
+           | ((_,s),t) -> 
                  CT_let_clause(xlate_ident s,
 			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
                                CT_coerce_TACTIC_COM_to_LET_VALUE
-                               (xlate_call_or_tacarg t))
-           | ((_,s),Some c,t) -> 
-	       CT_let_clause(xlate_ident s,
-			     CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c),
-                               CT_coerce_TACTIC_COM_to_LET_VALUE
-				 (xlate_call_or_tacarg t)) in
+                               (xlate_call_or_tacarg t)) in
          let cl_l = List.map cvt_clause l in
          (match cl_l with
             | [] -> assert false 
             | fst::others ->
                 CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t))
-   | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition"
-   | TacLetRecIn(f1::l, t) -> 
+   | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition"
+   | TacLetIn(true, f1::l, t) -> 
        let tl =  CT_rec_tactic_fun_list
 		   (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in
        CT_rec_tactic_in(tl, xlate_tactic t)
@@ -917,6 +917,7 @@ and xlate_tac =
     | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b)
     | TacChange (Some(l,c), f, b) -> 
 	(* TODO LATER: combine with other constructions of pattern_occ *)
+	let l = nums_of_occs l in
 	CT_change_local(
 	  CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), 
 			 xlate_formula c),
@@ -946,18 +947,22 @@ and xlate_tac =
 	xlate_error "TODO: injection as"
     | TacFix (idopt, n) ->
      CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
-    | TacMutualFix (id, n, fixtac_list) ->
+    | TacMutualFix (false, id, n, fixtac_list) ->
      let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in
      CT_fixtactic
       (ctf_ID_OPT_SOME (xlate_ident id), CT_int n,
       CT_fix_tac_list (List.map f fixtac_list))
+    | TacMutualFix (true, id, n, fixtac_list) ->
+        xlate_error "TODO: non user-visible fix"
     | TacCofix idopt ->
        CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list [])
-    | TacMutualCofix (id, cofixtac_list) ->
+    | TacMutualCofix (false, id, cofixtac_list) ->
      let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in
      CT_cofixtactic
       (CT_coerce_ID_to_ID_OPT (xlate_ident id),
       CT_cofix_tac_list (List.map f cofixtac_list))
+    | TacMutualCofix (true, id, cofixtac_list) ->
+        xlate_error "TODO: non user-visible cofix"
     | TacIntrosUntil (NamedHyp id) -> 
 	CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id))
     | TacIntrosUntil (AnonHyp n) -> 
@@ -975,10 +980,12 @@ and xlate_tac =
     | TacIntroMove (Some id, None) ->
      CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)])
     | TacIntroMove (None, None) ->  CT_intro (CT_coerce_NONE_to_ID_OPT CT_none)
-    | TacLeft bindl -> CT_left (xlate_bindings bindl)
-    | TacRight bindl -> CT_right (xlate_bindings bindl)
-    | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl)
-    | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl)
+    | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl)
+    | TacRight (false,bindl) -> CT_right (xlate_bindings bindl)
+    | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl)
+    | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl)
+    | TacSplit _ | TacRight _ | TacLeft _ -> 
+	xlate_error "TODO: esplit, eright, etc"
     | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) ->
 	let c1 = xlate_formula (out_gen rawwit_constr c1) in
 	let c2 = xlate_formula (out_gen rawwit_constr c2) in
@@ -991,7 +998,7 @@ and xlate_tac =
 	  let cl_as_xlate_arg = 
 	    {cl_as_clause with 
 	       Tacexpr.onhyps = 
-		option_map 
+		Option.map 
 		  (fun l -> 
 		     List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
 		  )
@@ -1009,12 +1016,15 @@ and xlate_tac =
 		CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
 	in 
 	CT_replace_with (c1, c2,cl,tac_opt)
-    | TacRewrite(b,cbindl,cl) -> 
+    | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> 
      let cl = xlate_clause cl 
      and c = xlate_formula (fst cbindl) 
      and bindl = xlate_bindings (snd cbindl) in
      if b then CT_rewrite_lr (c, bindl, cl)
      else CT_rewrite_rl (c, bindl, cl)
+    | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by"
+    | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once"
+    | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite"
     | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) ->
      let t = out_gen rawwit_main_tactic t in
      let b = out_gen Extraargs.rawwit_orient b in
@@ -1127,10 +1137,9 @@ and xlate_tac =
       (match out_gen rawwit_int_or_var n with
 	| ArgVar _ -> xlate_error ""
 	| ArgArg n -> CT_prolog (CT_formula_list cl, CT_int  n))
-    | TacExtend (_,"eapply", [cbindl]) ->
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     CT_eapply (c, bindl)
+    (* eapply now represented by TacApply (true,cbindl) 
+    | TacExtend (_,"eapply", [cbindl]) -> 
+*)
     | TacTrivial ([],Some []) -> CT_trivial
     | TacTrivial ([],None) -> 
 	CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
@@ -1141,25 +1150,36 @@ and xlate_tac =
 	xlate_error "TODO: trivial using"
     | TacReduce (red, l) ->
      CT_reduce (xlate_red_tactic red, xlate_clause l)
-    | TacApply (c,bindl) ->
+    | TacApply (true,false,(c,bindl)) ->
      CT_apply (xlate_formula c, xlate_bindings bindl)
-    | TacConstructor (n_or_meta, bindl) ->
+    | TacApply (true,true,(c,bindl)) ->
+     CT_eapply (xlate_formula c, xlate_bindings bindl)
+    | TacApply (false,_,_) -> xlate_error "TODO: simple (e)apply"
+    | TacConstructor (false,n_or_meta, bindl) ->
 	let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error ""
 	in CT_constructor (CT_int n, xlate_bindings bindl)
+    | TacConstructor _ -> xlate_error "TODO: econstructor"
     | TacSpecialize (nopt, (c,sl)) ->
      CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl)
     | TacGeneralize [] -> xlate_error ""
-    | TacGeneralize (first :: cl) ->
+    | TacGeneralize ((((true,[]),first),Anonymous) :: cl)
+	when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr
+	  & na = Anonymous) cl ->
      CT_generalize
-      (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl))
+      (CT_formula_ne_list (xlate_formula first, 
+                           List.map (fun ((_,c),_) -> xlate_formula c) cl))
+    | TacGeneralize _ -> xlate_error "TODO: Generalize at and as"
     | TacGeneralizeDep c ->
 	CT_generalize_dependent (xlate_formula c)
     | TacElimType c -> CT_elim_type (xlate_formula c)
     | TacCaseType c -> CT_case_type (xlate_formula c)
-    | TacElim ((c1,sl), u) ->
+    | TacElim (false,(c1,sl), u) ->
      CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u)
-    | TacCase (c1,sl) ->
+    | TacCase (false,(c1,sl)) ->
      CT_casetac (xlate_formula c1, xlate_bindings sl)
+    | TacElim (true,_,_) | TacCase (true,_)
+    | TacNewDestruct (true,_,_,_,_) | TacNewInduction (true,_,_,_,_) ->
+	xlate_error "TODO: eelim, ecase, edestruct, einduction"
     | TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h)
     | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h)
     | TacCut c -> CT_cut (xlate_formula c)
@@ -1167,8 +1187,8 @@ and xlate_tac =
     | TacDecompose ([],c) ->
 	xlate_error "Decompose : empty list of identifiers?"
     | TacDecompose (id::l,c) ->
-	let id' = tac_qualid_to_ct_ID id in
-	let l' = List.map tac_qualid_to_ct_ID l in
+	let id' = apply_or_by_notation tac_qualid_to_ct_ID id in
+	let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in
         CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c)
     | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c)
     | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c)
@@ -1178,6 +1198,7 @@ and xlate_tac =
        let idl' = List.map xlate_hyp idl in
        CT_clear (CT_id_ne_list (xlate_hyp id, idl'))
     | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'"
+    | TacRevert _ -> xlate_error "TODO: revert"
     | (*For translating tactics/Inv.v *)
       TacInversion (NonDepInversion (k,idl,l),quant_hyp) ->
 	CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp,
@@ -1192,30 +1213,36 @@ and xlate_tac =
 	  CT_use_inversion (id, xlate_formula c,
 	    CT_id_list (List.map xlate_hyp idlist))
     | TacExtend (_,"omega", []) -> CT_omega
-    | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2)
+    | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2)
+    | TacRename _ -> xlate_error "TODO: add support for n-ary rename"
     | TacClearBody([]) -> assert false
     | TacClearBody(a::l) -> 
 	CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l))
-    | TacDAuto (a, b) ->
+    | TacDAuto (a, b, []) ->
 	CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b)
-    | TacNewDestruct(a,b,c) ->
-	CT_new_destruct (* Julien F. : est-ce correct *)
+    | TacDAuto (a, b, _) ->
+	xlate_error "TODO: dauto using"
+    | TacNewDestruct(false,a,b,c,None) ->
+	CT_new_destruct
 	  (List.map  xlate_int_or_constr a, xlate_using b, 
 	   xlate_with_names c)
-    | TacNewInduction(a,b,c) ->
-	CT_new_induction (* Pierre C. : est-ce correct *)
+    | TacNewInduction(false,a,b,c,None) ->
+	CT_new_induction
 	  (List.map xlate_int_or_constr a, xlate_using b,
 	   xlate_with_names c)
+    | TacNewDestruct(false,a,b,c,_) -> xlate_error "TODO: destruct in"
+    | TacNewInduction(false,a,b,c,_) ->xlate_error "TODO: induction in"
     (*| TacInstantiate (a, b, cl) -> 
         CT_instantiate(CT_int a, xlate_formula b,
 		       assert false) *)
-    | TacLetTac (na, c, cl) when cl = nowhere -> 
+    | TacLetTac (na, c, cl, true) when cl = nowhere -> 
         CT_pose(xlate_id_opt_aux na, xlate_formula c)
-    | TacLetTac (na, c, cl) ->
+    | TacLetTac (na, c, cl, true) ->
         CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, 
 		  (* TODO LATER: This should be shared with Unfold,
 		     but the structures are different *)
 		  xlate_clause cl)
+    | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember"
     | TacAssert (None, IntroIdentifier id, c) -> 
         CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c)
     | TacAssert (None, IntroAnonymous, c) -> 
@@ -1226,16 +1253,18 @@ and xlate_tac =
         CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
     | TacAssert _ ->
 	xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'"
-    | TacAnyConstructor(Some tac) -> 
+    | TacAnyConstructor(false,Some tac) -> 
 	CT_any_constructor
 	(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
-    | TacAnyConstructor(None) -> 
+    | TacAnyConstructor(false,None) -> 
 	CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none)
+    | TacAnyConstructor _ -> xlate_error "TODO: econstructor"
     | TacExtend(_, "ring", [args]) -> 
 	CT_ring
 	  (CT_formula_list
 	     (List.map xlate_formula
 		(out_gen (wit_list0 rawwit_constr) args)))
+    | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal"
     | TacExtend (_,id, l) ->
 	print_endline ("Extratactics : "^ id);
      CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l))
@@ -1299,7 +1328,7 @@ and coerce_genarg_to_TARG x =
 					 (snd (out_gen
 					    (rawwit_open_constr_gen b) x))))
   | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
-      let n = out_some (Pcoq.tactic_genarg_level s) in
+      let n = Option.get (Pcoq.tactic_genarg_level s) in
       let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
       CT_coerce_TACTIC_COM_to_TARG t
   | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
@@ -1392,7 +1421,7 @@ let coerce_genarg_to_VARG x =
   | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
   | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
   | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
-      let n = out_some (Pcoq.tactic_genarg_level s) in
+      let n = Option.get (Pcoq.tactic_genarg_level s) in
       let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
       CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t)
   | OpenConstrArgType _ -> xlate_error "TODO: generic open constr"
@@ -1563,7 +1592,9 @@ let rec xlate_module_type = function
 	   | CWith_Module((_, idl), (_, qid)) ->
 	       CT_module_type_with_mod(mty1,
 				       CT_id_list (List.map xlate_ident idl), 
-				       CT_ident (xlate_qualid qid)));;
+				       CT_ident (xlate_qualid qid)))
+  | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";;
+
 
 let xlate_module_binder_list (l:module_binder list) =
   CT_module_binder_list
@@ -1596,8 +1627,8 @@ let rec xlate_vernac =
    | VernacDeclareTacticDefinition (true, tacs) ->
        (match List.map 
 	 (function
-	      ((_, id), body) ->
-		CT_tac_def(CT_ident (string_of_id id), xlate_tactic body))
+	      (id, _, body) ->
+		CT_tac_def(reference_to_ct_ID id, xlate_tactic body))
 	 tacs with
 	     [] -> assert false
 	   | fst::tacs1 ->
@@ -1714,7 +1745,7 @@ let rec xlate_vernac =
 		      CT_id_ne_list(n1, names), dblist)
 	| HintsExtern (n, c, t) ->
 	    CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist)
-        | HintsResolve l | HintsImmediate l -> 
+        | HintsImmediate l -> 
 	 let f1, formulas = match List.map xlate_formula l with
 	     a :: tl -> a, tl
 	   | _  -> failwith "" in
@@ -1731,6 +1762,23 @@ let rec xlate_vernac =
 		  HintsResolve _ -> CT_hints_resolve(l', dblist)
 		| HintsImmediate _ -> CT_hints_immediate(l', dblist)
 		| _ -> assert false)
+        | HintsResolve l -> 
+	 let f1, formulas = match List.map xlate_formula (List.map snd l) with
+	     a :: tl -> a, tl
+	   | _  -> failwith "" in
+	 let l' = CT_formula_ne_list(f1, formulas) in
+	   if local then
+             (match h with 
+		  HintsResolve _ ->
+		    CT_local_hints_resolve(l', dblist)
+	       	| HintsImmediate _ ->
+		    CT_local_hints_immediate(l', dblist)
+	       	| _ -> assert false)
+	   else
+	     (match h with
+		  HintsResolve _ -> CT_hints_resolve(l', dblist)
+		| HintsImmediate _ -> CT_hints_immediate(l', dblist)
+		| _ -> assert false)
         | HintsUnfold l -> 
 	 let n1, names = match List.map loc_qualid_to_ct_ID l with
 	     n1 :: names -> n1, names
@@ -1766,13 +1814,11 @@ let rec xlate_vernac =
        ctf_ID_OPT_SOME (xlate_ident s))
   | VernacEndProof Admitted ->
       CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE)
-  | VernacSetOpacity (false, id :: idl) ->
-            CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id,
-                   List.map loc_qualid_to_ct_ID idl))
-  | VernacSetOpacity (true, id :: idl)
-            -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id,
-                   List.map loc_qualid_to_ct_ID idl))
-  | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur"
+  | VernacSetOpacity (_,l) ->
+      CT_strategy(CT_level_list
+        (List.map (fun (l,q) ->
+          (level_to_ct_LEVEL l,
+           CT_id_list(List.map loc_qualid_to_ct_ID q))) l))
   | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n))
   | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt)
   | VernacShow ShowNode -> CT_show_node
@@ -1799,7 +1845,7 @@ let rec xlate_vernac =
 	| PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id)
 	| PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id)
 	| PrintModules -> CT_print_modules
-	| PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none
+	| PrintGrammar name -> CT_print_grammar CT_grammar_none
 	| PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star)
 	| PrintHintDbName id -> 
 	    CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id))
@@ -1819,6 +1865,12 @@ let rec xlate_vernac =
 	    CT_print_path (xlate_class id1, xlate_class id2)
 	| PrintCanonicalConversions ->
 	    xlate_error "TODO: Print Canonical Structures"
+	| PrintAssumptions _ -> 
+	    xlate_error "TODO: Print Needed Assumptions"
+	| PrintInstances _ -> 
+	    xlate_error "TODO: Print Instances"
+	| PrintTypeClasses -> 
+	    xlate_error "TODO: Print TypeClasses"
 	| PrintInspect n -> CT_inspect (CT_int n)
 	| PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s)
 	| PrintSetoids -> CT_print_setoids
@@ -1837,12 +1889,14 @@ let rec xlate_vernac =
   | VernacBeginSection (_,id) ->
       CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id))
   | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id)
-  | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) ->
+  | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) ->
       CT_coerce_THEOREM_GOAL_to_COMMAND(
 	CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s,
            xlate_binder_list bl, xlate_formula c))
+  | VernacStartTheoremProof _ ->
+      xlate_error "TODO: Mutually dependent theorems"
   | VernacSuspend -> CT_suspend
-  | VernacResume idopt -> CT_resume (xlate_ident_opt (option_map snd idopt))
+  | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt))
   | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
       CT_coerce_THEOREM_GOAL_to_COMMAND
 	(CT_theorem_goal
@@ -1853,8 +1907,9 @@ let rec xlate_vernac =
 	(xlate_defn kind, xlate_ident s, xlate_binder_list bl,
 	   cvt_optional_eval_for_definition c red_option,
            xlate_formula_opt typ_opt)
-  | VernacAssumption (kind, b) ->
-      CT_variable (xlate_var kind, cvt_vernac_binders b)
+  | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline"
+      (*inline : bool -> automatic delta reduction at fonctor application*)
+     (* CT_variable (xlate_var kind, cvt_vernac_binders b)*)
   | VernacCheckMayEval (None, numopt, c) ->
       CT_check (xlate_formula c)
   | VernacSearch (s,x) ->
@@ -1884,7 +1939,7 @@ let rec xlate_vernac =
       (_, (add_coercion, (_,s)), binders, c1,
        rec_constructor_or_none, field_list) ->
       let record_constructor =
-        xlate_ident_opt (option_map snd rec_constructor_or_none) in
+        xlate_ident_opt (Option.map snd rec_constructor_or_none) in
       CT_record
        ((if add_coercion then CT_coercion_atm else
           CT_coerce_NONE_to_COERCION_OPT(CT_none)),
@@ -1902,15 +1957,8 @@ let rec xlate_vernac =
 	  (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi))
    | VernacFixpoint ([],_) -> xlate_error "mutual recursive"
    | VernacFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) =
-        let (struct_arg,bl,arf,ardef) =
-	 (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
-	 (* By the way, how could [bl = []] happen in V8 syntax ?  *)
-         if bl = [] then
-	   let n = out_some n in 
-           let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
-           (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
-         else (make_fix_struct (n, bl),bl,arf,ardef) in
+      let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) =
+        let struct_arg = make_fix_struct (n, bl) in
         let arf = xlate_formula arf in
         let ardef = xlate_formula ardef in
 	match xlate_binder_list bl with
@@ -1922,26 +1970,35 @@ let rec xlate_vernac =
 	  (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi))
    | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive"
    | VernacCoFixpoint ((lm :: lmi),boxed) ->
-      let strip_mutcorec ((fid, bl, arf, ardef), _ntn) =
+      let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) =
 	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
                       xlate_formula arf, xlate_formula ardef) in
         CT_cofix_decl
 	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))
    | VernacScheme [] -> xlate_error "induction scheme"
    | VernacScheme (lm :: lmi) ->
-      let strip_ind ((_,id), depstr, inde, sort) =
+      let strip_ind = function
+      | (Some (_,id), InductionScheme (depstr, inde, sort)) ->
            CT_scheme_spec
             (xlate_ident id, xlate_dep depstr, 
 	    CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
-	     xlate_sort sort) in
+	     xlate_sort sort)
+      | (None, InductionScheme (depstr, inde, sort)) ->
+           CT_scheme_spec
+            (xlate_ident (id_of_string ""), xlate_dep depstr,
+            CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
+             xlate_sort sort)
+      | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in
         CT_ind_scheme
 	  (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi))
-   | VernacSyntacticDefinition (id, c, false, _) ->
+   | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme"
+   | VernacSyntacticDefinition ((_,id), ([],c), false, _) ->
        CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None)
-   | VernacSyntacticDefinition (id, c, true, _) ->
-       xlate_error "TODO: Local abbreviations"
+   | VernacSyntacticDefinition ((_,id), _, _, _) ->
+       xlate_error"TODO: Local abbreviations and abbreviations with parameters"
   (* Modules and Module Types *)
-  | VernacDeclareModuleType((_, id), bl, mty_o)  -> 
+   | VernacInclude (_) -> xlate_error "TODO : Include "
+   | VernacDeclareModuleType((_, id), bl, mty_o)  -> 
       CT_module_type_decl(xlate_ident id,
 			  xlate_module_binder_list bl,
 			  match mty_o with
@@ -2051,6 +2108,12 @@ let rec xlate_vernac =
        | Local -> CT_local in
       CT_coercion (local_opt, id_opt, xlate_ident id1,
         xlate_class id2, xlate_class id3)
+
+    (* Type Classes *) 
+   | VernacDeclareInstance _|VernacContext _|
+	 VernacInstance (_, _, _, _, _)|VernacClass (_, _, _, _, _) ->
+	   xlate_error "TODO: Type Classes commands"
+
   | VernacResetName id -> CT_reset (xlate_ident (snd id))
   | VernacResetInitial -> CT_restore_state (CT_ident "Initial")
   | VernacExtend (s, l) ->
@@ -2073,10 +2136,10 @@ let rec xlate_vernac =
 	       CT_coerce_ID_LIST_to_ID_LIST_OPT
 	       (CT_id_list
 	       (List.map
-		  (function ExplByPos x
+		  (function ExplByPos (x,_), _, _
 		       -> xlate_error
 			   "explication argument by rank is obsolete"
-		     | ExplByName id -> CT_ident (string_of_id id)) l)))
+		     | ExplByName id, _, _ -> CT_ident (string_of_id id)) l)))
   | VernacDeclareImplicits(false, id, opt_positions) ->
       xlate_error "TODO: Implicit Arguments Global"
   | VernacReserve((_,a)::l, f) ->
@@ -2096,13 +2159,15 @@ let rec xlate_vernac =
       let table1 = 
 	match table with
 	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
 	CT_set_option(table1)
   | VernacSetOption (table, v) -> 
       let table1 = 
 	match table with
 	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
       let value =
 	match v with
 	  | BoolValue _ -> assert false
@@ -2115,7 +2180,8 @@ let rec xlate_vernac =
       let table1 = 
 	match table with
 	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
 	CT_unset_option(table1)
   | VernacAddOption (table, l) ->
       let values =
@@ -2130,7 +2196,8 @@ let rec xlate_vernac =
       let table1 = 
 	match table with
 	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
-	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
 	CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1))
   | VernacImport(true, a::l) ->
       CT_export_id(CT_id_ne_list(reference_to_ct_ID a,
@@ -2140,13 +2207,17 @@ let rec xlate_vernac =
 				 List.map reference_to_ct_ID l))
   | VernacImport(_, []) -> assert false
   | VernacProof t -> CT_proof_with(xlate_tactic t)
-  | VernacVar _ -> xlate_error "Grammar vernac obsolete"
   | (VernacGlobalCheck _|VernacPrintOption _|
      VernacMemOption (_, _)|VernacRemoveOption (_, _)
   | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _|
     VernacSolveExistential (_, _)|VernacCanonical _ |
-     VernacTacticNotation _)
-    -> xlate_error "TODO: vernac";;
+     VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _)
+    -> xlate_error "TODO: vernac"
+and level_to_ct_LEVEL = function
+    Conv_oracle.Opaque -> CT_Opaque
+  | Conv_oracle.Level n -> CT_Level (CT_int n)
+  | Conv_oracle.Expand -> CT_Expand;;
+
 
 let rec xlate_vernac_list =
  function
diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli
index bedb4ac8..2e2b95fe 100644
--- a/contrib/interface/xlate.mli
+++ b/contrib/interface/xlate.mli
@@ -6,4 +6,3 @@ val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;;
 val xlate_ident : Names.identifier -> ct_ID;;
 val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;;
 
-val declare_in_coq : (unit -> unit);;
diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml
index a2a72676..a9ebe5b6 100644
--- a/contrib/jprover/jall.ml
+++ b/contrib/jprover/jall.ml
@@ -31,23 +31,6 @@
  * Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
  *)
 
-(*: All of Huang's modifications of this file are quoted or denoted
-    by comments followed by a colon.
-:*)
-
-(*:
-open Mp_debug
-
-open Refiner.Refiner
-open Term
-open TermType
-open TermOp
-open TermSubst
-open TermMan
-open RefineError
-open Opname
-:*)
-
 open Jterm
 open Opname
 open Jlogic
@@ -55,10 +38,6 @@ open Jtunify
 
 let ruletable = Jlogic.ruletable
 
-(*:
-let free_var_op = make_opname ["free_variable";"Jprover"]
-let jprover_op = make_opname ["string";"Jprover"]
-:*)
 let free_var_op = make_opname ["free_variable"; "Jprover"]
 let jprover_op = make_opname ["jprover"; "string"]
 
@@ -1308,23 +1287,6 @@ struct
 (* append renamed paramater "r" to non-quantifier subformulae
    of renamed quantifier formulae *)
 
-(*: BUG :*)
-(*:
-   let make_new_eigenvariable term =
-      let op = (dest_term term).term_op in
-      let opn = (dest_op op).op_name in
-      let opnam = dest_opname opn in
-      match opnam with
-         [] ->
-            raise jprover_bug
-       | ofirst::orest ->
-            let ofname = List.hd orest in
-            let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in
-            eigen_counter := !eigen_counter + 1;
-(*        print_endline ("New Counter :"^(string_of_int (!eigen_counter))); *)
-            mk_string_term jprover_op new_eigen_var
-:*)
-
    let make_new_eigenvariable term =
       let op = (dest_term term).term_op in
       let opa = (dest_op op).op_params in
@@ -2485,30 +2447,6 @@ struct
          let dbt = dest_bterm bt in
          (dbt.bterm)::(collect_subterms r)
 
-   (*: Bug! :*)
-(*:   let rec collect_delta_terms = function
-      [] -> []
-    | t::r ->
-         let dt = dest_term t in
-         let top = dt.term_op
-         and tterms = dt.term_terms in
-         let dop = dest_op top in
-         let don = dest_opname dop.op_name in
-         match don with
-            [] ->
-               let sub_terms = collect_subterms tterms in
-               collect_delta_terms (sub_terms @ r)
-          | op1::opr ->
-               if op1 = "jprover" then
-                  match opr with
-                     [] -> raise (Invalid_argument "Jprover: delta position missing")
-                   | delta::_ ->
-                        delta::(collect_delta_terms r)
-               else
-                  let sub_terms = collect_subterms tterms in
-                  collect_delta_terms (sub_terms @ r)
-:*)
-
   let rec collect_delta_terms = function
       [] -> []
     | t::r ->
@@ -3219,23 +3157,7 @@ struct
        | (v,termlist)::r ->
             let dterms = collect_delta_terms termlist in
             begin
-(*:               print_stringlist dterms;
-               mbreak "add_sigmaQ:1\n";
-               Format.open_box 0;
-               print_endline " ";
-               print_endline "sigmaQ: ";
-               print_string (v^" = ");
-               print_term_list termlist;
-               Format.force_newline ();
-               print_stringlist dterms;
-               Format.force_newline ();
-               Format.print_flush ();
-               mbreak "add_sigmaQ:2\n";
-:*)
                let new_ordering = add_arrowsQ  v dterms ordering in
-(*:               print_ordering new_ordering;
-               mbreak "add_sigmaQ:3\n";
-:*)
                let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in
                    ((v,dterms)::rest_pairs),rest_ordering
             end
@@ -3303,7 +3225,6 @@ struct
    let jqunify term1 term2 sigmaQ =
       let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in
       try
-(*:         let tauQ = unify_mm app_term1 app_term2 String_set.StringSet.empty in :*)
          let tauQ = unify_mm app_term1 app_term2 StringSet.empty in
          let (mult,oel) = multiply sigmaQ tauQ in
          (mult,oel)
@@ -3740,19 +3661,7 @@ let rec subst_replace subst_list t =
       [] -> t
     | (old_t,new_t)::r ->
          let inter_term = var_subst t  old_t "dummy"  in
-(*:         print_string "(";
-         print_term stdout old_t;
-         print_string " --> ";
-         print_term stdout new_t;
-         print_string ")\n";
-         print_term stdout t;
-         print_newline ();
-         print_term stdout inter_term;
-         print_newline ();     :*)
          let new_term = subst1 inter_term "dummy" new_t in
-(*:         print_term stdout new_term;
-         print_newline ();
-         mbreak "\n+++========-----    ---------..........\n";  :*)
          subst_replace r new_term
 
 let rename_pos x m =
@@ -3950,10 +3859,6 @@ exception Failed_connections
 let path_checker atom_rel atom_sets qprefixes init_ordering logic =
 
    let con = connections atom_rel [] in
-(*:   print_endline "";
-   print_endline ("number of connections: "^(string_of_int (List.length con)));
-   mbreak "#connec\n";
-:*)
    let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) =
 
       let rec check_connections (reduction_partners,extension_partners) ext_atom =
@@ -4470,7 +4375,6 @@ let rec create_output rule_list input_map =
          and new_term2 = apply_var_subst next_term2 var_mapping
          and (a,b) = pos
          in
-(*:         print_string (a^"+++"^b^"\n");  :*)
 
 (* kick away the first argument, the position *)
          (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule)
@@ -4514,8 +4418,6 @@ let rec make_test_interface rule_list input_map =
 
 (**************************************************************)
 
-(*: modified for Coq :*)
-
 let decomp_pos pos =
     let {name=n; address=a; label=l} = pos in
       (n,(a,l))
@@ -4590,8 +4492,6 @@ let gen_prover mult_limit logic calculus hyps concls =
      (* from the LJmc to the LJ proof *)
      create_coq_input (create_output sequent_proof input_map) idl
 
-(*: end of coq modification :*)
-
 let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl]
 
 (************* test with propositional proof reconstruction ************)
@@ -4658,7 +4558,6 @@ let do_prove mult_limit termlist logic calculus =
       print_endline "";
       print_endline "";
       Format.print_flush ();
-(*:      let _ = input_char stdin in :*)
       let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in
       let sequent_proof = make_test_interface reconstr_proof input_map in
       Format.open_box 0;
@@ -4676,7 +4575,7 @@ let do_prove mult_limit termlist logic calculus =
       Format.force_newline ();
       Format.force_newline ();
       Format.print_flush ();
-      tt ptree;     (*: print proof tree :*)
+      tt ptree;
       Format.print_flush ();
       print_endline "";
       print_endline ""
diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4
index 294943f7..5fd763c3 100644
--- a/contrib/jprover/jprover.ml4
+++ b/contrib/jprover/jprover.ml4
@@ -410,7 +410,7 @@ i*)
      | Negl -> dyn_negl s1
      | Allr -> dyn_allr (JT.dest_var t2)
      | Alll -> dyn_alll s1 s2 (constr_of_jterm t2)
-     | Exr  -> dyn_exr (constr_of_jterm t2)
+     | Exr  -> dyn_exr (Tactics.inj_open (constr_of_jterm t2))
      | Exl  -> dyn_exl s1 s2 (JT.dest_var t2)
      | Ax -> T.assumption (*i TCL.tclIDTAC i*)
      | Truer -> dyn_truer
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v
new file mode 100644
index 00000000..93b4d213
--- /dev/null
+++ b/contrib/micromega/CheckerMaker.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Decidable.
+Require Import List.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Section CheckerMaker.
+
+(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
+Variable Formula : Type.
+
+Variable Env : Type.
+
+Variable eval : Env -> Formula -> Prop.
+
+Variable Formula' : Type.
+
+Variable eval' : Env -> Formula' -> Prop.
+
+Variable normalise : Formula -> Formula'.
+
+Variable negate : Formula -> Formula'.
+
+Hypothesis normalise_sound :
+  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
+
+Hypothesis negate_correct :
+  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
+
+Variable Witness : Type.
+
+Variable check_formulas' : list Formula' -> Witness -> bool.
+
+Hypothesis check_formulas'_sound :
+  forall (l : list Formula') (w : Witness),
+    check_formulas' l w = true ->
+      forall env : Env, make_impl (eval' env) l False.
+
+Definition normalise_list : list Formula -> list Formula' := map normalise.
+Definition negate_list : list Formula -> list Formula' := map negate.
+
+Definition check_formulas (l : list Formula) (w : Witness) : bool :=
+  check_formulas' (map normalise l) w.
+
+(* Contraposition of normalise_sound for lists *)
+Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
+  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
+Proof.
+intros env l; induction l as [| t l IH]; simpl in *.
+trivial.
+intros H1 H2. apply IH. apply H1. now apply normalise_sound.
+Qed.
+
+Theorem check_formulas_sound :
+  forall (l : list Formula) (w : Witness),
+    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
+Proof.
+unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
+pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
+intro H1. apply normalise_sound in H1.
+pose proof (check_formulas'_sound H env) as H2; simpl in H2.
+apply H2 in H1. now apply normalise_sound_contr.
+Qed.
+
+(* In check_conj_formulas', t2 is supposed to be a list of negations of
+formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
+check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
+inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
+A1 /\ A2 -> B1 /\ B2. *)
+
+Fixpoint check_conj_formulas'
+  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
+match t2 with
+| nil => true
+| t':: rt2 =>
+  match wits with
+  | nil => false
+  | w :: rwits =>
+    match check_formulas' (t':: t1) w with
+    | true => check_conj_formulas' t1 rwits rt2
+    | false => false
+    end
+  end
+end.
+
+(* checks whether the conjunction of t1 implies the conjunction of t2 *)
+
+Definition check_conj_formulas
+  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
+    check_conj_formulas' (normalise_list t1) wits (negate_list t2).
+
+Theorem check_conj_formulas_sound :
+  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
+    check_conj_formulas t1 wits t2 = true ->
+      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
+Proof.
+intro t1; induction t2 as [| a2 t2' IH].
+intros; apply make_impl_true.
+intros wits H env.
+unfold check_conj_formulas in H; simpl in H.
+destruct wits as [| w ws]; simpl in H. discriminate.
+case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
+intro H1; rewrite H1 in H; [| discriminate].
+assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
+now apply check_formulas'_sound with (w := w). clear H1.
+pose proof (IH ws H env) as H1. simpl in H2.
+assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
+by auto using normalise_sound_contr. clear H2.
+rewrite <- make_conj_impl in *.
+rewrite make_conj_cons. intro H2. split.
+apply <- negate_correct. intro; now elim H3. exact (H1 H2).
+Qed.
+
+End CheckerMaker.
diff --git a/contrib/micromega/Env.v b/contrib/micromega/Env.v
new file mode 100644
index 00000000..40db9e46
--- /dev/null
+++ b/contrib/micromega/Env.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZArith.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) 
+   -- this is harmless and spares a lot of Empty.
+   This means smaller proof-terms. 
+   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
+*)
+
+Section S.
+
+  Variable D :Type.
+
+  Definition Env := positive -> D.
+
+  Definition jump  (j:positive) (e:Env) := fun x => e (Pplus x j).
+
+  Definition nth  (n:positive) (e : Env ) := e n.
+
+  Definition hd (x:D)  (e: Env)  := nth xH e.
+
+  Definition tail (e: Env) := jump xH e.
+
+  Lemma psucc : forall p,  (match p with
+                              | xI y' => xO (Psucc y')
+                              | xO y' => xI y'
+                              | 1%positive => 2%positive 
+                            end) = (p+1)%positive.
+  Proof.
+    destruct p.
+    auto with zarith.
+    rewrite xI_succ_xO.
+    auto with zarith.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Pplus : forall i j l, 
+    forall x, jump (i + j) l x = jump i (jump j l) x.
+  Proof.
+    unfold jump.
+    intros.
+    rewrite Pplus_assoc.
+    reflexivity.
+  Qed.
+
+  Lemma jump_simpl : forall p l,
+    forall x, jump p l x = 
+    match p with
+      | xH => tail l x
+      | xO p => jump p (jump p l) x
+      | xI p  => jump p (jump p (tail l)) x
+    end.
+  Proof.
+    destruct p ; unfold tail ; intros ;  repeat rewrite <- jump_Pplus.
+    (* xI p = p + p + 1 *)
+    rewrite xI_succ_xO.
+    rewrite Pplus_diag.
+    rewrite <- Pplus_one_succ_r.
+    reflexivity.
+    (* xO p = p + p *)
+    rewrite Pplus_diag.
+    reflexivity.
+    reflexivity.
+  Qed.
+
+  Ltac jump_s :=
+    repeat 
+      match goal with
+        | |- context [jump xH ?e] => rewrite (jump_simpl xH)
+        | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
+        | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
+      end.
+    
+  Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
+  Proof. 
+    unfold tail.
+    intros.
+    repeat rewrite <- jump_Pplus.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Psucc : forall j l, 
+    forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
+  Proof.
+    intros.
+    rewrite <- jump_Pplus.
+    rewrite Pplus_one_succ_r.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Pdouble_minus_one : forall i l,
+    forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
+  Proof.
+    unfold tail.
+    intros.
+    repeat rewrite <- jump_Pplus.
+    rewrite <- Pplus_one_succ_r.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    rewrite Pplus_diag.
+    reflexivity.
+  Qed.
+
+  Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
+  Proof.
+    intros.
+    unfold jump.
+    unfold tail.
+    unfold jump.
+    rewrite <- Pplus_assoc.
+    simpl.
+    reflexivity.
+  Qed.
+
+  Lemma nth_spec : forall p l x, 
+    nth p l = 
+    match p with
+      | xH => hd x l
+      | xO p => nth p (jump p l)
+      | xI p => nth p (jump p (tail l))
+    end. 
+  Proof.
+    unfold nth.
+    destruct p.
+    intros.
+    unfold jump, tail.
+    unfold jump.
+    rewrite Pplus_diag.
+    rewrite xI_succ_xO.
+    simpl.
+    reflexivity.
+    unfold jump.
+    rewrite Pplus_diag.
+    reflexivity.
+    unfold hd.
+    unfold nth.
+    reflexivity.
+  Qed.
+
+
+  Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
+  Proof.
+    unfold tail.
+    unfold hd.
+    unfold jump.
+    unfold nth.
+    intros.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma nth_Pdouble_minus_one :
+    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+  Proof.
+    intros.
+    unfold tail.
+    unfold nth, jump.
+    rewrite Pplus_diag.
+    rewrite <- Psucc_o_double_minus_one_eq_xO.
+    rewrite Pplus_one_succ_r.
+    reflexivity.
+  Qed.
+
+End S.
+
diff --git a/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v
new file mode 100644
index 00000000..04e68272
--- /dev/null
+++ b/contrib/micromega/EnvRing.v
@@ -0,0 +1,1403 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(* F. Besson: to evaluate polynomials, the original code is using a list.
+   For big polynomials, this is inefficient -- linear access.
+   I have modified the code to use binary trees -- logarithmic access.  *)
+
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import Env.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+
+ (* Ring elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                                cO cI cadd cmul csub copp ceqb phi.
+
+  (* 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.
+ Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)		
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Usefull tactics *)		
+  Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+    Type [Pol] represents [X1 ... Xn].
+    The representation is Horner's where a [n] variable polynomial
+    (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+    are polynomials with [n-1] variables (C[X2..Xn]).
+    There are several optimisations to make the repr compacter:
+    - [Pc c] is the constant polynomial of value c
+       == c*X1^0*..*Xn^0
+    - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+        variable indices are shifted of j in Q.
+       == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+    - [PX P i Q] is an optimised Horner form of P*X^i + Q
+        with P not the null polynomial
+       == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+    In addition:
+    - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+      since they can be represented by the simpler form (PX P (i+j) Q)
+    - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+    - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+  | Pc : C -> Pol
+  | Pinj : positive -> Pol -> Pol
+  | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+  match P, P' with
+  | Pc c, Pc c' => c ?=! c'
+  | Pinj j Q, Pinj j' Q' =>
+    match Pcompare j j' Eq with
+    | Eq => Peq Q Q'
+    | _ => false
+    end
+  | PX P i Q, PX P' i' Q' =>
+    match Pcompare i i' Eq with
+    | Eq => if Peq P P' then Peq Q Q' else false
+    | _ => false
+    end
+  | _, _ => false
+  end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+  match P with
+  | Pc _ => P
+  | Pinj j' Q => Pinj ((j + j'):positive) Q
+  | _ => 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 *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+  match P with
+  | Pc c => Pc (-! c)
+  | Pinj j Q => Pinj j (Popp Q)
+  | PX P i Q => PX (Popp P) i (Popp Q)
+  end.
+
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 +! c)
+  | Pinj j Q => Pinj j (PaddC Q c)
+  | PX P i Q => PX P i (PaddC Q c)
+  end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 -! c)
+  | Pinj j Q => Pinj j (PsubC Q c)
+  | PX P i Q => PX P i (PsubC Q c)
+  end.
+
+ Section PopI.
+
+  Variable Pop : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+
+  Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC Q c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PaddI k Q')
+     end
+   | PX P i Q' =>
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PaddI (xO j) Q')
+     end
+   end.
+
+  Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC (--Q) c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PsubI k Q')
+     end
+   | PX P i Q' =>
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PsubI (xO j) Q')
+     end
+   end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX P' i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX P' i' Q'
+    | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX P' i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PaddX k P) i Q'
+    end
+  end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX (--P') i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX (--P') i' Q'
+    | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX (--P') i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PsubX k P) i Q'
+    end
+  end.
+
+
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PaddC P c'
+  | Pinj j' Q' => PaddI Padd Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX P' i' (PaddC Q' c)
+    | Pinj j Q =>
+      match j with
+      | xH => PX P' i' (Padd Q Q')
+      | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+      | Z0 => mkPX (Padd P P') i (Padd Q Q')
+      | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+      end
+    end
+  end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PsubC P c'
+  | Pinj j' Q' => PsubI Psub Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+    | Pinj j Q =>
+      match j with
+      | xH => PX (--P') i' (Psub Q Q')
+      | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+      | Z0 => mkPX (Psub P P') i (Psub Q Q')
+      | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+      end
+    end
+  end.
+ Notation "P -- P'" := (Psub P P').
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c' => Pc (c' *! c)
+  | Pinj j Q => mkPinj j (PmulC_aux Q c)
+  | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+  end.
+
+ Definition PmulC P c :=
+  if c ?=! cO then P0 else
+  if c ?=! cI then P else PmulC_aux P c.
+
+ Section PmulI.
+  Variable Pmul : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+  Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PmulC Q c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pmul Q' Q)
+     | Zneg k => mkPinj j' (PmulI k Q')
+     end
+   | PX P' i' Q' =>
+     match j with
+     | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+     | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+     | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+     end
+   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'
+  | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+  | PX P' i' Q' =>
+     (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+  end.
+
+ Definition Pmul P P' :=
+  match P with
+  | Pc c => PmulC P' c
+  | Pinj j Q => PmulI Pmul_aux Q j P'
+  | PX P i Q =>
+    (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 **)
+
+  Inductive Mon: Set :=
+    mon0: Mon
+  | zmon: positive -> Mon -> Mon
+  | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:Env 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_pos rmul x i in
+    (Mphi (tail l) M1) * xi
+  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)
+   | Pc _, _    => (P, Pc cO)
+   | Pinj j1 P1, zmon j2 M1 =>
+      match (j1 ?= j2) Eq with
+        Eq => let (R,S) := MFactor P1 M1 in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Gt => (P, Pc cO)
+      end
+  | Pinj _ _, vmon _ _ => (P, Pc cO)
+  | PX P1 i Q1, zmon j M1 =>
+             let M2 := zmon_pred j M1 in
+             let (R1, S1) := MFactor P1 M in
+             let (R2, S2) := MFactor Q1 M2 in
+               (mkPX R1 i R2, mkPX S1 i S2)
+  | PX P1 i Q1, vmon j M1 =>
+      match (i ?= j) Eq with
+        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, S1)
+      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+                 (mkPX R1 i Q1, S1)
+      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+      end
+   end.
+
+  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+    let (Q1,R1) := MFactor P1 M1 in
+    match R1 with
+     (Pc c) => if c ?=! cO then None
+               else Some (Padd Q1 (Pmul P2 R1))
+    | _ => Some (Padd Q1 (Pmul P2 R1))
+    end.
+
+  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+    match POneSubst P1 M1 P2 with
+     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+    | _ => P1
+    end.
+
+  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+    match POneSubst P1 M1 P2 with
+     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+    | _ => None
+    end.
+
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
+     Pol :=
+    match LM1 with
+     cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+    | _ => P1
+    end.
+
+  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+    match LM1 with
+     cons (M1,P2) LM2 =>
+      match PNSubst P1 M1 P2 n with
+        Some P3 => Some (PSubstL1 P3 LM2 n)
+     |  None => PSubstL P1 LM2 n
+     end
+    | _ => None
+    end.
+
+  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+    match PSubstL P1 LM1 n with
+     Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+    | _ => P1
+    end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
+  match P with
+  | Pc c => [c]
+  | Pinj j Q => Pphi (jump j l) Q
+  | PX P i Q =>
+     let x := hd 0 l in
+     let xi := pow_pos rmul x i in
+    (Pphi l P) * xi + (Pphi (tail l) Q)
+  end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+ (** Proofs *)
+ Lemma ZPminus_spec : forall x y,
+  match ZPminus x y with
+  | Z0 => x = y
+  | Zpos k => x = (y + k)%positive
+  | Zneg k => y = (x + k)%positive
+  end.
+ Proof.
+  induction x;destruct y.
+  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  simpl;trivial.
+  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+  replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  simpl;trivial.
+ Qed.
+
+ Lemma Peq_ok : forall P P',
+    (P ?== P') = true -> forall l, P@l == P'@ l.
+ Proof.
+  induction P;destruct P';simpl;intros;try discriminate;trivial.
+  apply (morph_eq CRmorph);trivial.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite H1;trivial. clear H1.
+  assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+   destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+                         |discriminate H].
+  rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+  intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> 
+ p @ e1 = p @ e2.
+Proof.
+  induction p ; simpl.
+  reflexivity.
+  intros.
+  apply IHp.
+  intros.
+  unfold jump.
+  apply H.
+  intros.
+  rewrite (IHp1 e1 e2) ; auto.
+  rewrite (IHp2 (tail e1) (tail e2)) ; auto.
+  unfold hd. unfold nth.  rewrite H.  reflexivity.
+  unfold tail.  unfold jump. intros ; apply H.
+Qed.
+
+Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
+Proof.
+  intros. apply env_morph. intros. rewrite <- jump_Pplus.
+  rewrite Pplus_comm.
+  reflexivity.
+Qed.
+
+Lemma Pjump_xO_tail : forall P p l, 
+  P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
+Proof.
+  intros.
+  apply env_morph.
+  intros.
+  rewrite (@jump_simpl R (xI p)).
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Pjump_Pdouble_minus_one : forall P p l,
+  P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
+Proof.
+  intros.
+  apply env_morph.
+  intros.
+  rewrite jump_Pdouble_minus_one.
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+
+
+ Lemma Pphi1 : forall l,  P1@l == 1.
+ Proof.
+  intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+  intros j l p;destruct p;simpl;rsimpl.
+  rewrite Pjump_Pplus.
+  reflexivity.
+ 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_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+  intros l P i Q;unfold mkPX.
+  destruct P;try (simpl;rrefl).
+  assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+  rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+  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_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Ltac Esimpl :=
+  repeat (progress (
+   match goal with
+   | |- context [P0@?l] => rewrite (Pphi0 l)
+   | |- context [P1@?l] => rewrite (Pphi1 l)
+   | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
+   | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
+   | |- context [[cO]] => rewrite (morph0 CRmorph)
+   | |- context [[cI]] => rewrite (morph1 CRmorph)
+   | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
+   | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
+   | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
+   | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+   end));
+  rsimpl; simpl.
+
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  rewrite IHP;rsimpl.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+  mul_push ([c]);rrefl.
+ Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+  intros c P l; unfold PmulC.
+  assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+  rewrite (H (refl_equal true));Esimpl.
+  assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+  rewrite (H1 (refl_equal true));Esimpl.
+  apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  apply IHP.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+  Esimpl;
+  repeat (progress (
+   match goal with
+   | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+   | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+   end)); Esimpl.
+
+
+
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rrefl.
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite Pjump_Pplus. rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite Pjump_Pplus. rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl. rsimpl.
+  rewrite Pjump_xO_tail. Esimpl.
+  rewrite IHP2;simpl.
+  rewrite Pjump_Pdouble_minus_one.
+  rsimpl.
+  rewrite IHP'.
+  rsimpl.
+  destruct P;simpl.
+  Esimpl2;add_push [c];rrefl.
+  destruct p0;simpl;Esimpl2.
+  rewrite IHP'2;simpl.
+  rewrite Pjump_xO_tail.
+  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;simpl.
+  rewrite Pjump_Pdouble_minus_one. rsimpl.
+  add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;rsimpl.
+  unfold tail.
+  add_push (P @ (jump 1 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_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_pos rmul (hd 0 l) k).
+   induction P;simpl;intros;try apply (ARadd_comm ARth).
+   destruct p2; simpl; try apply (ARadd_comm ARth).
+   rewrite Pjump_xO_tail.
+   apply (ARadd_comm ARth).   
+   rewrite Pjump_Pdouble_minus_one.
+   apply (ARadd_comm ARth).   
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP'1;simpl;Esimpl.
+    rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    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_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2;trivial.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rsimpl.
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl; try   rewrite Pjump_xO_tail ; rsimpl.
+  rewrite IHP2;simpl.
+  rewrite Pjump_Pdouble_minus_one;rsimpl.
+  unfold tail ; rsimpl.
+  rewrite IHP';rsimpl.
+  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_pos rmul (hd 0 l) p));trivial.
+  rewrite Pjump_xO_tail.
+  add_push (P @ ((jump (xI p0) l)));rrefl.  
+  rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
+  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
+  unfold tail.
+  rewrite IHP'2;rsimpl;add_push (P @ (jump 1 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_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_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.
+   rewrite Pjump_xO_tail.
+   apply (ARadd_comm ARth);trivial.
+   rewrite Pjump_Pdouble_minus_one.
+   apply (ARadd_comm ARth);trivial.
+   apply (ARadd_comm ARth);trivial.
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+    rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    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_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetric version *)
+
+ Lemma PmulI_ok :
+  forall P',
+   (forall (P : Pol) (l : Env  R), (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : Env 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 Pjump_Pplus;simpl;rrefl.
+  rewrite H1.
+  rewrite Pjump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+  rewrite Pjump_xO_tail.
+  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 Pjump_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) ->
+   forall (P : Pol) (p : positive) (l : list R),
+    (PmulI Pmul_aux 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 Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+  induction P';simpl;intros.
+  Esimpl2;trivial.
+  apply PmulI_ok;trivial.
+  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;rewrite IHP'2;Esimpl.
+   rewrite Pjump_xO_tail. reflexivity.
+   rewrite Pjump_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.
+   unfold tail.
+   mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 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)).
+  apply (ARmul_comm ARth).
+  rewrite Padd_ok; Esimpl2.
+  rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+  rewrite Pmul_aux_ok;mul_push (P' @ l).
+  rewrite (ARmul_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 Mphi_morph : forall P env env', (forall x, env x = env' x ) -> 
+   Mphi env P = Mphi env' P.
+ Proof.
+   induction P ; simpl.
+   reflexivity.
+   intros.
+   apply IHP.
+   intros.
+   unfold jump.
+   apply H.
+   (**)
+   intros.
+   replace (Mphi (tail env) P) with (Mphi (tail env') P).
+   unfold hd. unfold nth.
+   rewrite H.
+   reflexivity.
+   apply IHP.
+   unfold tail,jump.
+   intros. symmetry. apply H.
+ Qed.
+
+Lemma Mjump_xO_tail : forall M p l, 
+  Mphi  (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
+Proof.
+  intros.
+  apply Mphi_morph.
+  intros.
+  rewrite (@jump_simpl R (xI p)).
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Mjump_Pdouble_minus_one : forall M p l,
+  Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
+Proof.
+  intros.
+  apply Mphi_morph.
+  intros.
+  rewrite jump_Pdouble_minus_one.
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
+Proof.
+  intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
+  rewrite Pplus_comm.
+  reflexivity.
+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 l; rsimpl.
+   rewrite mkZmon_ok;rsimpl.
+   simpl.
+   rewrite Mjump_xO_tail.
+   reflexivity.
+   rewrite mkZmon_ok;simpl.
+   rewrite Mjump_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
+      P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+   intros c M l; case M; simpl; auto; try intro p; try intro m;
+   try rewrite (morph0 CRmorph); rsimpl.
+
+   intros i P Hrec M l; case M; simpl; clear M.
+     rewrite (morph0 CRmorph); rsimpl.
+     intros j M.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec M (jump j l)); case (MFactor P M);
+        simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       generalize (Hrec (zmon (j -i) M) (jump i l));
+       case (MFactor P (zmon (j -i) M)); simpl.
+       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
+       rewrite Mjump_Pplus; auto.
+       rewrite (morph0 CRmorph); rsimpl.
+       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+   rewrite (morph0 CRmorph); rsimpl.
+   intros j M1.
+     generalize (Hrec1 (zmon j M1) l);
+     case (MFactor P2 (zmon j M1)).
+     intros R1 S1 H1.
+     generalize (Hrec2 (zmon_pred j M1) (tail l));
+     case (MFactor Q2 (zmon_pred j M1)); simpl.
+     intros R2 S2 H2; rewrite H1; rewrite H2.
+     repeat rewrite mkPX_ok; simpl.
+     rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     rewrite zmon_pred_ok;rsimpl.
+   intros j M1.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite mkZmon_ok.
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       generalize (Hrec1 (vmon (j - i) M1) l);
+             case (MFactor P2 (vmon (j - i) M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_pos_Pplus.
+       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+       generalize (Hrec1 (mkZmon 1 M1) l);
+             case (MFactor P2 (mkZmon 1 M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       rewrite mkZmon_ok.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       rewrite mkPX_ok; simpl; rsimpl.
+       rewrite (morph0 CRmorph); rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_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.
+   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.
+ (* 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 PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. 
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   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.
+ intros n; elim n; simpl; auto.
+   intros P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate).
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
+    match LM1 with
+     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+    | _ => True
+    end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+   rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ Inductive PExpr : Type :=
+  | PEc : C -> PExpr
+  | PEX : positive -> PExpr
+  | PEadd : PExpr -> PExpr -> PExpr
+  | PEsub : PExpr -> PExpr -> PExpr
+  | PEmul : PExpr -> PExpr -> PExpr
+  | PEopp : PExpr -> PExpr
+  | PEpow : PExpr -> N -> PExpr.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
+   match pe with
+   | PEc c => phi c
+   | PEX j => nth 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  p l == (mk_X p) @ l.
+ Proof.
+  destruct p;simpl;intros;Esimpl;trivial.
+  rewrite nth_spec ; auto.
+  unfold hd.
+  rewrite <- nth_Pdouble_minus_one.
+  rewrite (nth_jump (Pdouble_minus_one p) l 1).
+  reflexivity.
+ 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)
+  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.  auto. 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.
+
+  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 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 by reflexivity. 
+   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.
+
+
+ End NORM_SUBST_REC.
+
+
+End MakeRingPol.
+
diff --git a/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos
new file mode 100644
index 00000000..5aadfa2a
--- /dev/null
+++ b/contrib/micromega/LICENSE.sos
@@ -0,0 +1,29 @@
+            HOL Light copyright notice, licence and disclaimer
+
+                     (c) University of Cambridge 1998
+                  (c) Copyright, John Harrison 1998-2006
+
+HOL Light version 2.20, hereinafter referred to as "the software", is a
+computer theorem proving system written by John Harrison. Much of the
+software was developed at the University of Cambridge Computer Laboratory,
+New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The
+software is copyright, University of Cambridge 1998 and John Harrison
+1998-2006.
+
+Permission to use, copy, modify, and distribute the software and its
+documentation for any purpose and without fee is hereby granted. In the
+case of further distribution of the software the present text, including
+copyright notice, licence and disclaimer of warranty, must be included in
+full and unmodified form in any release. Distribution of derivative
+software obtained by modifying the software, or incorporating it into
+other software, is permitted, provided the inclusion of the software is
+acknowledged and that any changes made to the software are clearly
+documented.
+
+John Harrison and the University of Cambridge disclaim all warranties
+with regard to the software, including all implied warranties of
+merchantability and fitness. In no event shall John Harrison or the
+University of Cambridge be liable for any special, indirect,
+incidental or consequential damages or any damages whatsoever,
+including, but not limited to, those arising from computer failure or
+malfunction, work stoppage, loss of profit or loss of contracts.
diff --git a/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v
new file mode 100644
index 00000000..a5ac92db
--- /dev/null
+++ b/contrib/micromega/MExtraction.v
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+(* Used to generate micromega.ml *)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import VarMap.
+Require Import RingMicromega.
+Require Import NArith.
+
+Extraction "micromega.ml"  List.map simpl_cone map_cone indexes  n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find.
diff --git a/contrib/micromega/Micromegatac.v b/contrib/micromega/Micromegatac.v
new file mode 100644
index 00000000..13c7eace
--- /dev/null
+++ b/contrib/micromega/Micromegatac.v
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import RMicromega.
+Require Import QArith.
+Require Export Ring_normalize.
+Require Import ZArith.
+Require Import Raxioms.
+Require Export RingMicromega.
+Require Import VarMap.
+Require Tauto.
+
+Ltac micromegac dom d :=
+  let tac := lazymatch dom with
+  | Z => 
+    micromegap d ;
+    intros __wit __varmap __ff ; 
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | R =>
+    rmicromegap d ;
+    intros __wit __varmap __ff ; 
+    change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; 
+    apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | _ => fail "Unsupported domain"
+  end in tac.
+
+Tactic Notation "micromega" constr(dom) int_or_var(n) := micromegac dom n.
+Tactic Notation "micromega" constr(dom) := micromegac dom ltac:-1.
+
+Ltac zfarkas :=  omicronp ;
+  intros __wit __varmap __ff ; 
+  change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+  apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+Ltac omicron dom :=
+  let tac := lazymatch dom with
+  | Z =>
+    zomicronp ;
+    intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | Q =>
+    qomicronp ; 
+    intros __wit __varmap __ff ; 
+    change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; 
+    apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | R => 
+    romicronp ;
+    intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; 
+    apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | _ => fail "Unsupported domain"
+  end in tac.
+
+Ltac sos dom :=
+  let tac := lazymatch dom with
+  | Z =>
+    sosp ;
+    intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
+    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | _ => fail "Unsupported domain"
+  end in tac.
+
+
diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v
new file mode 100644
index 00000000..149b7731
--- /dev/null
+++ b/contrib/micromega/OrderedRing.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Ring.
+
+(** Generic properties of ordered rings on a setoid equality *)
+
+Set Implicit Arguments.
+
+Module Import OrderedRingSyntax.
+Export RingSyntax.
+
+Reserved Notation "x ~= y" (at level 70, no associativity).
+Reserved Notation "x [=] y" (at level 70, no associativity).
+Reserved Notation "x [~=] y" (at level 70, no associativity).
+Reserved Notation "x [<] y" (at level 70, no associativity).
+Reserved Notation "x [<=] y" (at level 70, no associativity).
+End OrderedRingSyntax.
+
+Section DEFINITIONS.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Record SOR : Type := mk_SOR_theory {
+  SORsetoid : Setoid_Theory R req;
+  SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+  SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+  SORopp_wd : forall x1 x2, x1 == x2 ->  -x1 == -x2;
+  SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
+  SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
+  SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
+  SORle_refl : forall n : R, n <= n;
+  SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
+  SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
+  SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
+  SORlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n;
+  SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
+  SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
+  SORneq_0_1 : 0 ~= 1
+}.
+
+(* We cannot use Relation_Definitions.order.ord_antisym and
+Relations_1.Antisymmetric because they refer to Leibniz equality *)
+
+End DEFINITIONS.
+
+Section STRICT_ORDERED_RING.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as sor_setoid.
+
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+
+Add Ring SOR : sor.(SORrt).
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+intros x1 x2 H1 y1 y2 H2.
+rewrite (sor.(SORrt).(Rsub_def) x1 y1).
+rewrite (sor.(SORrt).(Rsub_def) x2 y2).
+rewrite H1; now rewrite H2.
+Qed.
+
+Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
+Proof.
+intros n m H1 H2; rewrite H2 in H1; now apply H1.
+Qed.
+
+(* Propeties of plus, minus and opp *)
+
+Theorem Rplus_0_l : forall n : R, 0 + n == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_0_r : forall n : R, n + 0 == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_comm : forall n m : R, n + m == m + n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_comm : forall n m : R, n * m == m * n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
+Proof.
+intros n m.
+split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. 
+now rewrite Rplus_0_l.
+rewrite H; ring.
+Qed.
+
+Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
+Proof.
+intros n m p; split; intro H.
+setoid_replace n with (- p + (p + n)) by ring.
+setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
+now rewrite H.
+Qed.
+
+(* Relations *)
+
+Theorem Rle_refl : forall n : R, n <= n.
+Proof sor.(SORle_refl).
+
+Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
+Proof sor.(SORle_antisymm).
+
+Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
+Proof sor.(SORle_trans).
+
+Theorem Rlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n.
+Proof sor.(SORlt_trichotomy).
+
+Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
+Proof sor.(SORlt_le_neq).
+
+Theorem Rneq_0_1 : 0 ~= 1.
+Proof sor.(SORneq_0_1).
+
+Theorem Req_em : forall n m : R, n == m \/ n ~= m.
+Proof.
+intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
+right; now destruct H.
+now left.
+right; apply Rneq_symm; now destruct H.
+Qed.
+
+Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
+Proof.
+intros n m; destruct (Req_em n m) as [H | H].
+split; auto.
+split. intro H1; false_hyp H H1. auto.
+Qed.
+
+Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
+Proof.
+intros n m; rewrite Rlt_le_neq.
+split; [intro H | intros [[H1 H2] | H]].
+destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
+assumption.
+rewrite H; apply Rle_refl.
+Qed.
+
+Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
+Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].
+
+Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
+Proof.
+intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
+now apply Rle_trans with m.
+intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
+Qed.
+
+Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H1.
+now apply Rlt_trans with (m := m). now rewrite H1.
+Qed.
+
+Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H2.
+now apply Rlt_trans with (m := m). now rewrite <- H2.
+Qed.
+
+Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
+Proof.
+intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
+left; now le_less. left; now le_equal. now right.
+Qed.
+
+Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
+Proof.
+intros n m; rewrite Rlt_le_neq; now intros [_ H].
+Qed.
+
+Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
+Qed.
+
+Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
+Qed.
+
+(* Plus, minus and order *)
+
+Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
+Proof.
+intros n m p; split.
+apply sor.(SORplus_le_mono_l).
+intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
+setoid_replace (- p + (p + n)) with n in H by ring.
+setoid_replace (- p + (p + m)) with m in H by ring. assumption.
+Qed.
+
+Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
+Proof.
+intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
+apply Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
+Proof.
+intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
+now rewrite <- Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
+Proof.
+intros n m p.
+rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
+Qed.
+
+Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
+Qed.
+
+Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
+Qed.
+
+Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
+Qed.
+
+Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
+Proof.
+intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
+Proof.
+intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
+Proof.
+intros n m. split; intro H.
+apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
+setoid_replace (- n - m + n) with (- m) in H by ring.
+now setoid_replace (- n - m + m) with (- n) in H by ring.
+apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
+setoid_replace (n + m + - m) with n in H by ring.
+now setoid_replace (n + m + - n) with m in H by ring.
+Qed.
+
+Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
+Proof.
+intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
+Qed.
+
+(* Times and order *)
+
+Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
+Proof sor.(SORtimes_pos_pos).
+
+Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
+Proof.
+intros n m H1 H2.
+le_elim H1. le_elim H2.
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H2; rewrite Rtimes_0_r; le_equal.
+rewrite <- H1; rewrite Rtimes_0_l; le_equal.
+Qed.
+
+Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
+Proof.
+intros n m H1 H2. apply -> Ropp_pos_neg.
+setoid_replace (- (n * m)) with (n * (- m)) by ring.
+apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
+Proof.
+intros n m H1 H2.
+setoid_replace (n * m) with ((- n) * (- m)) by ring.
+apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
+Proof.
+intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H, Rtimes_0_l; le_equal.
+le_less; now apply Rtimes_neg_neg.
+Qed.
+
+Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
+Proof.
+intros n m [H1 H2].
+destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
+destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
+try (false_hyp H3 H1); try (false_hyp H4 H2).
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
+apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
+apply Rlt_neq. now apply Rtimes_pos_neg.
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
+Qed.
+
+(* The following theorems are used to build a morphism from Z to R and
+prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)
+
+(* Surprisingly, multilication is needed to prove the following theorem *)
+
+Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
+Proof.
+intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
+now setoid_replace (- - n) with n by ring.
+Qed.
+
+Theorem Rlt_0_1 : 0 < 1.
+Proof.
+apply <- Rlt_le_neq. split.
+setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
+apply Rneq_0_1.
+Qed.
+
+Theorem Rlt_succ_r : forall n : R, n < 1 + n.
+Proof.
+intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
+apply -> Rplus_lt_mono_r. apply Rlt_0_1.
+Qed.
+
+Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
+Proof.
+intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
+Qed.
+
+(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
+Proof.
+intros n m p H1 H2. apply <- Rlt_lt_minus.
+setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
+apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
+Qed.*)
+
+End STRICT_ORDERED_RING.
+
diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v
new file mode 100644
index 00000000..9e95f6c4
--- /dev/null
+++ b/contrib/micromega/QMicromega.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import QArith.
+Require Import Qring.
+
+(* Qsrt has been removed from the library ? *)
+Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq.
+Proof.
+  constructor.
+  exact Qplus_0_l.
+  exact Qplus_comm.
+  exact Qplus_assoc.
+  exact Qmult_1_l.
+  exact Qmult_comm.
+  exact Qmult_assoc.
+  exact Qmult_plus_distr_l.
+  reflexivity.
+  exact Qplus_opp_r.
+Qed.
+
+
+Add Ring Qring : Qsrt.
+
+Lemma Qmult_neutral : forall x , 0 * x == 0.
+Proof.
+  intros.
+  compute.
+  reflexivity.
+Qed.
+
+(* Is there any qarith database ? *)
+
+Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq  Qle Qlt.
+Proof.
+  constructor; intros ; subst ; try (intuition (subst; auto  with qarith)).
+  apply Q_Setoid.
+  rewrite H ; rewrite H0 ; reflexivity.
+  rewrite H ; rewrite H0 ; reflexivity.
+  rewrite H ; auto ; reflexivity.
+  rewrite <- H ; rewrite <- H0 ; auto.
+  rewrite H ; rewrite H0 ; auto.
+  rewrite <- H ; rewrite <- H0 ; auto.
+  rewrite H ; rewrite  H0 ; auto.
+  apply Qsrt.
+  apply Qle_refl.
+  apply Qle_antisym ; auto.
+  eapply Qle_trans ; eauto.
+  apply Qlt_le_weak ; auto.
+  apply (Qlt_not_eq n m H H0) ; auto.
+  destruct (Qle_lt_or_eq _ _ H0) ; auto.
+  tauto.
+  destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
+  apply (Qplus_le_compat  p p n m  (Qle_refl p) H).
+  generalize (Qmult_lt_compat_r 0 n m H0 H).
+  rewrite Qmult_neutral.
+  auto.
+  compute in H.
+  discriminate.
+Qed.
+
+Definition Qeq_bool (p q : Q) : bool := Zeq_bool (Qnum p * ' Qden q)%Z  (Qnum q * ' Qden p)%Z.
+
+Definition Qle_bool (x y : Q) : bool := Zle_bool (Qnum x * ' Qden y)%Z (Qnum y * ' Qden x)%Z.
+
+Require ZMicromega.
+
+Lemma Qeq_bool_ok : forall x y, Qeq_bool x y = true -> x == y.
+Proof.
+  intros.
+  unfold Qeq_bool in H.
+  unfold Qeq.
+  apply (Zeqb_ok  _ _ H).
+Qed.
+
+
+Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y.
+Proof.
+  unfold Qeq_bool,Qeq.
+  red ; intros ; subst.
+  rewrite H0 in H.
+  apply  (ZMicromega.Zeq_bool_neq _ _ H).
+  reflexivity.
+Qed.
+
+Lemma Qle_bool_imp_le : forall x y : Q, Qle_bool x y = true -> x <= y.
+Proof.
+  unfold Qle_bool, Qle.
+  intros.
+  apply Zle_bool_imp_le ; auto.
+Qed.
+  
+
+
+
+Lemma QSORaddon :
+  SORaddon 0 1 Qplus Qmult Qminus Qopp  Qeq  Qle (* ring elements *)
+  0 1 Qplus Qmult Qminus Qopp (* coefficients *)
+  Qeq_bool Qle_bool
+  (fun x => x) (fun x => x) (pow_N 1 Qmult).
+Proof.
+  constructor.
+  constructor ; intros ; try reflexivity.
+  apply Qeq_bool_ok ; auto.
+  constructor.
+  reflexivity.
+  intros x y.
+  apply Qeq_bool_neq ; auto.
+  apply Qle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr :=  eval_pexpr 0 Zplus Zmult Zminus Zopp  (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+Require Import EnvRing.
+
+Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
+  match e with
+    | PEc c =>  c
+    | PEX j =>  env j
+    | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+    | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+    | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+    | PEopp pe1 => - (Qeval_expr env pe1)
+    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
+  end.
+
+Lemma Qeval_expr_simpl : forall env e,
+  Qeval_expr env e = 
+  match e with
+    | PEc c =>  c
+    | PEX j =>  env j
+    | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+    | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+    | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+    | PEopp pe1 => - (Qeval_expr env pe1)
+    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
+  end.
+Proof.
+  destruct e ; reflexivity.
+Qed.
+
+Definition Qeval_expr' := eval_pexpr  Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
+Proof.
+  destruct n ; reflexivity.
+Qed.
+
+
+Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
+Proof.
+  induction e ; simpl ; subst ; try congruence.
+  rewrite IHe.
+  apply QNpower.
+Qed.
+
+Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop :=
+match o with
+| OpEq =>  Qeq
+| OpNEq => fun x y  => ~ x == y
+| OpLe => Qle
+| OpGe => Qge
+| OpLt => Qlt
+| OpGt => Qgt
+end.
+
+Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) :=
+  let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs).
+
+Definition Qeval_formula' :=
+  eval_formula  Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f.
+Proof.
+  intros.
+  unfold Qeval_formula.
+  destruct f.
+  repeat rewrite Qeval_expr_compat.
+  unfold Qeval_formula'.
+  unfold Qeval_expr'.
+  split ; destruct Fop ; simpl; auto.
+Qed.
+
+
+
+Definition Qeval_nformula :=
+  eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Definition Qeval_op1 (o : Op1) : Q -> Prop :=
+match o with
+| Equal => fun x : Q => x == 0
+| NonEqual => fun x : Q => ~ x == 0
+| Strict => fun x : Q => 0 < x
+| NonStrict => fun x : Q => 0 <= x
+end.
+
+Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)).
+Proof.
+  intros.
+  destruct f.
+  rewrite Qeval_expr_compat.
+  reflexivity.
+Qed.
+  
+Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
+Proof.
+  exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d).
+Qed.
+
+Definition QWitness := ConeMember Q.
+
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+
+Require Import List.
+
+Lemma QWeakChecker_sound :   forall (l : list (NFormula Q)) (cm : QWitness),
+  QWeakChecker l cm = true ->
+  forall env, make_impl (Qeval_nformula env) l False.
+Proof.
+  intros l cm H.
+  intro.
+  unfold Qeval_nformula.
+  apply (checker_nf_sound Qsor QSORaddon l cm).
+  unfold QWeakChecker in H.
+  exact H.
+Qed.
+
+Require Import Tauto.
+
+Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
+  @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q)  QWitness QWeakChecker f w.
+
+Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f  (Qeval_formula env)  f.
+Proof.
+  intros f w.
+  unfold QTautoChecker.
+  apply (tauto_checker_sound  Qeval_formula Qeval_nformula).
+  apply Qeval_nformula_dec.
+  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor).
+  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor).
+  intros t w0.
+  apply QWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v
new file mode 100644
index 00000000..ef28db32
--- /dev/null
+++ b/contrib/micromega/RMicromega.v
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Setoid.
+
+Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
+Proof.
+  constructor.
+  exact Rplus_0_l.
+  exact Rplus_comm.
+  intros. rewrite Rplus_assoc. auto.
+  exact Rmult_1_l.
+  exact Rmult_comm.
+  intros ; rewrite Rmult_assoc ; auto.
+  intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
+   rewrite (Rmult_comm z).    rewrite (Rmult_comm z). auto.
+  reflexivity.
+  exact Rplus_opp_r.
+Qed.
+
+Add Ring Rring : Rsrt.
+Open Scope R_scope.
+
+Lemma Rmult_neutral : forall x:R , 0 * x = 0.
+Proof.
+  intro ; ring.
+Qed.
+
+
+Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R)  Rle Rlt.
+Proof.
+  constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
+  constructor.
+  constructor.
+  unfold RelationClasses.Symmetric. auto.
+  unfold RelationClasses.Transitive. intros. subst. reflexivity.
+  apply Rsrt.
+  eapply Rle_trans ; eauto.
+  apply (Rlt_irrefl m) ; auto.
+  apply Rnot_le_lt. auto with real.
+  destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
+  intros.
+  rewrite <- (Rmult_neutral m).
+  apply (Rmult_lt_compat_r) ; auto.
+Qed.
+
+Require ZMicromega.
+
+(* R with coeffs in Z *)
+
+Lemma RZSORaddon :
+  SORaddon R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
+  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+  Zeq_bool Zle_bool
+  IZR Nnat.nat_of_N pow.
+Proof.
+  constructor.
+  constructor ; intros ; try reflexivity.
+  apply plus_IZR.
+  symmetry. apply Z_R_minus.
+  apply mult_IZR.
+  apply Ropp_Ropp_IZR.
+  apply IZR_eq.
+  apply Zeqb_ok ; auto.
+  apply R_power_theory.
+  intros x y.
+  intro.
+  apply IZR_neq.
+  apply ZMicromega.Zeq_bool_neq ; auto.
+  intros. apply IZR_le.  apply Zle_bool_imp_le. auto.
+Qed.
+
+
+Require Import EnvRing.
+
+Definition INZ (n:N) : R :=
+  match n with
+    | N0 => IZR 0%Z
+    | Npos p => IZR (Zpos p)
+  end.
+
+Definition Reval_expr := eval_pexpr  Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_formula :=
+  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_nformula :=
+  eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
+Proof.
+  exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d).
+Qed.
+
+Definition RWitness := ConeMember Z.
+
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+
+Require Import List.
+
+Lemma RWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : RWitness),
+  RWeakChecker l cm = true ->
+  forall env, make_impl (Reval_nformula env) l False.
+Proof.
+  intros l cm H.
+  intro.
+  unfold Reval_nformula.
+  apply (checker_nf_sound Rsor RZSORaddon l cm).
+  unfold RWeakChecker in H.
+  exact H.
+Qed.
+
+Require Import Tauto.
+
+Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness)  : bool :=
+  @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z)  RWitness RWeakChecker f w.
+
+Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f  (Reval_formula env)  f.
+Proof.
+  intros f w.
+  unfold RTautoChecker.
+  apply (tauto_checker_sound  Reval_formula Reval_nformula).
+  apply Reval_nformula_dec.
+  intros. unfold Reval_formula. now apply (cnf_normalise_correct Rsor).
+  intros. unfold Reval_formula. now apply (cnf_negate_correct Rsor).
+  intros t w0.
+  apply RWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v
new file mode 100644
index 00000000..801d8b21
--- /dev/null
+++ b/contrib/micromega/Refl.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import List.
+Require Setoid.
+
+Set Implicit Arguments.
+
+(* Refl of '->' '/\': basic properties *)
+
+Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop :=
+  match l with
+    | nil => goal
+    | cons e l => (eval e) -> (make_impl eval l goal)
+  end.
+
+Theorem make_impl_true :
+  forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True.
+Proof.
+induction l as [| a l IH]; simpl.
+trivial.
+intro; apply IH.
+Qed.
+
+Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop :=
+  match l with
+    | nil => True
+    | cons e nil => (eval e)
+    | cons e l2 => ((eval e) /\ (make_conj eval l2))
+  end.
+
+Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A),
+  make_conj eval (a :: l) <-> eval a /\ make_conj eval l.
+Proof.
+intros; destruct l; simpl; tauto.
+Qed.
+
+
+Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop),
+  (make_conj eval l -> g) <-> make_impl eval l g.
+Proof.
+  induction l.
+  simpl.
+  tauto.
+  simpl.
+  intros.
+  destruct l.
+  simpl.
+  tauto.
+  generalize (IHl g).
+  tauto.
+Qed.
+
+Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A),
+  make_conj eval l -> (forall p, In p l -> eval p).
+Proof.
+  induction l.
+  simpl.
+  tauto.
+  simpl.
+  intros.
+  destruct l.
+  simpl in H0.
+  destruct H0.
+  subst; auto.
+  tauto.
+  destruct H.
+  destruct H0.
+  subst;auto.
+  apply IHl; auto.
+Qed.
+
+
+
+Lemma make_conj_app : forall  A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2.
+Proof.
+  induction l1.
+  simpl.
+  tauto.
+  intros.
+  change ((a::l1) ++ l2) with (a :: (l1 ++ l2)).
+  rewrite make_conj_cons.
+  rewrite IHl1.
+  rewrite make_conj_cons.
+  tauto.
+Qed.
+
+Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval  (no_middle_eval : (eval t) \/ ~ (eval  t)),
+  ~ make_conj  eval (t ::a) -> ~  (eval t) \/ (~ make_conj  eval a).
+Proof.
+  intros.
+  simpl in H.
+  destruct a.
+  tauto.
+  tauto.
+Qed.
+
+Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval
+  (no_middle_eval : forall d, eval d \/ ~ eval d) , 
+  ~ make_conj  eval (t ++ a) -> (~ make_conj  eval t) \/ (~ make_conj eval a).
+Proof.
+  induction t.
+  simpl.
+  tauto.
+  intros.
+  simpl ((a::t)++a0)in H.
+  destruct (@not_make_conj_cons _ _ _ _  (no_middle_eval a) H).
+  left ; red ; intros.
+  apply H0.
+  rewrite  make_conj_cons in H1.
+  tauto.
+  destruct (IHt _ _ no_middle_eval H0).
+  left ; red ; intros.
+  apply H1.
+  rewrite make_conj_cons in H2.
+  tauto.
+  right ; auto.
+Qed.
diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v
new file mode 100644
index 00000000..6885b82c
--- /dev/null
+++ b/contrib/micromega/RingMicromega.v
@@ -0,0 +1,779 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import NArith.
+Require Import Relation_Definitions.
+Require Import Setoid.
+(*****)
+Require Import Env.
+Require Import EnvRing.
+(*****)
+Require Import List.
+Require Import Bool.
+Require Import OrderedRing.
+Require Import Refl.
+
+
+Set Implicit Arguments.
+
+Import OrderedRingSyntax.
+
+Section Micromega.
+
+(* Assume we have a strict(ly?) ordered ring *)
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+(* Assume we have a type of coefficients C and a morphism from C to R *)
+
+Variable C : Type.
+Variables cO cI : C.
+Variables cplus ctimes cminus: C -> C -> C.
+Variable copp : C -> C.
+Variables ceqb cleb : C -> C -> bool.
+Variable phi : C -> R.
+
+(* Power coefficients *)
+Variable E : Set. (* the type of exponents *)
+Variable pow_phi : N -> E.
+Variable rpow : R -> E -> R.
+
+Notation "[ x ]" := (phi x).
+Notation "x [=] y" := (ceqb x y).
+Notation "x [<=] y" := (cleb x y).
+
+(* Let's collect all hypotheses in addition to the ordered ring axioms into
+one structure *)
+
+Record SORaddon := mk_SOR_addon {
+  SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
+  SORpower : power_theory rI rtimes req pow_phi rpow;
+  SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
+  SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
+}.
+
+Variable addon : SORaddon.
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as micomega_sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+  exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+  exact sor.(SORlt_wd).
+Qed.
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+  exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
+Qed.
+
+Definition cneqb (x y : C) := negb (ceqb x y).
+Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
+
+Notation "x [~=] y" := (cneqb x y).
+Notation "x [<] y" := (cltb x y).
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
+
+Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
+Proof.
+  exact addon.(SORcleb_morph).
+Qed.
+
+Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
+Proof.
+intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
+destruct (ceqb x y); now try discriminate.
+Qed.
+
+Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
+Proof.
+intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
+apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
+Qed.
+
+(* Begin Micromega *)
+
+Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *)
+Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+(*****)
+(*Definition Env := Env R. (* For interpreting PExprC *)*)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+(*****)
+(*Definition Env := list R.
+Definition PolEnv := list R.*)
+(*****)
+
+(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr
+explicitely below and not through PEeval, as the following lemma says? The
+function eval_pexpr seems to be a straightforward special case of PEeval
+when the environment (i.e., the second last argument of PEeval) of type
+off_map (which is (option positive * t)) is (None, env). *)
+
+(*****)
+Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R :=
+match pe with
+| PEc c => phi c
+| PEX j =>  l j
+| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+| PEopp pe1 => - (eval_pexpr l pe1)
+| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+end.
+
+
+Lemma eval_pexpr_simpl : forall  (l : PolEnv) (pe : PExprC),
+  eval_pexpr l pe = 
+  match pe with
+    | PEc c => phi c
+    | PEX j => l j
+    | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+    | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+    | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+    | PEopp pe1 => - (eval_pexpr l pe1)
+    | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+  end.
+Proof.
+  intros ; destruct pe ; reflexivity.
+Qed.
+
+
+
+Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC),
+  eval_pexpr env pe =
+  PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe.
+Proof.
+induction pe; simpl; intros.
+reflexivity.
+reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe; reflexivity.
+rewrite <- IHpe; reflexivity.
+Qed.
+(*****)
+(*Definition eval_pexpr : Env -> PExprC -> R :=
+  PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*)
+(*****)
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PExprC * Op1)%type. (* normalized formula *)
+
+Definition eval_op1 (o : Op1) : R -> Prop :=
+match o with
+| Equal => fun x => x == 0
+| NonEqual => fun x : R => x ~= 0
+| Strict => fun x : R => 0 < x
+| NonStrict => fun x : R => 0 <= x
+end.
+
+Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
+let (p, op) := f in eval_op1 op (eval_pexpr env p).
+
+
+Definition OpMult (o o' : Op1) : Op1 :=
+match o with
+| Equal => Equal
+| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *)
+| Strict => o'
+| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *)
+end.
+
+Definition OpAdd (o o': Op1) : Op1 :=
+match o with
+| Equal => o'
+| NonStrict =>
+  match o' with
+  | Strict => Strict
+  | _ => NonStrict
+  end
+| Strict => Strict
+| NonEqual => NonEqual (* does not matter what we return here *)
+end.
+
+Lemma OpMultNonEqual :
+  forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpAdd_NonEqual :
+  forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpMult_sound :
+  forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual ->
+    eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4.
+rewrite H3; now rewrite (Rtimes_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+rewrite H4; now rewrite (Rtimes_0_r sor).
+elimtype False; now apply H2.
+now apply (Rtimes_pos_pos sor).
+apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+destruct o'.
+rewrite H4, (Rtimes_0_r sor); le_equal.
+elimtype False; now apply H2.
+apply (Rtimes_nonneg_nonneg sor); [assumption | le_less].
+now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+  forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual ->
+    eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4.
+destruct o'.
+now rewrite H3, H4, (Rplus_0_l sor).
+elimtype False; now apply H2.
+now rewrite H3, (Rplus_0_l sor).
+now rewrite H3, (Rplus_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_pos_pos sor).
+now apply (Rplus_pos_nonneg sor).
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_nonneg_pos sor).
+now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+(* We consider a monoid whose generators are polynomials from the
+hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that
+every element of the monoid (i.e., arbitrary product of generators) is ~=
+0. Therefore, the square of every element is > 0. *)
+
+Inductive Monoid (l : list NFormula) : PExprC -> Prop :=
+| M_One : Monoid l (PEc cI)
+| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p
+| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2).
+
+(* Do we really need to rely on the intermediate definition of monoid ?
+   InC why the restriction NonEqual ?
+   Could not we consider the IsIdeal as a IsMult ?
+   The same for IsSquare ?
+*)
+
+Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop :=
+| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op
+| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal
+| IsSquare : forall p, Cone l (PEmul p p) NonStrict
+| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict
+| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq)
+| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq)
+| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict
+| IsZ : Cone l (PEc cO) Equal.
+
+(* As promised, if all hypotheses are true in some environment, then every
+member of the monoid is nonzero in this environment *)
+
+Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv),
+  (forall f : NFormula, In f l -> eval_nformula env f) ->
+    forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0.
+Proof.
+intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl.
+rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor).
+apply H1 in H. now simpl in H.
+simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split.
+Qed.
+
+(* If all members of a cone base are true in some environment, then every
+member of the cone is true as well *)
+
+Lemma cone_true :
+  forall (l : list NFormula) (env : PolEnv),
+    (forall (f : NFormula), In f l -> eval_nformula env f) ->
+      forall (p : PExprC) (op : Op1), Cone l p op ->
+        op <> NonEqual /\ eval_nformula env (p, op).
+Proof.
+intros l env H1 p op H2. induction H2; simpl in *.
+split. assumption. apply H1 in H. now unfold eval_nformula in H.
+split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor).
+split. discriminate. apply (Rtimes_square_nonneg sor).
+split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor).
+apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpMultNonEqual. now apply OpMult_sound.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpAdd_NonEqual. now apply OpAdd_sound.
+split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+split. discriminate. apply addon.(SORrm).(morph0).
+Qed.
+
+(* Every element of a monoid is a product of some generators; therefore,
+to determine an element we can give a list of generators' indices *)
+
+Definition MonoidMember : Set := list nat.
+
+Inductive ConeMember : Type :=
+| S_In : nat -> ConeMember
+| S_Ideal : PExprC -> ConeMember -> ConeMember
+| S_Square : PExprC -> ConeMember
+| S_Monoid : MonoidMember -> ConeMember
+| S_Mult : ConeMember -> ConeMember -> ConeMember
+| S_Add : ConeMember -> ConeMember -> ConeMember
+| S_Pos : C -> ConeMember 
+| S_Z : ConeMember.
+
+Definition nformula_times (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+  let (p', op') := f' in
+    (PEmul p p', OpMult op op').
+
+Definition nformula_plus (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+  let (p', op') := f' in
+    (PEadd p p', OpAdd op op').
+
+Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula :=
+let (q, op) := f in
+  match op with
+  | Equal => (PEmul q p, Equal)
+  | _ => f
+  end.
+
+Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC :=
+match ns with
+| nil => PEc cI
+| n :: ns =>
+  let p := match nth n l (PEc cI, NonEqual) with
+           | (q, NonEqual) => q
+           | _ => PEc cI
+           end in
+    PEmul p (eval_monoid l ns)
+end.
+
+Theorem eval_monoid_in_monoid :
+  forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns).
+Proof.
+intro l; induction ns; simpl in *.
+constructor.
+apply M_Mult; [| assumption].
+destruct (nth_in_or_default a l (PEc cI, NonEqual)).
+destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption.
+rewrite e; simpl. constructor.
+Qed.
+
+(* Provides the cone member from the witness, i.e., ConeMember *)
+Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula :=
+match cm with
+| S_In n => match nth n l (PEc cO, Equal) with
+            | (_, NonEqual) => (PEc cO, Equal)
+            | f => f
+            end
+| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm')
+| S_Square p => (PEmul p p, NonStrict)
+| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict)
+| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q)
+| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q)
+| S_Pos c  => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal)
+| S_Z => (PEc cO, Equal)
+end.
+
+Theorem eval_cone_in_cone :
+  forall (l : list NFormula) (cm : ConeMember),
+    let (p, op) := eval_cone l cm in Cone l p op.
+Proof.
+intros l cm; induction cm; simpl.
+destruct (nth_in_or_default n l (PEc cO, Equal)).
+destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ.
+rewrite e. apply IsZ.
+destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal.
+apply IsSquare.
+apply IsMonoid. apply eval_monoid_in_monoid.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd.
+case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ].
+apply IsZ.
+Qed.
+
+(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op
+(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact
+implies that l is inconsistent, as shown by the next lemma. Inconsistency
+of a formula (p, op) can be established by normalizing p and showing that
+it is a constant c for which (c, op) is false. (This is only a sufficient,
+not necessary, condition, of course.) Membership in the cone can be
+verified if we have a certificate. *)
+
+Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) :=
+  exists op : Op1, Cone l p op /\
+    forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p).
+
+(* If some element of a cone is inconsistent, then the base of the cone
+is also inconsistent *)
+
+Lemma prove_inconsistent :
+  forall (l : list NFormula) (p : PExprC),
+    inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False.
+Proof.
+intros l p H env.
+destruct H as [o [wit H]].
+apply -> make_conj_impl.
+intro H1. apply H with env.
+pose proof (@cone_true l env) as H2.
+cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3.
+apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in.
+Qed.
+
+Definition normalise_pexpr : PExprC -> PolC :=
+  norm_aux cO cI cplus ctimes cminus copp ceqb.
+
+(* The following definition we don't really need, hence it is commented *)
+(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*)
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+  forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+  norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+                addon.(SORrm) addon.(SORpower).
+(*****)
+(*Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+  norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt))
+                addon.(SORrm) addon.(SORpower) nil.*)
+(*****)
+
+(* Check that a formula f is inconsistent by normalizing and comparing the
+resulting constant with 0 *)
+
+Definition check_inconsistent (f : NFormula) : bool :=
+let (e, op) := f in
+  match normalise_pexpr e with
+  | Pc c =>
+    match op with
+    | Equal => cneqb c cO
+    | NonStrict => c [<] cO
+    | Strict => c [<=] cO
+    | NonEqual => false (* eval_cone never returns (p, NonEqual) *)
+    end
+  | _ => false (* not a constant *)
+  end.
+
+Lemma check_inconsistent_sound :
+  forall (p : PExprC) (op : Op1),
+    check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1.
+destruct op; simpl;
+(*****)
+rewrite eval_pexpr_PEeval;
+(*****)
+(*unfold eval_pexpr;*)
+(*****)
+rewrite normalise_pexpr_correct;
+destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+apply cleb_sound in H1. now apply -> (Rle_ngt sor).
+apply cltb_sound in H1. now apply -> (Rlt_nge sor).
+Qed.
+
+Definition check_normalised_formulas : list NFormula -> ConeMember -> bool :=
+  fun l cm => check_inconsistent (eval_cone l cm).
+
+Lemma checker_nf_sound :
+  forall (l : list NFormula) (cm : ConeMember),
+    check_normalised_formulas l cm = true ->
+      forall env : PolEnv, make_impl (eval_nformula env) l False.
+Proof.
+intros l cm H env.
+unfold check_normalised_formulas in H.
+case_eq (eval_cone l cm). intros p op H1.
+apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split.
+pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2.
+apply check_inconsistent_sound. now rewrite <- H1.
+Qed.
+
+(** Normalisation of formulae **)
+
+Inductive Op2 : Set := (* binary relations *)
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt.
+
+Definition eval_op2 (o : Op2) : R -> R -> Prop :=
+match o with
+| OpEq => req
+| OpNEq => fun x y : R => x ~= y
+| OpLe => rle
+| OpGe => fun x y : R => y <= x
+| OpLt => fun x y : R => x < y
+| OpGt => fun x y : R => y < x
+end.
+
+Record Formula : Type := {
+  Flhs : PExprC;
+  Fop : Op2;
+  Frhs : PExprC
+}.
+
+Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
+  let (lhs, op, rhs) := f in
+    (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
+
+(* We normalize Formulas by moving terms to one side *)
+
+Definition normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  match op with
+  | OpEq => (PEsub lhs rhs, Equal)
+  | OpNEq => (PEsub lhs rhs, NonEqual)
+  | OpLe => (PEsub rhs lhs, NonStrict)
+  | OpGe => (PEsub lhs rhs, NonStrict)
+  | OpGt => (PEsub lhs rhs, Strict)
+  | OpLt => (PEsub rhs lhs, Strict)
+  end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  match op with
+  | OpEq => (PEsub rhs lhs, NonEqual)
+  | OpNEq => (PEsub rhs lhs, Equal)
+  | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+  | OpGe => (PEsub rhs lhs, Strict)
+  | OpGt => (PEsub rhs lhs, NonStrict)
+  | OpLt => (PEsub lhs rhs, NonStrict)
+end.
+
+Theorem normalise_sound :
+  forall (env : PolEnv) (f : Formula),
+    eval_formula env f -> eval_nformula env (normalise f).
+Proof.
+intros env f H; destruct f as [lhs op rhs]; simpl in *.
+destruct op; simpl in *.
+now apply <- (Rminus_eq_0 sor).
+intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
+now apply -> (Rle_le_minus sor).
+now apply -> (Rle_le_minus sor).
+now apply -> (Rlt_lt_minus sor).
+now apply -> (Rlt_lt_minus sor).
+Qed.
+
+Theorem negate_correct :
+  forall (env : PolEnv) (f : Formula),
+    eval_formula env f <-> ~ (eval_nformula env (negate f)).
+Proof.
+intros env f; destruct f as [lhs op rhs]; simpl.
+destruct op; simpl.
+symmetry. rewrite (Rminus_eq_0 sor).
+split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
+rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+Qed.
+
+(** Another normalistion - this is used for cnf conversion **)
+
+Definition xnormalise (t:Formula) : list (NFormula)  :=
+  let (lhs,o,rhs) := t in
+    match o with
+      | OpEq => 
+        (PEsub lhs  rhs, Strict)::(PEsub rhs lhs , Strict)::nil
+      | OpNEq => (PEsub lhs rhs,Equal) :: nil
+      | OpGt   => (PEsub rhs lhs,NonStrict) :: nil
+      | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+      | OpGe => (PEsub rhs lhs , Strict) :: nil
+      | OpLe => (PEsub lhs rhs ,Strict) :: nil
+    end.
+
+Require Import Tauto.
+
+Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
+  List.map  (fun x => x::nil) (xnormalise t).
+
+
+Add Ring SORRing : sor.(SORrt).
+
+Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t.
+Proof.
+  unfold cnf_normalise, xnormalise ; simpl ; intros env t.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl;    
+    generalize (eval_pexpr  env lhs);
+      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros.
+  (**)
+  apply sor.(SORle_antisymm).
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  now rewrite <- (Rminus_eq_0 sor).
+  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
+  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
+  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
+  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
+Qed.
+
+Definition xnegate (t:Formula) : list (NFormula)  :=
+  let (lhs,o,rhs) := t in
+    match o with
+      | OpEq  => (PEsub lhs rhs,Equal) :: nil
+      | OpNEq => (PEsub lhs  rhs ,Strict)::(PEsub rhs lhs,Strict)::nil
+      | OpGt  => (PEsub lhs  rhs,Strict) :: nil
+      | OpLt  => (PEsub rhs lhs,Strict) :: nil
+      | OpGe  => (PEsub lhs rhs,NonStrict) :: nil
+      | OpLe  => (PEsub rhs lhs,NonStrict) :: nil
+    end.
+
+Definition cnf_negate (t:Formula) : cnf (NFormula) :=
+  List.map  (fun x => x::nil) (xnegate t).
+
+Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t.
+Proof.
+  unfold cnf_negate, xnegate ; simpl ; intros env t.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl ;
+    generalize (eval_pexpr env lhs);
+    generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; 
+    intuition.
+  (**)
+  apply H0.
+  rewrite H1 ; ring.
+  (**)
+  apply H1.
+  apply sor.(SORle_antisymm).
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+  (**)
+  apply H0. now rewrite  (Rle_le_minus sor) in H1.
+  apply H0. now rewrite (Rle_le_minus sor) in H1.
+  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+Qed.
+
+
+Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+  intros.
+  destruct d ; simpl.
+  generalize (eval_pexpr env p); intros.
+  destruct o ; simpl. 
+  apply (Req_em sor r 0).
+  destruct (Req_em sor r 0) ; tauto.
+  rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
+  rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
+Qed.
+
+(** Some syntactic simplifications of expressions and cone elements *)
+
+
+Fixpoint simpl_expr (e:PExprC) : PExprC :=
+  match e with
+    | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in
+      match y' , z' with
+        | PEc c , z' => if ceqb c cI then z' else PEmul y' z'
+        |     _     , _   => PEmul y' z'
+      end
+    | PEadd x  y => PEadd (simpl_expr x) (simpl_expr y)
+    |   _    => e
+  end.
+
+
+Definition simpl_cone (e:ConeMember) : ConeMember :=
+  match e with
+    | S_Square t => match simpl_expr t with
+                      | PEc c   => if ceqb cO c then S_Z else S_Pos (ctimes c c)
+                      |       x     => S_Square x
+                    end
+    | S_Mult t1 t2 => 
+      match t1 , t2 with
+        | S_Z      , x        => S_Z 
+        |    x     , S_Z      => S_Z 
+        | S_Pos c ,  S_Pos c' => S_Pos (ctimes c c')
+        | S_Pos p1 , S_Mult (S_Pos p2)  x => S_Mult (S_Pos (ctimes p1 p2)) x
+        | S_Pos p1 , S_Mult x (S_Pos p2)  => S_Mult (S_Pos (ctimes p1 p2)) x
+        | S_Mult (S_Pos p2)  x  , S_Pos p1   => S_Mult (S_Pos (ctimes p1 p2)) x
+        | S_Mult x (S_Pos p2)   , S_Pos p1   => S_Mult (S_Pos (ctimes p1 p2)) x
+        | S_Pos x   , S_Add y z   => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z)
+        | S_Pos c ,  _        => if ceqb cI c then t2 else S_Mult t1 t2
+        | _ ,  S_Pos c        => if ceqb cI c then t1 else S_Mult t1 t2
+        |     _     , _   => e
+      end
+    | S_Add t1 t2 => 
+      match t1 ,  t2 with
+        | S_Z     , x => x
+        |   x     , S_Z => x
+        |   x     , y   => S_Add x y
+      end
+    |   _     => e
+  end.
+
+
+
+End Micromega.
+
diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v
new file mode 100644
index 00000000..ef48efa6
--- /dev/null
+++ b/contrib/micromega/Tauto.v
@@ -0,0 +1,324 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import List.
+Require Import Refl.
+Require Import Bool.
+
+Set Implicit Arguments.
+
+
+  Inductive BFormula (A:Type) : Type :=
+  | TT   : BFormula A 
+  | FF   : BFormula A
+  | X : Prop -> BFormula A
+  | A : A -> BFormula A 
+  | Cj  : BFormula A -> BFormula A -> BFormula A
+  | D   : BFormula A-> BFormula A -> BFormula A
+  | N  : BFormula A -> BFormula A
+  | I : BFormula A-> BFormula A-> BFormula A. 
+
+  Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
+    match f with
+      | TT => True
+      | FF => False
+      | A a =>  ev a
+      | X p => p
+      | Cj e1 e2 => (eval_f  ev e1) /\ (eval_f ev e2)
+      | D e1 e2  => (eval_f  ev e1) \/ (eval_f  ev e2)
+      | N e     => ~ (eval_f  ev e)
+      | I f1 f2 => (eval_f  ev f1) -> (eval_f  ev f2)
+    end.
+
+
+  Lemma map_simpl : forall A B f l, @map A B f l = match l with 
+                                                 | nil => nil
+                                                 | a :: l=> (f a) :: (@map A B f l)
+                                               end.
+  Proof.
+    destruct l ; reflexivity.
+  Qed.
+
+
+
+  Section S.
+
+    Variable Env   : Type.
+    Variable Term  : Type.
+    Variable eval  : Env -> Term -> Prop.
+    Variable Term' : Type.  
+    Variable eval'  : Env -> Term' -> Prop.
+
+
+
+    Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
+
+
+    Definition clause := list  Term'.
+    Definition cnf := list clause.
+
+    Variable normalise : Term -> cnf.
+    Variable negate : Term -> cnf.
+
+
+    Definition tt : cnf := @nil clause.
+    Definition ff : cnf :=  cons (@nil Term') nil.
+
+
+    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
+      List.map (fun x => (t++x)) f.
+    
+    Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
+      match f with
+        | nil => tt
+        | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
+      end.
+    
+
+    Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
+      f1 ++ f2.
+    
+    Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
+      match f with
+        | TT => if pol then tt else ff
+        | FF => if pol then ff else tt
+        | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
+        | A x => if pol then normalise x else negate x
+        | N e  => xcnf (negb pol) e
+        | Cj e1 e2 => 
+          (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
+        | D e1 e2  => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
+        | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
+      end.
+
+  Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj  (fun cl => ~ make_conj  env cl) f.
+  
+
+  Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
+  Proof.
+    unfold eval_cnf.
+    intros.
+    rewrite make_conj_app in H ; auto.
+  Qed.
+    
+
+  Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj  (eval' env) t) \/ (eval_cnf (eval' env) f).
+  Proof.
+    unfold eval_cnf.
+    unfold or_clause_cnf.
+    induction f.
+    simpl.
+    intros ; right;auto.
+    (**)
+    rewrite map_simpl.
+    intros.
+    rewrite make_conj_cons in H.
+    destruct H as [HH1 HH2].
+    generalize (IHf HH2) ; clear IHf ; intro.
+    destruct H.
+    left ; auto.
+    rewrite make_conj_cons.
+    destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1).
+    tauto.
+    tauto.
+  Qed.
+
+ Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f).
+ Proof.
+   intros.
+   unfold eval_cnf in *.
+   rewrite make_conj_cons ; eauto.
+ Qed.
+
+  Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env)  f) \/ (eval_cnf (eval' env) f').
+  Proof.
+    induction f.
+    unfold eval_cnf.
+    simpl.
+    tauto.
+    (**)
+    intros.
+    simpl in H.
+    destruct (eval_cnf_app _ _ _ H).
+    clear H.
+    destruct (IHf _ H0).
+    destruct (or_clause_correct _ _ _ H1).
+    left.
+    apply eval_cnf_cons ; auto.
+    right ; auto.
+    right ; auto.
+  Qed.
+
+  Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t.
+
+  Variable negate_correct : forall env t, eval_cnf  (eval' env) (negate t) -> ~ eval env t.
+
+
+  Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
+  Proof.
+    induction f.
+    (* TT *)
+    unfold eval_cnf.
+    simpl.
+    destruct pol ; simpl ; auto.
+    (* FF *)
+    unfold eval_cnf.
+    destruct pol; simpl ; auto.
+    (* P *)
+    simpl.
+    destruct pol ; intros ;simpl.
+    unfold eval_cnf in H.
+    (* Here I have to drop the proposition *)
+    simpl in H.
+    tauto.
+    (* Here, I could store P in the clause *)
+    unfold eval_cnf in H;simpl in H.
+    tauto.
+    (* A *)
+    simpl.
+    destruct pol ; simpl.
+    intros.
+    apply normalise_correct  ; auto.
+    (* A 2 *)
+    intros.
+    apply  negate_correct ; auto.
+    auto.
+    (* Cj *)
+    destruct pol ; simpl.
+    (* pol = true *)
+    intros.
+    unfold and_cnf in H.
+    destruct (eval_cnf_app  _ _ _ H).
+    clear H.
+    split.
+    apply (IHf1 _ _ H0).
+    apply (IHf2 _ _ H1).
+    (* pol = false *)
+    intros.
+    destruct (or_cnf_correct _ _ _ H).
+    generalize (IHf1 false  env H0).
+    simpl.
+    tauto.
+    generalize (IHf2 false  env H0).
+    simpl.
+    tauto.
+    (* D *)
+    simpl.
+    destruct pol.
+    (* pol = true *)
+    intros.
+    destruct (or_cnf_correct _ _ _ H).
+    generalize (IHf1 _  env H0).
+    simpl.
+    tauto.
+    generalize (IHf2 _  env H0).
+    simpl.
+    tauto.
+    (* pol = true *)
+    unfold and_cnf.
+    intros.
+    destruct (eval_cnf_app  _ _ _ H).
+    clear H.
+    simpl.
+    generalize (IHf1 _ _ H0).
+    generalize (IHf2 _ _ H1).
+    simpl.
+    tauto.
+    (**)
+    simpl.
+    destruct pol ; simpl.
+    intros.
+    apply (IHf false) ; auto.
+    intros.
+    generalize (IHf _ _ H).
+    tauto.
+    (* I *)
+    simpl; intros.
+    destruct pol.
+    simpl.
+    intro.
+    destruct (or_cnf_correct _ _ _ H).
+    generalize (IHf1 _ _ H1).
+    simpl in *.
+    tauto.
+    generalize (IHf2 _ _ H1).
+    auto.
+    (* pol = false *)
+    unfold and_cnf in H.
+    simpl in H.
+    destruct (eval_cnf_app _ _ _ H).
+    generalize (IHf1 _ _ H0).    
+    generalize (IHf2 _ _ H1).    
+    simpl.
+    tauto.
+  Qed.
+
+
+  Variable Witness : Type.
+  Variable checker : list Term' -> Witness -> bool.
+  
+  Variable checker_sound : forall t  w, checker t w = true -> forall env, make_impl (eval' env)  t False.
+
+  Fixpoint cnf_checker (f : cnf) (l : list Witness)  {struct f}: bool :=
+    match f with
+      | nil => true
+      | e::f => match l with 
+                  | nil => false
+                  | c::l => match checker e c with
+                              | true => cnf_checker f l
+                              |   _  => false
+                            end
+                end
+      end.
+
+  Lemma cnf_checker_sound : forall t  w, cnf_checker t w = true -> forall env, eval_cnf  (eval' env)  t.
+  Proof.
+    unfold eval_cnf.
+    induction t.
+    (* bc *)
+    simpl.
+    auto.
+    (* ic *)
+    simpl.
+    destruct w.
+    intros ; discriminate.
+    case_eq (checker a w) ; intros ; try discriminate.
+    generalize (@checker_sound _ _ H env).
+    generalize (IHt _ H0 env) ; intros.
+    destruct t.
+    red ; intro.
+    rewrite <- make_conj_impl in H2.
+    tauto.
+    rewrite <- make_conj_impl in H2.
+    tauto.
+  Qed.
+
+
+  Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
+    cnf_checker (xcnf true f) w.
+
+  Lemma tauto_checker_sound : forall t  w, tauto_checker t w = true -> forall env, eval_f  (eval env)  t.
+  Proof.
+    unfold tauto_checker.
+    intros.
+    change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
+    apply (xcnf_correct t true).
+    eapply cnf_checker_sound ; eauto.
+  Qed.
+
+
+
+
+End S.
+
diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v
new file mode 100644
index 00000000..240c0fb7
--- /dev/null
+++ b/contrib/micromega/VarMap.v
@@ -0,0 +1,258 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZArith.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) 
+   -- this is harmless and spares a lot of Empty.
+   This means smaller proof-terms. 
+   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
+*)
+
+Section MakeVarMap.
+  Variable A : Type.
+  Variable default : A.
+  
+  Inductive t  : Type :=
+  | Empty : t 
+  | Leaf : A -> t 
+  | Node : t  -> A -> t  -> t .
+  
+  Fixpoint find   (vm : t ) (p:positive) {struct vm} : A :=
+    match vm with
+      | Empty => default
+      | Leaf i => i
+      | Node l e r => match p with
+                        | xH => e
+                        | xO p => find l p
+                        | xI p => find r p
+                      end
+    end.
+
+ (* an off_map (a map with offset) offers the same functionalites  as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *)
+(*
+  Definition off_map  :=  (option positive *t )%type.
+
+
+
+  Definition jump  (j:positive) (l:off_map ) := 
+    let (o,m) := l in
+      match o with
+        | None => (Some j,m)
+        | Some j0 => (Some (j+j0)%positive,m)
+      end.
+
+  Definition nth  (n:positive) (l: off_map ) :=
+    let (o,m) := l in
+      let idx  := match o with
+                    | None => n
+                    | Some i => i + n
+                  end%positive in
+      find  idx m.
+
+
+  Definition hd  (l:off_map) := nth  xH l.
+
+
+  Definition tail (l:off_map ) := jump xH l.
+
+
+  Lemma psucc : forall p,  (match p with
+                              | xI y' => xO (Psucc y')
+                              | xO y' => xI y'
+                              | 1%positive => 2%positive 
+                            end) = (p+1)%positive.
+  Proof.
+    destruct p.
+    auto with zarith.
+    rewrite xI_succ_xO.
+    auto with zarith.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Pplus : forall i j l, 
+    (jump (i + j) l) = (jump i (jump j l)).
+  Proof.
+    unfold jump.
+    destruct l.
+    destruct o.
+    rewrite Pplus_assoc.
+    reflexivity.
+    reflexivity.
+  Qed.
+
+  Lemma jump_simpl : forall p l,
+    jump p l = 
+    match p with
+      | xH => tail l
+      | xO p => jump p (jump p l)
+      | xI p  => jump p (jump p (tail l))
+    end.
+  Proof.
+    destruct p ; unfold tail ; intros ;  repeat rewrite <- jump_Pplus.
+    (* xI p = p + p + 1 *)
+    rewrite xI_succ_xO.
+    rewrite Pplus_diag.
+    rewrite <- Pplus_one_succ_r.
+    reflexivity.
+    (* xO p = p + p *)
+    rewrite Pplus_diag.
+    reflexivity.
+    reflexivity.
+  Qed.
+
+  Ltac jump_s :=
+    repeat 
+      match goal with
+        | |- context [jump xH ?e] => rewrite (jump_simpl xH)
+        | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
+        | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
+      end.
+    
+  Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
+  Proof. 
+    unfold tail.
+    intros.
+    repeat rewrite <- jump_Pplus.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Psucc : forall j l, 
+    (jump (Psucc j) l) = (jump 1 (jump j l)).
+  Proof.
+    intros.
+    rewrite <- jump_Pplus.
+    rewrite Pplus_one_succ_r.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma jump_Pdouble_minus_one : forall i l,
+    (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
+  Proof.
+    unfold tail.
+    intros.
+    repeat rewrite <- jump_Pplus.
+    rewrite <- Pplus_one_succ_r.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    rewrite Pplus_diag.
+    reflexivity.
+  Qed.
+
+  Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
+  Proof.
+    intros.
+    jump_s.
+    repeat rewrite <- jump_Pplus.
+    reflexivity.
+  Qed.
+
+  
+  Lemma nth_spec : forall p l, 
+    nth p l = 
+    match p with
+      | xH => hd  l
+      | xO p => nth p (jump p l)
+      | xI p => nth p (jump p (tail l))
+    end. 
+  Proof.
+    unfold nth.
+    destruct l.
+    destruct o.
+    simpl.
+    rewrite psucc.
+    destruct p.
+    replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
+    reflexivity.
+    rewrite xI_succ_xO.
+    rewrite Pplus_one_succ_r.
+    rewrite <- Pplus_diag.
+    rewrite Pplus_comm.
+    symmetry.
+    rewrite (Pplus_comm p0).
+    rewrite <- Pplus_assoc.
+    rewrite (Pplus_comm 1)%positive.
+    rewrite <- Pplus_assoc.
+    reflexivity.
+  (**)
+    replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
+    reflexivity.
+    rewrite <- Pplus_diag.
+    rewrite <- Pplus_assoc.
+    rewrite Pplus_comm.
+    rewrite Pplus_assoc.
+    reflexivity.
+    reflexivity.
+    simpl.
+    destruct p.
+    rewrite xI_succ_xO.
+    rewrite Pplus_one_succ_r.
+    rewrite <- Pplus_diag.
+    symmetry.
+    rewrite Pplus_comm.
+    rewrite Pplus_assoc.
+    reflexivity.
+    rewrite Pplus_diag.
+    reflexivity.
+    reflexivity.
+  Qed.
+
+
+  Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
+  Proof.
+    destruct l.
+    unfold tail.
+    unfold hd.
+    unfold jump.
+    unfold nth.
+    destruct o.
+    symmetry.
+    rewrite Pplus_comm.
+    rewrite <- Pplus_assoc.
+    rewrite (Pplus_comm p0).
+    reflexivity.
+    rewrite Pplus_comm.
+    reflexivity.
+  Qed.
+
+  Lemma nth_Pdouble_minus_one :
+    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+  Proof.
+    destruct l.
+    unfold tail.
+    unfold nth, jump.
+    destruct o.
+    rewrite ((Pplus_comm p)).
+    rewrite <- (Pplus_assoc p0).
+    rewrite Pplus_diag.
+    rewrite <- Psucc_o_double_minus_one_eq_xO.
+    rewrite Pplus_one_succ_r.
+    rewrite (Pplus_comm (Pdouble_minus_one p)).
+    rewrite Pplus_assoc.
+    rewrite (Pplus_comm p0).
+    reflexivity.
+    rewrite <- Pplus_one_succ_l.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    rewrite Pplus_diag.
+    reflexivity.
+  Qed.
+
+*)
+
+End MakeVarMap.
+
diff --git a/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v
new file mode 100644
index 00000000..ced67e39
--- /dev/null
+++ b/contrib/micromega/ZCoeff.v
@@ -0,0 +1,173 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZArith.
+Require Import InitialRing.
+Require Import Setoid.
+
+Import OrderedRingSyntax.
+
+Set Implicit Arguments.
+
+Section InitialMorphism.
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Lemma req_refl : forall x, req x x.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Reflexive.
+Qed.
+
+Lemma req_sym : forall x y, req x y -> req y x.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Symmetric.
+Qed.
+
+Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Transitive.
+Qed.
+  
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
+as sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+  exact (rminus_morph sor).
+Qed.
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+
+Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+
+Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
+Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
+
+Notation "[ x ]" := (gen_order_phi_Z x).
+
+Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
+Proof.
+constructor.
+exact rplus_morph.
+exact rtimes_morph.
+exact ropp_morph.
+Qed.
+
+Lemma Zring_morph :
+  ring_morph 0 1 rplus rtimes rminus ropp req
+             0%Z 1%Z Zplus Zmult Zminus Zopp
+             Zeq_bool gen_order_phi_Z.
+Proof.
+exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
+Qed.
+
+Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
+Proof.
+induction x as [x IH | x IH |]; simpl;
+try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
+try apply (Rlt_0_1 sor); assumption.
+Qed.
+
+Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
+Proof.
+exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
+        (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
+Qed.
+
+Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
+Proof.
+intros x y H. pattern y; apply Plt_ind with x.
+rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
+clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
+assumption.
+Qed.
+
+Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
+Proof.
+unfold Zlt; intros x y H;
+do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
+destruct x; destruct y; simpl in *; try discriminate.
+apply phi_pos1_pos.
+now apply clt_pos_morph.
+apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply phi_pos1_pos.
+rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor).
+now apply clt_pos_morph.
+Qed.
+
+Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
+Proof.
+unfold Zle_bool; intros x y H.
+case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
+le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
+le_less. now apply clt_morph.
+discriminate.
+Qed.
+
+Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
+Proof.
+intros x y H. unfold Zeq_bool in H.
+case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
+apply (Rlt_neq sor). now apply clt_morph.
+fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
+apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
+Qed.
+
+End InitialMorphism.
+
+
diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v
new file mode 100644
index 00000000..94c83f73
--- /dev/null
+++ b/contrib/micromega/ZMicromega.v
@@ -0,0 +1,714 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZCoeff.
+Require Import Refl.
+Require Import ZArith.
+Require Import List.
+Require Import Bool.
+
+Ltac flatten_bool :=
+  repeat match goal with
+           [ id : (_ && _)%bool = true |- _ ] =>  destruct (andb_prop _ _ id); clear id
+           |  [ id : (_ || _)%bool = true |- _ ] =>  destruct (orb_prop _ _ id); clear id
+         end.
+
+Require Import EnvRing.
+
+Open Scope Z_scope.
+  
+Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
+Proof.
+  constructor ; intros ; subst ; try (intuition (auto  with zarith)).
+  apply Zsth.
+  apply Zth.
+  destruct (Ztrichotomy n m) ; intuition (auto with zarith).
+  apply Zmult_lt_0_compat ; auto.
+Qed.
+
+Lemma Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y.
+Proof.
+  red ; intros.
+  subst.
+  unfold Zeq_bool in H.
+  rewrite Zcompare_refl  in H.
+  discriminate.
+Qed.
+
+Lemma ZSORaddon :
+  SORaddon 0 1 Zplus Zmult Zminus Zopp  (@eq Z) Zle (* ring elements *)
+  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+  Zeq_bool Zle_bool
+  (fun x => x) (fun x => x) (pow_N 1 Zmult).
+Proof.
+  constructor.
+  constructor ; intros ; try reflexivity.
+  apply Zeqb_ok ; auto.
+  constructor.
+  reflexivity.
+  intros x y.
+  apply Zeq_bool_neq ; auto.
+  apply Zle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr :=  eval_pexpr 0 Zplus Zmult Zminus Zopp  (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+
+Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z :=
+  match e with
+    | PEc c =>  c
+    | PEX j =>  env j
+    | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+    | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+    | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+    | PEopp pe1 => - (Zeval_expr env pe1)
+    | PEpow pe1 n => Zpower (Zeval_expr env pe1)  (Z_of_N n)
+  end.
+
+Lemma Zeval_expr_simpl : forall env e,
+  Zeval_expr env e = 
+  match e with
+    | PEc c =>  c
+    | PEX j =>  env j
+    | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+    | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+    | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+    | PEopp pe1 => - (Zeval_expr env pe1)
+    | PEpow pe1 n => Zpower (Zeval_expr env pe1)  (Z_of_N n)
+  end.
+Proof.
+  destruct e ; reflexivity.
+Qed.
+
+
+Definition Zeval_expr' := eval_pexpr  Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
+Proof.
+  destruct n.
+  reflexivity.
+  simpl.
+  unfold Zpower_pos.
+  replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
+  generalize 1.
+  induction p; simpl ; intros ; repeat rewrite IHp ; ring.
+Qed.
+
+
+
+Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e.
+Proof.
+  induction e ; simpl ; subst ; try congruence.
+  rewrite IHe.
+  apply ZNpower.
+Qed.
+
+Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
+match o with
+| OpEq =>  @eq Z
+| OpNEq => fun x y  => ~ x = y
+| OpLe => Zle
+| OpGe => Zge
+| OpLt => Zlt
+| OpGt => Zgt
+end.
+
+Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) :=
+  let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs).
+
+Definition Zeval_formula' :=
+  eval_formula  Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
+Proof.
+  intros.
+  unfold Zeval_formula.
+  destruct f.
+  repeat rewrite Zeval_expr_compat.
+  unfold Zeval_formula'.
+  unfold Zeval_expr'.
+  split ; destruct Fop ; simpl; auto with zarith.
+Qed.
+
+
+
+Definition Zeval_nformula :=
+  eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Definition Zeval_op1 (o : Op1) : Z -> Prop :=
+match o with
+| Equal => fun x : Z => x = 0
+| NonEqual => fun x : Z => x <> 0
+| Strict => fun x : Z => 0 < x
+| NonStrict => fun x : Z => 0 <= x
+end.
+
+Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)).
+Proof.
+  intros.
+  destruct f.
+  rewrite Zeval_expr_compat.
+  reflexivity.
+Qed.
+  
+Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d).
+Proof.
+  exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d).
+Qed.
+
+Definition ZWitness := ConeMember Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
+  ZWeakChecker l cm = true ->
+  forall env, make_impl (Zeval_nformula env) l False.
+Proof.
+  intros l cm H.
+  intro.
+  unfold Zeval_nformula.
+  apply (checker_nf_sound Zsor ZSORaddon l cm).
+  unfold ZWeakChecker in H.
+  exact H.
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    match o with
+      | OpEq => 
+        ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+      | OpNEq => (PEsub lhs rhs,Equal) :: nil
+      | OpGt   => (PEsub rhs lhs,NonStrict) :: nil
+      | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+      | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+      | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
+    end.
+
+Require Import Tauto.
+
+Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
+  List.map  (fun x => x::nil) (xnormalise t).
+
+
+Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t.
+Proof.
+  unfold normalise, xnormalise ; simpl ; intros env t.
+  rewrite Zeval_formula_compat.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl;
+    generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+      (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+    generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+      (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+    intuition (auto with zarith).
+Qed.
+  
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    match o with
+      | OpEq  => (PEsub lhs rhs,Equal) :: nil
+      | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+      | OpGt  => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
+      | OpLt  => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+      | OpGe  => (PEsub lhs rhs,NonStrict) :: nil
+      | OpLe  => (PEsub rhs lhs,NonStrict) :: nil
+    end.
+
+Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
+  List.map  (fun x => x::nil) (xnegate t).
+
+Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t.
+Proof.
+  unfold negate, xnegate ; simpl ; intros env t.
+  rewrite Zeval_formula_compat.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o ; simpl ;
+    generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+      (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+    generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
+      (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; 
+    intuition (auto with zarith).
+Qed.
+
+
+Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
+  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZWitness ZWeakChecker f w.
+
+(* To get a complete checker, the proof format has to be enriched *)
+
+Require Import Zdiv.
+Open Scope Z_scope.
+
+Definition ceiling (a b:Z) : Z :=
+  let (q,r) := Zdiv_eucl a b in
+    match r with
+      | Z0 => q
+      | _  => q + 1
+    end.
+
+Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
+Proof.
+  unfold ceiling.
+  intros.
+  generalize (Z_div_mod b a H).
+  destruct (Zdiv_eucl b a).
+  intros.
+  destruct H1.
+  destruct H2.
+  subst.
+  destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
+  assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
+  destruct HH ;auto.
+  generalize (Zmult_lt_compat_l _ _ _ H3 H1).
+  auto with zarith.
+  clear H2.
+  assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+  destruct HH ;auto.
+  assert (0 < a) by auto with zarith.
+  generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
+  intros.
+  rewrite Zmult_comm  in H4.
+  rewrite (Zmult_comm z)  in H4.
+  auto with zarith.
+Qed.
+
+Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x  <= b -> x <= Zdiv b a.
+Proof.
+  unfold Zdiv.
+  intros.
+  generalize (Z_div_mod b a H).
+  destruct (Zdiv_eucl b a).
+  intros.
+  destruct H1.
+  destruct H2.
+  subst.
+  assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+  destruct HH ;auto.
+  assert (0 < a) by auto with zarith.
+  generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1).
+  intros.
+  ring_simplify in H5.
+  rewrite Zmult_comm in H5.
+  auto with zarith.
+Qed.
+
+
+(* In this case, a certificate is made of a pair of inequations, in 1 variable,
+   that do not have an integer solution.
+   => modify the fourier elimination
+   *)
+Require Import QArith.
+
+
+Inductive ProofTerm : Type :=
+| RatProof : ZWitness -> ProofTerm
+| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm
+| EnumProof : Q ->  PExprC Z ->  Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm.
+
+(* n/d <= x  -> d*x - n >= 0 *)
+
+Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
+  let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc  n),NonStrict).
+
+(* x <= n/d  -> d * x <= d  *)
+Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
+  let (n,d) := q in
+    (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
+
+Definition qceiling (q:Q) : Z :=
+  let (n,d) := q in ceiling n (Zpos d).
+
+Definition qfloor (q:Q) : Z :=
+  let (n,d) := q in Zdiv n (Zpos d).
+
+Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
+  (PEsub v  (PEc (qceiling  q)), NonStrict).
+
+Definition neg_nformula (f : NFormula Z) :=
+  let (e,o) := f in
+    (PEopp (PEadd e (PEc 1%Z)), o).
+    
+Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
+Proof.
+  unfold neg_nformula.
+  destruct f. 
+  simpl.
+  intros ; subst ; simpl in *.
+  split;  auto with zarith.
+Qed.
+ 
+
+Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) :=
+    let (lb,lc) :=  (makeLb e lb,makeLbCut e lb) in
+      if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None.
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm)  {struct pf} : bool :=
+  match pf with
+    | RatProof pf => ZWeakChecker l pf
+    | CutProof e q pf rst => 
+      match cutChecker l e q pf with
+        | None => false
+        | Some c => ZChecker  (c::l) rst
+      end
+    | EnumProof lb e ub  pf1 pf2 rst => 
+      match cutChecker l e lb  pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+        | None ,  _  | _ , None => false
+        | Some _  , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+          (fix label (pfs:list ProofTerm) :=
+            fun lb ub => 
+              match pfs with
+                | nil => if Z_gt_dec lb ub then true else false
+                | pf::rsr => andb (ZChecker  ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) 
+              end)
+               rst lb' ub'
+      end
+  end.
+
+
+Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)),
+  ZChecker  l pf = 
+  match pf with
+    | RatProof pf => ZWeakChecker l pf
+    | CutProof e q pf rst => 
+      match cutChecker l e q pf with
+        | None => false
+        | Some c => ZChecker  (c::l) rst
+      end
+    | EnumProof lb e ub  pf1 pf2 rst => 
+      match cutChecker l e lb  pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+        | None ,  _  | _ , None => false
+        | Some _  , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+          (fix label (pfs:list ProofTerm) :=
+            fun lb ub => 
+              match pfs with
+                | nil => if Z_gt_dec lb ub then true else false
+                | pf::rsr => andb (ZChecker  ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) 
+              end)
+               rst lb' ub'
+      end
+  end.
+Proof.
+  destruct pf ; reflexivity.
+Qed.
+
+(*
+Fixpoint depth (n:nat) : ProofTerm -> option nat :=
+  match n with
+    | O => fun pf => None
+    | S n => 
+      fun pf => 
+        match pf with
+          | RatProof _ => Some O
+          | CutProof _ _ _ p =>  option_map S  (depth n p)
+          | EnumProof  _ _ _ _ _ l => 
+            let f := fun pf x => 
+              match x , depth n pf with
+                | None ,  _ | _ , None => None
+                | Some n1 , Some n2 => Some (Max.max n1 n2)
+              end in
+            List.fold_right f  (Some O) l
+        end
+  end.
+*)
+Fixpoint bdepth (pf : ProofTerm) : nat :=
+  match pf with
+    | RatProof _ =>  O
+    | CutProof _ _ _ p =>   S  (bdepth p)
+    | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x)   O l)
+  end.
+
+Require Import Wf_nat.
+
+Lemma in_bdepth : forall l a b p c c0  y, In y l ->  ltof ProofTerm bdepth y (EnumProof a b p c c0 l).
+Proof.
+  induction l.
+  simpl.
+  tauto.
+  simpl.
+  intros.
+  destruct H.
+  subst.
+  unfold ltof.
+  simpl.
+  generalize (         (fold_right
+            (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
+  intros.
+  generalize (bdepth y) ; intros.
+  generalize (Max.max_l n0 n) (Max.max_r n0 n).
+  omega.
+  generalize (IHl a0 b p c c0 y  H).
+  unfold ltof.
+  simpl.
+  generalize (      (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat
+         l)).
+  intros.
+  generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+  omega.
+Qed.
+
+Lemma lb_lbcut : forall env e q,  Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q).
+Proof.
+  unfold makeLb, makeLbCut.
+  destruct q.
+  rewrite Zeval_nformula_simpl.
+  rewrite Zeval_nformula_simpl.
+  unfold Zeval_op1.
+  rewrite Zeval_expr_simpl.
+  rewrite Zeval_expr_simpl.
+  rewrite Zeval_expr_simpl.
+  intro.
+  rewrite Zeval_expr_simpl.
+  revert H.
+  generalize (Zeval_expr env e).
+  rewrite Zeval_expr_simpl.
+  rewrite Zeval_expr_simpl.
+  unfold qceiling.
+  intros.
+  assert ( z >= ceiling Qnum (' Qden))%Z.
+  apply narrow_interval_lower_bound.
+  compute.
+  reflexivity.
+  destruct z ; auto with zarith.
+  auto with zarith.
+Qed.
+
+Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res -> 
+  forall env, make_impl  (Zeval_nformula env) l (Zeval_nformula env res).
+Proof.
+  unfold cutChecker.
+  intros.
+  revert H.
+  case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate].
+  generalize (ZWeakChecker_sound _ _  H env).
+  intros.
+  inversion H0 ; subst ; clear H0.
+  apply -> make_conj_impl.
+  simpl in H1.
+  rewrite <- make_conj_impl in H1.
+  intros.
+  apply -> neg_nformula_sound ; auto.
+  red ; intros.
+  apply H1 ; auto.
+  clear H H1 H0.
+  generalize (lb_lbcut env e lb).
+  intros.
+  destruct (Zeval_nformula_dec  env ((neg_nformula (makeLb e lb)))).
+  auto.
+  rewrite -> neg_nformula_sound in H0.
+  assert (HH := H H0).
+  rewrite <- neg_nformula_sound in HH.
+  tauto.
+  reflexivity.
+  unfold makeLb.
+  destruct lb.
+  reflexivity.
+Qed.
+
+
+Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res -> 
+  forall env,  make_conj  (Zeval_nformula env) l  -> (Zeval_expr env e >= qceiling lb)%Z.
+Proof.
+  intros.
+  generalize (cutChecker_sound _ _ _ _ _ H env).
+  intros.
+  rewrite  <- (make_conj_impl) in H1. 
+  generalize (H1 H0).
+  unfold cutChecker in H.
+  destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf).
+  unfold makeLbCut in H.
+  inversion H ; subst.
+  clear H.
+  simpl.
+  rewrite Zeval_expr_compat.
+  unfold Zeval_expr'.
+  auto with zarith.
+  discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl  (Zeval_nformula env)  l False.
+Proof.
+  induction w    using (well_founded_ind (well_founded_ltof _ bdepth)).
+  destruct w.
+  (* RatProof *)
+  simpl.
+  intros.
+  eapply ZWeakChecker_sound.
+  apply H0.
+  (* CutProof *)
+  simpl.
+  intro.
+  case_eq (cutChecker l p q z) ; intros.
+  generalize (cutChecker_sound _ _ _ _ _ H0 env).
+  intro.
+  assert (make_impl  (Zeval_nformula env) (n::l) False).
+  eapply (H w) ; auto.
+  unfold ltof.
+  simpl.
+  auto with arith.
+  simpl in H3.
+  rewrite <- make_conj_impl in H2.
+  rewrite <- make_conj_impl in H3.
+  rewrite <- make_conj_impl.
+  tauto.
+  discriminate.
+  (* EnumProof *)
+  intro.
+  rewrite ZChecker_simpl.
+  case_eq (cutChecker l0 p q z).
+  rename q into llb.
+  case_eq (cutChecker l0 (PEopp p) (- q0) z0).
+  intros.
+  rename q0 into uub.
+  (* get the bounds of the enum *)
+  rewrite <- make_conj_impl.
+  intro.
+  assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z.
+  generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3).
+  generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3).
+  intros.
+  rewrite Zeval_expr_simpl in H5.
+  auto with zarith.
+  clear H0 H1.
+  revert H2 H3 H4.
+  generalize (qceiling llb) (- qceiling (- uub))%Z.
+  set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool :=
+    match pfs with
+      | nil => if Z_gt_dec lb ub then true else false
+      | pf :: rsr =>
+        (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf &&
+          label rsr (lb + 1)%Z ub)%bool
+    end)).
+  intros z1 z2.
+  intros.
+  assert (forall x, z1 <= x <= z2 -> exists pr, 
+    (In pr l /\
+      ZChecker  ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z.
+  clear H.
+  revert H2.
+  clear H4.
+  revert z1 z2.
+  induction l;simpl ;intros.
+  destruct (Z_gt_dec z1 z2).
+  intros.
+  apply False_ind ; omega.
+  discriminate.
+  intros.
+  simpl in H2.
+  flatten_bool.
+  assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
+  destruct HH.
+  subst.
+  exists a ; auto.
+  assert (z1 + 1 <= x <= z2)%Z by omega.
+  destruct (IHl _ _ H1 _ H4).
+  destruct H5.
+  exists x0 ; split;auto.
+  (*/asser *)
+  destruct (H0 _ H4) as [pr [Hin Hcheker]].
+  assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False).
+  apply (H pr);auto.
+  apply in_bdepth ; auto.
+  rewrite <- make_conj_impl in H1.
+  apply H1.
+  rewrite  make_conj_cons.
+  split ;auto.
+  rewrite Zeval_nformula_simpl;
+    unfold Zeval_op1;
+      rewrite Zeval_expr_simpl.
+  generalize (Zeval_expr env p).
+  intros.
+  rewrite Zeval_expr_simpl.
+  auto with zarith.
+  intros ; discriminate.
+  intros ; discriminate.
+Qed.
+
+Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ProofTerm): bool :=
+  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ProofTerm ZChecker f w.
+
+Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f  (Zeval_formula env)  f.
+Proof.
+  intros f w.
+  unfold ZTautoChecker.
+  apply (tauto_checker_sound  Zeval_formula Zeval_nformula).
+  apply Zeval_nformula_dec.
+  intros env t.
+  rewrite normalise_correct ; auto.
+  intros env t.
+  rewrite negate_correct ; auto.
+  intros t w0.
+  apply ZChecker_sound.
+Qed.
+
+
+Open Scope Z_scope.
+
+
+Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness :=
+  match e with
+    | S_In n         => S_In _ (f n)
+    | S_Ideal e cm   => S_Ideal e (map_cone f cm)
+    | S_Square _     => e
+    | S_Monoid l     => S_Monoid _ (List.map f l)
+    | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2)
+    | S_Add cm1 cm2  => S_Add (map_cone f cm1) (map_cone f cm2)
+    |  _             => e
+  end.
+
+Fixpoint indexes (e:ZWitness) : list nat :=
+  match e with
+    | S_In n         => n::nil
+    | S_Ideal e cm   => indexes cm
+    | S_Square e     => nil
+    | S_Monoid l     => l
+    | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2)
+    | S_Add cm1 cm2  => (indexes cm1)++ (indexes cm2)
+    |  _             => nil
+  end.
+  
+(** To ease bindings from ml code **)
+(*Definition varmap := Quote.varmap.*)
+Definition make_impl := Refl.make_impl.
+Definition make_conj := Refl.make_conj.
+
+Require VarMap.
+
+(*Definition varmap_type := VarMap.t Z. *)
+Definition env := PolEnv Z.
+Definition node := @VarMap.Node Z.
+Definition empty := @VarMap.Empty Z.
+Definition leaf := @VarMap.Leaf Z.
+
+Definition coneMember := ZWitness.
+
+Definition eval := Zeval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Require Import Int.
+
+
+Definition n_of_Z (z:Z) : BinNat.N :=
+  match z with
+    | Z0 => N0
+    | Zpos p => Npos p
+    | Zneg p => N0
+  end.
+
+
+
diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml
new file mode 100644
index 00000000..88e882e6
--- /dev/null
+++ b/contrib/micromega/certificate.ml
@@ -0,0 +1,618 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+(* We take as input a list of polynomials [p1...pn] and return an unfeasibility
+   certificate polynomial. *)
+
+(*open Micromega.Polynomial*)
+open Big_int
+open Num
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+let (<+>) = add_num
+let (<->) = minus_num
+let (<*>) = mult_num
+
+type var = Mc.positive
+
+module Monomial :
+sig
+ type t
+ val const : t
+ val var : var -> t
+ val find : var -> t -> int
+ val mult : var -> t -> t
+ val prod : t -> t -> t
+ val compare : t -> t -> int
+ val pp : out_channel -> t -> unit
+ val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
+end
+ =
+struct
+ (* A monomial is represented by a multiset of variables  *)
+ module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
+ open Map
+ 
+ type t = int Map.t
+
+ (* The monomial that corresponds to a constant *)
+ let const = Map.empty
+  
+ (* The monomial 'x' *)
+ let var x = Map.add x 1 Map.empty
+
+ (* Get the degre of a variable in a monomial *)
+ let find x m = try find x m with Not_found -> 0
+  
+ (* Multiply a monomial by a variable *)
+ let mult x m = add x (  (find x m) + 1) m
+  
+ (* Product of monomials *)
+ let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
+  
+ (* Total ordering of monomials *)
+ let compare m1 m2 = Map.compare Pervasives.compare m1 m2
+
+ let pp o m = Map.iter (fun k v -> 
+  if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
+  else     Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
+
+ let fold = fold
+
+end
+
+
+module  Poly :
+ (* A polynomial is a map of monomials *)
+ (* 
+    This is probably a naive implementation 
+    (expected to be fast enough - Coq is probably the bottleneck)
+    *The new ring contribution is using a sparse Horner representation.
+ *)
+sig
+ type t
+ val get : Monomial.t -> t -> num
+ val variable : var -> t
+ val add : Monomial.t -> num -> t -> t
+ val constant : num -> t
+ val mult : Monomial.t -> num -> t -> t
+ val product : t -> t -> t
+ val addition : t -> t -> t
+ val uminus : t -> t
+ val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
+ val pp : out_channel -> t -> unit
+ val compare : t -> t -> int
+end =
+struct
+ (*normalisation bug : 0*x ... *)
+ module P = Map.Make(Monomial)
+ open P
+
+ type t = num P.t
+
+ let pp o p = P.iter (fun k v -> 
+  if compare_num v (Int 0) <> 0
+  then 
+   if Monomial.compare Monomial.const k = 0
+   then 	Printf.fprintf o "%s " (string_of_num v)
+   else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p  
+
+ (* Get the coefficient of monomial mn *)
+ let get : Monomial.t -> t -> num = 
+  fun mn p -> try find mn p with Not_found -> (Int 0)
+
+
+ (* The polynomial 1.x *)
+ let variable : var -> t =
+  fun  x ->  add (Monomial.var x) (Int 1) empty
+   
+ (*The constant polynomial *)
+ let constant : num -> t =
+  fun c -> add (Monomial.const) c empty
+
+ (* The addition of a monomial *)
+
+ let add : Monomial.t -> num -> t -> t =
+  fun mn v p -> 
+   let vl = (get mn p) <+> v in
+    add mn vl p
+
+
+ (** Design choice: empty is not a polynomial 
+     I do not remember why .... 
+ **)
+
+ (* The product by a monomial *)
+ let mult : Monomial.t -> num -> t -> t =
+  fun mn v p -> 
+   fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
+
+
+ let  addition : t -> t -> t =
+  fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
+   
+
+ let product : t -> t -> t =
+  fun p1 p2 -> 
+   fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
+
+
+ let uminus : t -> t =
+  fun p -> map (fun v -> minus_num v) p
+
+ let fold = P.fold
+
+ let compare = compare compare_num
+end
+
+open Mutils
+type 'a number_spec = {
+ bigint_to_number : big_int -> 'a;
+ number_to_num : 'a  -> num;
+ zero : 'a;
+ unit : 'a;
+ mult : 'a -> 'a -> 'a;
+ eqb  : 'a -> 'a -> Mc.bool
+}
+
+let z_spec = {
+ bigint_to_number = Ml2C.bigint ;
+ number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
+ zero = Mc.Z0;
+ unit = Mc.Zpos Mc.XH;
+ mult = Mc.zmult;
+ eqb  = Mc.zeq_bool
+}
+ 
+
+let q_spec = {
+ bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
+ number_to_num = C2Ml.q_to_num;
+ zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH};
+ unit = {Mc.qnum =  (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH};
+ mult = Mc.qmult;
+ eqb  = Mc.qeq_bool
+}
+
+let r_spec = z_spec
+
+
+
+
+let dev_form n_spec  p =
+ let rec dev_form p = 
+  match p with
+   | Mc.PEc z ->  Poly.constant (n_spec.number_to_num z)
+   | Mc.PEX v ->  Poly.variable v
+   | Mc.PEmul(p1,p2) -> 
+      let p1 = dev_form p1 in
+      let p2 = dev_form p2 in
+       Poly.product p1 p2 
+   | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
+   | Mc.PEopp p ->  Poly.uminus (dev_form p)
+   | Mc.PEsub(p1,p2) ->  Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
+   | Mc.PEpow(p,n)   ->  
+      let p = dev_form p in
+      let n = C2Ml.n n in
+      let rec pow n = 
+       if n = 0 
+       then Poly.constant (n_spec.number_to_num n_spec.unit)
+       else Poly.product p (pow (n-1)) in
+       pow n in
+  dev_form p
+
+
+let monomial_to_polynomial mn = 
+ Monomial.fold 
+  (fun v i acc -> 
+   let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+    if acc = Mc.PEc (Mc.Zpos Mc.XH)
+    then mn 
+    else Mc.PEmul(mn,acc))
+  mn 
+  (Mc.PEc (Mc.Zpos Mc.XH))
+  
+let list_to_polynomial vars l = 
+ assert (List.for_all (fun x -> ceiling_num x =/ x) l);
+ let var x = monomial_to_polynomial (List.nth vars x)  in 
+ let rec xtopoly p i = function
+  | [] -> p
+  | c::l -> if c =/  (Int 0) then xtopoly p (i+1) l 
+    else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+    let mn = 
+     if c =  Mc.PEc (Mc.Zpos Mc.XH)
+     then var i
+     else Mc.PEmul (c,var i) in
+    let p' = if p = Mc.PEc Mc.Z0 then mn else
+      Mc.PEadd (mn, p) in
+     xtopoly p' (i+1) l in
+  
+  xtopoly (Mc.PEc Mc.Z0) 0 l
+
+let rec fixpoint f x =
+ let y' = f x in
+  if y' = x then y'
+  else fixpoint f y'
+
+
+
+
+
+
+
+
+let  rec_simpl_cone n_spec e = 
+ let simpl_cone = 
+  Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
+
+ let rec rec_simpl_cone  = function
+ | Mc.S_Mult(t1, t2) -> 
+    simpl_cone  (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.S_Add(t1,t2)  -> 
+    simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2))
+ |  x           -> simpl_cone x in
+  rec_simpl_cone e
+   
+   
+let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
+ 
+type cone_prod = 
+  Const of cone 
+  | Ideal of cone *cone 
+  | Mult of cone * cone 
+  | Other of cone
+and cone =   Mc.zWitness
+
+
+
+let factorise_linear_cone c =
+ 
+ let rec cone_list  c l = 
+  match c with
+   | Mc.S_Add (x,r) -> cone_list  r (x::l)
+   |  _        ->  c :: l in
+  
+ let factorise c1 c2 =
+  match c1 , c2 with
+   | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') -> 
+      if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None
+   | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') -> 
+      if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None
+   |  _     -> None in
+  
+ let rec rebuild_cone l pending  =
+  match l with
+   | [] -> (match pending with
+      | None -> Mc.S_Z
+      | Some p -> p
+     )
+   | e::l -> 
+      (match pending with
+       | None -> rebuild_cone l (Some e) 
+       | Some p -> (match factorise p e with
+	  | None -> Mc.S_Add(p, rebuild_cone l (Some e))
+	  | Some f -> rebuild_cone l (Some f) )
+      ) in
+
+  (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+
+
+
+(* The binding with Fourier might be a bit obsolete 
+   -- how does it handle equalities ? *)
+
+(* Certificates are elements of the cone such that P = 0  *)
+
+(* To begin with, we search for certificates of the form:
+   a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0   
+   where pi >= 0 qi > 0
+   ai >= 0 
+   bi >= 0
+   Sum bi + c >= 1
+   This is a linear problem: each monomial is considered as a variable.
+   Hence, we can use fourier.
+
+   The variable c is at index 0
+*)
+
+open Mfourier
+   (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*)
+   (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*)
+module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)
+
+module Vect = Fourier.Vect
+open Fourier.Cstr
+
+(* fold_left followed by a rev ! *)
+
+let constrain_monomial mn l  = 
+ let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
+  if mn = Monomial.const
+  then  
+   { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
+     op = Eq ; 
+     cst = Big_int zero_big_int  }
+  else
+   { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; 
+     op = Eq ; 
+     cst = Big_int zero_big_int  }
+
+    
+let positivity l = 
+ let rec xpositivity i l = 
+  match l with
+   | [] -> []
+   | (_,Mc.Equal)::l -> xpositivity (i+1) l
+   | (_,_)::l -> 
+      {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; 
+       op = Ge ; 
+       cst = Int 0 }  :: (xpositivity (i+1) l)
+ in
+  xpositivity 0 l
+
+
+let string_of_op = function
+ | Mc.Strict -> "> 0" 
+ | Mc.NonStrict -> ">= 0" 
+ | Mc.Equal -> "= 0"
+ | Mc.NonEqual -> "<> 0"
+
+
+
+(* If the certificate includes at least one strict inequality, 
+   the obtained polynomial can also be 0 *)
+let build_linear_system l =
+
+ (* Gather the monomials:  HINT add up of the polynomials *)
+ let l' = List.map fst l in
+ let monomials = 
+  List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
+ in  (* For each monomial, compute a constraint *)
+ let s0 = 
+  Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in
+  (* I need at least something strictly positive *)
+ let strict = {
+  coeffs = Vect.from_list ((Big_int unit_big_int)::
+			    (List.map (fun (x,y) -> 
+			     match y with Mc.Strict -> 
+			      Big_int unit_big_int 
+			      | _ -> Big_int zero_big_int) l));
+  op = Ge ; cst = Big_int unit_big_int } in
+  (* Add the positivity constraint *)
+  {coeffs = Vect.from_list ([Big_int unit_big_int]) ; 
+   op = Ge ; 
+   cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
+
+
+let big_int_to_z = Ml2C.bigint
+ 
+(* For Q, this is a pity that the certificate has been scaled 
+   -- at a lower layer, certificates are using nums... *)
+let make_certificate n_spec cert li = 
+ let bint_to_cst = n_spec.bigint_to_number in
+  match cert with
+   | [] -> None
+   | e::cert' -> 
+      let cst = match compare_big_int e zero_big_int with
+       | 0 -> Mc.S_Z
+       | 1 ->  Mc.S_Pos (bint_to_cst e) 
+       | _ -> failwith "positivity error" 
+      in
+      let rec scalar_product cert l =
+       match cert with
+	| [] -> Mc.S_Z
+	| c::cert -> match l with
+	   | [] -> failwith "make_certificate(1)"
+	   | i::l ->  
+	      let r = scalar_product cert l in
+	       match compare_big_int c  zero_big_int with
+		| -1 -> Mc.S_Add (
+		   Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)), 
+		   r)
+		| 0  -> r
+		| _ ->  Mc.S_Add (
+		   Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+		   r) in
+       
+      Some ((factorise_linear_cone 
+	      (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li)))))
+
+
+exception Found of Monomial.t
+ 
+let raw_certificate l = 
+ let sys = build_linear_system l in
+  try 
+   match Fourier.find_point sys with
+    | None -> None
+    | Some cert ->  Some (rats_to_ints (Vect.to_list cert)) 
+       (* should not use rats_to_ints *)
+  with x -> 
+   if debug 
+   then (Printf.printf "raw certificate %s" (Printexc.to_string x);   
+	 flush stdout) ;
+   None
+
+
+let simple_linear_prover to_constant l =
+ let (lc,li) = List.split l in
+  match raw_certificate lc with
+   |  None -> None (* No certificate *)
+   | Some cert -> make_certificate to_constant cert li
+      
+      
+
+let linear_prover n_spec l  =
+ let li = List.combine l (interval 0 (List.length l -1)) in
+ let (l1,l') = List.partition 
+  (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in
+ let l' = List.map 
+  (fun (c,i) -> let (Mc.Pair(x,y)) = c in 
+		 match y with 
+		   Mc.NonEqual -> failwith "cannot happen" 
+		  |  y -> ((dev_form n_spec x, y),i)) l' in
+  
+  simple_linear_prover n_spec l' 
+
+
+let linear_prover n_spec l  =
+ try linear_prover n_spec l with
+   x -> (print_string (Printexc.to_string x); None)
+
+(* zprover.... *)
+
+(* I need to gather the set of variables --->
+   Then go for fold 
+   Once I have an interval, I need a certificate : 2 other fourier elims.
+   (I could probably get the certificate directly 
+   as it is done in the fourier contrib.)
+*)
+
+let make_linear_system l =
+ let l' = List.map fst l in
+ let monomials = List.fold_left (fun acc p -> Poly.addition p acc) 
+  (Poly.constant (Int 0)) l' in
+ let monomials = Poly.fold 
+  (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in
+  (List.map (fun (c,op) -> 
+   {coeffs = Vect.from_list (List.map (fun mn ->  (Poly.get mn c)) monomials) ; 
+    op = op ; 
+    cst = minus_num ( (Poly.get Monomial.const c))}) l
+    ,monomials)
+
+
+open Interval 
+let pplus x y = Mc.PEadd(x,y)
+let pmult x y = Mc.PEmul(x,y)
+let pconst x = Mc.PEc x
+let popp x = Mc.PEopp x
+ 
+let debug = false
+ 
+(* keep track of enumerated vectors *)
+let rec mem p x  l = 
+ match l with  [] -> false | e::l -> if p x e then true else mem p x l
+
+let rec remove_assoc p x l = 
+ match l with [] -> [] | e::l -> if p x (fst e) then
+  remove_assoc p x l else e::(remove_assoc p x l) 
+
+let eq x y = Vect.compare x y = 0
+
+(* Beurk... this code is a shame *)
+
+let rec zlinear_prover sys = xzlinear_prover [] sys
+
+and xzlinear_prover enum l :  (Mc.proofTerm option) = 
+ match linear_prover z_spec l with
+  | Some prf ->  Some (Mc.RatProof prf)
+  | None     ->  
+     let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with 
+       Mc.NonEqual -> r  
+      | k -> (dev_form z_spec e , 
+	     match k with
+	      | Mc.Strict | Mc.NonStrict -> Ge 
+		 (* Loss of precision -- weakness of fourier*)
+	      | Mc.Equal              -> Eq
+	      | Mc.NonEqual -> failwith "Cannot happen") :: r) l [] in
+
+     let (sys,var) = make_linear_system ll in
+     let res = 
+      match Fourier.find_Q_interval sys with
+       | Some(i,x,j) -> if i =/ j 
+	 then Some(i,Vect.set x (Int 1) Vect.null,i) else None 
+       | None -> None in
+     let res = match res with
+      | None ->
+	 begin
+	  let candidates = List.fold_right 
+	   (fun cstr acc -> 
+	    let gcd = Big_int (Vect.gcd cstr.coeffs) in
+	    let vect = Vect.mul (Int 1 // gcd) cstr.coeffs in
+	     if mem eq vect enum then acc
+	     else ((vect,Fourier.optimise vect sys)::acc)) sys [] in
+	  let candidates = List.fold_left (fun l (x,i) -> 
+	   match i with 
+	     None -> (x,Empty)::l 
+	    | Some i ->  (x,i)::l) [] (candidates) in
+	   match List.fold_left (fun (x1,i1) (x2,i2) -> 
+	    if smaller_itv i1 i2 
+	    then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates 
+	   with
+	    | (i,Empty) -> None
+	    | (x,Itv(Some i, Some j))  -> Some(i,x,j)
+	    | (x,Point n) ->  Some(n,x,n)
+	    |   x        ->   match Fourier.find_Q_interval sys with
+		 | None -> None
+		 | Some(i,x,j) -> 
+		    if i =/ j 
+		    then Some(i,Vect.set x (Int 1) Vect.null,i) 
+		    else None 
+	 end
+      |   _ -> res in
+
+      match res with 
+       | Some (lb,e,ub) -> 
+	  let (lbn,lbd) = 
+	   (Ml2C.bigint (sub_big_int (numerator lb)  unit_big_int),
+	   Ml2C.bigint (denominator lb)) in
+	  let (ubn,ubd) = 
+	   (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , 
+	   Ml2C.bigint (denominator ub)) in
+	  let expr = list_to_polynomial var (Vect.to_list e) in
+	   (match 
+	     (*x <= ub ->  x  > ub *)
+	     linear_prover  z_spec 
+	      (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst  ubn)),
+		      Mc.NonStrict) :: l),
+	    (* lb <= x  -> lb > x *)
+	    linear_prover z_spec 
+	     (Mc.Pair( pplus  (popp (pmult  (pconst lbd) expr)) (pconst lbn) ,  
+		     Mc.NonStrict)::l) 
+	    with
+	     | Some cub , Some clb  ->   
+		(match zlinear_enum (e::enum)   expr 
+		  (ceiling_num lb)  (floor_num ub) l 
+		 with
+		 | None -> None
+		 | Some prf -> 
+		    Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
+	     | _ -> None
+	   )
+       |  _ -> None
+and xzlinear_enum enum expr clb cub l = 
+ if clb >/  cub
+ then Some Mc.Nil
+ else 
+  let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
+  let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in
+   match xzlinear_prover enum sys' with
+    | None -> if debug then print_string "zlp?"; None
+    | Some prf -> if debug then print_string "zlp!";
+    match zlinear_enum enum expr (clb +/ (Int 1)) cub l with
+     | None -> None
+     | Some prfl -> Some (Mc.Cons(prf,prfl))
+
+and zlinear_enum enum expr clb cub l = 
+ let res = xzlinear_enum enum expr clb cub l in
+  if debug then Printf.printf "zlinear_enum %s %s -> %s\n" 
+   (string_of_num clb) 
+   (string_of_num cub) 
+   (match res with
+    | None -> "None"
+    | Some r -> "Some") ; res
+
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
new file mode 100644
index 00000000..29e2a183
--- /dev/null
+++ b/contrib/micromega/coq_micromega.ml
@@ -0,0 +1,1290 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+open Mutils
+let debug = false
+
+let time str f x = 
+ let t0 = (Unix.times()).Unix.tms_utime in
+ let res = f x in 
+ let t1 = (Unix.times()).Unix.tms_utime in 
+  (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; 
+		     flush stdout); 
+  res
+
+type ('a,'b) formula =
+  | TT 
+  | FF 
+  | X of 'b 
+  | A of 'a * Names.name
+  | C of ('a,'b) formula * ('a,'b) formula * Names.name
+  | D of ('a,'b) formula * ('a,'b) formula * Names.name
+  | N of ('a,'b) formula * Names.name
+  | I of ('a,'b) formula * ('a,'b) formula * Names.name
+
+let none = Names.Anonymous
+
+let tag_formula t f = 
+ match f with
+  | A(x,_) -> A(x,t)
+  | C(x,y,_) -> C(x,y,t)
+  | D(x,y,_) -> D(x,y,t)
+  | N(x,_) -> N(x,t)
+  | I(x,y,_) -> I(x,y,t)
+  |   _      -> f
+
+let tt = []
+let ff = [ [] ]
+
+
+type ('constant,'contr) sentence =  
+  ('constant Micromega.formula, 'contr) formula
+
+let cnf negate normalise f = 
+ let negate a = 
+  CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in
+
+ let normalise a = 
+  CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in
+
+ let and_cnf x y = x @ y in
+ let or_clause_cnf t f =  List.map (fun x -> t@x ) f in
+  
+ let rec or_cnf f f'  =
+  match f with
+   | [] -> tt
+   | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
+  
+ let rec xcnf  (pol : bool) f    =
+  match f with
+   | TT -> if pol then tt else ff (* ?? *)
+   | FF  -> if pol then ff else tt (* ?? *)
+   | X p -> if pol then ff else ff (* ?? *)
+   | A(x,t) -> if pol then normalise  x else negate x
+   | N(e,t)  -> xcnf  (not pol) e
+   | C(e1,e2,t) -> 
+      (if pol then and_cnf else or_cnf) (xcnf  pol e1) (xcnf  pol e2)
+   | D(e1,e2,t)  -> 
+      (if pol then or_cnf else and_cnf) (xcnf  pol e1) (xcnf  pol e2)
+   | I(e1,e2,t) -> 
+      (if pol then or_cnf else and_cnf) (xcnf  (not pol) e1) (xcnf  pol e2) in
+
+  xcnf  true f
+
+
+
+module M =
+struct
+ open Coqlib
+ open Term
+  (*    let constant = gen_constant_in_modules "Omicron" coq_modules*)
+  
+  
+ let logic_dir = ["Coq";"Logic";"Decidable"]
+ let coq_modules =
+  init_modules @ 
+   [logic_dir] @ arith_modules @ zarith_base_modules @ 
+   [ ["Coq";"Lists";"List"];
+     ["ZMicromega"];
+     ["Tauto"];
+     ["RingMicromega"];
+     ["EnvRing"];
+     ["Coq"; "micromega"; "ZMicromega"];
+     ["Coq" ; "micromega" ; "Tauto"];
+     ["Coq" ; "micromega" ; "RingMicromega"];
+     ["Coq" ; "micromega" ; "EnvRing"];
+     ["Coq";"QArith"; "QArith_base"];
+     ["Coq";"Reals" ; "Rdefinitions"];
+     ["LRing_normalise"]]
+   
+ let constant = gen_constant_in_modules "ZMicromega" coq_modules
+
+ let coq_and = lazy (constant "and")
+ let coq_or = lazy (constant "or")
+ let coq_not = lazy (constant "not")
+ let coq_iff = lazy (constant "iff")
+ let coq_True = lazy (constant "True")
+ let coq_False = lazy (constant "False")
+  
+ let coq_cons = lazy (constant "cons")
+ let coq_nil = lazy (constant "nil")
+ let coq_list = lazy (constant "list")
+
+ let coq_O = lazy (constant "O")
+ let coq_S = lazy (constant "S")
+ let coq_nat = lazy (constant "nat")
+
+ let coq_NO = lazy 
+  (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]]  "N0")
+ let coq_Npos = lazy 
+  (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]]  "Npos")
+  (* let coq_n = lazy (constant "N")*)
+
+ let coq_pair = lazy (constant "pair")
+ let coq_None = lazy (constant "None")
+ let coq_option = lazy (constant "option")
+ let coq_positive = lazy (constant "positive")
+ let coq_xH = lazy (constant "xH")
+ let coq_xO = lazy (constant "xO")
+ let coq_xI = lazy (constant "xI")
+  
+ let coq_N0 = lazy (constant "N0")
+ let coq_N0 = lazy (constant "Npos")
+
+
+ let coq_Z = lazy (constant "Z")
+ let coq_Q = lazy (constant "Q")
+ let coq_R = lazy (constant "R")
+
+ let coq_ZERO = lazy (constant  "Z0")
+ let coq_POS = lazy (constant  "Zpos")
+ let coq_NEG = lazy (constant  "Zneg")
+
+ let coq_QWitness = lazy 
+  (gen_constant_in_modules "QMicromega" 
+    [["Coq"; "micromega"; "QMicromega"]] "QWitness")
+ let coq_ZWitness = lazy 
+  (gen_constant_in_modules "QMicromega" 
+    [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
+
+
+ let coq_Build_Witness = lazy (constant "Build_Witness")
+
+
+ let coq_Qmake = lazy (constant "Qmake")
+
+ let coq_proofTerm = lazy (constant "ProofTerm")
+ let coq_ratProof = lazy (constant "RatProof")
+ let coq_cutProof = lazy (constant "CutProof")
+ let coq_enumProof = lazy (constant "EnumProof")
+
+ let coq_Zgt = lazy (constant "Zgt")
+ let coq_Zge = lazy (constant "Zge")
+ let coq_Zle = lazy (constant "Zle")
+ let coq_Zlt = lazy (constant "Zlt")
+ let coq_Eq  = lazy (constant "eq")
+
+ let coq_Zplus = lazy (constant "Zplus")
+ let coq_Zminus = lazy (constant "Zminus")
+ let coq_Zopp = lazy (constant "Zopp")
+ let coq_Zmult = lazy (constant "Zmult")
+ let coq_N_of_Z = lazy 
+  (gen_constant_in_modules "ZArithRing" 
+    [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+
+ let coq_PEX = lazy (constant "PEX" )
+ let coq_PEc = lazy (constant"PEc")
+ let coq_PEadd = lazy (constant "PEadd")
+ let coq_PEopp = lazy (constant "PEopp")
+ let coq_PEmul = lazy (constant "PEmul")
+ let coq_PEsub = lazy (constant "PEsub")
+ let coq_PEpow = lazy (constant "PEpow")
+
+
+ let coq_OpEq = lazy (constant "OpEq")
+ let coq_OpNEq = lazy (constant "OpNEq")
+ let coq_OpLe = lazy (constant "OpLe")
+ let coq_OpLt = lazy (constant  "OpLt")
+ let coq_OpGe = lazy (constant "OpGe")
+ let coq_OpGt = lazy (constant  "OpGt")
+
+
+ let coq_S_In = lazy (constant "S_In")
+ let coq_S_Square = lazy (constant "S_Square")
+ let coq_S_Monoid = lazy (constant "S_Monoid")
+ let coq_S_Ideal = lazy (constant "S_Ideal")
+ let coq_S_Mult = lazy (constant "S_Mult")
+ let coq_S_Add  = lazy (constant "S_Add")
+ let coq_S_Pos  = lazy (constant "S_Pos")
+ let coq_S_Z    = lazy (constant "S_Z")
+ let coq_coneMember    = lazy (constant "coneMember")
+  
+
+ let coq_make_impl = lazy 
+  (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
+ let coq_make_conj = lazy 
+  (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
+
+ let coq_Build = lazy 
+  (gen_constant_in_modules "RingMicromega" 
+    [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] 
+    "Build_Formula")
+ let coq_Cstr = lazy 
+  (gen_constant_in_modules "RingMicromega" 
+    [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
+
+ type parse_error  = 
+   | Ukn 
+   | BadStr of string 
+   | BadNum of int 
+   | BadTerm of Term.constr 
+   | Msg   of string
+   | Goal of (Term.constr list ) * Term.constr * parse_error
+
+ let string_of_error = function
+  | Ukn -> "ukn"
+  | BadStr s -> s
+  | BadNum i -> string_of_int i
+  | BadTerm _ -> "BadTerm"
+  | Msg  s    -> s
+  | Goal _    -> "Goal"
+
+
+ exception ParseError 
+
+
+
+
+ let get_left_construct term = 
+  match Term.kind_of_term term with
+   | Term.Construct(_,i) -> (i,[| |])
+   | Term.App(l,rst) -> 
+      (match Term.kind_of_term l with
+       | Term.Construct(_,i) -> (i,rst)
+       |   _     -> raise ParseError
+      )
+   | _ ->   raise ParseError
+      
+ module Mc = Micromega
+      
+ let rec parse_nat term = 
+  let (i,c) = get_left_construct term in
+   match i with
+    | 1 -> Mc.O
+    | 2 -> Mc.S (parse_nat (c.(0)))
+    | i -> raise ParseError
+       
+
+ let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
+
+
+ let rec dump_nat x = 
+  match x with
+   | Mc.O -> Lazy.force coq_O
+   | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
+
+
+ let rec parse_positive term = 
+  let (i,c) = get_left_construct term in
+   match i with
+    | 1 -> Mc.XI (parse_positive c.(0))
+    | 2 -> Mc.XO (parse_positive c.(0))
+    | 3 -> Mc.XH
+    | i -> raise ParseError
+       
+
+ let rec dump_positive x = 
+  match x with
+   | Mc.XH -> Lazy.force coq_xH
+   | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
+   | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
+
+ let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)	  
+
+
+ let rec dump_n x = 
+  match x with 
+   | Mc.N0 -> Lazy.force coq_N0
+   | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
+
+ let rec dump_index x = 
+  match x with
+   | Mc.XH -> Lazy.force coq_xH
+   | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
+   | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
+
+
+ let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)	  
+
+ let rec dump_n x = 
+  match x with
+   | Mc.N0 -> Lazy.force coq_NO
+   | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |])
+
+ let rec pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
+
+ let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) =
+  Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
+
+
+ let rec parse_z term =
+  let (i,c) = get_left_construct term in
+   match i with
+    | 1 -> Mc.Z0
+    | 2 -> Mc.Zpos (parse_positive c.(0))
+    | 3 -> Mc.Zneg (parse_positive c.(0))
+    | i -> raise ParseError
+
+ let dump_z x =
+  match x with
+   | Mc.Z0 ->Lazy.force coq_ZERO
+   | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) 
+   | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|])  
+
+ let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x)
+
+let dump_num bd1 = 
+ Term.mkApp(Lazy.force coq_Qmake,
+	   [|dump_z (CamlToCoq.bigint (numerator bd1)) ; 
+	     dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
+
+
+let dump_q q = 
+ Term.mkApp(Lazy.force coq_Qmake, 
+	   [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
+
+let parse_q term =  
+ match Term.kind_of_term term with
+  | Term.App(c, args) -> 
+     (
+      match Term.kind_of_term c with
+	Term.Construct((n,j),i) -> 
+      if Names.string_of_kn n  = "Coq.QArith.QArith_base#<>#Q"
+      then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
+      else raise ParseError
+       |  _ -> raise ParseError
+     )
+  |   _ -> raise ParseError
+  
+ let rec parse_list parse_elt term = 
+  let (i,c) = get_left_construct term in
+   match i with
+    | 1 -> Mc.Nil
+    | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2))
+    | i -> raise ParseError
+
+
+ let rec dump_list typ dump_elt l =
+  match l with
+   | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+   | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons, 
+			       [| typ; dump_elt e;dump_list typ dump_elt l|])
+      
+ let rec dump_ml_list typ dump_elt l =
+  match l with
+   | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+   | e::l -> Term.mkApp(Lazy.force coq_cons, 
+		       [| typ; dump_elt e;dump_ml_list typ dump_elt l|])
+
+
+
+ let pp_list op cl elt o l = 
+  let rec _pp  o l = 
+   match l with
+    | Mc.Nil -> ()
+    | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e
+    | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e  _pp l in
+   Printf.fprintf o "%s%a%s" op _pp l cl 
+
+
+
+ let pp_var  = pp_positive
+ let dump_var = dump_positive
+
+ let rec pp_expr o e = 
+  match e with
+   | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
+   | Mc.PEc z -> pp_z o z
+   | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
+   | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
+   | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
+   | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
+   | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n  n
+
+
+ let  dump_expr typ dump_z e =
+  let rec dump_expr  e =
+  match e with
+   | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
+   | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
+   | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
+			     [| typ; dump_expr e1;dump_expr e2|])
+   | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
+			     [| typ; dump_expr  e1;dump_expr  e2|])
+   | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
+			[| typ; dump_expr  e|])
+   | Mc.PEmul(e1,e2) ->  mkApp(Lazy.force coq_PEmul,
+			      [| typ; dump_expr  e1;dump_expr e2|])
+   | Mc.PEpow(e,n) ->  mkApp(Lazy.force coq_PEpow,
+			    [| typ; dump_expr  e; dump_n  n|])
+     in
+   dump_expr e
+
+ let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l
+
+ let rec dump_cone typ dump_z e = 
+  let z = Lazy.force typ in 
+ let rec dump_cone e =
+  match e with
+   | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |])
+   | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal, 
+			     [| z; dump_expr z dump_z e ; dump_cone c |])
+   | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square, 
+			   [| z;dump_expr z dump_z e|])
+   | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid, 
+			    [|z; dump_monoid l|])
+   | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add,
+			     [| z; dump_cone e1; dump_cone e2|])
+   | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult,
+			      [| z; dump_cone e1; dump_cone e2|])
+   | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|])
+   | Mc.S_Z    -> mkApp( Lazy.force coq_S_Z,[| z|]) in 
+  dump_cone e
+
+
+ let  pp_cone pp_z o e = 
+  let rec pp_cone o e = 
+   match e with 
+    | Mc.S_In n -> 
+       Printf.fprintf o "(S_In %a)%%nat" pp_nat n
+    | Mc.S_Ideal(e,c) -> 
+       Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c
+    | Mc.S_Square e -> 
+       Printf.fprintf o "(S_Square %a)" pp_expr e
+    | Mc.S_Monoid l -> 
+       Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l
+    | Mc.S_Add(e1,e2) -> 
+       Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2
+    | Mc.S_Mult(e1,e2) -> 
+       Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2
+    | Mc.S_Pos p -> 
+       Printf.fprintf o "(S_Pos %a)%%positive" pp_z p
+    | Mc.S_Z    -> 
+       Printf.fprintf o "S_Z" in
+   pp_cone o e
+
+
+
+
+ let rec parse_op term = 
+  let (i,c) = get_left_construct term in
+   match i with
+    | 1 -> Mc.OpEq
+    | 2 -> Mc.OpLe
+    | 3 -> Mc.OpGe
+    | 4 -> Mc.OpGt
+    | 5 -> Mc.OpLt
+    | i -> raise ParseError
+
+
+ let rec dump_op = function
+  | Mc.OpEq-> Lazy.force coq_OpEq
+  | Mc.OpNEq-> Lazy.force coq_OpNEq
+  | Mc.OpLe -> Lazy.force coq_OpLe
+  | Mc.OpGe -> Lazy.force coq_OpGe
+  | Mc.OpGt-> Lazy.force coq_OpGt
+  | Mc.OpLt-> Lazy.force coq_OpLt
+
+
+
+ let pp_op o e= 
+  match e with 
+   | Mc.OpEq-> Printf.fprintf o "="
+   | Mc.OpNEq-> Printf.fprintf o "<>"
+   | Mc.OpLe -> Printf.fprintf o "=<"
+   | Mc.OpGe -> Printf.fprintf o ">="
+   | Mc.OpGt-> Printf.fprintf o ">"
+   | Mc.OpLt-> Printf.fprintf o "<"
+
+
+
+
+ let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+  Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r
+
+ let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
+   Term.mkApp(Lazy.force coq_Build,
+	     [| typ; dump_expr typ dump_constant e1 ; 
+		dump_op o ; 
+		dump_expr typ dump_constant e2|])
+
+
+
+ let parse_zop (op,args) =
+  match kind_of_term op with
+   | Const x -> 
+      (match Names.string_of_con x with
+       | "Coq.ZArith.BinInt#<>#Zgt" -> (Mc.OpGt, args.(0), args.(1))
+       | "Coq.ZArith.BinInt#<>#Zge" -> (Mc.OpGe, args.(0), args.(1))
+       | "Coq.ZArith.BinInt#<>#Zlt" -> (Mc.OpLt, args.(0), args.(1))
+       | "Coq.ZArith.BinInt#<>#Zle" -> (Mc.OpLe, args.(0), args.(1))
+       (*| "Coq.Init.Logic#<>#not"    -> Mc.OpNEq  (* for backward compat *)*)
+       |   s -> raise ParseError
+      )
+   |  Ind(n,0) -> 
+       (match Names.string_of_kn n with
+	| "Coq.Init.Logic#<>#eq" -> 
+	   if args.(0) <> Lazy.force coq_Z
+	   then raise ParseError
+	   else (Mc.OpEq, args.(1), args.(2))
+	|  _ -> raise ParseError)
+   |   _ -> failwith "parse_zop"
+
+
+ let parse_rop (op,args) =
+  try 
+   match kind_of_term op with
+    | Const x -> 
+       (match Names.string_of_con x with
+	| "Coq.Reals.Rdefinitions#<>#Rgt" -> (Mc.OpGt, args.(0), args.(1))
+	| "Coq.Reals.Rdefinitions#<>#Rge" -> (Mc.OpGe, args.(0), args.(1))
+	| "Coq.Reals.Rdefinitions#<>#Rlt" -> (Mc.OpLt, args.(0), args.(1))
+	| "Coq.Reals.Rdefinitions#<>#Rle" -> (Mc.OpLe, args.(0), args.(1))
+	   (*| "Coq.Init.Logic#<>#not"-> Mc.OpNEq  (* for backward compat *)*)
+       |   s -> raise ParseError
+       )
+    |  Ind(n,0) -> 
+	(match Names.string_of_kn n with
+	 | "Coq.Init.Logic#<>#eq" -> 
+	    (*   if args.(0) <> Lazy.force coq_R
+		 then raise ParseError
+		 else*) (Mc.OpEq, args.(1), args.(2))
+	 |  _ -> raise ParseError)
+    |   _ -> failwith "parse_rop"
+  with x -> 
+   (Pp.pp (Pp.str "parse_rop failure ") ; 
+    Pp.pp (Printer.prterm op) ; Pp.pp_flush ()) 
+   ; raise x
+
+
+ let parse_qop (op,args) =
+  (
+   (match kind_of_term op with
+   | Const x -> 
+      (match Names.string_of_con x with
+       | "Coq.QArith.QArith_base#<>#Qgt" -> Mc.OpGt
+       | "Coq.QArith.QArith_base#<>#Qge" -> Mc.OpGe
+       | "Coq.QArith.QArith_base#<>#Qlt" -> Mc.OpLt
+       | "Coq.QArith.QArith_base#<>#Qle" -> Mc.OpLe
+       | "Coq.QArith.QArith_base#<>#Qeq" -> Mc.OpEq
+       |   s -> raise ParseError
+      )
+   |   _ -> failwith "parse_zop") , args.(0) , args.(1))
+
+
+ module Env =
+ struct 
+  type t = constr list
+    
+  let compute_rank_add env v =
+   let rec _add env n v =
+    match env with
+     | [] -> ([v],n)
+     | e::l -> 
+	if eq_constr e v 
+	then (env,n)
+	else 
+	 let (env,n) = _add l ( n+1) v in
+	  (e::env,n) in
+   let (env, n) =  _add env 1 v in
+    (env, CamlToCoq.idx n)
+
+     
+  let empty = []
+   
+  let elements env = env
+
+ end
+
+
+ let is_constant t = (* This is an approx *)
+  match kind_of_term t with
+   | Construct(i,_) -> true 
+   |   _ -> false
+
+
+ type 'a op = 
+   | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) 
+   | Opp 
+   | Power 
+   | Ukn of string
+
+
+ let parse_expr parse_constant parse_exp ops_spec env term = 
+ if debug 
+ then (Pp.pp (Pp.str "parse_expr: ");   
+       Pp.pp_flush ();Pp.pp (Printer.prterm  term); Pp.pp_flush ());
+
+  let constant_or_variable env term = 
+   try 
+    ( Mc.PEc (parse_constant term) , env)
+   with ParseError -> 
+    let (env,n) = Env.compute_rank_add env term in
+     (Mc.PEX  n , env) in
+
+  let rec parse_expr env term = 
+   let combine env op (t1,t2) =
+    let (expr1,env) = parse_expr env t1 in
+    let (expr2,env) = parse_expr env t2 in
+    (op expr1 expr2,env) in
+    match kind_of_term term with
+     | App(t,args) -> 
+	(
+	 match kind_of_term t with
+	  | Const c -> 
+	     ( match ops_spec (Names.string_of_con c) with
+	      | Binop f -> combine env f (args.(0),args.(1))
+	      | Opp     -> let (expr,env) = parse_expr env args.(0) in
+			    (Mc.PEopp expr, env)
+	      | Power   -> 
+		 let (expr,env) = parse_expr env args.(0) in
+		 let exp = (parse_exp args.(1)) in 
+		  (Mc.PEpow(expr, exp)  , env) 
+	      | Ukn  s -> 
+		 if debug 
+		 then (Printf.printf "unknown op: %s\n" s; flush stdout;);
+		 let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+	     )
+	  |   _ -> constant_or_variable env term
+	)
+     | _ -> constant_or_variable env term in
+   parse_expr env term
+    
+
+let zop_spec = function
+ | "Coq.ZArith.BinInt#<>#Zplus"    -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.ZArith.BinInt#<>#Zminus"   -> Binop (fun x y -> Mc.PEsub(x,y)) 
+ | "Coq.ZArith.BinInt#<>#Zmult"    -> Binop  (fun x y -> Mc.PEmul (x,y))
+  | "Coq.ZArith.BinInt#<>#Zopp"     ->  Opp
+  | "Coq.ZArith.Zpow_def#<>#Zpower" -> Power
+  |  s                                   -> Ukn s
+
+let qop_spec = function
+ | "Coq.QArith.QArith_base#<>#Qplus"    -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.QArith.QArith_base#<>#Qminus"   -> Binop (fun x y -> Mc.PEsub(x,y)) 
+ | "Coq.QArith.QArith_base#<>#Qmult"    -> Binop  (fun x y -> Mc.PEmul (x,y)) 
+  | "Coq.QArith.QArith_base#<>#Qopp"     ->  Opp
+  | "Coq.QArith.QArith_base#<>#Qpower" -> Power
+  |  s                                   -> Ukn s
+
+let rop_spec = function
+ | "Coq.Reals.Rdefinitions#<>#Rplus"    -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.Reals.Rdefinitions#<>#Rminus"   -> Binop (fun x y -> Mc.PEsub(x,y)) 
+ | "Coq.Reals.Rdefinitions#<>#Rmult"    -> Binop  (fun x y -> Mc.PEmul (x,y))
+ | "Coq.Reals.Rdefinitions#<>#Ropp"     -> Opp
+ | "Coq.Reals.Rpow_def#<>#pow"          -> Power
+ |  s                                        -> Ukn s
+
+
+
+
+      
+let zconstant = parse_z
+let qconstant = parse_q
+
+
+let rconstant term = 
+ if debug 
+ then (Pp.pp_flush ();
+       Pp.pp (Pp.str "rconstant: ");
+       Pp.pp (Printer.prterm  term); Pp.pp_flush ());
+ match Term.kind_of_term term with
+  | Const x ->        
+     (match Names.string_of_con x with
+      | "Coq.Reals.Rdefinitions#<>#R0" -> Mc.Z0
+      | "Coq.Reals.Rdefinitions#<>#R1" -> Mc.Zpos Mc.XH
+      | _   -> raise ParseError
+     )
+  |  _ -> raise ParseError
+
+
+let parse_zexpr = 
+ parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x))  zop_spec 
+let parse_qexpr  = 
+ parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec 
+let parse_rexpr = 
+ parse_expr rconstant  (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec
+
+
+ let  parse_arith parse_op parse_expr env cstr = 
+  if debug 
+  then (Pp.pp_flush ();
+	Pp.pp (Pp.str "parse_arith: ");
+	Pp.pp (Printer.prterm  cstr); 
+	Pp.pp_flush ());
+  match kind_of_term cstr with
+   | App(op,args) -> 
+      let (op,lhs,rhs) = parse_op (op,args) in
+      let (e1,env) = parse_expr env lhs in
+      let (e2,env) = parse_expr env rhs in
+       ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
+   |  _ -> failwith "error : parse_arith(2)"
+
+ let parse_zarith = parse_arith  parse_zop parse_zexpr 
+  
+ let parse_qarith = parse_arith  parse_qop parse_qexpr
+  
+ let parse_rarith = parse_arith  parse_rop parse_rexpr
+  
+  
+ (* generic parsing of arithmetic expressions *)
+  
+ let rec parse_conj parse_arith env term = 
+  match kind_of_term term with
+   | App(l,rst) -> 
+      (match kind_of_term l with
+       | Ind (n,_) -> 
+	  ( match Names.string_of_kn n with
+	   | "Coq.Init.Logic#<>#and" -> 
+	      let (e1,env) = parse_arith env rst.(0) in
+	      let (e2,env) = parse_conj parse_arith env rst.(1) in
+	       (Mc.Cons(e1,e2),env)
+	   |   _ -> (* This might be an equality *) 
+		let (e,env) = parse_arith env term in
+		 (Mc.Cons(e,Mc.Nil),env))
+       |  _ -> (* This is an arithmetic expression *)
+	   let (e,env) = parse_arith env term in
+	    (Mc.Cons(e,Mc.Nil),env))
+   |  _ -> failwith "parse_conj(2)"
+
+
+
+ let rec f2f = function
+  | TT  -> Mc.TT
+  | FF  -> Mc.FF
+  | X _  -> Mc.X
+  | A (x,_) -> Mc.A x
+  | C (a,b,_)  -> Mc.Cj(f2f a,f2f b)
+  | D (a,b,_)  -> Mc.D(f2f a,f2f b)
+  | N (a,_) -> Mc.N(f2f a)
+  | I(a,b,_)  -> Mc.I(f2f a,f2f b)
+
+ let is_prop t = 
+  match t with
+   | Names.Anonymous -> true (* Not quite right *)
+   | Names.Name x    -> false
+
+ let mkC f1 f2 = C(f1,f2,none)
+ let mkD f1 f2 = D(f1,f2,none)
+ let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none)
+ let mkI f1 f2 = I(f1,f2,none)
+
+ let mkformula_binary g term f1 f2 =
+   match f1 , f2 with
+   |  X _  , X _ -> X(term)
+   |   _         -> g f1 f2
+
+ let parse_formula parse_atom env term =
+  let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in
+
+  let rec xparse_formula env term =
+   match kind_of_term term with
+    | App(l,rst) ->
+        (match rst with
+         | [|a;b|] when l = Lazy.force coq_and ->
+	     let f,env = xparse_formula env a in
+	     let g,env = xparse_formula env b in
+             mkformula_binary mkC term f g,env
+         | [|a;b|] when l = Lazy.force coq_or ->
+	     let f,env = xparse_formula env a in
+	     let g,env = xparse_formula env b in
+             mkformula_binary mkD term f g,env
+         | [|a|] when l = Lazy.force coq_not ->
+             let (f,env) = xparse_formula env a in (N(f,none), env)
+         | [|a;b|] when l = Lazy.force coq_iff ->
+	     let f,env = xparse_formula env a in
+	     let g,env = xparse_formula env b in
+             mkformula_binary mkIff term f g,env
+         | _ -> parse_atom env term)
+    | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+	let f,env = xparse_formula env a in
+	let g,env = xparse_formula env b in
+        mkformula_binary mkI term f g,env
+    | _ when term = Lazy.force coq_True -> (TT,env)
+    | _ when term = Lazy.force coq_False -> (FF,env)
+    | _  -> X(term),env in
+  xparse_formula env term
+
+ let coq_TT = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "TT")
+ let coq_FF = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "FF")
+ let coq_And = lazy 
+  (gen_constant_in_modules "ZMicromega"    
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "Cj")
+ let coq_Or = lazy 
+  (gen_constant_in_modules "ZMicromega"  
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]    "D")
+ let coq_Neg = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "N")
+ let coq_Atom = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "A")
+ let coq_X = lazy 
+  (gen_constant_in_modules "ZMicromega"  
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "X")
+ let coq_Impl = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "I")
+ let coq_Formula = lazy 
+  (gen_constant_in_modules "ZMicromega" 
+    [["Coq" ; "micromega" ; "Tauto"];["Tauto"]]  "BFormula")
+
+ let dump_formula typ dump_atom f = 
+  let rec xdump f = 
+   match f with
+    | TT  -> mkApp(Lazy.force coq_TT,[| typ|])
+    | FF  -> mkApp(Lazy.force coq_FF,[| typ|])
+    | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|])
+    | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|])
+    | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|])
+    | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|])
+    | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) 
+    | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|])  in
+
+   xdump f
+    
+
+ (* Backward compat *)
+
+ let rec parse_concl parse_arith env term =
+  match kind_of_term term with
+   | Prod(_,expr,rst) -> (* a -> b *)
+      let (lhs,rhs,env) = parse_concl parse_arith env rst in
+      let (e,env) = parse_arith env expr in
+       (Mc.Cons(e,lhs),rhs,env)
+   | App(_,_) -> 
+      let (conj, env) = parse_conj parse_arith env term in
+       (Mc.Nil,conj,env)
+   |  Ind(n,_) -> 
+       (match (Names.string_of_kn n) with
+	| "Coq.Init.Logic#<>#False" -> (Mc.Nil,Mc.Nil,env)
+	|    s                           -> 
+	      print_string s ; flush stdout;
+	      failwith "parse_concl")
+   |  _ -> failwith "parse_concl"
+
+
+ let rec parse_hyps parse_arith env goal_hyps hyps = 
+  match hyps with
+   | [] -> ([],goal_hyps,env)
+   | (i,t)::l -> 
+      let (li,lt,env) = parse_hyps parse_arith env goal_hyps l in
+       try 
+	let (c,env) = parse_arith env  t in
+	 (i::li, Mc.Cons(c,lt), env)
+       with  x -> 
+	(*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+	(li,lt,env)
+
+
+ let parse_goal parse_arith env hyps term = 
+  try
+   let (lhs,rhs,env) = parse_concl parse_arith env term in
+   let (li,lt,env) = parse_hyps parse_arith env lhs hyps in
+    (li,lt,rhs,env)
+  with Failure x -> raise ParseError
+   (* backward compat *)
+
+
+ (* ! reverse the list of bindings *)
+ let set l concl =
+  let rec _set acc = function
+   | [] -> acc
+   | (e::l) ->  
+      let (name,expr,typ) = e in
+       _set (Term.mkNamedLetIn
+	      (Names.id_of_string name)
+	      expr typ acc) l in
+   _set concl l
+
+
+end            
+
+open M
+
+
+let rec sig_of_cone = function
+ | Mc.S_In n -> [CoqToCaml.nat n]
+ | Mc.S_Ideal(e,w) -> sig_of_cone w
+ | Mc.S_Mult(w1,w2) ->
+    (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.S_Add(w1,w2) -> 	(sig_of_cone w1)@(sig_of_cone w2)
+ | _  -> []
+
+let same_proof sg cl1 cl2 =
+ let cl1 = CoqToCaml.list (fun x -> x) cl1 in
+ let cl2 = CoqToCaml.list (fun x -> x) cl2 in
+ let rec xsame_proof sg = 
+  match sg with
+   | [] -> true
+   | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) 
+      && (xsame_proof sg ) in
+  xsame_proof sg
+
+
+
+
+let tags_of_clause tgs wit clause = 
+ let rec xtags tgs = function
+  | Mc.S_In n -> Names.Idset.union tgs  
+     (snd (List.nth clause (CoqToCaml.nat n) ))
+  | Mc.S_Ideal(e,w) -> xtags tgs w
+  | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2
+  |   _   -> tgs in
+  xtags tgs wit
+
+let tags_of_cnf wits cnf = 
+ List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) 
+  Names.Idset.empty wits cnf
+
+
+let find_witness prover  polys1 =
+ let l = CoqToCaml.list (fun x -> x) polys1 in
+  try_any prover l
+
+let rec witness prover   l1 l2 = 
+ match l2 with
+  | Micromega.Nil -> Some (Micromega.Nil)
+  | Micromega.Cons(e,l2) -> 
+     match find_witness prover   (Micromega.Cons( e,l1)) with
+      | None -> None
+      | Some w -> 
+	 (match witness prover   l1 l2 with
+	  | None -> None
+	  | Some l -> Some (Micromega.Cons (w,l))
+	 )
+
+
+let rec apply_ids t ids = 
+ match ids with
+  | [] -> t
+  | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
+
+     
+let coq_Node = lazy 
+ (Coqlib.gen_constant_in_modules "VarMap" 
+   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
+let coq_Leaf = lazy 
+ (Coqlib.gen_constant_in_modules "VarMap" 
+   [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
+let coq_Empty = lazy 
+ (Coqlib.gen_constant_in_modules "VarMap" 
+   [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
+ 
+ 
+let btree_of_array typ a  =
+ let size_of_a = Array.length a in
+ let semi_size_of_a = size_of_a lsr 1 in
+ let node = Lazy.force coq_Node
+ and leaf = Lazy.force coq_Leaf
+ and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in
+ let rec aux n =
+  if n > size_of_a 
+  then empty
+  else if  n > semi_size_of_a 
+  then Term.mkApp (leaf, [| typ; a.(n-1) |])
+  else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |])
+ in 
+  aux 1
+
+let btree_of_array typ a = 
+ try 
+  btree_of_array typ a
+ with x -> 
+  failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
+
+let dump_varmap typ env =
+ btree_of_array typ (Array.of_list env)
+
+
+let rec pp_varmap o vm = 
+ match vm with
+  | Mc.Empty -> output_string o "[]"
+  | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z  z
+  | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l  pp_z z pp_varmap r
+
+
+
+let rec dump_proof_term = function 
+ | Micromega.RatProof cone -> 
+    Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|])
+ | Micromega.CutProof(e,q,cone,prf) ->
+    Term.mkApp(Lazy.force coq_cutProof, 
+	      [| dump_expr (Lazy.force coq_Z) dump_z e ; 
+		 dump_q q ; 
+		 dump_cone coq_Z dump_z cone ; 
+		 dump_proof_term prf|])
+ | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) -> 
+    Term.mkApp (Lazy.force coq_enumProof,
+	       [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2;
+		  dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ; 
+		  dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |])
+
+let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
+ 
+ 
+let rec pp_proof_term o = function
+ | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone
+ | Micromega.CutProof(e,q,_,p) -> failwith "not implemented"
+ | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) -> 
+    Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]" 
+     pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2 
+     (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env hyps =
+ match hyps with
+  | [] -> ([],env)
+  | (i,t)::l -> 
+     let (lhyps,env) = parse_hyps parse_arith env l in
+      try 
+       let (c,env) = parse_formula parse_arith env  t in
+	((i,c)::lhyps, env)
+      with _ -> 		(lhyps,env)
+       (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+exception ParseError
+
+let parse_goal parse_arith env hyps term = 
+ (*  try*)
+ let (f,env) = parse_formula parse_arith env term in
+ let (lhyps,env) = parse_hyps parse_arith env hyps in
+  (lhyps,f,env)
+   (*  with Failure x -> raise ParseError*)
+
+
+type ('a, 'b) domain_spec = { 
+ typ : Term.constr; (* Z, Q , R *)
+ coeff : Term.constr ; (* Z, Q *)
+ dump_coeff : 'a -> Term.constr ; 
+ proof_typ : Term.constr ; 
+ dump_proof : 'b -> Term.constr
+}
+
+let zz_domain_spec  = lazy {
+ typ = Lazy.force coq_Z;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z ;
+ proof_typ = Lazy.force coq_proofTerm ;
+ dump_proof = dump_proof_term
+}
+
+let qq_domain_spec  = lazy {
+ typ = Lazy.force coq_Q;
+ coeff = Lazy.force coq_Q;
+ dump_coeff = dump_q ;
+ proof_typ = Lazy.force coq_QWitness ;
+ dump_proof = dump_cone coq_Q dump_q
+}
+
+let rz_domain_spec = lazy {
+ typ = Lazy.force coq_R;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z;
+ proof_typ = Lazy.force coq_ZWitness ;
+ dump_proof = dump_cone coq_Z dump_z
+}
+
+
+
+
+let micromega_order_change spec cert cert_typ env  ff gl = 
+ let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[|  spec.coeff|])) in
+
+ let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
+ let vm  = dump_varmap  ( spec.typ)  env in
+  Tactics.change_in_concl None
+   (set 
+     [ 
+      ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |]));
+      ("__varmap", vm , Term.mkApp 
+       (Coqlib.gen_constant_in_modules "VarMap" 
+	 [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [|  spec.typ|]));
+      ("__wit", cert,cert_typ)
+     ]  	
+     (Tacmach.pf_concl gl )
+
+       )
+   gl 
+   
+
+let detect_duplicates cnf wit = 
+ let cnf = CoqToCaml.list (fun x -> x) cnf in
+ let wit = CoqToCaml.list (fun x -> x) wit in
+
+ let rec xdup cnf wit = 
+  match wit with
+   | [] -> []
+   | w :: wit -> 
+      let sg = sig_of_cone w in
+       match cnf with
+	| [] -> []
+	| e::cnf -> 
+	   let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in
+	    dups@(xdup cnf wit) in
+  xdup cnf wit
+
+let find_witness prover    polys1 =
+ try_any prover polys1
+
+
+let witness_list_with_tags prover l = 
+ 
+ let rec xwitness_list l = 
+  match l with
+   | [] -> Some([])
+   | e::l -> 
+      match find_witness prover  (List.map fst e)  with
+       | None -> None
+       | Some w -> 
+	  (match xwitness_list l with
+	   | None -> None
+	   | Some l -> Some (w::l)
+	  ) in
+  xwitness_list l
+
+let witness_list_without_tags prover l = 
+ 
+ let rec xwitness_list l = 
+  match l with
+   | [] -> Some([])
+   | e::l -> 
+      match find_witness prover e  with
+       | None -> None
+       | Some w -> 
+	  (match xwitness_list l with
+	   | None -> None
+	   | Some l -> Some (w::l)
+	  ) in
+  xwitness_list l
+
+let witness_list prover l = 
+ let rec xwitness_list l = 
+  match l with
+   | Micromega.Nil -> Some(Micromega.Nil)
+   | Micromega.Cons(e,l) -> 
+      match find_witness prover e  with
+       | None -> None
+       | Some w -> 
+	  (match xwitness_list l with
+	   | None -> None
+	   | Some l -> Some (Micromega.Cons(w,l))
+	  ) in
+  xwitness_list l
+
+
+
+
+let is_singleton = function [] -> true | [e] -> true | _ -> false
+ 
+
+let micromega_tauto negate normalise spec prover env polys1 polys2  gl = 
+ let spec = Lazy.force spec in 
+ let (ff,ids) = 
+  List.fold_right 
+   (fun (id,f)  (cc,ids) -> 
+    match f with 
+      X _ -> (cc,ids) 
+     | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids)) 
+   polys1 (polys2,[]) in
+
+ let cnf_ff = cnf negate normalise ff in
+
+  if debug then 
+   (Pp.pp (Pp.str "Formula....\n") ;
+     let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
+     let ff = dump_formula formula_typ 
+      (dump_cstr spec.typ spec.dump_coeff) ff in
+      Pp.pp (Printer.prterm  ff) ;  Pp.pp_flush ()) ;
+
+   match witness_list_without_tags prover  cnf_ff with
+    | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl
+    | Some res -> (*Printf.printf "\nList %i" (List.length res); *)
+       let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in
+       let res' = dump_ml_list (spec.proof_typ) spec.dump_proof  res in
+	(Tacticals.tclTHENSEQ
+	  [
+	   Tactics.generalize ids;
+	   micromega_order_change spec res' 
+	    (Term.mkApp(Lazy.force coq_list,[|  spec.proof_typ|]))  env  ff ;
+	   ]) gl
+
+
+let micromega_gen parse_arith negate normalise spec  prover   gl =
+ let concl = Tacmach.pf_concl gl in
+ let hyps  = Tacmach.pf_hyps_types gl in
+  try
+   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let env = Env.elements env in
+    micromega_tauto negate normalise spec prover env hyps concl gl
+  with 
+   | Failure x -> flush stdout ; Pp.pp_flush () ; 
+      Tacticals.tclFAIL 0 (Pp.str x) gl
+   | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
+
+
+let lift_ratproof prover l =
+ match prover l with
+  | None -> None
+  | Some c -> Some (Mc.RatProof c)
+
+
+type csdpcert = Certificate.Mc.z Certificate.Mc.coneMember option
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type provername = string * int option
+
+let call_csdpcert provername poly =
+  let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in
+  let tmp_from = Filename.temp_file "csdpcert" ".out" in
+  output_value ch_to (provername,poly : provername * micromega_polys);
+  close_out ch_to;
+  let cmdname =
+    Filename.concat Coq_config.bindir
+      ("csdpcert" ^ Coq_config.exec_extension) in
+  let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in
+  (try Sys.remove tmp_to with _ -> ());
+  if c <> 0 then Util.error ("Failed to call csdp certificate generator");
+  let ch_from = open_in tmp_from in
+  let cert = (input_value ch_from : csdpcert) in
+  close_in ch_from; Sys.remove tmp_from;
+  cert
+
+let omicron gl = 
+ micromega_gen parse_zarith  Mc.negate Mc.normalise zz_domain_spec
+  [lift_ratproof 
+    (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
+
+
+let qomicron gl = 
+ micromega_gen  parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec 
+  [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ]   gl
+
+let romicron gl = 
+ micromega_gen  parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec 
+  [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ]   gl
+
+
+let rmicromega i gl = 
+ micromega_gen parse_rarith Mc.negate Mc.normalise rz_domain_spec
+  [ call_csdpcert ("real_nonlinear_prover", Some i), "fourier refutation" ]  gl
+
+  
+let micromega i gl = 
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec 
+ [lift_ratproof (call_csdpcert ("real_nonlinear_prover",Some i)), 
+  "fourier refutation" ] gl
+
+
+let sos gl = 
+ micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec 
+  [lift_ratproof (call_csdpcert ("pure_sos", None)), "pure sos refutation"]  gl
+
+let zomicron gl = 
+ micromega_gen parse_zarith Mc.negate Mc.normalise   zz_domain_spec 
+  [Certificate.zlinear_prover, "zprover"] gl
diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml
new file mode 100644
index 00000000..cfaf6ae1
--- /dev/null
+++ b/contrib/micromega/csdpcert.ml
@@ -0,0 +1,333 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+open Big_int
+open Num
+open Sos
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+let debug = false
+
+module M =
+struct
+ open Mc
+
+ let rec expr_to_term = function
+  |  PEc z ->  Const  (Big_int (C2Ml.z_big_int z))
+  |  PEX v ->  Var ("x"^(string_of_int (C2Ml.index v)))
+  |  PEmul(p1,p2) -> 
+      let p1 = expr_to_term p1 in
+      let p2 = expr_to_term p2 in
+      let res = Mul(p1,p2) in 	   res
+
+  | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2)
+  | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2)
+  | PEpow(p,n)   -> Pow(expr_to_term p , C2Ml.n n)
+  |  PEopp p ->  Opp (expr_to_term p)
+
+      
+ let rec term_to_expr = function
+  | Const n ->  PEc (Ml2C.bigint (big_int_of_num n))
+  | Zero   ->  PEc ( Z0)
+  | Var s   ->  PEX (Ml2C.index 
+		      (int_of_string (String.sub s 1 (String.length s - 1))))
+  | Mul(p1,p2) ->  PEmul(term_to_expr p1, term_to_expr p2)
+  | Add(p1,p2) ->   PEadd(term_to_expr p1, term_to_expr p2)
+  | Opp p ->   PEopp (term_to_expr p)
+  | Pow(t,n) ->  PEpow (term_to_expr t,Ml2C.n n)
+  | Sub(t1,t2) ->  PEsub (term_to_expr t1,  term_to_expr t2)
+  | _ -> failwith "term_to_expr: not implemented"
+
+ let term_to_expr e =
+  let e' = term_to_expr e in
+   if debug 
+   then Printf.printf "term_to_expr : %s - %s\n"  
+    (string_of_poly (poly_of_term  e)) 
+    (string_of_poly (poly_of_term (expr_to_term e')));
+   e'
+
+end 
+open M      
+
+open List
+open Mutils 
+
+let rec scale_term t = 
+ match t with
+  | Zero    -> unit_big_int , Zero
+  | Const n ->  (denominator n) , Const (Big_int (numerator n))
+  | Var n   -> unit_big_int , Var n
+  | Inv _   -> failwith "scale_term : not implemented"
+  | Opp t   -> let s, t = scale_term t in s, Opp t
+  | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
+    let g = gcd_big_int s1 s2 in
+    let s1' = div_big_int s1 g in
+    let s2' = div_big_int s2 g in
+    let e = mult_big_int g (mult_big_int s1' s2') in
+     if (compare_big_int e unit_big_int) = 0
+     then (unit_big_int, Add (y1,y2))
+     else 	e, Add (Mul(Const (Big_int s2'), y1),
+		       Mul (Const (Big_int s1'), y2))
+  | Sub _ -> failwith "scale term: not implemented"
+  | Mul(y,z) ->       let s1,y1 = scale_term y and s2,y2 = scale_term z in
+		       mult_big_int s1 s2 , Mul (y1, y2)
+  |  Pow(t,n) -> let s,t = scale_term t in
+		  power_big_int_positive_int s  n , Pow(t,n)
+  |   _ -> failwith "scale_term : not implemented"
+
+let scale_term t =
+ let (s,t') = scale_term t in
+  s,t'
+   
+
+
+
+let rec scale_certificate pos = match pos with
+ | Axiom_eq i ->  unit_big_int , Axiom_eq i
+ | Axiom_le i ->  unit_big_int , Axiom_le i
+ | Axiom_lt i ->   unit_big_int , Axiom_lt i
+ | Monoid l   -> unit_big_int , Monoid l
+ | Rational_eq n ->  (denominator n) , Rational_eq (Big_int (numerator n))
+ | Rational_le n ->  (denominator n) , Rational_le (Big_int (numerator n))
+ | Rational_lt n ->  (denominator n) , Rational_lt (Big_int (numerator n))
+ | Square t -> let s,t' =  scale_term t in 
+		mult_big_int s s , Square t'
+ | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
+		    mult_big_int s1 s2 , Eqmul (y1,y2)
+ | Sum (y, z) -> let s1,y1 = scale_certificate y 
+   and s2,y2 = scale_certificate z in
+   let g = gcd_big_int s1 s2 in
+   let s1' = div_big_int s1 g in
+   let s2' = div_big_int s2 g in
+    mult_big_int g (mult_big_int s1' s2'), 
+    Sum (Product(Rational_le (Big_int s2'), y1),
+	Product (Rational_le (Big_int s1'), y2))
+ | Product (y, z) -> 
+    let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+     mult_big_int s1 s2 , Product (y1,y2)
+
+
+let is_eq = function  Mc.Equal -> true | _ -> false
+let is_le = function  Mc.NonStrict -> true | _ -> false
+let is_lt = function  Mc.Strict -> true | _ -> false
+
+let get_index_of_ith_match f i l  =
+ let rec get j res l =
+  match l with
+   | [] -> failwith "bad index"
+   | e::l -> if f e
+     then 
+       (if j = i then res else get (j+1) (res+1) l )
+     else get j (res+1) l in
+  get 0 0 l
+
+
+let  cert_of_pos eq le lt ll l pos = 
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+   Axiom_eq i -> let idx = get_index_of_ith_match is_eq i l in
+		  Mc.S_In (Ml2C.nat idx)
+  | Axiom_le i -> let idx = get_index_of_ith_match is_le i l in
+		   Mc.S_In (Ml2C.nat idx)
+  | Axiom_lt i -> let idx = get_index_of_ith_match is_lt i l in
+		   Mc.S_In (Ml2C.nat idx)
+  | Monoid l  -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+  | Rational_eq n | Rational_le n | Rational_lt n -> 
+     if compare_num n (Int 0) = 0 then Mc.S_Z else
+      Mc.S_Pos (Ml2C.bigint (big_int_of_num  n))
+  | Square t -> Mc.S_Square (term_to_expr  t)
+  | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+  | Sum (y, z) -> Mc.S_Add  (_cert_of_pos y, _cert_of_pos z)
+  | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+  s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+
+let  term_of_cert l pos = 
+ let l = List.map fst' l in
+ let rec _cert_of_pos = function
+  | Mc.S_In i -> expr_to_term (List.nth l (C2Ml.nat i))
+  | Mc.S_Pos p -> Const (C2Ml.num  p)
+  | Mc.S_Z     -> Const (Int 0)
+  | Mc.S_Square t -> Mul(expr_to_term t, expr_to_term t)
+  | Mc.S_Monoid m -> List.fold_right 
+     (fun x m -> Mul (expr_to_term (List.nth l (C2Ml.nat x)),m)) 
+     (C2Ml.list (fun x -> x) m)  (Const (Int 1))
+  | Mc.S_Ideal (t, y) -> Mul(expr_to_term t, _cert_of_pos y)
+  | Mc.S_Add (y, z) -> Add  (_cert_of_pos y, _cert_of_pos z)
+  | Mc.S_Mult (y, z) -> Mul (_cert_of_pos y, _cert_of_pos z) in
+  (_cert_of_pos pos)
+
+let rec canonical_sum_to_string = function s -> failwith "not implemented"
+
+let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
+
+let print_list_term l = 
+ print_string "print_list_term\n";
+ List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;" 
+  (string_of_poly (poly_of_term (expr_to_term e))) 
+  (match k with 
+    Mc.Equal -> "= " 
+   | Mc.Strict -> "> " 
+   | Mc.NonStrict -> ">= " 
+   | _ -> failwith "not_implemented")) l ;
+ print_string "\n"
+
+
+let partition_expr l = 
+ let rec f i = function
+  | [] -> ([],[],[])
+  | Mc.Pair(e,k)::l -> 
+     let (eq,ge,neq) = f (i+1) l in
+      match k with 
+       | Mc.Equal -> ((e,i)::eq,ge,neq)
+       | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
+       | Mc.Strict    -> (* e > 0 == e >= 0 /\ e <> 0 *) 
+	  (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
+       | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) 
+	  (* Not quite sure -- Coq interface has changed *)
+ in f 0 l
+
+
+let rec sets_of_list l =
+ match l with
+  | [] -> [[]]
+  | e::l -> let s = sets_of_list l in
+	     s@(List.map (fun s0 -> e::s0) s) 
+
+let  cert_of_pos  pos = 
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+   Axiom_eq i ->  Mc.S_In (Ml2C.nat i)
+  | Axiom_le i ->  Mc.S_In (Ml2C.nat i)
+  | Axiom_lt i ->  Mc.S_In (Ml2C.nat i)
+  | Monoid l  -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+  | Rational_eq n | Rational_le n | Rational_lt n -> 
+     if compare_num n (Int 0) = 0 then Mc.S_Z else
+      Mc.S_Pos (Ml2C.bigint (big_int_of_num  n))
+  | Square t -> Mc.S_Square (term_to_expr  t)
+  | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+  | Sum (y, z) -> Mc.S_Add  (_cert_of_pos y, _cert_of_pos z)
+  | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+  s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+(* The exploration is probably not complete - for simple cases, it works... *)
+let real_nonlinear_prover d l =
+ try 
+  let (eq,ge,neq) = partition_expr l in
+
+  let rec elim_const  = function
+    [] ->  []
+   | (x,y)::l -> let p = poly_of_term (expr_to_term x) in
+		  if poly_isconst p 
+		  then elim_const l 
+		  else (p,y)::(elim_const l) in
+
+  let eq = elim_const eq in
+  let peq = List.map  fst eq in
+   
+  let pge = List.map 
+   (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
+   
+  let monoids = List.map (fun m ->  (List.fold_right (fun (p,kd) y -> 
+   let p = poly_of_term (expr_to_term p) in
+    match kd with
+     | Axiom_lt i -> poly_mul p y
+     | Axiom_eq i -> poly_mul (poly_pow p 2) y
+     |   _        -> failwith "monoids") m (poly_const (Int 1)) , map  snd m))
+   (sets_of_list neq) in
+
+  let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> 
+   list_try_find (fun m -> let (ci,cc) = 
+    real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
+		      (ci,cc,snd m)) monoids) 0 in
+   
+  let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))  
+   cert_ideal (List.map snd eq) in
+
+  let proofs_cone = map term_of_sos cert_cone in
+   
+  let proof_ne =  
+   let (neq , lt) = List.partition 
+    (function  Axiom_eq _ -> true | _ -> false ) monoid in
+   let sq = match 
+     (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) 
+    with
+    | []  -> Rational_lt (Int 1)
+    | l   -> Monoid l in
+    List.fold_right (fun x y -> Product(x,y)) lt sq in
+
+  let proof = list_fold_right_elements 
+   (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+   
+  let s,proof' = scale_certificate proof in
+  let cert  = snd (cert_of_pos proof') in
+   if debug 
+   then Printf.printf "cert poly : %s\n" 
+    (string_of_poly (poly_of_term (term_of_cert l cert)));
+   match Mc.zWeakChecker (Ml2C.list (fun x -> x) l)  cert with
+    | Mc.True -> Some cert
+    | Mc.False ->  (print_string "buggy certificate" ; flush stdout) ;None
+ with 
+  | Sos.TooDeep -> None
+
+
+(* This is somewhat buggy, over Z, strict inequality vanish... *)
+let pure_sos  l =
+ (* If there is no strict inequality, 
+    I should nonetheless be able to try something - over Z  > is equivalent to -1  >= *)
+ try 
+  let l = List.combine l (interval 0 (length l -1)) in
+  let (lt,i) =  try (List.find (fun (x,_) -> snd' x =  Mc.Strict) l) 
+   with Not_found -> List.hd l in
+  let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in
+  let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
+  let pos = Product (Rational_lt n, 
+		    List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
+		     (term_of_poly p)), rst)) 
+		     polys (Rational_lt (Int 0))) in
+  let proof = Sum(Axiom_lt i, pos) in
+  let s,proof' = scale_certificate proof in
+  let cert  = snd (cert_of_pos proof') in
+   Some cert
+ with
+  | Not_found -> (* This is no strict inequality *) None
+  |  x        -> None
+
+
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type csdp_certificate = Certificate.Mc.z Certificate.Mc.coneMember option
+type provername = string * int option
+
+let main () =
+  if Array.length Sys.argv <> 3 then
+    (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1);
+  let input_file = Sys.argv.(1) in
+  let output_file = Sys.argv.(2) in
+  let inch = open_in input_file in
+  let (prover,poly) = (input_value inch : provername * micromega_polys) in
+  close_in inch;
+  let cert =
+    match prover with
+    | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly
+    | "pure_sos", None -> pure_sos poly
+    | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in
+  let outch = open_out output_file in
+  output_value outch (cert:csdp_certificate);
+  close_out outch;
+  exit 0;;
+
+let _ = main () in ()
diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4
new file mode 100644
index 00000000..259b5d4b
--- /dev/null
+++ b/contrib/micromega/g_micromega.ml4
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008			        *)
+(*                                                                      *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_micromega.ml4 10947 2008-05-19 19:10:40Z herbelin $ *)
+
+open Quote
+open Ring
+open Mutils
+open Rawterm
+open Util
+
+let out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
+TACTIC EXTEND Micromega
+| [ "micromegap" int_or_var(i) ] -> [ Coq_micromega.micromega (out_arg i) ]
+| [ "micromegap" ] -> [ Coq_micromega.micromega (-1) ]
+END
+
+TACTIC EXTEND Sos
+[ "sosp" ] -> [ Coq_micromega.sos]
+END
+
+
+TACTIC EXTEND Omicron
+[ "omicronp"  ] -> [ Coq_micromega.omicron]
+END
+
+TACTIC EXTEND QOmicron
+[ "qomicronp"  ] -> [ Coq_micromega.qomicron]
+END
+
+
+TACTIC EXTEND ZOmicron
+[ "zomicronp"  ] -> [ Coq_micromega.zomicron]
+END
+
+TACTIC EXTEND ROmicron
+[ "romicronp"  ] -> [ Coq_micromega.romicron]
+END
+
+TACTIC EXTEND RMicromega
+| [ "rmicromegap" int_or_var(i) ] -> [ Coq_micromega.rmicromega (out_arg i) ]
+| [ "rmicromegap" ] -> [ Coq_micromega.rmicromega (-1) ]
+END
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
new file mode 100644
index 00000000..415d3a3e
--- /dev/null
+++ b/contrib/micromega/mfourier.ml
@@ -0,0 +1,667 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+(* Yet another implementation of Fourier *)
+open Num
+
+module Cmp =
+ (* How to compare pairs, lists ... *)
+struct
+ let rec compare_lexical l = 
+  match l with
+   | [] -> 0 (* Equal *)
+   | f::l -> 
+      let cmp = f () in
+       if cmp = 0 	then  compare_lexical l else cmp
+	
+ let rec compare_list cmp l1 l2 = 
+  match l1 , l2 with
+   | []  , [] -> 0
+   | []  , _  -> -1
+   | _   , [] -> 1
+   | e1::l1 , e2::l2 -> 
+      let c = cmp e1 e2 in
+       if c = 0 then compare_list cmp l1 l2 else c
+	
+ let hash_list hash l = 
+  let rec xhash res l = 
+   match l with
+    | []  -> res 
+    | e::l -> xhash ((hash e)  lxor res) l in
+   xhash  (Hashtbl.hash []) l
+
+end
+ 
+module Interval = 
+struct
+ (** The type of intervals.  **)
+ type intrvl = Empty | Point of num | Itv  of  num option * num option
+  
+ (**
+    Different intervals can denote the same set of variables e.g., 
+    Point n && Itv (Some n, Some n)
+    Itv (Some x) (Some y) && Empty if x > y
+    see the 'belongs_to' function.
+ **)
+
+ (* The set of numerics that belong to an interval *)
+ let belongs_to n = function
+  | Empty -> false
+  | Point x -> n =/ x
+  | Itv(Some x, Some y) -> x <=/ n && n <=/ y
+  | Itv(None,Some y) -> n <=/ y
+  | Itv(Some x,None) -> x <=/ n
+  | Itv(None,None) -> true
+
+ let string_of_bound = function
+  | None -> "oo"
+  | Some n -> Printf.sprintf "Bd(%s)"  (string_of_num n)
+
+ let string_of_intrvl = function
+  | Empty -> "[]"
+  | Point n -> Printf.sprintf "[%s]" (string_of_num n)
+  | Itv(bd1,bd2) -> 
+     Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2)
+
+ let pick_closed_to_zero = function
+  | Empty -> None
+  | Point n -> Some n
+  | Itv(None,None) -> Some (Int 0)
+  | Itv(None,Some i) -> 
+     Some (if  (Int 0) <=/ (floor_num  i) then Int 0 else floor_num i)
+  | Itv(Some i,None) -> 
+     Some (if i <=/ (Int 0) then Int 0 else ceiling_num i)
+  | Itv(Some i,Some j) -> 
+     Some (
+      if i <=/ Int 0 && Int 0 <=/ j 
+      then Int 0
+      else if ceiling_num i <=/ floor_num j 
+      then ceiling_num i (* why not *) else i)
+
+ type status = 
+   | O | Qonly | Z | Q 
+       
+ let interval_kind = function
+  | Empty -> O
+  | Point n -> if ceiling_num n =/ n then Z else Qonly
+  | Itv(None,None) -> Z
+  | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z
+  | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z
+  | Itv(Some i,Some j) -> 
+     if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z
+
+ let empty_z = function
+  | Empty -> true
+  | Point n ->  ceiling_num n <>/ n 
+  | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false
+  | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j
+
+
+ let normalise b1 b2 =
+  match b1 , b2 with
+   | Some i , Some j -> 
+      (match compare_num i j with
+       | 1 -> Empty
+       | 0 -> Point i
+       | _ -> Itv(b1,b2)
+      )
+   |  _ -> Itv(b1,b2)
+
+       
+
+ let min x y = 
+  match x , y with
+   | None , x | x , None -> x
+   | Some i , Some j -> Some (min_num i j)
+      
+ let max x y = 
+  match x , y with
+   | None , x | x , None -> x
+   | Some i , Some j -> Some (max_num i j)
+
+ let inter i1 i2 = 
+  match i1,i2 with
+   | Empty , _ -> Empty
+   |  _   , Empty -> Empty
+   |  Point n , Point m -> if n =/ m then i1 else Empty
+   | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n-> 
+      if (match mn with 
+       | None -> true
+       | Some mn ->  mn <=/ n) && 
+       (match mx with 
+	| None -> true
+	| Some mx ->  n <=/ mx) then Point n else Empty
+   | Itv (min1,max1) , Itv (min2,max2) -> 
+      let bmin = max min1 min2
+      and bmax = min max1 max2 in
+       normalise bmin bmax
+
+ (* a.x >= b*)
+ let bound_of_constraint (a,b) =
+  match compare_num a (Int 0) with
+   | 0 -> 
+      if compare_num b (Int 0) = 1
+      then Empty  
+       (*actually this is a contradiction  failwith "bound_of_constraint" *)
+      else Itv (None,None)
+   | 1 -> Itv (Some (div_num  b a),None)
+   | -1 -> Itv (None, Some (div_num  b a))
+   | x -> failwith "bound_of_constraint(2)"
+
+
+ let bounded x = 
+  match x with
+   | Itv(None,_) | Itv(_,None) -> false
+   |   _   -> true
+
+
+ let range = function
+  | Empty -> Some (Int 0)
+  | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0))
+  | Itv(None,_) | Itv(_,None)-> None
+  | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+ (* Returns the interval of smallest range *)
+ let smaller_itv i1 i2 = 
+  match range i1 , range i2  with
+   | None , _ -> false
+   |  _   , None -> true
+   | Some i , Some j -> i <=/ j
+
+end
+open Interval
+
+(* A set of constraints *)
+module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) = 
+struct
+ 
+ module Vect = V
+  
+ module Cstr = Vector.Cstr(V)
+ open Cstr
+ 
+ 
+ module CMap = Map.Make(
+  struct
+   type t = Vect.t
+   let compare = Vect.compare
+  end)
+  
+ module CstrBag = 
+ struct 
+
+  type mut_itv = { mutable itv : intrvl} 
+
+  type t = mut_itv CMap.t
+    
+  exception Contradiction
+
+  let cstr_to_itv cstr = 
+   let (n,l) = V.normalise cstr.coeffs in 
+    if n =/ (Int 0)
+    then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *)
+    else
+     match cstr.op with
+      | Eq -> let n = cstr.cst // n in (l, Point n)
+      | Ge -> 
+	 match  compare_num n (Int 0) with
+	  | 0 -> failwith "intrvl_of_constraint"
+	  | 1 -> (l,Itv (Some (cstr.cst // n), None))
+	  | -1 -> (l, Itv(None,Some (cstr.cst // n)))
+	  |  _ -> failwith "cstr_to_itv"
+
+	      
+  let empty = CMap.empty
+
+
+
+
+  let is_empty = CMap.is_empty
+
+  let find_vect v bag = 
+   try
+    (bag,CMap.find v bag) 
+   with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x)
+
+
+  let add (v,b) bag = 
+   match b with
+    | Empty -> raise Contradiction
+    | Itv(None,None) -> bag
+    | _    -> 
+       let (bag,intrl) = find_vect v bag in
+	match inter b intrl.itv with
+	 | Empty -> raise Contradiction
+	 |  itv  -> intrl.itv <- itv ; bag
+
+  exception Found of cstr
+
+  let find_equation bag = 
+   try 
+    CMap.fold (fun v i () -> 
+     match i.itv with
+      | Point n -> let e = {coeffs = v ; op = Eq ; cst = n} 
+	in 	raise	(Found e)
+      |    _    -> () ) bag () ; None
+   with Found c -> Some c
+
+    
+  let fold f bag acc = 
+   CMap.fold (fun v itv acc -> 
+    match itv.itv with
+     | Empty | Itv(None,None)  -> failwith "fold Empty"
+     | Itv(None ,Some i) -> 
+	f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+     | Point n           ->   f {coeffs =  v ; op = Eq ; cst = n} acc
+     | Itv(x,y) -> 	
+	(match x with 
+	 | None -> (fun x -> x)
+	 | Some i -> f {coeffs = v ; op = Ge ; cst = i})
+	 (match y with
+	  | None -> acc
+	  | Some i -> 
+	     f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+	 ) ) bag acc
+
+
+  let remove l _ = failwith "remove:Not implemented"
+   
+  module Map = 
+   Map.Make(
+    struct 
+     type t = int 
+     let compare : int -> int -> int = Pervasives.compare 
+    end)
+
+  let split f (t:t) =
+   let res = 
+    fold (fun e m -> let i = f e in
+                      Map.add i (add (cstr_to_itv e) 
+				  (try Map.find i m with 
+				    Not_found -> empty)) m) t Map.empty in
+    (fun i -> try Map.find i res with Not_found -> empty)
+     
+  type map = (int list * int list) Map.t
+    
+    
+  let status (b:t) = 
+   let _ , map = fold (fun c ( (idx:int),(res: map)) ->
+    ( idx + 1,
+    List.fold_left (fun (res:map) (pos,s) -> 
+     let (lp,ln) = try  Map.find pos res with Not_found -> ([],[]) in
+      match s with
+       | Vect.Pos -> Map.add pos (idx::lp,ln) res
+       | Vect.Neg -> 
+	  Map.add pos (lp, idx::ln) res) res 
+     (Vect.status c.coeffs))) b (0,Map.empty) in
+    Map.fold (fun k e res -> (k,e)::res)  map []
+     
+
+  type it = num CMap.t
+    
+  let iterator x = x
+   
+  let element it = failwith "element:Not implemented"
+
+ end
+end
+
+module Fourier(Vect : Vector.S)  =
+struct
+ module Vect = Vect
+ module Sys = Sys( Vect)
+ module Cstr = Sys.Cstr
+ module Bag = Sys.CstrBag
+
+ open Cstr
+ open Sys
+
+ let debug = false
+
+ let print_bag msg b =
+  print_endline msg;
+  CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b () 
+
+ let print_bag_file file msg b =
+  let f = open_out file in
+   output_string f msg;
+   CstrBag.fold (fun e () -> 
+    Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b () 
+
+    
+ (* A system with only inequations --
+ *)
+ let partition i m =
+  let splitter cstr =  compare_num (Vect.get i cstr.coeffs ) (Int 0) in
+  let split = CstrBag.split splitter m in
+   (split (-1) , split 0, split 1)
+
+    
+ (* op of the result is arbitrary Ge *) 
+ let lin_comb n1 c1 n2 c2 =
+  { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ; 
+    op = Ge ; 
+    cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)}
+
+ (* BUG? : operator of the result ? *)
+
+ let combine_project i c1 c2 =
+  let p = Vect.get  i c1.coeffs  
+  and n = Vect.get i c2.coeffs  in 
+   assert (n </ Int 0 && p >/ Int 0) ;
+   let nopp = minus_num n in 
+   let c =lin_comb nopp c1 p c2  in
+   let op = if c1.op = Ge ||  c2.op = Ge then Ge else Eq in
+    CstrBag.cstr_to_itv {coeffs =  c.coeffs ; op = op ; cst= c.cst }
+
+
+ let project i m =
+  let (neg,zero,pos) = partition i m in
+  let project1 cpos acc = 
+   CstrBag.fold (fun cneg res ->
+    CstrBag.add (combine_project i cpos cneg) res) neg acc in
+   (CstrBag.fold project1 pos zero)
+
+ (* Given a vector [x1 -> v1; ... ; xn -> vn]
+    and a constraint {x1 ; .... xn >= c }
+ *)
+ let evaluate_constraint i map cstr =
+  let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in
+  let vi = Vect.get  i _coeffs  in
+  let v = Vect.set i (Int 0) _coeffs in
+   (vi, _cst -/ Vect.dotp map v)
+
+
+ let rec bounds m itv =
+  match m with
+   | [] -> itv
+   | e::m -> bounds m (inter itv (bound_of_constraint e))
+
+
+
+ let compare_status (i,(lp,ln)) (i',(lp',ln')) = 
+  let cmp = Pervasives.compare 
+   ((List.length lp) * (List.length ln))  
+   ((List.length lp') * (List.length ln')) in
+   if cmp = 0
+   then Pervasives.compare i i'
+   else cmp
+
+ let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0
+
+ let lightest_projection  l c m  =
+  let bound = c in 
+   if debug then (Printf.printf "l%i" bound; flush stdout) ; 
+   let rec xlight best l =
+    match l with
+     | [] -> best
+     | i::l -> 
+	let proj = (project i m) in
+	let cproj = cardinal proj in
+	 (*Printf.printf " p %i " cproj; flush stdout;*)
+	 match best with
+	  | None -> 
+	     if cproj < bound 
+	     then Some(cproj,proj,i) 
+	     else xlight (Some(cproj,proj,i)) l
+	  | Some (cbest,_,_) -> 		
+	     if cproj < cbest 
+	     then 
+	      if cproj < bound then Some(cproj,proj,i)
+	      else xlight (Some(cproj,proj,i)) l 
+	     else xlight best l in
+    match xlight None l with
+     | None -> None
+     | Some(_,p,i) -> Some (p,i)
+	
+
+
+ exception Equality of cstr
+
+ let find_equality m = Bag.find_equation m
+
+  
+
+ let pivot (n,v) eq ge =
+  assert (eq.op = Eq) ;
+  let res = 
+   match 
+    compare_num v (Int 0), 
+    compare_num (Vect.get n ge.coeffs) (Int 0) 
+   with
+    | 0 , _ -> failwith "Buggy"
+    | _ ,0  -> (CstrBag.cstr_to_itv ge)
+    | 1 , -1 -> combine_project n eq ge
+    | -1 , 1 -> combine_project n ge eq
+    | 1  , 1 -> 
+       combine_project n ge 
+	{coeffs = Vect.mul (Int (-1)) eq.coeffs; 
+	 op = eq.op ; 
+	 cst = minus_num eq.cst}
+    | -1 , -1 -> 
+       combine_project n 
+	{coeffs = Vect.mul (Int (-1)) eq.coeffs; 
+	 op = eq.op ; cst = minus_num eq.cst} ge
+    | _ -> failwith "pivot" in
+   res
+
+ let check_cstr v c = 
+  let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+  let vl = Vect.dotp v _coeffs in
+   match _op with
+    | Eq -> vl =/ _cst
+    | Ge -> vl >= _cst
+
+
+ let forall p  sys = 
+  try 
+   CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true
+  with Not_found -> false
+
+
+ let check_sys v sys = forall (check_cstr v) sys
+
+ let check_null_cstr c = 
+  let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+   match _op with
+    | Eq -> (Int 0) =/ _cst
+    | Ge -> (Int 0) >= _cst
+       
+ let check_null sys = forall check_null_cstr sys
+
+
+ let optimise_ge 
+   quick_check choose choose_idx return_empty return_ge return_eq  m =
+  let c = cardinal m in
+  let bound =  2 * c  in
+   if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout);
+
+   let rec xoptimise  m =
+    if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout);
+    if debug then (print_bag "xoptimise" m ; flush stdout);
+    if quick_check m
+    then return_empty m
+    else 
+     match find_equality m with
+      | None -> xoptimise_ge m
+      | Some eq -> xoptimise_eq eq m
+	 
+   and xoptimise_ge m =
+    begin
+     let c = cardinal m in
+     let l = List.map fst (List.sort compare_status (CstrBag.status m)) in
+     let  idx = choose bound l c m in
+      match idx with
+       | None -> return_empty m
+       | Some (proj,i) -> 
+	  match xoptimise proj with
+	   | None -> None
+	   | Some mapping -> return_ge m i mapping
+    end
+   and xoptimise_eq eq m = 
+    let l = List.map fst (Vect.status eq.coeffs) in
+     match choose_idx l with
+      | None -> (*if l = [] then None else*) return_empty m
+      | Some i -> 
+	 let p  = (i,Vect.get i eq.coeffs) in
+	 let m' = CstrBag.fold 
+	  (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in
+	  match xoptimise ( m') with
+	   | None -> None
+	   | Some mapp -> return_eq m eq i mapp in
+    try 
+     let res = xoptimise   m  in res
+    with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None
+
+
+
+ let minimise m = 
+  let opt_zero_choose bound l c m = 
+   if c > bound 
+   then lightest_projection l c m
+   else match l with
+    | [] -> None
+    | i::_ -> Some (project i m, i) in
+   
+  let choose_idx = function [] -> None | x::l -> Some x in
+
+  let opt_zero_return_empty m = Some Vect.null in
+
+   
+  let opt_zero_return_ge m i mapping = 
+   let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter 
+    (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m 
+    (Itv (None, None)) in
+    match pick_closed_to_zero it with
+     | None -> print_endline "Cannot pick" ; None
+     | Some v -> 
+	let res =  (Vect.set i v mapping) in
+	 if debug 
+	 then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ;
+	 Some res in
+
+  let opt_zero_return_eq m eq i mapp = 
+   let (a,b) = evaluate_constraint i mapp eq in
+    Some (Vect.set i (div_num b a) mapp) in
+   
+   optimise_ge check_null opt_zero_choose 
+    choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq   m
+
+ let normalise cstr = [CstrBag.cstr_to_itv cstr]
+
+ let find_point l = 
+  (*  List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*)
+  try 
+   let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys) 
+    CstrBag.empty l in
+    match minimise m with
+     | None -> None
+     | Some res -> 
+	if debug then Printf.printf "[%s]"  (Vect.string res); 
+	Some res
+  with CstrBag.Contradiction -> None
+
+
+ let find_q_interval_for x m = 
+  if debug then Printf.printf "find_q_interval_for %i\n" x ;
+
+  let choose bound l c m =
+   let rec xchoose l = 
+    match l with
+     | [] -> None
+     | i::l -> if i = x then xchoose l else Some (project i m,i) in
+    xchoose l in
+
+  let rec choose_idx = function 
+    [] -> None 
+   | e::l -> if e = x then choose_idx l else Some e in
+
+  let return_empty m = (* Beurk *)
+   (* returns the interval of x *)
+   Some (CstrBag.fold (fun cstr itv -> 
+    let i = if cstr.op = Eq 
+    then Point (cstr.cst // Vect.get x cstr.coeffs)  
+     else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs) 
+     then  bound_of_constraint (Vect.get x cstr.coeffs  , cstr.cst) 
+     else itv
+   in
+		       Interval.inter i itv) m (Itv (None, None)))  in
+   
+  let return_ge m i res = Some res in
+
+  let return_eq m eq i res = Some res in
+
+   try 
+    optimise_ge 
+     (fun x -> false) choose choose_idx return_empty return_ge return_eq m
+   with CstrBag.Contradiction -> None
+
+
+ let find_q_intervals sys =
+  let variables =  
+   List.map fst (List.sort compare_status (CstrBag.status sys)) in
+   List.map (fun x -> (x,find_q_interval_for x sys)) variables
+
+ let pp_option f o = function 
+   None -> Printf.fprintf o "None" 
+  | Some x -> Printf.fprintf o "Some %a" f x
+
+ let optimise vect sys = 
+  (* we have to modify the system with a dummy variable *)
+  let fresh = 
+   List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in
+   assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys);
+   let cstr = {
+    coeffs = Vect.set fresh (Int (-1)) vect ; 
+    op = Eq ; 
+    cst = (Int 0)} in
+    try 
+     find_q_interval_for fresh 
+      (List.fold_left 
+	(fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)  
+	CstrBag.empty (cstr::sys))
+    with CstrBag.Contradiction -> None
+
+
+ let optimise vect sys = 
+  let res = optimise vect sys in 
+   if debug 
+   then Printf.printf "optimise %s -> %a\n" 
+    (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res  
+   ; res
+
+ let find_Q_interval sys = 
+  try 
+   let sys = 
+    (List.fold_left 
+      (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)  CstrBag.empty sys) in
+   let candidates = 
+    List.fold_left 
+     (fun l (x,i) -> match i with 
+       None -> (x,Empty)::l 
+      | Some i ->  (x,i)::l) [] (find_q_intervals sys) in
+    match List.fold_left 
+     (fun (x1,i1) (x2,i2) -> 
+      if smaller_itv i1 i2 
+      then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates 
+    with
+     | (i,Empty) -> None
+     | (x,Itv(Some i, Some j))  -> Some(i,x,j)
+     | (x,Point n) -> Some(n,x,n)
+     |   _        -> None
+  with CstrBag.Contradiction -> None
+
+
+end
+
diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml
new file mode 100644
index 00000000..e151e4e1
--- /dev/null
+++ b/contrib/micromega/micromega.ml
@@ -0,0 +1,1512 @@
+type __ = Obj.t
+let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+type bool =
+  | True
+  | False
+
+(** val negb : bool -> bool **)
+
+let negb = function
+  | True -> False
+  | False -> True
+
+type nat =
+  | O
+  | S of nat
+
+type 'a option =
+  | Some of 'a
+  | None
+
+type ('a, 'b) prod =
+  | Pair of 'a * 'b
+
+type comparison =
+  | Eq
+  | Lt
+  | Gt
+
+(** val compOpp : comparison -> comparison **)
+
+let compOpp = function
+  | Eq -> Eq
+  | Lt -> Gt
+  | Gt -> Lt
+
+type sumbool =
+  | Left
+  | Right
+
+type 'a sumor =
+  | Inleft of 'a
+  | Inright
+
+type 'a list =
+  | Nil
+  | Cons of 'a * 'a list
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+  match l with
+    | Nil -> m
+    | Cons (a, l1) -> Cons (a, (app l1 m))
+
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+
+let rec nth n0 l default =
+  match n0 with
+    | O -> (match l with
+              | Nil -> default
+              | Cons (x, l') -> x)
+    | S m ->
+        (match l with
+           | Nil -> default
+           | Cons (x, t0) -> nth m t0 default)
+
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+
+let rec map f = function
+  | Nil -> Nil
+  | Cons (a, t0) -> Cons ((f a), (map f t0))
+
+type positive =
+  | XI of positive
+  | XO of positive
+  | XH
+
+(** val psucc : positive -> positive **)
+
+let rec psucc = function
+  | XI p -> XO (psucc p)
+  | XO p -> XI p
+  | XH -> XO XH
+
+(** val pplus : positive -> positive -> positive **)
+
+let rec pplus x y =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> XO (pplus_carry p q0)
+           | XO q0 -> XI (pplus p q0)
+           | XH -> XO (psucc p))
+    | XO p ->
+        (match y with
+           | XI q0 -> XI (pplus p q0)
+           | XO q0 -> XO (pplus p q0)
+           | XH -> XI p)
+    | XH ->
+        (match y with
+           | XI q0 -> XO (psucc q0)
+           | XO q0 -> XI q0
+           | XH -> XO XH)
+
+(** val pplus_carry : positive -> positive -> positive **)
+
+and pplus_carry x y =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> XI (pplus_carry p q0)
+           | XO q0 -> XO (pplus_carry p q0)
+           | XH -> XI (psucc p))
+    | XO p ->
+        (match y with
+           | XI q0 -> XO (pplus_carry p q0)
+           | XO q0 -> XI (pplus p q0)
+           | XH -> XO (psucc p))
+    | XH ->
+        (match y with
+           | XI q0 -> XI (psucc q0)
+           | XO q0 -> XO (psucc q0)
+           | XH -> XI XH)
+
+(** val p_of_succ_nat : nat -> positive **)
+
+let rec p_of_succ_nat = function
+  | O -> XH
+  | S x -> psucc (p_of_succ_nat x)
+
+(** val pdouble_minus_one : positive -> positive **)
+
+let rec pdouble_minus_one = function
+  | XI p -> XI (XO p)
+  | XO p -> XI (pdouble_minus_one p)
+  | XH -> XH
+
+type positive_mask =
+  | IsNul
+  | IsPos of positive
+  | IsNeg
+
+(** val pdouble_plus_one_mask : positive_mask -> positive_mask **)
+
+let pdouble_plus_one_mask = function
+  | IsNul -> IsPos XH
+  | IsPos p -> IsPos (XI p)
+  | IsNeg -> IsNeg
+
+(** val pdouble_mask : positive_mask -> positive_mask **)
+
+let pdouble_mask = function
+  | IsNul -> IsNul
+  | IsPos p -> IsPos (XO p)
+  | IsNeg -> IsNeg
+
+(** val pdouble_minus_two : positive -> positive_mask **)
+
+let pdouble_minus_two = function
+  | XI p -> IsPos (XO (XO p))
+  | XO p -> IsPos (XO (pdouble_minus_one p))
+  | XH -> IsNul
+
+(** val pminus_mask : positive -> positive -> positive_mask **)
+
+let rec pminus_mask x y =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> pdouble_mask (pminus_mask p q0)
+           | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0)
+           | XH -> IsPos (XO p))
+    | XO p ->
+        (match y with
+           | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+           | XO q0 -> pdouble_mask (pminus_mask p q0)
+           | XH -> IsPos (pdouble_minus_one p))
+    | XH -> (match y with
+               | XH -> IsNul
+               | _ -> IsNeg)
+
+(** val pminus_mask_carry : positive -> positive -> positive_mask **)
+
+and pminus_mask_carry x y =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+           | XO q0 -> pdouble_mask (pminus_mask p q0)
+           | XH -> IsPos (pdouble_minus_one p))
+    | XO p ->
+        (match y with
+           | XI q0 -> pdouble_mask (pminus_mask_carry p q0)
+           | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+           | XH -> pdouble_minus_two p)
+    | XH -> IsNeg
+
+(** val pminus : positive -> positive -> positive **)
+
+let pminus x y =
+  match pminus_mask x y with
+    | IsPos z0 -> z0
+    | _ -> XH
+
+(** val pmult : positive -> positive -> positive **)
+
+let rec pmult x y =
+  match x with
+    | XI p -> pplus y (XO (pmult p y))
+    | XO p -> XO (pmult p y)
+    | XH -> y
+
+(** val pcompare : positive -> positive -> comparison -> comparison **)
+
+let rec pcompare x y r =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> pcompare p q0 r
+           | XO q0 -> pcompare p q0 Gt
+           | XH -> Gt)
+    | XO p ->
+        (match y with
+           | XI q0 -> pcompare p q0 Lt
+           | XO q0 -> pcompare p q0 r
+           | XH -> Gt)
+    | XH -> (match y with
+               | XH -> r
+               | _ -> Lt)
+
+type n =
+  | N0
+  | Npos of positive
+
+type z =
+  | Z0
+  | Zpos of positive
+  | Zneg of positive
+
+(** val zdouble_plus_one : z -> z **)
+
+let zdouble_plus_one = function
+  | Z0 -> Zpos XH
+  | Zpos p -> Zpos (XI p)
+  | Zneg p -> Zneg (pdouble_minus_one p)
+
+(** val zdouble_minus_one : z -> z **)
+
+let zdouble_minus_one = function
+  | Z0 -> Zneg XH
+  | Zpos p -> Zpos (pdouble_minus_one p)
+  | Zneg p -> Zneg (XI p)
+
+(** val zdouble : z -> z **)
+
+let zdouble = function
+  | Z0 -> Z0
+  | Zpos p -> Zpos (XO p)
+  | Zneg p -> Zneg (XO p)
+
+(** val zPminus : positive -> positive -> z **)
+
+let rec zPminus x y =
+  match x with
+    | XI p ->
+        (match y with
+           | XI q0 -> zdouble (zPminus p q0)
+           | XO q0 -> zdouble_plus_one (zPminus p q0)
+           | XH -> Zpos (XO p))
+    | XO p ->
+        (match y with
+           | XI q0 -> zdouble_minus_one (zPminus p q0)
+           | XO q0 -> zdouble (zPminus p q0)
+           | XH -> Zpos (pdouble_minus_one p))
+    | XH ->
+        (match y with
+           | XI q0 -> Zneg (XO q0)
+           | XO q0 -> Zneg (pdouble_minus_one q0)
+           | XH -> Z0)
+
+(** val zplus : z -> z -> z **)
+
+let zplus x y =
+  match x with
+    | Z0 -> y
+    | Zpos x' ->
+        (match y with
+           | Z0 -> Zpos x'
+           | Zpos y' -> Zpos (pplus x' y')
+           | Zneg y' ->
+               (match pcompare x' y' Eq with
+                  | Eq -> Z0
+                  | Lt -> Zneg (pminus y' x')
+                  | Gt -> Zpos (pminus x' y')))
+    | Zneg x' ->
+        (match y with
+           | Z0 -> Zneg x'
+           | Zpos y' ->
+               (match pcompare x' y' Eq with
+                  | Eq -> Z0
+                  | Lt -> Zpos (pminus y' x')
+                  | Gt -> Zneg (pminus x' y'))
+           | Zneg y' -> Zneg (pplus x' y'))
+
+(** val zopp : z -> z **)
+
+let zopp = function
+  | Z0 -> Z0
+  | Zpos x0 -> Zneg x0
+  | Zneg x0 -> Zpos x0
+
+(** val zminus : z -> z -> z **)
+
+let zminus m n0 =
+  zplus m (zopp n0)
+
+(** val zmult : z -> z -> z **)
+
+let zmult x y =
+  match x with
+    | Z0 -> Z0
+    | Zpos x' ->
+        (match y with
+           | Z0 -> Z0
+           | Zpos y' -> Zpos (pmult x' y')
+           | Zneg y' -> Zneg (pmult x' y'))
+    | Zneg x' ->
+        (match y with
+           | Z0 -> Z0
+           | Zpos y' -> Zneg (pmult x' y')
+           | Zneg y' -> Zpos (pmult x' y'))
+
+(** val zcompare : z -> z -> comparison **)
+
+let zcompare x y =
+  match x with
+    | Z0 -> (match y with
+               | Z0 -> Eq
+               | Zpos y' -> Lt
+               | Zneg y' -> Gt)
+    | Zpos x' -> (match y with
+                    | Zpos y' -> pcompare x' y' Eq
+                    | _ -> Gt)
+    | Zneg x' ->
+        (match y with
+           | Zneg y' -> compOpp (pcompare x' y' Eq)
+           | _ -> Lt)
+
+(** val dcompare_inf : comparison -> sumbool sumor **)
+
+let dcompare_inf = function
+  | Eq -> Inleft Left
+  | Lt -> Inleft Right
+  | Gt -> Inright
+
+(** val zcompare_rec :
+    z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+
+let zcompare_rec x y h1 h2 h3 =
+  match dcompare_inf (zcompare x y) with
+    | Inleft x0 -> (match x0 with
+                      | Left -> h1 __
+                      | Right -> h2 __)
+    | Inright -> h3 __
+
+(** val z_gt_dec : z -> z -> sumbool **)
+
+let z_gt_dec x y =
+  zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left)
+
+(** val zle_bool : z -> z -> bool **)
+
+let zle_bool x y =
+  match zcompare x y with
+    | Gt -> False
+    | _ -> True
+
+(** val zge_bool : z -> z -> bool **)
+
+let zge_bool x y =
+  match zcompare x y with
+    | Lt -> False
+    | _ -> True
+
+(** val zgt_bool : z -> z -> bool **)
+
+let zgt_bool x y =
+  match zcompare x y with
+    | Gt -> True
+    | _ -> False
+
+(** val zeq_bool : z -> z -> bool **)
+
+let zeq_bool x y =
+  match zcompare x y with
+    | Eq -> True
+    | _ -> False
+
+(** val n_of_nat : nat -> n **)
+
+let n_of_nat = function
+  | O -> N0
+  | S n' -> Npos (p_of_succ_nat n')
+
+(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **)
+
+let rec zdiv_eucl_POS a b =
+  match a with
+    | XI a' ->
+        let Pair (q0, r) = zdiv_eucl_POS a' b in
+        let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
+        (match zgt_bool b r' with
+           | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+           | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+               (zminus r' b)))
+    | XO a' ->
+        let Pair (q0, r) = zdiv_eucl_POS a' b in
+        let r' = zmult (Zpos (XO XH)) r in
+        (match zgt_bool b r' with
+           | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+           | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+               (zminus r' b)))
+    | XH ->
+        (match zge_bool b (Zpos (XO XH)) with
+           | True -> Pair (Z0, (Zpos XH))
+           | False -> Pair ((Zpos XH), Z0))
+
+(** val zdiv_eucl : z -> z -> (z, z) prod **)
+
+let zdiv_eucl a b =
+  match a with
+    | Z0 -> Pair (Z0, Z0)
+    | Zpos a' ->
+        (match b with
+           | Z0 -> Pair (Z0, Z0)
+           | Zpos p -> zdiv_eucl_POS a' b
+           | Zneg b' ->
+               let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+               (match r with
+                  | Z0 -> Pair ((zopp q0), Z0)
+                  | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r))))
+    | Zneg a' ->
+        (match b with
+           | Z0 -> Pair (Z0, Z0)
+           | Zpos p ->
+               let Pair (q0, r) = zdiv_eucl_POS a' b in
+               (match r with
+                  | Z0 -> Pair ((zopp q0), Z0)
+                  | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r)))
+           | Zneg b' ->
+               let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+               Pair (q0, (zopp r)))
+
+type 'c pol =
+  | Pc of 'c
+  | Pinj of positive * 'c pol
+  | PX of 'c pol * positive * 'c pol
+
+(** val p0 : 'a1 -> 'a1 pol **)
+
+let p0 cO =
+  Pc cO
+
+(** val p1 : 'a1 -> 'a1 pol **)
+
+let p1 cI =
+  Pc cI
+
+(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **)
+
+let rec peq ceqb p p' =
+  match p with
+    | Pc c -> (match p' with
+                 | Pc c' -> ceqb c c'
+                 | _ -> False)
+    | Pinj (j, q0) ->
+        (match p' with
+           | Pinj (j', q') ->
+               (match pcompare j j' Eq with
+                  | Eq -> peq ceqb q0 q'
+                  | _ -> False)
+           | _ -> False)
+    | PX (p2, i, q0) ->
+        (match p' with
+           | PX (p'0, i', q') ->
+               (match pcompare i i' Eq with
+                  | Eq ->
+                      (match peq ceqb p2 p'0 with
+                         | True -> peq ceqb q0 q'
+                         | False -> False)
+                  | _ -> False)
+           | _ -> False)
+
+(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
+
+let mkPinj_pred j p =
+  match j with
+    | XI j0 -> Pinj ((XO j0), p)
+    | XO j0 -> Pinj ((pdouble_minus_one j0), p)
+    | XH -> p
+
+(** val mkPX :
+    'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let mkPX cO ceqb p i q0 =
+  match p with
+    | Pc c ->
+        (match ceqb c cO with
+           | True ->
+               (match q0 with
+                  | Pc c0 -> q0
+                  | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+                  | PX (p2, p3, p4) -> Pinj (XH, q0))
+           | False -> PX (p, i, q0))
+    | Pinj (p2, p3) -> PX (p, i, q0)
+    | PX (p', i', q') ->
+        (match peq ceqb q' (p0 cO) with
+           | True -> PX (p', (pplus i' i), q0)
+           | False -> PX (p, i, q0))
+
+(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mkXi cO cI i =
+  PX ((p1 cI), i, (p0 cO))
+
+(** val mkX : 'a1 -> 'a1 -> 'a1 pol **)
+
+let mkX cO cI =
+  mkXi cO cI XH
+
+(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **)
+
+let rec popp copp = function
+  | Pc c -> Pc (copp c)
+  | Pinj (j, q0) -> Pinj (j, (popp copp q0))
+  | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0))
+
+(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
+
+let rec paddC cadd p c =
+  match p with
+    | Pc c1 -> Pc (cadd c1 c)
+    | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c))
+    | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c))
+
+(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
+
+let rec psubC csub p c =
+  match p with
+    | Pc c1 -> Pc (csub c1 c)
+    | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c))
+    | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c))
+
+(** val paddI :
+    ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
+    positive -> 'a1 pol -> 'a1 pol **)
+
+let rec paddI cadd pop q0 j = function
+  | Pc c ->
+      let p2 = paddC cadd q0 c in
+      (match p2 with
+         | Pc c0 -> p2
+         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+         | PX (p3, p4, p5) -> Pinj (j, p2))
+  | Pinj (j', q') ->
+      (match zPminus j' j with
+         | Z0 ->
+             let p2 = pop q' q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zpos k ->
+             let p2 = pop (Pinj (k, q')) q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zneg k ->
+             let p2 = paddI cadd pop q0 k q' in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j', p2)))
+  | PX (p2, i, q') ->
+      (match j with
+         | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q'))
+         | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q'))
+         | XH -> PX (p2, i, (pop q' q0)))
+
+(** val psubI :
+    ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
+    'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec psubI cadd copp pop q0 j = function
+  | Pc c ->
+      let p2 = paddC cadd (popp copp q0) c in
+      (match p2 with
+         | Pc c0 -> p2
+         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+         | PX (p3, p4, p5) -> Pinj (j, p2))
+  | Pinj (j', q') ->
+      (match zPminus j' j with
+         | Z0 ->
+             let p2 = pop q' q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zpos k ->
+             let p2 = pop (Pinj (k, q')) q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zneg k ->
+             let p2 = psubI cadd copp pop q0 k q' in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j', p2)))
+  | PX (p2, i, q') ->
+      (match j with
+         | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q'))
+         | XO j0 -> PX (p2, i,
+             (psubI cadd copp pop q0 (pdouble_minus_one j0) q'))
+         | XH -> PX (p2, i, (pop q' q0)))
+
+(** val paddX :
+    'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
+    -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec paddX cO ceqb pop p' i' p = match p with
+  | Pc c -> PX (p', i', p)
+  | Pinj (j, q') ->
+      (match j with
+         | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
+         | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q')))
+         | XH -> PX (p', i', q'))
+  | PX (p2, i, q') ->
+      (match zPminus i i' with
+         | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+         | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+         | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
+
+(** val psubX :
+    'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
+    pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec psubX cO copp ceqb pop p' i' p = match p with
+  | Pc c -> PX ((popp copp p'), i', p)
+  | Pinj (j, q') ->
+      (match j with
+         | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
+         | XO j0 -> PX ((popp copp p'), i', (Pinj (
+             (pdouble_minus_one j0), q')))
+         | XH -> PX ((popp copp p'), i', q'))
+  | PX (p2, i, q') ->
+      (match zPminus i i' with
+         | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+         | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+         | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
+
+(** val padd :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+    -> 'a1 pol **)
+
+let rec padd cO cadd ceqb p = function
+  | Pc c' -> paddC cadd p c'
+  | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p
+  | PX (p'0, i', q') ->
+      (match p with
+         | Pc c -> PX (p'0, i', (paddC cadd q' c))
+         | Pinj (j, q0) ->
+             (match j with
+                | XI j0 -> PX (p'0, i',
+                    (padd cO cadd ceqb (Pinj ((XO j0), q0)) q'))
+                | XO j0 -> PX (p'0, i',
+                    (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0))
+                      q'))
+                | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q')))
+         | PX (p2, i, q0) ->
+             (match zPminus i i' with
+                | Z0 ->
+                    mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i
+                      (padd cO cadd ceqb q0 q')
+                | Zpos k ->
+                    mkPX cO ceqb
+                      (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
+                      (padd cO cadd ceqb q0 q')
+                | Zneg k ->
+                    mkPX cO ceqb
+                      (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0
+                        k p2) i (padd cO cadd ceqb q0 q')))
+
+(** val psub :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+    -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+
+let rec psub cO cadd csub copp ceqb p = function
+  | Pc c' -> psubC csub p c'
+  | Pinj (j', q') ->
+      psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p
+  | PX (p'0, i', q') ->
+      (match p with
+         | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c))
+         | Pinj (j, q0) ->
+             (match j with
+                | XI j0 -> PX ((popp copp p'0), i',
+                    (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
+                | XO j0 -> PX ((popp copp p'0), i',
+                    (psub cO cadd csub copp ceqb (Pinj
+                      ((pdouble_minus_one j0), q0)) q'))
+                | XH -> PX ((popp copp p'0), i',
+                    (psub cO cadd csub copp ceqb q0 q')))
+         | PX (p2, i, q0) ->
+             (match zPminus i i' with
+                | Z0 ->
+                    mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
+                      (psub cO cadd csub copp ceqb q0 q')
+                | Zpos k ->
+                    mkPX cO ceqb
+                      (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
+                      i' (psub cO cadd csub copp ceqb q0 q')
+                | Zneg k ->
+                    mkPX cO ceqb
+                      (psubX cO copp ceqb (fun x x0 ->
+                        psub cO cadd csub copp ceqb x x0) p'0 k p2) i
+                      (psub cO cadd csub copp ceqb q0 q')))
+
+(** val pmulC_aux :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
+    'a1 pol **)
+
+let rec pmulC_aux cO cmul ceqb p c =
+  match p with
+    | Pc c' -> Pc (cmul c' c)
+    | Pinj (j, q0) ->
+        let p2 = pmulC_aux cO cmul ceqb q0 c in
+        (match p2 with
+           | Pc c0 -> p2
+           | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+           | PX (p3, p4, p5) -> Pinj (j, p2))
+    | PX (p2, i, q0) ->
+        mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i
+          (pmulC_aux cO cmul ceqb q0 c)
+
+(** val pmulC :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
+    'a1 -> 'a1 pol **)
+
+let pmulC cO cI cmul ceqb p c =
+  match ceqb c cO with
+    | True -> p0 cO
+    | False ->
+        (match ceqb c cI with
+           | True -> p
+           | False -> pmulC_aux cO cmul ceqb p c)
+
+(** val pmulI :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+    'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
+  | Pc c ->
+      let p2 = pmulC cO cI cmul ceqb q0 c in
+      (match p2 with
+         | Pc c0 -> p2
+         | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+         | PX (p3, p4, p5) -> Pinj (j, p2))
+  | Pinj (j', q') ->
+      (match zPminus j' j with
+         | Z0 ->
+             let p2 = pmul0 q' q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zpos k ->
+             let p2 = pmul0 (Pinj (k, q')) q0 in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j, p2))
+         | Zneg k ->
+             let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in
+             (match p2 with
+                | Pc c -> p2
+                | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+                | PX (p3, p4, p5) -> Pinj (j', p2)))
+  | PX (p', i', q') ->
+      (match j with
+         | XI j' ->
+             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+               (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q')
+         | XO j' ->
+             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+               (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q')
+         | XH ->
+             mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i'
+               (pmul0 q' q0))
+
+(** val pmul :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+
+let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
+  | Pc c -> pmulC cO cI cmul ceqb p c
+  | Pinj (j', q') ->
+      pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q'
+        j' p
+  | PX (p', i', q') ->
+      (match p with
+         | Pc c -> pmulC cO cI cmul ceqb p'' c
+         | Pinj (j, q0) ->
+             mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i'
+               (match j with
+                  | XI j0 ->
+                      pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
+                  | XO j0 ->
+                      pmul cO cI cadd cmul ceqb (Pinj
+                        ((pdouble_minus_one j0), q0)) q'
+                  | XH -> pmul cO cI cadd cmul ceqb q0 q')
+         | PX (p2, i, q0) ->
+             padd cO cadd ceqb
+               (mkPX cO ceqb
+                 (padd cO cadd ceqb
+                   (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO))
+                   (pmul cO cI cadd cmul ceqb
+                     (match q0 with
+                        | Pc c -> q0
+                        | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+                        | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' 
+                 (p0 cO))
+               (mkPX cO ceqb
+                 (pmulI cO cI cmul ceqb (fun x x0 ->
+                   pmul cO cI cadd cmul ceqb x x0) q' XH p2) i
+                 (pmul cO cI cadd cmul ceqb q0 q')))
+
+type 'c pExpr =
+  | PEc of 'c
+  | PEX of positive
+  | PEadd of 'c pExpr * 'c pExpr
+  | PEsub of 'c pExpr * 'c pExpr
+  | PEmul of 'c pExpr * 'c pExpr
+  | PEopp of 'c pExpr
+  | PEpow of 'c pExpr * n
+
+(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mk_X cO cI j =
+  mkPinj_pred j (mkX cO cI)
+
+(** val ppow_pos :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1
+    pol **)
+
+let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
+  | XI p3 ->
+      subst_l
+        (pmul cO cI cadd cmul ceqb
+          (ppow_pos cO cI cadd cmul ceqb subst_l
+            (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p)
+  | XO p3 ->
+      ppow_pos cO cI cadd cmul ceqb subst_l
+        (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3
+  | XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
+
+(** val ppow_N :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
+
+let ppow_N cO cI cadd cmul ceqb subst_l p = function
+  | N0 -> p1 cI
+  | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
+
+(** val norm_aux :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+
+let rec norm_aux cO cI cadd cmul csub copp ceqb = function
+  | PEc c -> Pc c
+  | PEX j -> mk_X cO cI j
+  | PEadd (pe1, pe2) ->
+      (match pe1 with
+         | PEopp pe3 ->
+             psub cO cadd csub copp ceqb
+               (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+               (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+         | _ ->
+             (match pe2 with
+                | PEopp pe3 ->
+                    psub cO cadd csub copp ceqb
+                      (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+                      (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+                | _ ->
+                    padd cO cadd ceqb
+                      (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+                      (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
+  | PEsub (pe1, pe2) ->
+      psub cO cadd csub copp ceqb
+        (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+        (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+  | PEmul (pe1, pe2) ->
+      pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+        (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+  | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+  | PEpow (pe1, n0) ->
+      ppow_N cO cI cadd cmul ceqb (fun p -> p)
+        (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0
+
+type 'a bFormula =
+  | TT
+  | FF
+  | X
+  | A of 'a
+  | Cj of 'a bFormula * 'a bFormula
+  | D of 'a bFormula * 'a bFormula
+  | N of 'a bFormula
+  | I of 'a bFormula * 'a bFormula
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+(** val tt : 'a1 cnf **)
+
+let tt =
+  Nil
+
+(** val ff : 'a1 cnf **)
+
+let ff =
+  Cons (Nil, Nil)
+
+(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
+
+let or_clause_cnf t0 f =
+  map (fun x -> app t0 x) f
+
+(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+let rec or_cnf f f' =
+  match f with
+    | Nil -> tt
+    | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f')
+
+(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+let and_cnf f1 f2 =
+  app f1 f2
+
+(** val xcnf :
+    ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
+
+let rec xcnf normalise0 negate0 pol0 = function
+  | TT -> (match pol0 with
+             | True -> tt
+             | False -> ff)
+  | FF -> (match pol0 with
+             | True -> ff
+             | False -> tt)
+  | X -> ff
+  | A x -> (match pol0 with
+              | True -> normalise0 x
+              | False -> negate0 x)
+  | Cj (e1, e2) ->
+      (match pol0 with
+         | True ->
+             and_cnf (xcnf normalise0 negate0 pol0 e1)
+               (xcnf normalise0 negate0 pol0 e2)
+         | False ->
+             or_cnf (xcnf normalise0 negate0 pol0 e1)
+               (xcnf normalise0 negate0 pol0 e2))
+  | D (e1, e2) ->
+      (match pol0 with
+         | True ->
+             or_cnf (xcnf normalise0 negate0 pol0 e1)
+               (xcnf normalise0 negate0 pol0 e2)
+         | False ->
+             and_cnf (xcnf normalise0 negate0 pol0 e1)
+               (xcnf normalise0 negate0 pol0 e2))
+  | N e -> xcnf normalise0 negate0 (negb pol0) e
+  | I (e1, e2) ->
+      (match pol0 with
+         | True ->
+             or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+               (xcnf normalise0 negate0 pol0 e2)
+         | False ->
+             and_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+               (xcnf normalise0 negate0 pol0 e2))
+
+(** val cnf_checker :
+    ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **)
+
+let rec cnf_checker checker f l =
+  match f with
+    | Nil -> True
+    | Cons (e, f0) ->
+        (match l with
+           | Nil -> False
+           | Cons (c, l0) ->
+               (match checker e c with
+                  | True -> cnf_checker checker f0 l0
+                  | False -> False))
+
+(** val tauto_checker :
+    ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
+    bFormula -> 'a3 list -> bool **)
+
+let tauto_checker normalise0 negate0 checker f w =
+  cnf_checker checker (xcnf normalise0 negate0 True f) w
+
+type 'c pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+  | Equal
+  | NonEqual
+  | Strict
+  | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+  | S_In of nat
+  | S_Ideal of 'c pExprC * 'c coneMember
+  | S_Square of 'c pExprC
+  | S_Monoid of monoidMember
+  | S_Mult of 'c coneMember * 'c coneMember
+  | S_Add of 'c coneMember * 'c coneMember
+  | S_Pos of 'c
+  | S_Z
+
+(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_times f f' =
+  let Pair (p, op) = f in
+  let Pair (p', op') = f' in
+  Pair ((PEmul (p, p')),
+  (match op with
+     | Equal -> Equal
+     | NonEqual -> NonEqual
+     | Strict -> op'
+     | NonStrict -> NonStrict))
+
+(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_plus f f' =
+  let Pair (p, op) = f in
+  let Pair (p', op') = f' in
+  Pair ((PEadd (p, p')),
+  (match op with
+     | Equal -> op'
+     | NonEqual -> NonEqual
+     | Strict -> Strict
+     | NonStrict -> (match op' with
+                       | Strict -> Strict
+                       | _ -> NonStrict)))
+
+(** val eval_monoid :
+    'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **)
+
+let rec eval_monoid cI l = function
+  | Nil -> PEc cI
+  | Cons (n0, ns0) -> PEmul
+      ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in
+       (match o with
+          | NonEqual -> q0
+          | _ -> PEc cI)), (eval_monoid cI l ns0))
+
+(** val eval_cone :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+    nFormula list -> 'a1 coneMember -> 'a1 nFormula **)
+
+let rec eval_cone cO cI ceqb cleb l = function
+  | S_In n0 ->
+      let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in
+      (match o with
+         | NonEqual -> Pair ((PEc cO), Equal)
+         | _ -> nth n0 l (Pair ((PEc cO), Equal)))
+  | S_Ideal (p, cm') ->
+      let f = eval_cone cO cI ceqb cleb l cm' in
+      let Pair (q0, op) = f in
+      (match op with
+         | Equal -> Pair ((PEmul (q0, p)), Equal)
+         | _ -> f)
+  | S_Square p -> Pair ((PEmul (p, p)), NonStrict)
+  | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict)
+  | S_Mult (p, q0) ->
+      nformula_times (eval_cone cO cI ceqb cleb l p)
+        (eval_cone cO cI ceqb cleb l q0)
+  | S_Add (p, q0) ->
+      nformula_plus (eval_cone cO cI ceqb cleb l p)
+        (eval_cone cO cI ceqb cleb l q0)
+  | S_Pos c ->
+      (match match cleb cO c with
+               | True -> negb (ceqb cO c)
+               | False -> False with
+         | True -> Pair ((PEc c), Strict)
+         | False -> Pair ((PEc cO), Equal))
+  | S_Z -> Pair ((PEc cO), Equal)
+
+(** val normalise_pexpr :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **)
+
+let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x =
+  norm_aux cO cI cplus ctimes cminus copp ceqb x
+
+(** val check_inconsistent :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+    -> 'a1 nFormula -> bool **)
+
+let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function
+  | Pair (e, op) ->
+      (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with
+         | Pc c ->
+             (match op with
+                | Equal -> negb (ceqb c cO)
+                | NonEqual -> False
+                | Strict -> cleb c cO
+                | NonStrict ->
+                    (match cleb c cO with
+                       | True -> negb (ceqb c cO)
+                       | False -> False))
+         | _ -> False)
+
+(** val check_normalised_formulas :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+    -> 'a1 nFormula list -> 'a1 coneMember -> bool **)
+
+let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm =
+  check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb
+    (eval_cone cO cI ceqb cleb l cm)
+
+type op2 =
+  | OpEq
+  | OpNEq
+  | OpLe
+  | OpGe
+  | OpLt
+  | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+(** val flhs : 'a1 formula -> 'a1 pExprC **)
+
+let flhs x = x.flhs
+
+(** val fop : 'a1 formula -> op2 **)
+
+let fop x = x.fop
+
+(** val frhs : 'a1 formula -> 'a1 pExprC **)
+
+let frhs x = x.frhs
+
+(** val xnormalise : 'a1 formula -> 'a1 nFormula list **)
+
+let xnormalise t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  (match o with
+     | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+         ((PEsub (rhs, lhs)), Strict)), Nil)))
+     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+     | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)
+     | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+     | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+     | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_normalise t0 =
+  map (fun x -> Cons (x, Nil)) (xnormalise t0)
+
+(** val xnegate : 'a1 formula -> 'a1 nFormula list **)
+
+let xnegate t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  (match o with
+     | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+         ((PEsub (rhs, lhs)), Strict)), Nil)))
+     | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+     | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+     | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+     | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil))
+
+(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_negate t0 =
+  map (fun x -> Cons (x, Nil)) (xnegate t0)
+
+(** val simpl_expr :
+    'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **)
+
+let rec simpl_expr cI ceqb e = match e with
+  | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y))
+  | PEmul (y, z0) ->
+      let y' = simpl_expr cI ceqb y in
+      (match y' with
+         | PEc c ->
+             (match ceqb c cI with
+                | True -> simpl_expr cI ceqb z0
+                | False -> PEmul (y', (simpl_expr cI ceqb z0)))
+         | _ -> PEmul (y', (simpl_expr cI ceqb z0)))
+  | _ -> e
+
+(** val simpl_cone :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
+    coneMember -> 'a1 coneMember **)
+
+let simpl_cone cO cI ctimes ceqb e = match e with
+  | S_Square t0 ->
+      (match simpl_expr cI ceqb t0 with
+         | PEc c ->
+             (match ceqb cO c with
+                | True -> S_Z
+                | False -> S_Pos (ctimes c c))
+         | _ -> S_Square (simpl_expr cI ceqb t0))
+  | S_Mult (t1, t2) ->
+      (match t1 with
+         | S_Mult (x, x0) ->
+             (match x with
+                | S_Pos p2 ->
+                    (match t2 with
+                       | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0)
+                       | S_Z -> S_Z
+                       | _ -> e)
+                | _ ->
+                    (match x0 with
+                       | S_Pos p2 ->
+                           (match t2 with
+                              | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x)
+                              | S_Z -> S_Z
+                              | _ -> e)
+                       | _ ->
+                           (match t2 with
+                              | S_Pos c ->
+                                  (match ceqb cI c with
+                                     | True -> t1
+                                     | False -> S_Mult (t1, t2))
+                              | S_Z -> S_Z
+                              | _ -> e)))
+         | S_Pos c ->
+             (match t2 with
+                | S_Mult (x, x0) ->
+                    (match x with
+                       | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0)
+                       | _ ->
+                           (match x0 with
+                              | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x)
+                              | _ ->
+                                  (match ceqb cI c with
+                                     | True -> t2
+                                     | False -> S_Mult (t1, t2))))
+                | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult
+                    ((S_Pos c), z0)))
+                | S_Pos c0 -> S_Pos (ctimes c c0)
+                | S_Z -> S_Z
+                | _ ->
+                    (match ceqb cI c with
+                       | True -> t2
+                       | False -> S_Mult (t1, t2)))
+         | S_Z -> S_Z
+         | _ ->
+             (match t2 with
+                | S_Pos c ->
+                    (match ceqb cI c with
+                       | True -> t1
+                       | False -> S_Mult (t1, t2))
+                | S_Z -> S_Z
+                | _ -> e))
+  | S_Add (t1, t2) ->
+      (match t1 with
+         | S_Z -> t2
+         | _ -> (match t2 with
+                   | S_Z -> t1
+                   | _ -> S_Add (t1, t2)))
+  | _ -> e
+
+type q = { qnum : z; qden : positive }
+
+(** val qnum : q -> z **)
+
+let qnum x = x.qnum
+
+(** val qden : q -> positive **)
+
+let qden x = x.qden
+
+(** val qplus : q -> q -> q **)
+
+let qplus x y =
+  { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)));
+    qden = (pmult x.qden y.qden) }
+
+(** val qmult : q -> q -> q **)
+
+let qmult x y =
+  { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) }
+
+(** val qopp : q -> q **)
+
+let qopp x =
+  { qnum = (zopp x.qnum); qden = x.qden }
+
+(** val qminus : q -> q -> q **)
+
+let qminus x y =
+  qplus x (qopp y)
+
+type 'a t =
+  | Empty
+  | Leaf of 'a
+  | Node of 'a t * 'a * 'a t
+
+(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
+
+let rec find default vm p =
+  match vm with
+    | Empty -> default
+    | Leaf i -> i
+    | Node (l, e, r) ->
+        (match p with
+           | XI p2 -> find default r p2
+           | XO p2 -> find default l p2
+           | XH -> e)
+
+type zWitness = z coneMember
+
+(** val zWeakChecker : z nFormula list -> z coneMember -> bool **)
+
+let zWeakChecker x x0 =
+  check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool
+    zle_bool x x0
+
+(** val xnormalise0 : z formula -> z nFormula list **)
+
+let xnormalise0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  (match o with
+     | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+         NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+         XH)))))), NonStrict)), Nil)))
+     | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+     | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+         NonStrict)), Nil)
+     | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+         NonStrict)), Nil)
+     | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+     | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val normalise : z formula -> z nFormula cnf **)
+
+let normalise t0 =
+  map (fun x -> Cons (x, Nil)) (xnormalise0 t0)
+
+(** val xnegate0 : z formula -> z nFormula list **)
+
+let xnegate0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  (match o with
+     | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+     | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+         NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+         XH)))))), NonStrict)), Nil)))
+     | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+     | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+     | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+         NonStrict)), Nil)
+     | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+         NonStrict)), Nil))
+
+(** val negate : z formula -> z nFormula cnf **)
+
+let negate t0 =
+  map (fun x -> Cons (x, Nil)) (xnegate0 t0)
+
+(** val ceiling : z -> z -> z **)
+
+let ceiling a b =
+  let Pair (q0, r) = zdiv_eucl a b in
+  (match r with
+     | Z0 -> q0
+     | _ -> zplus q0 (Zpos XH))
+
+type proofTerm =
+  | RatProof of zWitness
+  | CutProof of z pExprC * q * zWitness * proofTerm
+  | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+(** val makeLb : z pExpr -> q -> z nFormula **)
+
+let makeLb v q0 =
+  let { qnum = n0; qden = d } = q0 in
+  Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict)
+
+(** val qceiling : q -> z **)
+
+let qceiling q0 =
+  let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d)
+
+(** val makeLbCut : z pExprC -> q -> z nFormula **)
+
+let makeLbCut v q0 =
+  Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict)
+
+(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **)
+
+let neg_nformula = function
+  | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o)
+
+(** val cutChecker :
+    z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **)
+
+let cutChecker l e lb pf =
+  match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with
+    | True -> Some (makeLbCut e lb)
+    | False -> None
+
+(** val zChecker : z nFormula list -> proofTerm -> bool **)
+
+let rec zChecker l = function
+  | RatProof pf0 -> zWeakChecker l pf0
+  | CutProof (e, q0, pf0, rst) ->
+      (match cutChecker l e q0 pf0 with
+         | Some c -> zChecker (Cons (c, l)) rst
+         | None -> False)
+  | EnumProof (lb, e, ub, pf1, pf2, rst) ->
+      (match cutChecker l e lb pf1 with
+         | Some n0 ->
+             (match cutChecker l (PEopp e) (qopp ub) pf2 with
+                | Some n1 ->
+                    let rec label pfs lb0 ub0 =
+                      match pfs with
+                        | Nil ->
+                            (match z_gt_dec lb0 ub0 with
+                               | Left -> True
+                               | Right -> False)
+                        | Cons (pf0, rsr) ->
+                            (match zChecker (Cons ((Pair ((PEsub (e, (PEc
+                                     lb0))), Equal)), l)) pf0 with
+                               | True -> label rsr (zplus lb0 (Zpos XH)) ub0
+                               | False -> False)
+                    in label rst (qceiling lb) (zopp (qceiling (qopp ub)))
+                | None -> False)
+         | None -> False)
+
+(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **)
+
+let zTautoChecker f w =
+  tauto_checker normalise negate zChecker f w
+
+(** val map_cone : (nat -> nat) -> zWitness -> zWitness **)
+
+let rec map_cone f e = match e with
+  | S_In n0 -> S_In (f n0)
+  | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm))
+  | S_Monoid l -> S_Monoid (map f l)
+  | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2))
+  | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2))
+  | _ -> e
+
+(** val indexes : zWitness -> nat list **)
+
+let rec indexes = function
+  | S_In n0 -> Cons (n0, Nil)
+  | S_Ideal (e0, cm) -> indexes cm
+  | S_Monoid l -> l
+  | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+  | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+  | _ -> Nil
+
+(** val n_of_Z : z -> n **)
+
+let n_of_Z = function
+  | Zpos p -> Npos p
+  | _ -> N0
+
+(** val qeq_bool : q -> q -> bool **)
+
+let qeq_bool p q0 =
+  zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden))
+
+(** val qle_bool : q -> q -> bool **)
+
+let qle_bool x y =
+  zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
+
+type qWitness = q coneMember
+
+(** val qWeakChecker : q nFormula list -> q coneMember -> bool **)
+
+let qWeakChecker x x0 =
+  check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+    qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0
+
+(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
+
+let qTautoChecker f w =
+  tauto_checker (fun x -> cnf_normalise x) (fun x -> 
+    cnf_negate x) qWeakChecker f w
+
diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli
new file mode 100644
index 00000000..f94f091e
--- /dev/null
+++ b/contrib/micromega/micromega.mli
@@ -0,0 +1,398 @@
+type __ = Obj.t
+
+type bool =
+  | True
+  | False
+
+val negb : bool -> bool
+
+type nat =
+  | O
+  | S of nat
+
+type 'a option =
+  | Some of 'a
+  | None
+
+type ('a, 'b) prod =
+  | Pair of 'a * 'b
+
+type comparison =
+  | Eq
+  | Lt
+  | Gt
+
+val compOpp : comparison -> comparison
+
+type sumbool =
+  | Left
+  | Right
+
+type 'a sumor =
+  | Inleft of 'a
+  | Inright
+
+type 'a list =
+  | Nil
+  | Cons of 'a * 'a list
+
+val app : 'a1 list -> 'a1 list -> 'a1 list
+
+val nth : nat -> 'a1 list -> 'a1 -> 'a1
+
+val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
+
+type positive =
+  | XI of positive
+  | XO of positive
+  | XH
+
+val psucc : positive -> positive
+
+val pplus : positive -> positive -> positive
+
+val pplus_carry : positive -> positive -> positive
+
+val p_of_succ_nat : nat -> positive
+
+val pdouble_minus_one : positive -> positive
+
+type positive_mask =
+  | IsNul
+  | IsPos of positive
+  | IsNeg
+
+val pdouble_plus_one_mask : positive_mask -> positive_mask
+
+val pdouble_mask : positive_mask -> positive_mask
+
+val pdouble_minus_two : positive -> positive_mask
+
+val pminus_mask : positive -> positive -> positive_mask
+
+val pminus_mask_carry : positive -> positive -> positive_mask
+
+val pminus : positive -> positive -> positive
+
+val pmult : positive -> positive -> positive
+
+val pcompare : positive -> positive -> comparison -> comparison
+
+type n =
+  | N0
+  | Npos of positive
+
+type z =
+  | Z0
+  | Zpos of positive
+  | Zneg of positive
+
+val zdouble_plus_one : z -> z
+
+val zdouble_minus_one : z -> z
+
+val zdouble : z -> z
+
+val zPminus : positive -> positive -> z
+
+val zplus : z -> z -> z
+
+val zopp : z -> z
+
+val zminus : z -> z -> z
+
+val zmult : z -> z -> z
+
+val zcompare : z -> z -> comparison
+
+val dcompare_inf : comparison -> sumbool sumor
+
+val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+
+val z_gt_dec : z -> z -> sumbool
+
+val zle_bool : z -> z -> bool
+
+val zge_bool : z -> z -> bool
+
+val zgt_bool : z -> z -> bool
+
+val zeq_bool : z -> z -> bool
+
+val n_of_nat : nat -> n
+
+val zdiv_eucl_POS : positive -> z -> (z, z) prod
+
+val zdiv_eucl : z -> z -> (z, z) prod
+
+type 'c pol =
+  | Pc of 'c
+  | Pinj of positive * 'c pol
+  | PX of 'c pol * positive * 'c pol
+
+val p0 : 'a1 -> 'a1 pol
+
+val p1 : 'a1 -> 'a1 pol
+
+val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
+
+val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
+
+val mkPX :
+  'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val mkX : 'a1 -> 'a1 -> 'a1 pol
+
+val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
+
+val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val paddI :
+  ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
+  positive -> 'a1 pol -> 'a1 pol
+
+val psubI :
+  ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
+  'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val paddX :
+  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
+  -> positive -> 'a1 pol -> 'a1 pol
+
+val psubX :
+  'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
+  pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val padd :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
+  'a1 pol
+
+val psub :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+  -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val pmulC_aux :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1
+  pol
+
+val pmulC :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+  -> 'a1 pol
+
+val pmulI :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+  'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val pmul :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+type 'c pExpr =
+  | PEc of 'c
+  | PEX of positive
+  | PEadd of 'c pExpr * 'c pExpr
+  | PEsub of 'c pExpr * 'c pExpr
+  | PEmul of 'c pExpr * 'c pExpr
+  | PEopp of 'c pExpr
+  | PEpow of 'c pExpr * n
+
+val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val ppow_pos :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
+
+val ppow_N :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
+
+val norm_aux :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+
+type 'a bFormula =
+  | TT
+  | FF
+  | X
+  | A of 'a
+  | Cj of 'a bFormula * 'a bFormula
+  | D of 'a bFormula * 'a bFormula
+  | N of 'a bFormula
+  | I of 'a bFormula * 'a bFormula
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+val tt : 'a1 cnf
+
+val ff : 'a1 cnf
+
+val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf
+
+val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
+
+val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
+
+val xcnf :
+  ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
+
+val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
+
+val tauto_checker :
+  ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
+  bFormula -> 'a3 list -> bool
+
+type 'c pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+  | Equal
+  | NonEqual
+  | Strict
+  | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+  | S_In of nat
+  | S_Ideal of 'c pExprC * 'c coneMember
+  | S_Square of 'c pExprC
+  | S_Monoid of monoidMember
+  | S_Mult of 'c coneMember * 'c coneMember
+  | S_Add of 'c coneMember * 'c coneMember
+  | S_Pos of 'c
+  | S_Z
+
+val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC
+
+val eval_cone :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula
+  list -> 'a1 coneMember -> 'a1 nFormula
+
+val normalise_pexpr :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC
+
+val check_inconsistent :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+  nFormula -> bool
+
+val check_normalised_formulas :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+  nFormula list -> 'a1 coneMember -> bool
+
+type op2 =
+  | OpEq
+  | OpNEq
+  | OpLe
+  | OpGe
+  | OpLt
+  | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+val flhs : 'a1 formula -> 'a1 pExprC
+
+val fop : 'a1 formula -> op2
+
+val frhs : 'a1 formula -> 'a1 pExprC
+
+val xnormalise : 'a1 formula -> 'a1 nFormula list
+
+val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf
+
+val xnegate : 'a1 formula -> 'a1 nFormula list
+
+val cnf_negate : 'a1 formula -> 'a1 nFormula cnf
+
+val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC
+
+val simpl_cone :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember
+  -> 'a1 coneMember
+
+type q = { qnum : z; qden : positive }
+
+val qnum : q -> z
+
+val qden : q -> positive
+
+val qplus : q -> q -> q
+
+val qmult : q -> q -> q
+
+val qopp : q -> q
+
+val qminus : q -> q -> q
+
+type 'a t =
+  | Empty
+  | Leaf of 'a
+  | Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
+
+type zWitness = z coneMember
+
+val zWeakChecker : z nFormula list -> z coneMember -> bool
+
+val xnormalise0 : z formula -> z nFormula list
+
+val normalise : z formula -> z nFormula cnf
+
+val xnegate0 : z formula -> z nFormula list
+
+val negate : z formula -> z nFormula cnf
+
+val ceiling : z -> z -> z
+
+type proofTerm =
+  | RatProof of zWitness
+  | CutProof of z pExprC * q * zWitness * proofTerm
+  | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+val makeLb : z pExpr -> q -> z nFormula
+
+val qceiling : q -> z
+
+val makeLbCut : z pExprC -> q -> z nFormula
+
+val neg_nformula : z nFormula -> (z pExpr, op1) prod
+
+val cutChecker :
+  z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option
+
+val zChecker : z nFormula list -> proofTerm -> bool
+
+val zTautoChecker : z formula bFormula -> proofTerm list -> bool
+
+val map_cone : (nat -> nat) -> zWitness -> zWitness
+
+val indexes : zWitness -> nat list
+
+val n_of_Z : z -> n
+
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
+type qWitness = q coneMember
+
+val qWeakChecker : q nFormula list -> q coneMember -> bool
+
+val qTautoChecker : q formula bFormula -> qWitness list -> bool
+
diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml
new file mode 100644
index 00000000..2473608f
--- /dev/null
+++ b/contrib/micromega/mutils.ml
@@ -0,0 +1,305 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+let debug = false
+
+let fst' (Micromega.Pair(x,y)) = x
+let snd' (Micromega.Pair(x,y)) = y
+
+let rec try_any l x = 
+ match l with
+  | [] -> None
+  | (f,s)::l -> match f x with
+     | None -> try_any l x
+     | x -> x
+
+let list_try_find f =
+  let rec try_find_f = function
+    | [] -> failwith "try_find"
+    | h::t -> try f h with Failure _ -> try_find_f t
+  in
+  try_find_f
+
+let rec list_fold_right_elements f l =
+  let rec aux = function
+    | [] -> invalid_arg "list_fold_right_elements"
+    | [x] -> x
+    | x::l -> f x (aux l) in
+  aux l
+
+let interval n m = 
+  let rec interval_n (l,m) =
+    if n > m then l else interval_n (m::l,pred m)
+  in 
+  interval_n ([],m)
+
+open Num
+open Big_int
+
+let ppcm x y = 
+ let g = gcd_big_int x y in
+ let x' = div_big_int x g in
+ let y' = div_big_int y g in
+  mult_big_int g (mult_big_int x' y')
+
+
+let denominator = function
+ | Int _ | Big_int _ -> unit_big_int
+ | Ratio r -> Ratio.denominator_ratio r
+
+let numerator = function
+ | Ratio r -> Ratio.numerator_ratio r
+ | Int i -> Big_int.big_int_of_int i
+ | Big_int i -> i
+
+let rec ppcm_list c l =
+ match l with
+  | [] -> c
+  | e::l -> ppcm_list (ppcm c (denominator e)) l
+
+let rec rec_gcd_list c l  = 
+ match l with
+  | [] -> c
+  | e::l -> rec_gcd_list (gcd_big_int  c (numerator e)) l
+
+let rec gcd_list l = 
+ let res = rec_gcd_list zero_big_int l in
+  if compare_big_int res zero_big_int = 0 
+  then unit_big_int else res
+   
+   
+   
+let rats_to_ints l = 
+ let c = ppcm_list unit_big_int l in
+  List.map (fun x ->  (div_big_int (mult_big_int (numerator x) c) 
+			(denominator x))) l
+   
+(* Nasty reordering of lists - useful to trim certificate down *)
+let mapi f l =
+ let rec xmapi i l = 
+  match l with
+   | []   -> []
+   | e::l ->  (f e i)::(xmapi (i+1) l) in
+  xmapi 0 l
+
+
+let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l)
+
+(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *)
+let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l))
+
+let assoc_pos_assoc l = 
+ let rec xpos i l =
+  match l with
+   | [] -> []
+   | (x,l) ::rst -> let (l',j) = assoc_pos i l in 
+		     (x,l')::(xpos j rst) in
+  xpos 0 l
+
+let filter_pos f l =
+ (* Could sort ... take care of duplicates... *)
+ let rec xfilter l =
+  match l with
+   | []  -> []
+   | (x,e)::l -> 
+      if List.exists (fun ee -> List.mem ee f) (List.map snd e)
+      then (x,e)::(xfilter l)
+      else xfilter l in
+  xfilter l
+
+let  select_pos lpos l =
+ let rec xselect i lpos l =
+  match lpos with
+   | [] -> []
+   | j::rpos -> 
+      match l with
+       | []   -> failwith "select_pos"
+       | e::l -> 
+	  if i = j 
+	  then e:: (xselect (i+1) rpos l)
+	  else xselect (i+1) lpos l in
+  xselect 0 lpos l
+
+
+module CoqToCaml =
+struct
+ open Micromega
+
+ let rec nat = function
+  | O -> 0
+  | S n -> (nat n) + 1
+
+
+ let rec positive p = 
+  match p with
+   | XH -> 1
+   | XI p -> 1+ 2*(positive p)
+   | XO p -> 2*(positive p)
+
+
+ let n nt =
+  match nt with
+   | N0 -> 0
+   | Npos p -> positive p
+
+
+ let rec index i = (* Swap left-right ? *)
+  match i with
+   | XH -> 1
+   | XI i -> 1+(2*(index i))
+   | XO i -> 2*(index i)
+
+
+ let z x = 
+  match x with
+   | Z0 -> 0
+   | Zpos p -> (positive p)
+   | Zneg p -> - (positive p)
+
+ open Big_int
+
+ let rec positive_big_int p =
+  match p with
+   | XH -> unit_big_int
+   | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
+   | XO p -> (mult_int_big_int 2 (positive_big_int p))
+
+
+ let z_big_int x = 
+  match x with
+   | Z0 -> zero_big_int
+   | Zpos p -> (positive_big_int p)
+   | Zneg p -> minus_big_int (positive_big_int p)
+
+
+ let num x = Num.Big_int (z_big_int x)
+
+ let rec list elt l =
+  match l with
+   | Nil -> []
+   | Cons(e,l) -> (elt e)::(list elt l)
+
+ let q_to_num {qnum = x ; qden = y} = 
+  Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
+  
+end
+
+
+module CamlToCoq =
+struct
+ open Micromega
+
+ let rec nat = function
+  | 0 -> O
+  | n -> S (nat (n-1))
+
+
+ let rec positive n =
+  if n=1 then XH
+  else if n land 1 = 1 then XI (positive (n lsr 1))
+  else  XO (positive (n lsr 1))
+
+ let  n nt = 
+  if nt < 0 
+  then assert false
+  else if nt = 0 then N0
+  else Npos (positive nt)
+
+
+   
+
+   
+ let rec index  n =
+  if n=1 then XH
+  else if n land 1 = 1 then XI (index (n lsr 1))
+  else  XO (index (n lsr 1))
+
+
+ let idx n = 
+  (*a.k.a path_of_int *)
+  (* returns the list of digits of n in reverse order with
+     initial 1 removed *)
+  let rec digits_of_int n =
+   if n=1 then [] 
+   else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+  in
+   List.fold_right 
+    (fun b c -> (if b then XI c else XO c))
+    (List.rev (digits_of_int n))
+    (XH)
+
+    
+
+ let z x = 
+  match compare x 0 with
+   | 0 -> Z0
+   | 1 -> Zpos (positive x)
+   | _ -> (* this should be -1 *)
+      Zneg (positive (-x)) 
+
+ open Big_int
+
+ let positive_big_int n = 
+  let two = big_int_of_int 2 in 
+  let rec _pos n = 
+   if eq_big_int n unit_big_int then XH
+   else
+    let (q,m) = quomod_big_int n two  in
+     if eq_big_int unit_big_int m 
+     then XI (_pos q)
+     else XO (_pos q) in
+   _pos n
+
+ let bigint x = 
+  match sign_big_int x with
+   | 0 -> Z0
+   | 1 -> Zpos (positive_big_int x)
+   | _ -> Zneg (positive_big_int (minus_big_int x))
+
+ let q n = 
+  {Micromega.qnum = bigint (numerator n) ; 
+   Micromega.qden = positive_big_int (denominator n)}
+
+
+ let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil
+
+end
+
+module Cmp =
+struct
+
+ let rec compare_lexical l = 
+  match l with
+   | [] -> 0 (* Equal *)
+   | f::l -> 
+      let cmp = f () in
+       if cmp = 0 	then  compare_lexical l else cmp
+
+ let rec compare_list cmp l1 l2 = 
+  match l1 , l2 with
+   | []  , [] -> 0
+   | []  , _  -> -1
+   | _   , [] -> 1
+   | e1::l1 , e2::l2 -> 
+      let c = cmp e1 e2 in
+       if c = 0 then compare_list cmp l1 l2 else c
+	
+ let hash_list hash l = 
+  let rec _hash_list l h =
+   match l with
+    | []  -> h lxor (Hashtbl.hash [])
+    | e::l -> _hash_list l   ((hash e)  lxor h) in
+
+   _hash_list  l 0
+end
diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml
new file mode 100644
index 00000000..e3d72ed9
--- /dev/null
+++ b/contrib/micromega/sos.ml
@@ -0,0 +1,1919 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.20                *)
+(*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(*   independent bits                                                        *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* - Addition of a csdp cache by the Coq development team                    *)
+(* ========================================================================= *)
+
+(* ========================================================================= *)
+(* Nonlinear universal reals procedure using SOS decomposition.              *)
+(* ========================================================================= *)
+
+open Num;;
+open List;;
+
+let debugging = ref false;;
+
+exception Sanity;;
+
+exception Unsolvable;;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparisons that are reflexive on NaN and also short-circuiting.          *)
+(* ------------------------------------------------------------------------- *)
+
+let (=?) = fun x y -> Pervasives.compare x y = 0;;
+let (<?) = fun x y -> Pervasives.compare x y < 0;;
+let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
+let (>?) = fun x y -> Pervasives.compare x y > 0;;
+let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* Combinators.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let (o) = fun f g x -> f(g x);;
+
+(* ------------------------------------------------------------------------- *)
+(* Some useful functions on "num" type.                                      *)
+(* ------------------------------------------------------------------------- *)
+
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10;;
+
+let pow2 n = power_num num_2 (Int n);;
+let pow10 n = power_num num_10 (Int n);;
+
+let numdom r =
+  let r' = Ratio.normalize_ratio (ratio_of_num r) in
+  num_of_big_int(Ratio.numerator_ratio r'),
+  num_of_big_int(Ratio.denominator_ratio r');;
+
+let numerator = (o) fst numdom
+and denominator = (o) snd numdom;;
+
+let gcd_num n1 n2 =
+  num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
+
+let lcm_num x y =
+  if x =/ num_0 & y =/ num_0 then num_0
+  else abs_num((x */ y) // gcd_num x y);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* List basics.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let rec el n l =
+  if n = 0 then hd l else el (n - 1) (tl l);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Various versions of list iteration.                                       *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itlist f l b =
+  match l with
+    [] -> b
+  | (h::t) -> f h (itlist f t b);;
+
+let rec end_itlist f l =
+  match l with
+        []     -> failwith "end_itlist"
+      | [x]    -> x
+      | (h::t) -> f h (end_itlist f t);;
+
+let rec itlist2 f l1 l2 b =
+  match (l1,l2) with
+    ([],[]) -> b
+  | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
+  | _ -> failwith "itlist2";;
+
+(* ------------------------------------------------------------------------- *)
+(* All pairs arising from applying a function over two lists.                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpairs f l1 l2 =
+  match l1 with
+   h1::t1 ->  itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
+  | [] -> [];;
+
+(* ------------------------------------------------------------------------- *)
+(* String operations (surely there is a better way...)                       *)
+(* ------------------------------------------------------------------------- *)
+
+let implode l = itlist (^) l "";;
+
+let explode s =
+  let rec exap n l =
+      if n < 0 then l else
+      exap (n - 1) ((String.sub s n 1)::l) in
+  exap (String.length s - 1) [];;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Attempting function or predicate applications.                            *)
+(* ------------------------------------------------------------------------- *)
+
+let can f x = try (f x; true) with Failure _ -> false;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Repetition of a function.                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let rec funpow n f x =
+  if n < 1 then x else funpow (n-1) f (f x);;
+
+
+(* ------------------------------------------------------------------------- *)
+(*  term??                                                                   *)
+(* ------------------------------------------------------------------------- *)
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Data structure for Positivstellensatz refutations.                        *)
+(* ------------------------------------------------------------------------- *)
+
+type positivstellensatz =
+   Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of num
+ | Rational_le of num
+ | Rational_lt of num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* Replication and sequences.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec replicate x n =
+    if n < 1 then []
+    else x::(replicate x (n - 1));;
+
+let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Various useful list operations.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let rec forall p l =
+  match l with
+    [] -> true
+  | h::t -> p(h) & forall p t;;
+
+let rec tryfind f l =
+  match l with
+      [] -> failwith "tryfind"
+    | (h::t) -> try f h with Failure _ -> tryfind f t;;
+
+let index x =
+  let rec ind n l =
+    match l with
+      [] -> failwith "index"
+    | (h::t) -> if x =? h then n else ind (n + 1) t in
+  ind 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* "Set" operations on lists.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec mem x lis =
+  match lis with
+    [] -> false
+  | (h::t) -> x =? h or mem x t;;
+
+let insert x l =
+  if mem x l then l else x::l;;
+
+let union l1 l2 = itlist insert l1 l2;;
+
+let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Merging and bottom-up mergesort.                                          *)
+(* ------------------------------------------------------------------------- *)
+
+let rec merge ord l1 l2 =
+  match l1 with
+    [] -> l2
+  | h1::t1 -> match l2 with
+                [] -> l1
+              | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
+                          else h2::(merge ord l1 t2);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Common measure predicates to use with "sort".                             *)
+(* ------------------------------------------------------------------------- *)
+
+let increasing f x y = f x <? f y;;
+
+let decreasing f x y = f x >? f y;;
+
+(* ------------------------------------------------------------------------- *)
+(* Zipping, unzipping etc.                                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let rec zip l1 l2 =
+  match (l1,l2) with
+        ([],[]) -> []
+      | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
+      | _ -> failwith "zip";;
+
+let rec unzip =
+  function [] -> [],[]
+         | ((a,b)::rest) -> let alist,blist = unzip rest in
+                            (a::alist,b::blist);;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterating functions over lists.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let rec do_list f l =
+  match l with
+    [] -> ()
+  | (h::t) -> (f h; do_list f t);;
+
+(* ------------------------------------------------------------------------- *)
+(* Sorting.                                                                  *)
+(* ------------------------------------------------------------------------- *)
+
+let rec sort cmp lis =
+  match lis with
+    [] -> []
+  | piv::rest ->
+      let r,l = partition (cmp piv) rest in
+      (sort cmp l) @ (piv::(sort cmp r));;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing adjacent (NB!) equal elements from list.                         *)
+(* ------------------------------------------------------------------------- *)
+
+let rec uniq l =
+  match l with
+    x::(y::_ as t) -> let t' = uniq t in
+                      if x =? y then t' else
+                      if t'==t then l else x::t'
+ | _ -> l;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert list into set by eliminating duplicates.                          *)
+(* ------------------------------------------------------------------------- *)
+
+let setify s = uniq (sort (<=?) s);;
+
+(* ------------------------------------------------------------------------- *)
+(* Polymorphic finite partial functions via Patricia trees.                  *)
+(*                                                                           *)
+(* The point of this strange representation is that it is canonical (equal   *)
+(* functions have the same encoding) yet reasonably efficient on average.    *)
+(*                                                                           *)
+(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).        *)
+(* ------------------------------------------------------------------------- *)
+
+type ('a,'b)func =
+   Empty
+ | Leaf of int * ('a*'b)list
+ | Branch of int * int * ('a,'b)func * ('a,'b)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefined function.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+let undefined = Empty;;
+
+(* ------------------------------------------------------------------------- *)
+(* In case of equality comparison worries, better use this.                  *)
+(* ------------------------------------------------------------------------- *)
+
+let is_undefined f =
+  match f with
+    Empty -> true
+  | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operation analagous to "map" for lists.                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let mapf =
+  let rec map_list f l =
+    match l with
+      [] -> []
+    | (x,y)::t -> (x,f(y))::(map_list f t) in
+  let rec mapf f t =
+    match t with
+      Empty -> Empty
+    | Leaf(h,l) -> Leaf(h,map_list f l)
+    | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
+  mapf;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operations analogous to "fold" for lists.                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let foldl =
+  let rec foldl_list f a l =
+    match l with
+      [] -> a
+    | (x,y)::t -> foldl_list f (f a x y) t in
+  let rec foldl f a t =
+    match t with
+      Empty -> a
+    | Leaf(h,l) -> foldl_list f a l
+    | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
+  foldl;;
+
+let foldr =
+  let rec foldr_list f l a =
+    match l with
+      [] -> a
+    | (x,y)::t -> f x y (foldr_list f t a) in
+  let rec foldr f t a =
+    match t with
+      Empty -> a
+    | Leaf(h,l) -> foldr_list f l a
+    | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
+  foldr;;
+
+(* ------------------------------------------------------------------------- *)
+(* Redefinition and combination.                                             *)
+(* ------------------------------------------------------------------------- *)
+
+let (|->),combine =
+  let ldb x y = let z = x lxor y in z land (-z) in
+  let newbranch p1 t1 p2 t2 =
+    let b = ldb p1 p2 in
+    let p = p1 land (b - 1) in
+    if p1 land b = 0 then Branch(p,b,t1,t2)
+    else Branch(p,b,t2,t1) in
+  let rec define_list (x,y as xy) l =
+    match l with
+      (a,b as ab)::t ->
+          if x =? a then xy::t
+          else if x <? a then xy::l
+          else ab::(define_list xy t)
+    | [] -> [xy]
+  and combine_list op z l1 l2 =
+    match (l1,l2) with
+      [],_ -> l2
+    | _,[] -> l1
+    | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
+          if x1 <? x2 then xy1::(combine_list op z t1 l2)
+          else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
+          let y = op y1 y2 and l = combine_list op z t1 t2 in
+          if z(y) then l else (x1,y)::l in
+  let (|->) x y =
+    let k = Hashtbl.hash x in
+    let rec upd t =
+      match t with
+        Empty -> Leaf (k,[x,y])
+      | Leaf(h,l) ->
+           if h = k then Leaf(h,define_list (x,y) l)
+           else newbranch h t k (Leaf(k,[x,y]))
+      | Branch(p,b,l,r) ->
+          if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
+          else if k land b = 0 then Branch(p,b,upd l,r)
+          else Branch(p,b,l,upd r) in
+    upd in
+  let rec combine op z t1 t2 =
+    match (t1,t2) with
+      Empty,_ -> t2
+    | _,Empty -> t1
+    | Leaf(h1,l1),Leaf(h2,l2) ->
+          if h1 = h2 then
+            let l = combine_list op z l1 l2 in
+            if l = [] then Empty else Leaf(h1,l)
+          else newbranch h1 t1 h2 t2
+    | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
+      (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
+          if k land (b - 1) = p then
+            if k land b = 0 then
+              let l' = combine op z lf l in
+              if is_undefined l' then r else Branch(p,b,l',r)
+            else
+              let r' = combine op z lf r in
+              if is_undefined r' then l else Branch(p,b,l,r')
+          else
+            newbranch k lf p br
+    | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
+          if b1 < b2 then
+            if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
+            else if p2 land b1 = 0 then
+              let l = combine op z l1 t2 in
+              if is_undefined l then r1 else Branch(p1,b1,l,r1)
+            else
+              let r = combine op z r1 t2 in
+              if is_undefined r then l1 else Branch(p1,b1,l1,r)
+          else if b2 < b1 then
+            if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
+            else if p1 land b2 = 0 then
+              let l = combine op z t1 l2 in
+              if is_undefined l then r2 else Branch(p2,b2,l,r2)
+            else
+              let r = combine op z t1 r2 in
+              if is_undefined r then l2 else Branch(p2,b2,l2,r)
+          else if p1 = p2 then
+            let l = combine op z l1 l2 and r = combine op z r1 r2 in
+            if is_undefined l then r
+            else if is_undefined r then l else Branch(p1,b1,l,r)
+          else
+            newbranch p1 t1 p2 t2 in
+  (|->),combine;;
+
+(* ------------------------------------------------------------------------- *)
+(* Special case of point function.                                           *)
+(* ------------------------------------------------------------------------- *)
+
+let (|=>) = fun x y -> (x |-> y) undefined;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Grab an arbitrary element.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let rec choose t =
+  match t with
+    Empty -> failwith "choose: completely undefined function"
+  | Leaf(h,l) -> hd l
+  | Branch(b,p,t1,t2) -> choose t1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Application.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let applyd =
+  let rec apply_listd l d x =
+    match l with
+      (a,b)::t -> if x =? a then b
+                  else if x >? a then apply_listd t d x else d x
+    | [] -> d x in
+  fun f d x ->
+    let k = Hashtbl.hash x in
+    let rec look t =
+      match t with
+        Leaf(h,l) when h = k -> apply_listd l d x
+      | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
+      | _ -> d x in
+    look f;;
+
+let apply f = applyd f (fun x -> failwith "apply");;
+
+let tryapplyd f a d = applyd f (fun x -> d) a;;
+
+let defined f x = try apply f x; true with Failure _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefinition.                                                             *)
+(* ------------------------------------------------------------------------- *)
+
+let undefine =
+  let rec undefine_list x l =
+    match l with
+      (a,b as ab)::t ->
+          if x =? a then t
+          else if x <? a then l else
+          let t' = undefine_list x t in
+          if t' == t then l else ab::t'
+    | [] -> [] in
+  fun x ->
+    let k = Hashtbl.hash x in
+    let rec und t =
+      match t with
+        Leaf(h,l) when h = k ->
+          let l' = undefine_list x l in
+          if l' == l then t
+          else if l' = [] then Empty
+          else Leaf(h,l')
+      | Branch(p,b,l,r) when k land (b - 1) = p ->
+          if k land b = 0 then
+            let l' = und l in
+            if l' == l then t
+            else if is_undefined l' then r
+            else Branch(p,b,l',r)
+          else
+            let r' = und r in
+            if r' == r then t
+            else if is_undefined r' then l
+            else Branch(p,b,l,r')
+      | _ -> t in
+    und;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to sorted-list representation of the graph, domain and range.     *)
+(* ------------------------------------------------------------------------- *)
+
+let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
+
+let dom f = setify(foldl (fun a x y -> x::a) [] f);;
+
+let ran f = setify(foldl (fun a x y -> y::a) [] f);;
+
+(* ------------------------------------------------------------------------- *)
+(* Turn a rational into a decimal string with d sig digits.                  *)
+(* ------------------------------------------------------------------------- *)
+
+let decimalize =
+  let rec normalize y =
+    if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1
+    else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1
+    else 0 in
+  fun d x ->
+    if x =/ Int 0 then "0.0" else
+    let y = abs_num x in
+    let e = normalize y in
+    let z = pow10(-e) */ y +/ Int 1 in
+    let k = round_num(pow10 d */ z) in
+    (if x </ Int 0 then "-0." else "0.") ^
+    implode(tl(explode(string_of_num k))) ^
+    (if e = 0 then "" else "e"^string_of_int e);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Iterations over numbers, and lists indexed by numbers.                    *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itern k l f a =
+  match l with
+    [] -> a
+  | h::t -> itern (k + 1) t f (f h k a);;
+
+let rec iter (m,n) f a =
+  if n < m then a
+  else iter (m+1,n) f (f m a);;
+
+(* ------------------------------------------------------------------------- *)
+(* The main types.                                                           *)
+(* ------------------------------------------------------------------------- *)
+
+type vector = int*(int,num)func;;
+
+type matrix = (int*int)*(int*int,num)func;;
+
+type monomial = (vname,int)func;;
+
+type poly = (monomial,num)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Assignment avoiding zeros.                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;;
+
+(* ------------------------------------------------------------------------- *)
+(* This can be generic.                                                      *)
+(* ------------------------------------------------------------------------- *)
+
+let element (d,v) i = tryapplyd v i (Int 0);;
+
+let mapa f (d,v) =
+  d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;;
+
+let is_zero (d,v) =
+  match v with
+    Empty -> true
+  | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Vectors. Conventionally indexed 1..n.                                     *)
+(* ------------------------------------------------------------------------- *)
+
+let vector_0 n = (n,undefined:vector);;
+
+let dim (v:vector) = fst v;;
+
+let vector_const c n =
+  if c =/ Int 0 then vector_0 n
+  else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);;
+
+let vector_1 = vector_const (Int 1);;
+
+let vector_cmul c (v:vector) =
+  let n = dim v in
+  if c =/ Int 0 then vector_0 n
+  else n,mapf (fun x -> c */ x) (snd v);;
+
+let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);;
+
+let vector_add (v1:vector) (v2:vector) =
+  let m = dim v1 and n = dim v2 in
+  if m <> n then failwith "vector_add: incompatible dimensions" else
+  (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);;
+
+let vector_sub v1 v2 = vector_add v1 (vector_neg v2);;
+
+let vector_of_list l =
+  let n = length l in
+  (n,itlist2 (|->) (1--n) l undefined :vector);;
+
+(* ------------------------------------------------------------------------- *)
+(* Matrices; again rows and columns indexed from 1.                          *)
+(* ------------------------------------------------------------------------- *)
+
+let matrix_0 (m,n) = ((m,n),undefined:matrix);;
+
+let dimensions (m:matrix) = fst m;;
+
+let matrix_const c (m,n as mn) =
+  if m <> n then failwith "matrix_const: needs to be square"
+  else if c =/ Int 0 then matrix_0 mn
+  else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);;
+
+let matrix_1 = matrix_const (Int 1);;
+
+let matrix_cmul c (m:matrix) =
+  let (i,j) = dimensions m in
+  if c =/ Int 0 then matrix_0 (i,j)
+  else (i,j),mapf (fun x -> c */ x) (snd m);;
+
+let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);;
+
+let matrix_add (m1:matrix) (m2:matrix) =
+  let d1 = dimensions m1 and d2 = dimensions m2 in
+  if d1 <> d2 then failwith "matrix_add: incompatible dimensions"
+  else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);;
+
+let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);;
+
+let row k (m:matrix) =
+  let i,j = dimensions m in
+  (j,
+   foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m)
+   : vector);;
+
+let column k (m:matrix) =
+  let i,j = dimensions m in
+  (i,
+   foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m)
+   : vector);;
+
+let transp (m:matrix) =
+  let i,j = dimensions m in
+  ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);;
+
+let diagonal (v:vector) =
+  let n = dim v in
+  ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
+
+let matrix_of_list l =
+  let m = length l in
+  if m = 0 then matrix_0 (0,0) else
+  let n = length (hd l) in
+  (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
+
+(* ------------------------------------------------------------------------- *)
+(* Monomials.                                                                *)
+(* ------------------------------------------------------------------------- *)
+
+let monomial_eval assig (m:monomial) =
+  foldl (fun a x k -> a */ power_num (apply assig x) (Int k))
+        (Int 1) m;;
+
+let monomial_1 = (undefined:monomial);;
+
+let monomial_var x = (x |=> 1 :monomial);;
+
+let (monomial_mul:monomial->monomial->monomial) =
+  combine (+) (fun x -> false);;
+
+let monomial_pow (m:monomial) k =
+  if k = 0 then monomial_1
+  else mapf (fun x -> k * x) m;;
+
+let monomial_divides (m1:monomial) (m2:monomial) =
+  foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
+
+let monomial_div (m1:monomial) (m2:monomial) =
+  let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
+  if foldl (fun a x k -> k >= 0 & a) true m then m
+  else failwith "monomial_div: non-divisible";;
+
+let monomial_degree x (m:monomial) = tryapplyd m x 0;;
+
+let monomial_lcm (m1:monomial) (m2:monomial) =
+  (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2))
+          (union (dom m1) (dom m2)) undefined :monomial);;
+
+let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;;
+
+let monomial_variables m = dom m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Polynomials.                                                              *)
+(* ------------------------------------------------------------------------- *)
+
+let eval assig (p:poly) =
+  foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;;
+
+let poly_0 = (undefined:poly);;
+
+let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
+
+let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
+
+let poly_const c =
+  if c =/ Int 0 then poly_0 else (monomial_1 |=> c);;
+
+let poly_cmul c (p:poly) =
+  if c =/ Int 0 then poly_0
+  else mapf (fun x -> c */ x) p;;
+
+let poly_neg (p:poly) = (mapf minus_num p :poly);;
+
+let poly_add (p1:poly) (p2:poly) =
+  (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);;
+
+let poly_sub p1 p2 = poly_add p1 (poly_neg p2);;
+
+let poly_cmmul (c,m) (p:poly) =
+  if c =/ Int 0 then poly_0
+  else if m = monomial_1 then mapf (fun d -> c */ d) p
+  else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;;
+
+let poly_mul (p1:poly) (p2:poly) =
+  foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;;
+
+let poly_div (p1:poly) (p2:poly) =
+  if not(poly_isconst p2) then failwith "poly_div: non-constant" else
+  let c = eval undefined p2 in
+  if c =/ Int 0 then failwith "poly_div: division by zero"
+  else poly_cmul (Int 1 // c) p1;;
+
+let poly_square p = poly_mul p p;;
+
+let rec poly_pow p k =
+  if k = 0 then poly_const (Int 1)
+  else if k = 1 then p
+  else let q = poly_square(poly_pow p (k / 2)) in
+       if k mod 2 = 1 then poly_mul p q else q;;
+
+let poly_exp p1 p2 =
+  if not(poly_isconst p2) then failwith "poly_exp: not a constant" else
+  poly_pow p1 (Num.int_of_num (eval undefined p2));;
+
+let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;;
+
+let multidegree (p:poly) =
+  foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;;
+
+let poly_variables (p:poly) =
+  foldr (fun m c -> union (monomial_variables m)) p [];;
+
+(* ------------------------------------------------------------------------- *)
+(* Order monomials for human presentation.                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);;
+
+let humanorder_monomial =
+  let rec ord l1 l2 = match (l1,l2) with
+    _,[] -> true
+  | [],_ -> false
+  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in
+  fun m1 m2 -> m1 = m2 or
+               ord (sort humanorder_varpow (graph m1))
+                   (sort humanorder_varpow (graph m2));;
+
+(* ------------------------------------------------------------------------- *)
+(* Conversions to strings.                                                   *)
+(* ------------------------------------------------------------------------- *)
+
+let string_of_vector min_size max_size (v:vector) =
+  let n_raw = dim v in
+  if n_raw = 0 then "[]" else
+  let n = max min_size (min n_raw max_size) in
+  let xs = map ((o) string_of_num (element v)) (1--n) in
+  "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
+  (if n_raw > max_size then ", ...]" else "]");;
+
+let string_of_matrix max_size (m:matrix) =
+  let i_raw,j_raw = dimensions m in
+  let i = min max_size i_raw and j = min max_size j_raw in
+  let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
+  "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
+  (if j > max_size then "\n ...]" else "]");;
+
+let string_of_vname (v:vname): string = (v: string);;
+
+let rec string_of_term t =
+  match t with
+  Opp t1 -> "(- " ^ string_of_term t1 ^ ")"
+| Add (t1, t2) -> 
+   "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")"
+| Sub (t1, t2) -> 
+   "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")"
+| Mul (t1, t2) -> 
+   "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")"
+| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")"
+| Div (t1, t2) -> 
+   "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")"
+| Pow (t1, n1) -> 
+   "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")"
+| Zero -> "0"
+| Var v -> "x" ^ (string_of_vname v)
+| Const x -> string_of_num x;;
+
+
+let string_of_varpow x k =
+  if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;;
+
+let string_of_monomial m =
+  if m = monomial_1 then "1" else
+  let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a)
+                            (sort humanorder_varpow (graph m)) [] in
+  end_itlist (fun s t -> s^"*"^t) vps;;
+
+let string_of_cmonomial (c,m) =
+  if m = monomial_1 then string_of_num c
+  else if c =/ Int 1 then string_of_monomial m
+  else string_of_num c ^ "*" ^ string_of_monomial m;;
+
+let string_of_poly (p:poly) =
+  if p = poly_0 then "<<0>>" else
+  let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in
+  let s =
+    List.fold_left (fun a (m,c) ->
+             if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m)
+             else a ^ " + " ^ string_of_cmonomial(c,m))
+          "" cms in
+  let s1 = String.sub s 0 3
+  and s2 = String.sub s 3 (String.length s - 3) in
+  "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";;
+
+(* ------------------------------------------------------------------------- *)
+(* Printers.                                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let print_vector v = Format.print_string(string_of_vector 0 20 v);;
+
+let print_matrix m = Format.print_string(string_of_matrix 20 m);;
+
+let print_monomial m = Format.print_string(string_of_monomial m);;
+
+let print_poly m = Format.print_string(string_of_poly m);;
+
+(*
+#install_printer print_vector;;
+#install_printer print_matrix;;
+#install_printer print_monomial;;
+#install_printer print_poly;;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Conversion from term.                                                     *)
+(* ------------------------------------------------------------------------- *)
+
+let rec poly_of_term t = match t with
+  Zero -> poly_0 
+| Const n -> poly_const n
+| Var x -> poly_var x
+| Opp t1 -> poly_neg (poly_of_term t1)
+| Inv t1 -> 
+      let p = poly_of_term t1 in
+      if poly_isconst p then poly_const(Int 1 // eval undefined p)
+      else failwith "poly_of_term: inverse of non-constant polyomial"
+| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
+| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
+| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
+| Div (l, r) ->
+      let p = poly_of_term l and q = poly_of_term r in
+      if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p
+      else failwith "poly_of_term: division by non-constant polynomial"
+| Pow (t, n) ->
+      poly_pow (poly_of_term t) n;;
+
+(* ------------------------------------------------------------------------- *)
+(* String of vector (just a list of space-separated numbers).                *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_vector (v:vector) =
+  let n = dim v in
+  let strs = map (o (decimalize 20) (element v)) (1--n) in
+  end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k.                              *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+  let pfx = string_of_int k ^" " in
+  let ents =
+    foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+  let entss = sort (increasing fst) ents in
+  itlist (fun ((b,i,j),c) a ->
+     pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for a matrix numbered k, in SDPA sparse format.                    *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_matrix k (m:matrix) =
+  let pfx = string_of_int k ^ " 1 " in
+  let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
+                 (snd m) [] in
+  let mss = sort (increasing fst) ms in
+  itlist (fun ((i,j),c) a ->
+     pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String in SDPA sparse format for standard SDP problem:                    *)
+(*                                                                           *)
+(*    X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD                *)
+(*    Minimize obj_1 * v_1 + ... obj_m * v_m                                 *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_problem comment obj mats =
+  let m = length mats - 1
+  and n,_ = dimensions (hd mats) in
+  "\"" ^ comment ^ "\"\n" ^
+  string_of_int m ^ "\n" ^
+  "1\n" ^
+  string_of_int n ^ "\n" ^
+  sdpa_of_vector obj ^
+  itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
+          (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* More parser basics.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+exception Noparse;;
+
+
+let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
+  let charcode s = Char.code(String.get s 0) in
+  let spaces = " \t\n\r"
+  and separators = ",;"
+  and brackets = "()[]{}"
+  and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
+  and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+  and nums = "0123456789" in
+  let allchars = spaces^separators^brackets^symbs^alphas^nums in
+  let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
+  let ctable = Array.make csetsize 0 in
+  do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
+  do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
+  do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
+  do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
+  do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
+  do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
+  let isspace c = Array.get ctable (charcode c) = 1
+  and issep c  = Array.get ctable (charcode c) = 2
+  and isbra c  = Array.get ctable (charcode c) = 4
+  and issymb c = Array.get ctable (charcode c) = 8
+  and isalpha c = Array.get ctable (charcode c) = 16
+  and isnum c = Array.get ctable (charcode c) = 32
+  and isalnum c = Array.get ctable (charcode c) >= 16 in
+  isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
+
+let (||) parser1 parser2 input =
+  try parser1 input
+  with Noparse -> parser2 input;;
+
+let (++) parser1 parser2 input =
+  let result1,rest1 = parser1 input in
+  let result2,rest2 = parser2 rest1 in
+  (result1,result2),rest2;;
+
+let rec many prs input =
+  try let result,next = prs input in
+      let results,rest = many prs next in
+      (result::results),rest
+  with Noparse -> [],input;;
+
+let (>>) prs treatment input =
+  let result,rest = prs input in
+  treatment(result),rest;;
+
+let fix err prs input =
+  try prs input
+  with Noparse -> failwith (err ^ " expected");;
+
+let rec listof prs sep err =
+  prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
+
+let possibly prs input =
+  try let x,rest = prs input in [x],rest
+  with Noparse -> [],input;;
+
+let some p =
+  function
+      [] -> raise Noparse
+    | (h::t) -> if p h then (h,t) else raise Noparse;;
+
+let a tok = some (fun item -> item = tok);;
+
+let rec atleast n prs i =
+  (if n <= 0 then many prs
+   else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
+
+let finished input =
+  if input = [] then 0,input else failwith "Unparsed input";;
+
+let word s =
+   end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
+              (map a (explode s));;
+
+let token s =
+  many (some isspace) ++ word s ++ many (some isspace)
+  >> (fun ((_,t),_) -> t);;
+
+let decimal =
+  let numeral = some isnum in
+  let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
+  let decimalfrac = atleast 1 numeral
+    >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
+  let decimalsig =
+    decimalint ++ possibly (a "." ++ decimalfrac >> snd)
+    >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in
+  let signed prs =
+       a "-" ++ prs >> ((o) minus_num snd)
+    || a "+" ++ prs >> snd
+    || prs in
+  let exponent = (a "e" || a "E") ++ signed decimalint >> snd in
+    signed decimalsig ++ possibly exponent
+    >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ -> 
+     failwith "exponent");;
+
+let mkparser p s =
+  let x,rst = p(explode s) in
+  if rst = [] then x else failwith "mkparser: unparsed input";;
+
+let parse_decimal = mkparser decimal;;
+
+(* ------------------------------------------------------------------------- *)
+(* Parse back a vector.                                                      *)
+(* ------------------------------------------------------------------------- *)
+
+let parse_csdpoutput =
+  let rec skipupto dscr prs inp =
+      (dscr ++ prs >> snd
+    || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+  let ignore inp = (),[] in
+  let csdpoutput =
+    (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
+    (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
+  mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* CSDP parameters; so far I'm sticking with the defaults.                   *)
+(* ------------------------------------------------------------------------- *)
+
+let csdp_default_parameters =
+"axtol=1.0e-8
+atytol=1.0e-8
+objtol=1.0e-8
+pinftol=1.0e8
+dinftol=1.0e8
+maxiter=100
+minstepfrac=0.9
+maxstepfrac=0.97
+minstepp=1.0e-8
+minstepd=1.0e-8
+usexzgap=1
+tweakgap=0
+affine=0
+printlevel=1
+";;
+
+let csdp_params = csdp_default_parameters;;
+
+(* ------------------------------------------------------------------------- *)
+(* The same thing with CSDP.                                                 *)
+(* Modified by the Coq development team to use a cache                       *)
+(* ------------------------------------------------------------------------- *)
+
+let buffer_add_line buff line =
+  Buffer.add_string buff line; Buffer.add_char buff '\n'
+
+let string_of_file filename =
+  let fd = open_in filename in
+  let buff = Buffer.create 16 in
+  try while true do buffer_add_line buff (input_line fd) done; failwith ""
+  with End_of_file -> (close_in fd; Buffer.contents buff)
+
+let file_of_string filename s =
+  let fd = Pervasives.open_out filename in
+  output_string fd s; close_out fd
+
+let request_mark = "*** REQUEST ***"
+let answer_mark  = "*** ANSWER ***"
+let end_mark     = "*** END ***"
+let infeasible_mark = "Infeasible\n"
+let failure_mark    = "Failure\n"
+
+let cache_name = "csdp.cache"
+
+let look_in_cache string_problem =
+  let n = String.length string_problem in
+  try
+    let inch = open_in cache_name in
+    let rec search () =
+      while input_line inch <> request_mark do () done;
+      let i = ref 0 in
+      while !i < n & string_problem.[!i] = input_char inch do incr i done;
+      if !i < n or input_line inch <> answer_mark then
+	search ()
+      else begin
+	let buff = Buffer.create 16 in
+	let line = ref (input_line inch) in
+	while (!line <> end_mark) do
+	  buffer_add_line buff !line; line := input_line inch
+	done;
+	close_in inch;
+	Buffer.contents buff
+      end in
+    try search () with End_of_file -> close_in inch; raise Not_found
+  with Sys_error _ -> raise Not_found
+
+let flush_to_cache string_problem string_result =
+  try
+    let flags = [Open_append;Open_text;Open_creat] in
+    let outch = open_out_gen flags 0o666 cache_name in
+    begin 
+    try
+      Printf.fprintf outch "%s\n" request_mark;
+      Printf.fprintf outch "%s" string_problem;
+      Printf.fprintf outch "%s\n" answer_mark;
+      Printf.fprintf outch "%s" string_result;
+      Printf.fprintf outch "%s\n" end_mark;
+    with Sys_error _ as e -> close_out outch; raise e
+    end;
+    close_out outch
+  with Sys_error _ -> 
+    print_endline "Warning: Could not open or write to csdp cache"
+
+exception CsdpInfeasible
+
+let run_csdp dbg string_problem =
+  try
+   let res = look_in_cache string_problem in
+   if res = infeasible_mark then raise CsdpInfeasible;
+   if res = failure_mark then failwith "csdp error";
+   res
+  with Not_found ->
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file = Filename.temp_file "sos" ".dat-s" in
+  let temp_path = Filename.dirname input_file in
+  let params_file = Filename.concat temp_path "param.csdp" in
+  file_of_string input_file string_problem;
+  file_of_string params_file csdp_params;
+  let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^
+                       (if dbg then "" else "> /dev/null")) in
+  if rv = 1 or rv = 2 then 
+    (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible);
+  if rv = 127 then
+     (print_string "csdp not found, exiting..."; exit 1);
+  if rv <> 0 & rv <> 3 (* reduced accuracy *) then
+    (flush_to_cache string_problem failure_mark;
+     failwith("csdp: error "^string_of_int rv));
+  let string_result = string_of_file output_file in
+  flush_to_cache string_problem string_result;
+  if not dbg then
+    (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file);
+  string_result
+
+let csdp obj mats =
+  try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats))
+  with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* Try some apparently sensible scaling first. Note that this is purely to   *)
+(* get a cleaner translation to floating-point, and doesn't affect any of    *)
+(* the results, in principle. In practice it seems a lot better when there   *)
+(* are extreme numbers in the original problem.                              *)
+(* ------------------------------------------------------------------------- *)
+
+let scale_then =
+  let common_denominator amat acc =
+    foldl (fun a m c -> lcm_num (denominator c) a) acc amat
+  and maximal_element amat acc =
+    foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in
+  fun solver obj mats ->
+    let cd1 = itlist common_denominator mats (Int 1)
+    and cd2 = common_denominator (snd obj)  (Int 1) in
+    let mats' = map (mapf (fun x -> cd1 */ x)) mats
+    and obj' = vector_cmul cd2 obj in
+    let max1 = itlist maximal_element mats' (Int 0)
+    and max2 = maximal_element (snd obj') (Int 0) in
+    let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
+    and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
+    let mats'' = map (mapf (fun x -> x */ scal1)) mats'
+    and obj'' = vector_cmul scal2 obj' in
+    solver obj'' mats'';;
+
+(* ------------------------------------------------------------------------- *)
+(* Round a vector to "nice" rationals.                                       *)
+(* ------------------------------------------------------------------------- *)
+
+let nice_rational n x = round_num (n */ x) // n;;
+
+let nice_vector n = mapa (nice_rational n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)
+(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants).   *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program_basic a =
+  let m,n = dimensions a in
+  let mats =  map (fun j -> diagonal (column j a)) (1--n)
+  and obj = vector_const (Int 1) m in
+  try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true
+  with CsdpInfeasible -> false
+
+(* ------------------------------------------------------------------------- *)
+(* Test whether a point is in the convex hull of others. Rather than use     *)
+(* computational geometry, express as linear inequalities and call CSDP.     *)
+(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *)
+(* ------------------------------------------------------------------------- *)
+
+let in_convex_hull pts pt =
+  let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
+  let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
+  let n = length pts + 1
+  and v = 2 * (length pt + 1) in
+  let m = v + n - 1 in
+  let mat =
+    (m,n),
+    itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x))
+                 (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in
+  linear_program_basic mat;;
+
+(* ------------------------------------------------------------------------- *)
+(* Filter down a set of points to a minimal set with the same convex hull.   *)
+(* ------------------------------------------------------------------------- *)
+
+let minimal_convex_hull =
+  let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m] 
+          | _ -> failwith "augment1"
+  in
+  let augment m ms = funpow 3 augment1 (m::ms) in
+  fun mons ->
+    let mons' = itlist augment (tl mons) [hd mons] in
+    funpow (length mons') augment1 mons';;
+
+(* ------------------------------------------------------------------------- *)
+(* Stuff for "equations" (generic A->num functions).                         *)
+(* ------------------------------------------------------------------------- *)
+
+let equation_cmul c eq =
+  if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;;
+
+let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;;
+
+let equation_eval assig eq =
+  let value v = apply assig v in
+  foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate among linear equations: return unconstrained variables and      *)
+(* assignments for the others in terms of them. We give one pseudo-variable  *)
+(* "one" that's used for a constant term.                                    *)
+(* ------------------------------------------------------------------------- *)
+
+
+let eliminate_equations =
+  let rec extract_first p l =
+    match l with
+      [] -> failwith "extract_first"
+    | h::t -> if p(h) then h,t else
+              let k,s = extract_first p t in
+              k,h::s in
+  let rec eliminate vars dun eqs =
+    match vars with
+      [] -> if forall is_undefined eqs then dun
+            else (raise Unsolvable)
+    | v::vs ->
+            try let eq,oeqs = extract_first (fun e -> defined e v) eqs in
+                let a = apply eq v in
+                let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+                let elim e =
+                  let b = tryapplyd e v (Int 0) in
+                  if b =/ Int 0 then e else
+                  equation_add e (equation_cmul (minus_num b // a) eq) in
+                eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
+            with Failure _ -> eliminate vs dun eqs in
+  fun one vars eqs ->
+    let assig = eliminate vars undefined eqs in
+    let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+    setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate all variables, in an essentially arbitrary order.               *)
+(* ------------------------------------------------------------------------- *)
+
+let eliminate_all_equations one =
+  let choose_variable eq =
+    let (v,_) = choose eq in
+    if v = one then
+      let eq' = undefine v eq in
+      if is_undefined eq' then failwith "choose_variable" else
+      let (w,_) = choose eq' in w
+    else v in
+  let rec eliminate dun eqs =
+    match eqs with
+      [] -> dun
+    | eq::oeqs ->
+        if is_undefined eq then eliminate dun oeqs else
+        let v = choose_variable eq in
+        let a = apply eq v in
+        let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+        let elim e =
+          let b = tryapplyd e v (Int 0) in
+          if b =/ Int 0 then e else
+          equation_add e (equation_cmul (minus_num b // a) eq) in
+        eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
+  fun eqs ->
+    let assig = eliminate undefined eqs in
+    let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+    setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Solve equations by assigning arbitrary numbers.                           *)
+(* ------------------------------------------------------------------------- *)
+
+let solve_equations one eqs =
+  let vars,assigs = eliminate_all_equations one eqs in
+  let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in
+  let ass =
+    combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in
+  if forall (fun e -> equation_eval ass e =/ Int 0) eqs
+  then undefine one ass else raise Sanity;;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence produce the "relevant" monomials: those whose squares lie in the    *)
+(* Newton polytope of the monomials in the input. (This is enough according  *)
+(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal,       *)
+(* vol 45, pp. 363--374, 1978.                                               *)
+(*                                                                           *)
+(* These are ordered in sort of decreasing degree. In particular the         *)
+(* constant monomial is last; this gives an order in diagonalization of the  *)
+(* quadratic form that will tend to display constants.                       *)
+(* ------------------------------------------------------------------------- *)
+
+let newton_polytope pol =
+  let vars = poly_variables pol in
+  let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
+  and ds = map (fun x -> (degree x pol + 1) / 2) vars in
+  let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
+  and mons' = minimal_convex_hull mons in
+  let all' =
+    filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
+  map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
+                        vars m monomial_1) (rev all');;
+
+(* ------------------------------------------------------------------------- *)
+(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form.  *)
+(* ------------------------------------------------------------------------- *)
+
+let diag m =
+  let nn = dimensions m in
+  let n = fst nn in
+  if snd nn <> n then failwith "diagonalize: non-square matrix" else
+  let rec diagonalize i m =
+    if is_zero m then [] else
+    let a11 = element m (i,i) in
+    if a11 </ Int 0 then failwith "diagonalize: not PSD"
+    else if a11 =/ Int 0 then
+      if is_zero(row i m) then diagonalize (i + 1) m
+      else failwith "diagonalize: not PSD"
+    else
+      let v = row i m in
+      let v' = mapa (fun a1k -> a1k // a11) v in
+      let m' =
+      (n,n),
+      iter (i+1,n) (fun j ->
+          iter (i+1,n) (fun k ->
+              ((j,k) |--> (element m (j,k) -/ element v j */ element v' k))))
+          undefined in
+      (a11,v')::diagonalize (i + 1) m' in
+  diagonalize 1 m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Adjust a diagonalization to collect rationals at the start.               *)
+(* ------------------------------------------------------------------------- *)
+
+let deration d =
+  if d = [] then Int 0,d else
+  let adj(c,l) =
+    let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
+            foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
+    (c // (a */ a)),mapa (fun x -> a */ x) l in
+  let d' = map adj d in
+  let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) //
+          itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0)  in
+  (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumeration of monomials with given multidegree bound.                    *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_monomials d vars =
+  if d < 0 then []
+  else if d = 0 then [undefined]
+  else if vars = [] then [monomial_1] else
+  let alts =
+    map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
+                  map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
+        (0--d) in
+  end_itlist (@) alts;;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumerate products of distinct input polys with degree <= d.              *)
+(* We ignore any constant input polynomials.                                 *)
+(* Give the output polynomial and a record of how it was derived.            *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_products d pols =
+  if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else
+  match pols with
+    [] -> [poly_const num_1,Rational_lt num_1]
+  | (p,b)::ps -> let e = multidegree p in
+                 if e = 0 then enumerate_products d ps else
+                 enumerate_products d ps @
+                 map (fun (q,c) -> poly_mul p q,Product(b,c))
+                     (enumerate_products (d - e) ps);;
+
+(* ------------------------------------------------------------------------- *)
+(* Multiply equation-parametrized poly by regular poly and add accumulator.  *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_pmul p q acc =
+  foldl (fun a m1 c ->
+           foldl (fun b m2 e ->
+                        let m =  monomial_mul m1 m2 in
+                        let es = tryapplyd b m undefined in
+                        (m |-> equation_add (equation_cmul c e) es) b)
+                 a q) acc p;;
+
+(* ------------------------------------------------------------------------- *)
+(* Usual operations on equation-parametrized poly.                           *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_cmul c l =
+  if c =/ Int 0 then undefined else mapf (equation_cmul c) l;;
+
+let epoly_neg x = epoly_cmul (Int(-1)) x;;
+
+let epoly_add x = combine equation_add is_undefined x;;
+
+let epoly_sub p q = epoly_add p (epoly_neg q);;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert regular polynomial. Note that we treat (0,0,0) as -1.             *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_of_poly p =
+  foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k.                              *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+  let pfx = string_of_int k ^" " in
+  let ents =
+    foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+  let entss = sort (increasing fst) ents in
+  itlist (fun ((b,i,j),c) a ->
+     pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* SDPA for problem using block diagonal (i.e. multiple SDPs)                *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
+  let m = length mats - 1 in
+  "\"" ^ comment ^ "\"\n" ^
+  string_of_int m ^ "\n" ^
+  string_of_int nblocks ^ "\n" ^
+  (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
+  "\n" ^
+  sdpa_of_vector obj ^
+  itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
+          (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence run CSDP on a problem in block diagonal form.                       *)
+(* ------------------------------------------------------------------------- *)
+
+let csdp_blocks nblocks blocksizes obj mats =
+  let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in
+  try parse_csdpoutput (run_csdp !debugging string_problem)
+  with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* 3D versions of matrix operations to consider blocks separately.           *)
+(* ------------------------------------------------------------------------- *)
+
+let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);;
+
+let bmatrix_cmul c bm =
+  if c =/ Int 0 then undefined
+  else mapf (fun x -> c */ x) bm;;
+
+let bmatrix_neg = bmatrix_cmul (Int(-1));;
+
+let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
+
+(* ------------------------------------------------------------------------- *)
+(* Smash a block matrix into components.                                     *)
+(* ------------------------------------------------------------------------- *)
+
+let blocks blocksizes bm =
+  map (fun (bs,b0) ->
+        let m = foldl
+          (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
+          undefined bm in
+        (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*)
+        (((bs,bs),m):matrix))
+      (zip blocksizes (1--length blocksizes));;
+
+(* ------------------------------------------------------------------------- *)
+(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
+(* ------------------------------------------------------------------------- *)
+
+let real_positivnullstellensatz_general linf d eqs leqs pol 
+  :   poly list *  (positivstellensatz * (num * poly) list) list  =
+  
+  let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
+  let monoid =
+    if linf then
+      (poly_const num_1,Rational_lt num_1)::
+      (filter (fun (p,c) -> multidegree p <= d) leqs)
+    else enumerate_products d leqs in
+  let nblocks = length monoid in
+  let mk_idmultiplier k p =
+    let e = d - multidegree p in
+    let mons = enumerate_monomials e vars in
+    let nons = zip mons (1--length mons) in
+    mons,
+    itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
+  let mk_sqmultiplier k (p,c) =
+    let e = (d - multidegree p) / 2 in
+    let mons = enumerate_monomials e vars in
+    let nons = zip mons (1--length mons) in
+    mons,
+    itlist (fun (m1,n1) ->
+      itlist (fun (m2,n2) a ->
+          let m = monomial_mul m1 m2 in
+          if n1 > n2 then a else
+          let c = if n1 = n2 then Int 1 else Int 2 in
+          let e = tryapplyd a m undefined in
+          (m |-> equation_add ((k,n1,n2) |=> c) e) a)
+         nons)
+       nons undefined in
+  let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
+  and idmonlist,ids =  unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
+  let blocksizes = map length sqmonlist in
+  let bigsum =
+    itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
+            (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
+                     (epoly_of_poly(poly_neg pol))) in
+  let eqns = foldl (fun a m e -> e::a) [] bigsum in
+  let pvs,assig = eliminate_all_equations (0,0,0) eqns in
+  let qvars = (0,0,0)::pvs in
+  let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+  let mk_matrix v =
+    foldl (fun m (b,i,j) ass -> if b < 0 then m else
+                                let c = tryapplyd ass v (Int 0) in
+                                if c =/ Int 0 then m else
+                                ((b,j,i) |-> c) (((b,i,j) |-> c) m))
+          undefined allassig in
+  let diagents = foldl
+    (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
+    undefined allassig in
+  let mats = map mk_matrix qvars
+  and obj = length pvs,
+            itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+                        undefined in
+  let raw_vec = if pvs = [] then vector_0 0
+                else scale_then (csdp_blocks nblocks blocksizes) obj mats in
+  let find_rounding d =
+   (if !debugging then
+     (Format.print_string("Trying rounding with limit "^string_of_num d);
+      Format.print_newline())
+    else ());
+    let vec = nice_vector d raw_vec in
+    let blockmat = iter (1,dim vec)
+     (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
+     (bmatrix_neg (el 0 mats)) in
+    let allmats = blocks blocksizes blockmat in
+    vec,map diag allmats in
+  let vec,ratdias =
+    if pvs = [] then find_rounding num_1
+    else tryfind find_rounding (map Num.num_of_int (1--31) @
+                                map pow2 (5--66)) in
+  let newassigs =
+    itlist (fun k -> el (k - 1) pvs |-> element vec k)
+           (1--dim vec) ((0,0,0) |=> Int(-1)) in
+  let finalassigs =
+    foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs
+          allassig in
+  let poly_of_epoly p =
+    foldl (fun a v e -> (v |--> equation_eval finalassigs e) a)
+          undefined p in
+  let mk_sos mons =
+    let mk_sq (c,m) =
+        c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
+                 (1--length mons) undefined in
+    map mk_sq in
+  let sqs = map2 mk_sos sqmonlist ratdias
+  and cfs = map poly_of_epoly ids in
+  let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
+  let eval_sq sqs = itlist
+   (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
+  let sanity =
+    itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq
+           (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
+                    (poly_neg pol)) in
+  if not(is_undefined sanity) then raise Sanity else
+     cfs,map (fun (a,b) -> snd a,b) msq;;
+
+
+let term_of_monoid l1 m = itlist  (fun i m -> Mul (nth l1 i,m)) m (Const num_1)
+
+let rec term_of_pos l1 x = match x with
+   Axiom_eq i -> failwith "term_of_pos"
+ | Axiom_le i -> nth l1 i
+ | Axiom_lt i -> nth l1 i
+ | Monoid m   -> term_of_monoid l1 m
+ | Rational_eq n -> Const n
+ | Rational_le n -> Const n
+ | Rational_lt n -> Const n
+ | Square t -> Pow (t, 2)
+ | Eqmul (t, y) -> Mul (t, term_of_pos l1 y)
+ | Sum (y, z) -> Add  (term_of_pos l1 y, term_of_pos l1 z)
+ | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);;
+
+
+let dest_monomial mon = sort (increasing fst) (graph mon);;
+
+let monomial_order =
+  let rec lexorder l1 l2 =
+    match (l1,l2) with
+      [],[] -> true
+    | vps,[] -> false
+    | [],vps -> true
+    | ((x1,n1)::vs1),((x2,n2)::vs2) ->
+          if x1 < x2 then true
+          else if x2 < x1 then false
+          else if n1 < n2 then false
+          else if n2 < n1 then true
+          else lexorder vs1 vs2 in
+  fun m1 m2 ->
+    if m2 = monomial_1 then true else if m1 = monomial_1 then false else
+    let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
+    let deg1 = itlist ((o) (+) snd) mon1 0
+    and deg2 = itlist ((o) (+) snd) mon2 0 in
+    if deg1 < deg2 then false else if deg1 > deg2 then true
+    else lexorder mon1 mon2;;
+
+let dest_poly p =
+  map (fun (m,c) -> c,dest_monomial m)
+      (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
+
+(* ------------------------------------------------------------------------- *)
+(* Map back polynomials and their composites to term.                        *)
+(* ------------------------------------------------------------------------- *)
+
+let term_of_varpow =
+  fun x k ->
+    if k = 1 then Var x else Pow (Var x, k);;
+
+let term_of_monomial =
+  fun m -> if m = monomial_1 then Const num_1 else
+           let m' = dest_monomial m in
+           let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in
+           end_itlist (fun s t -> Mul (s,t)) vps;;
+
+let term_of_cmonomial =
+  fun (m,c) ->
+    if m = monomial_1 then Const c
+    else if c =/ num_1 then term_of_monomial m
+    else Mul (Const c,term_of_monomial m);;
+
+let term_of_poly =
+  fun p ->
+    if p = poly_0 then Zero else
+    let cms = map term_of_cmonomial
+     (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
+    end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
+
+let term_of_sqterm (c,p) =
+  Product(Rational_lt c,Square(term_of_poly p));;
+
+let term_of_sos (pr,sqs) =
+  if sqs = [] then pr
+  else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
+
+let rec deepen f n =
+  try (*print_string "Searching with depth limit ";
+      print_int n; print_newline();*) f n
+  with Failure _ -> deepen f (n + 1);;
+
+
+
+
+
+exception TooDeep
+
+let deepen_until limit f n = 
+  match compare limit 0 with
+    | 0 -> raise TooDeep
+    | -1 -> deepen f n
+    | _  -> 
+	let rec d_until  f n =
+	  try if !debugging 
+	  then (print_string "Searching with depth limit "; 
+		print_int n; print_newline()) ; f n
+	  with Failure x -> 
+	    if !debugging then (Printf.printf "solver error : %s\n" x) ; 
+	    if n = limit then raise TooDeep else  d_until f (n + 1) in
+	  d_until f n
+
+
+(* patch to remove  zero polynomials from equalities.
+   In this case, hol light loops *)
+
+let real_nonlinear_prover  depthmax eqs les lts =
+  let eq = map poly_of_term eqs
+  and le = map poly_of_term les
+  and lt = map poly_of_term lts in
+  let pol = itlist poly_mul lt (poly_const num_1)
+  and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1)))
+  and ltp =  map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1))) 
+  and eqp =  itlist2 (fun t i res -> 
+   if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) []
+  in
+    
+  let proof =
+      let leq = lep @ ltp in
+      let eq = List.map fst eqp in
+      let tryall d =
+	let e = multidegree pol (*and pol' = poly_neg pol*) in
+	let k = if e = 0 then 1 else d / e in
+	  tryfind (fun i -> d,i, 
+	   real_positivnullstellensatz_general false d  eq leq
+            (poly_neg(poly_pow pol i)))
+           (0--k) in
+      let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in
+      let proofs_ideal =
+       map2 (fun q i -> Eqmul(term_of_poly q,i))
+        cert_ideal (List.map snd eqp)
+      and proofs_cone = map term_of_sos cert_cone
+      and proof_ne =
+       if lt = [] then Rational_lt num_1 else
+	let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
+	 funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
+       end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+   if !debugging then (print_string("Translating proof certificate to Coq"); print_newline());
+   proof;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Now pure SOS stuff.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+(* ------------------------------------------------------------------------- *)
+(* Some combinatorial helper functions.                                      *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpermutations l =
+  if l = [] then [[]] else
+  itlist (fun h acc -> map (fun t -> h::t)
+                (allpermutations (subtract l [h])) @ acc) l [];;
+
+let allvarorders l =
+  map (fun vlis x -> index x vlis) (allpermutations l);;
+
+let changevariables_monomial zoln (m:monomial) =
+  foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
+
+let changevariables zoln pol =
+  foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
+        poly_0 pol;;
+
+(* ------------------------------------------------------------------------- *)
+(* Sum-of-squares function with some lowbrow symmetry reductions.            *)
+(* ------------------------------------------------------------------------- *)
+
+let sumofsquares_general_symmetry tool pol =
+  let vars = poly_variables pol
+  and lpps = newton_polytope pol in
+  let n = length lpps in
+  let sym_eqs =
+    let invariants = filter
+     (fun vars' ->
+        is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
+     (allpermutations vars) in
+(*    let lpps2 = allpairs monomial_mul lpps lpps in*)
+(*    let lpp2_classes =
+       setify(map (fun m ->
+         setify(map (fun vars' -> changevariables_monomial (zip vars vars') m)
+                   invariants)) lpps2) in *)
+    let lpns = zip lpps (1--length lpps) in
+    let lppcs =
+      filter (fun (m,(n1,n2)) -> n1 <= n2)
+             (allpairs
+               (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
+    let clppcs = end_itlist (@)
+       (map (fun ((m1,m2),(n1,n2)) ->
+                map (fun vars' ->
+                        (changevariables_monomial (zip vars vars') m1,
+                         changevariables_monomial (zip vars vars') m2),(n1,n2))
+                    invariants)
+            lppcs) in
+    let clppcs_dom = setify(map fst clppcs) in
+    let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
+                         clppcs_dom in
+    let eqvcls = map (o setify (map snd)) clppcs_cls in
+    let mk_eq cls acc =
+      match cls with
+        [] -> raise Sanity
+      | [h] -> acc
+      | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
+    itlist mk_eq eqvcls [] in
+  let eqs = foldl (fun a x y -> y::a) []
+   (itern 1 lpps (fun m1 n1 ->
+        itern 1 lpps (fun m2 n2 f ->
+                let m = monomial_mul m1 m2 in
+                if n1 > n2 then f else
+                let c = if n1 = n2 then Int 1 else Int 2 in
+                (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f))
+       (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a)
+              undefined pol)) @
+    sym_eqs in
+  let pvs,assig = eliminate_all_equations (0,0) eqs in
+  let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+  let qvars = (0,0)::pvs in
+  let diagents =
+    end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
+  let mk_matrix v =
+   ((n,n),
+    foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
+                              if c =/ Int 0 then m else
+                              ((j,i) |-> c) (((i,j) |-> c) m))
+          undefined allassig :matrix) in
+  let mats = map mk_matrix qvars
+  and obj = length pvs,
+            itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+                undefined in
+  let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
+  let find_rounding d =
+   (if !debugging then
+     (Format.print_string("Trying rounding with limit "^string_of_num d);
+      Format.print_newline())
+    else ());
+    let vec = nice_vector d raw_vec in
+    let mat = iter (1,dim vec)
+     (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a)
+     (matrix_neg (el 0 mats)) in
+    deration(diag mat) in
+  let rat,dia =
+    if pvs = [] then
+       let mat = matrix_neg (el 0 mats) in
+       deration(diag mat)
+    else
+       tryfind find_rounding (map Num.num_of_int (1--31) @
+                              map pow2 (5--66)) in
+  let poly_of_lin(d,v) =
+    d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
+  let lins = map poly_of_lin dia in
+  let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
+  let sos = poly_cmul rat (end_itlist poly_add sqs) in
+  if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
+
+let (sumofsquares: poly -> Num.num * (( Num.num * poly) list))  = 
+sumofsquares_general_symmetry csdp;;
diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli
new file mode 100644
index 00000000..31c9518c
--- /dev/null
+++ b/contrib/micromega/sos.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int)
+
+type positivstellensatz =
+   Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of Num.num
+ | Rational_le of Num.num
+ | Rational_lt of Num.num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz
+
+type poly
+
+val poly_isconst : poly -> bool
+
+val poly_neg : poly -> poly
+
+val poly_mul : poly -> poly -> poly
+
+val poly_pow : poly -> int -> poly
+
+val poly_const : Num.num -> poly
+
+val poly_of_term : term -> poly
+
+val term_of_poly : poly -> term
+
+val term_of_sos : positivstellensatz * (Num.num * poly) list -> 
+     positivstellensatz
+
+val string_of_poly : poly -> string
+
+exception TooDeep
+
+val deepen_until : int -> (int -> 'a) -> int -> 'a
+
+val real_positivnullstellensatz_general : bool -> int -> poly list ->
+     (poly * positivstellensatz) list ->
+     poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
+
+val sumofsquares : poly -> Num.num * ( Num.num * poly) list
diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml
new file mode 100644
index 00000000..fee4ebfc
--- /dev/null
+++ b/contrib/micromega/vector.ml
@@ -0,0 +1,674 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+open Num
+
+module type S =
+sig
+ type t 
+
+ val fresh : t -> int
+
+ val null : t
+
+ val is_null : t -> bool
+
+ val get : int -> t -> num
+
+ val update : int -> (num -> num) -> t -> t
+  (* behaviour is undef if index < 0 -- might loop*)
+
+ val set : int -> num -> t -> t
+
+ (* 
+    For efficiency...
+
+    val get_update : int -> (num -> num) -> t -> num * t  
+ *)
+
+ val mul : num -> t -> t
+
+ val uminus : t -> t
+
+ val add : t -> t -> t
+
+ val dotp : t -> t -> num
+
+ val lin_comb : num -> t -> num -> t -> t
+  (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *)
+
+ val gcd : t -> Big_int.big_int
+
+ val normalise : t -> num * t 
+
+ val hash : t -> int
+
+ val compare : t -> t -> int 
+
+ type it 
+
+ val iterator : t -> it
+ val element : it -> (num*it) option
+
+ val string : t -> string
+
+ type status = Pos | Neg
+
+ (* the result list is ordered by fst *)
+ val status : t -> (int * status) list 
+
+ val from_list : num list -> t
+ val to_list : t -> num list
+
+end
+
+
+module type SystemS = 
+sig
+ 
+ module Vect : S
+
+ module  Cstr :
+ sig
+  type kind = Eq | Ge
+  val string_of_kind : kind -> string
+  type cstr = {coeffs : Vect.t ; op : kind ; cst : num} 
+  val  string_of_cstr : cstr -> string
+  val compare : cstr -> cstr -> int
+ end
+ open Cstr
+
+
+ module CstrBag : 
+ sig 
+  type t
+  exception Contradiction
+
+  val empty : t
+
+  val is_empty : t -> bool
+
+  val add : cstr -> t -> t
+   (* c can be deduced from add c t *)
+
+  val find : (cstr -> bool) -> t  ->  cstr option
+
+  val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a
+
+  val status : t ->  (int * (int list * int list)) list
+   (* aggregate of vector statuses *)
+
+  val remove : cstr -> t -> t
+
+  (* remove_list the ith element -- it is the ith element visited by 'fold' *)
+
+  val split : (cstr -> int) -> t -> (int ->  t)
+
+  type it 
+  val iterator : t -> it
+  val element : it -> (cstr*it) option
+
+ end
+
+end
+
+let zero_num = Int 0
+let unit_num = Int 1
+
+
+
+
+module Cstr(V:S) = 
+struct 
+ type kind = Eq | Ge
+ let string_of_kind = function Eq -> "Eq" | Ge -> "Ge"
+
+ type cstr = {coeffs : V.t ; op : kind ; cst : num} 
+
+ let string_of_cstr  {coeffs =a  ; op = b ; cst =c} =
+  Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c)
+
+ type t = cstr
+ let compare 
+   {coeffs = v1 ; op = op1 ; cst = c1}
+   {coeffs = v2 ; op = op2 ; cst = c2} =
+  Mutils.Cmp.compare_lexical [
+   (fun () -> V.compare v1 v2);
+   (fun () -> Pervasives.compare op1 op2);
+   (fun () -> compare_num c1 c2)
+  ]
+
+
+end
+
+
+
+module VList : S with type t = num list =
+struct
+ type t =  num list
+
+ let fresh l = failwith "not implemented"
+
+ let null = []
+
+ let is_null  = List.for_all ((=/) zero_num) 
+
+ let normalise l = failwith "Not implemented"
+  (*match l with (* Buggy : What if the first num is zero! *)
+    | [] -> (Int 0,[])
+    | [n] -> (n,[Int 1])
+    | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l)
+  *)
+
+
+ let get i l = try List.nth l i with _ -> zero_num
+
+ (* This is not tail-recursive *)
+ let rec update i f t =
+  match t with
+   | []   -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f [])
+   | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t)
+
+ let rec set i n t =
+  match t with
+   | []   -> if i = 0 then [n] else (zero_num)::(set (i-1) n [])
+   | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t)
+
+
+
+
+ let rec mul z t = 
+  match z with
+   | Int 0 -> null
+   | Int 1 -> t
+   |  _    -> List.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+
+ let rec add t1 t2 =
+  match t1,t2 with
+   | [], _  -> t2
+   | _ , [] -> t1
+   | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2)
+
+ let dotp t1 t2 =
+  let rec _dotp t1 t2 acc = 
+   match t1, t2 with
+    | [] , _  -> acc
+    | _  , [] -> acc
+    | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in
+   _dotp t1 t2 zero_num
+
+ let add_mul n t1 t2 =
+  match n with
+   | Int 0 -> t2
+   | Int 1  -> add t1 t2
+   |  _     -> 
+       let rec _add_mul t1 t2 = 
+	match t1,t2 with
+	 | [], _  -> t2
+	 | _ , [] -> mul n t1
+	 | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in
+	_add_mul t1 t2
+
+ let lin_comb n1 t1 n2 t2 = 
+  match n1,n2 with
+   | Int 0 , _  -> mul n2 t2
+   | Int 1 , _ -> add_mul n2 t2 t1
+   |   _   , Int 0 ->  mul n1 t1
+   |   _   , Int 1 -> add_mul n1 t1 t2  
+   |       _       -> 
+	    let rec _lin_comb t1 t2 = 
+	     match t1,t2 with
+	      | [], _  -> mul n2 t2
+	      | _ , [] -> mul n1 t1
+	      | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in
+	     _lin_comb t1 t2
+	      
+ (* could be computed on the fly *)
+ let gcd  t =Mutils.gcd_list t
+
+
+
+
+ let hash = Mutils.Cmp.hash_list int_of_num 
+
+ let compare = Mutils.Cmp.compare_list compare_num
+
+ type it = t
+ let iterator (x:t) : it = x
+ let element it = 
+  match it with
+   | [] -> None
+   | e::l -> Some (e,l)
+
+ (* TODO: Buffer! *)
+ let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l ""
+
+ type status = Pos | Neg
+
+ let status l =
+  let rec xstatus i l = 
+   match l with 
+    | [] -> []
+    | e::l -> 
+       begin
+	match compare_num e (Int 0) with
+	 | 1 -> (i,Pos):: (xstatus (i+1) l)
+	 | 0 -> xstatus (i+1) l
+	 | -1 -> (i,Neg) :: (xstatus (i+1) l)
+	 | _  -> assert false
+       end in
+   xstatus 0 l
+
+ let from_list l = l
+ let to_list l = l
+  
+end
+
+module VMap : S =
+struct
+ module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end)
+
+ type t =  num Map.t
+
+ let null = Map.empty
+
+ let fresh m = failwith "not implemented"
+
+ let is_null  = Map.is_empty
+
+ let normalise m = failwith "Not implemented"
+
+
+
+ let get i l = try Map.find i l with _ -> zero_num
+
+ let  update i f t =
+  try
+   let res = f (Map.find i t) in
+    if res =/ zero_num
+    then Map.remove i t
+    else Map.add i res t
+  with
+    Not_found -> 
+     let res = f zero_num in
+      if res =/ zero_num then t else Map.add i res t
+
+ let set i n t =
+  if n =/ zero_num then Map.remove i t
+  else Map.add i n t
+
+
+ let rec mul z t = 
+  match z with
+   | Int 0 -> null
+   | Int 1 -> t
+   |  _    -> Map.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+  
+
+ let map2 f m1 m2 = 
+  let res,m2' = 
+   Map.fold (fun k e (res,m2) -> 
+    let v = f e (get k m2) in
+     if v =/ zero_num
+     then (res,Map.remove k m2)
+     else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in
+   Map.fold (fun k e res -> 
+    let v = f zero_num e in
+     if v =/ zero_num
+     then res else Map.add k v res) m2' res
+    
+ let  add t1 t2 = map2 (+/) t1 t2
+  
+
+ let dotp t1 t2 =
+  Map.fold (fun k e res -> 
+   res +/ (e */ get k t2)) t1 zero_num
+
+
+
+ let add_mul n t1 t2 =
+  match n with
+   | Int 0 -> t2
+   | Int 1  -> add t1 t2
+   |  _     -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let lin_comb n1 t1 n2 t2 = 
+  match n1,n2 with
+   | Int 0 , _  -> mul n2 t2
+   | Int 1 , _ -> add_mul n2 t2 t1
+   |   _   , Int 0 ->  mul n1 t1
+   |   _   , Int 1 -> add_mul n1 t1 t2  
+   |       _       -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2
+
+
+ let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0
+
+ let compare = Map.compare compare_num
+
+ type it = t * int
+
+ let iterator (x:t) : it = (x,0)
+  
+ let element (mp,id) = 
+  try 
+   Some (Map.find id mp, (mp, id+1))
+  with
+    Not_found -> None
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = Map.fold (fun k e l -> 
+  match compare_num e (Int 0) with
+   | 1 -> (k,Pos)::l
+   | 0 ->  l
+   | -1 -> (k,Neg) :: l
+   | _  -> assert false) l []
+ let from_list l = 
+  let rec from_list i l map = 
+   match l with
+    | [] -> map
+    | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in
+   from_list 0 l Map.empty
+
+ let gcd m = 
+  let res = Map.fold (fun _ e x -> Big_int.gcd_big_int  x (Mutils.numerator e)) m Big_int.zero_big_int in
+   if Big_int.compare_big_int res Big_int.zero_big_int = 0 
+   then Big_int.unit_big_int else res
+
+
+ let to_list m = 
+  let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in
+  let rec xto_list i l =
+   match l with
+    | [] -> []
+    |	(x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+   xto_list 0 l
+
+ let string l = VList.string (to_list l)
+
+  
+end
+
+
+module VSparse : S =
+struct
+
+ type t = (int*num) list
+
+ let null = []
+  
+ let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc)  0 l
+
+ let is_null l = l = []
+  
+ let rec is_sorted l =
+  match l with
+   |	[] -> true
+   | [e] -> true
+   | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l)
+      
+      
+ let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l)
+  
+ (*	let get i t = 
+	assert (check t);
+	try List.assoc i t with Not_found -> zero_num *)
+
+ let rec get (i:int) t = 
+  match t with
+   | [] -> zero_num
+   | (j,n)::t -> 
+      match compare i j with
+       | 0 -> n
+       | 1 -> get i t
+       |  _ -> zero_num
+
+ let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
+   
+ let rec update i f t = 
+  match t with
+   | [] -> cons i (f zero_num) []
+   | (k,v)::l -> 
+      match Pervasives.compare i k with
+       | 0 -> cons k (f v) l
+       | -1 -> cons i (f zero_num) t
+       |  1 -> (k,v) ::(update i f l)
+       |  _  -> failwith "compare_num"
+	   
+ let update i f t =
+  assert (check t); 
+  let res = update i f t in
+   assert (check t) ; res
+    
+    
+ let rec set i n t =
+  match t with
+   | [] -> cons i n []
+   | (k,v)::l -> 
+      match Pervasives.compare i k with
+       | 0 -> cons k n l
+       | -1 -> cons i n t
+       |  1 -> (k,v) :: (set i n l)
+       |  _  -> failwith "compare_num"
+	   
+
+ let rec map f l = 
+  match l with
+   | [] -> []
+   | (i,e)::l -> cons i (f e) (map f l)
+      
+ let rec mul z t = 
+  match z with
+   | Int 0 -> null
+   | Int 1 -> t
+   |  _    -> List.map (fun (i,n) -> (i, mult_num z n)) t
+       
+ let mul z t = 
+  assert (check t) ;
+  let res = mul z t in
+   assert (check res) ; 
+   res
+
+ let uminus t = mul (Int (-1)) t
+
+
+ let normalise l = 
+  match l with
+   | []   -> (Int 0,[])
+   | (i,n)::_ -> (n, mul ((Int 1) // n) l)
+      
+
+ let rec map2 f m1 m2 = 
+  match m1, m2 with
+   | [] , [] -> []
+   | l  , [] -> map (fun x -> f x zero_num) l
+   | [] ,l   -> map (f zero_num) l
+   | (i,e)::l1,(i',e')::l2 -> 
+      match Pervasives.compare i i' with
+       | 0 -> cons i (f e e') (map2 f l1 l2)
+       | -1 -> cons i (f e zero_num) (map2 f l1 m2)
+       |  1 -> cons i' (f zero_num e') (map2 f m1 l2)
+       | _  -> assert false
+	  
+ (* let  add t1 t2 = map2 (+/) t1 t2*)
+
+ let rec add (m1:t) (m2:t) = 
+  match m1, m2 with
+   | [] , [] -> []
+   | l  , [] -> l
+   | [] ,l   -> l
+   | (i,e)::l1,(i',e')::l2 -> 
+      match Pervasives.compare i i' with
+       | 0 -> cons i ( e +/ e') (add  l1 l2)
+       | -1 -> (i,e) :: (add l1 m2)
+       |  1 -> (i', e') :: (add m1 l2)
+       | _  -> assert false
+
+
+
+
+ let add t1 t2 = 
+  assert (check t1 && check t2);
+  let res = add t1 t2 in
+   assert (check res);
+   res
+
+
+ let rec dotp (t1:t) (t2:t) =
+  match t1, t2 with
+   | [] , _ -> zero_num
+   | _  , [] -> zero_num
+   | (i,e)::l1 , (i',e')::l2 -> 
+      match Pervasives.compare i i' with
+       | 0 -> (e */ e') +/ (dotp l1 l2)
+       | -1 -> dotp l1 t2
+       |  1 -> dotp t1 l2
+       |  _ -> assert false
+	   
+ let dotp t1 t2 = 
+  assert (check t1 && check t2) ; dotp t1 t2
+
+ let add_mul n t1 t2 =
+  match n with
+   | Int 0 -> t2
+   | Int 1  -> add t1 t2
+   |  _     -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let add_mul n (t1:t) (t2:t) =
+  match n with
+   | Int 0 -> t2
+   | Int 1  -> add t1 t2
+   |   _    -> 
+	let rec xadd_mul m1 m2 = 
+	 match m1, m2 with
+	  | [] , [] -> []
+	  | _  , [] -> mul n m1
+	  | [] , _   -> m2
+	  | (i,e)::l1,(i',e')::l2 -> 
+	     match Pervasives.compare i i' with
+	      | 0 -> cons i ( n */ e +/ e') (xadd_mul  l1 l2)
+	      | -1 -> (i,n */ e) :: (xadd_mul l1 m2)
+	      |  1 -> (i', e') :: (xadd_mul m1 l2)
+	      | _  -> assert false in
+	 xadd_mul t1 t2
+	  
+
+
+
+ let lin_comb n1 t1 n2 t2 = 
+  match n1,n2 with
+   | Int 0 , _  -> mul n2 t2
+   | Int 1 , _ -> add_mul n2 t2 t1
+   |   _   , Int 0 ->  mul n1 t1
+   |   _   , Int 1 -> add_mul n1 t1 t2  
+   |       _       -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*)
+	    let rec xlin_comb m1 m2 = 
+	     match m1, m2 with
+	      | [] , [] -> []
+	      | _  , [] -> mul n1 m1
+	      | [] , _   -> mul n2 m2
+	      | (i,e)::l1,(i',e')::l2 -> 
+		 match Pervasives.compare i i' with
+		  | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb  l1 l2)
+		  | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2)
+		  |  1 -> (i', n2 */ e') :: (xlin_comb m1 l2)
+		  | _  -> assert false in
+	     xlin_comb t1 t2
+
+
+
+
+
+ let lin_comb n1 t1 n2 t2 = 
+  assert (check t1 && check t2);
+  let res = lin_comb n1 t1 n2 t2 in
+   assert (check res); res
+
+ let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y))
+
+
+ let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical 
+  [
+   (fun () -> Pervasives.compare (fst x) (fst y));
+   (fun () -> compare_num (snd x) (snd y))]) 
+
+ (* 
+    let compare (x:t) (y:t) = 
+    let rec xcompare acc1 acc2 x y = 
+    match x , y with
+    | [] , [] -> xcomp acc1 acc2
+    | [] , _  -> -1
+    |  _ , [] -> 1
+    | (i,n1)::l1 , (j,n2)::l2 -> 
+    match Pervasives.compare i j with
+    | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2
+    | c -> c
+    and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in
+    xcompare [] [] x y
+ *)
+
+ type it = t
+
+ let iterator (x:t) : it =  x
+  
+ let element l = failwith "Not_implemented"
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = List.map (fun (i,e) -> 
+  match compare_num e (Int 0) with
+   | 1 -> i,Pos
+   | -1 -> i,Neg
+   | _  -> assert false) l
+
+ let from_list (l: num list) = 
+  let rec xfrom_list i l = 
+   match l with
+    | [] -> []
+    | e::l ->  
+       if e <>/ Int 0 
+       then (i,e)::(xfrom_list (i+1) l)
+       else xfrom_list (i+1) l in
+   
+  let res = xfrom_list 0 l in
+   assert (check res) ; res
+
+
+ let gcd m = 
+  let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int  x (Mutils.numerator e))  Big_int.zero_big_int m in
+   if Big_int.compare_big_int res Big_int.zero_big_int = 0 
+   then Big_int.unit_big_int else res
+
+ let to_list m = 
+  let rec xto_list i l =
+   match l with
+    | [] -> []
+    |	(x,v)::l' -> 
+	 if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+   xto_list 0 m
+
+ let to_list l =
+  assert (check l); 
+  to_list l
+
+
+ let string l = VList.string (to_list l)
+  
+end
diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v
index 66f86a49..ee823502 100644
--- a/contrib/omega/Omega.v
+++ b/contrib/omega/Omega.v
@@ -9,15 +9,16 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: Omega.v 8642 2006-03-17 10:09:02Z notin $ *)
+(* $Id: Omega.v 10028 2007-07-18 22:38:06Z letouzey $ *)
 
 (* We do not require [ZArith] anymore, but only what's necessary for Omega *)
 Require Export ZArith_base.
 Require Export OmegaLemmas.
+Require Export PreOmega.
 
 Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
   Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
diff --git a/contrib/omega/PreOmega.v b/contrib/omega/PreOmega.v
new file mode 100644
index 00000000..47e22a97
--- /dev/null
+++ b/contrib/omega/PreOmega.v
@@ -0,0 +1,445 @@
+Require Import Arith Max Min ZArith_base NArith Nnat.
+
+Open Local Scope Z_scope.
+
+
+(** * zify: the Z-ification tactic *)
+
+(* This tactic searches for nat and N and positive elements in the goal and 
+   translates everything into Z. It is meant as a pre-processor for 
+   (r)omega; for instance a positivity hypothesis is added whenever
+     - a multiplication is encountered
+     - an atom is encountered (that is a variable or an unknown construct)
+
+   Recognized relations (can be handled as deeply as allowed by setoid rewrite):
+     - { eq, le, lt, ge, gt } on { Z, positive, N, nat }
+   
+   Recognized operations: 
+     - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
+     - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
+     - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
+     - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
+*)
+
+
+
+
+(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)
+
+Ltac zify_unop_core t thm a := 
+ (* Let's introduce the specification theorem for t *)
+ let H:= fresh "H" in assert (H:=thm a); 
+ (* Then we replace (t a) everywhere with a fresh variable *)
+ let z := fresh "z" in set (z:=t a) in *; clearbody z.
+
+Ltac zify_unop_var_or_term t thm a := 
+ (* If a is a variable, no need for aliasing *)
+ let za := fresh "z" in 
+ (rename a into za; rename za into a; zify_unop_core t thm a) ||
+ (* Otherwise, a is a complex term: we alias it. *)
+ (remember a as za; zify_unop_core t thm za).
+
+Ltac zify_unop t thm a := 
+ (* if a is a scalar, we can simply reduce the unop *)
+ let isz := isZcst a in 
+ match isz with 
+  | true => simpl (t a) in *
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_unop_nored t thm a := 
+ (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
+ let isz := isZcst a in 
+ match isz with 
+  | true => zify_unop_core t thm a
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_binop t thm a b:=
+ (* works as zify_unop, except that we should be careful when
+    dealing with b, since it can be equal to a *)
+ let isza := isZcst a in 
+ match isza with 
+   | true => zify_unop (t a) (thm a) b
+   | _ => 
+       let za := fresh "z" in 
+       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
+       (remember a as za; match goal with 
+         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
+         | _ => zify_unop_nored (t za) (thm za) b
+        end)
+ end.
+
+Ltac zify_op_1 := 
+  match goal with 
+   | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
+   | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
+   | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
+   | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
+   | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
+   | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
+   | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
+   | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
+  end.
+
+Ltac zify_op := repeat zify_op_1.
+
+
+
+
+
+(** II) Conversion from nat to Z *)
+
+
+Definition Z_of_nat' := Z_of_nat.
+
+Ltac hide_Z_of_nat t := 
+  let z := fresh "z" in set (z:=Z_of_nat t) in *; 
+  change Z_of_nat with Z_of_nat' in z; 
+  unfold z in *; clear z.
+
+Ltac zify_nat_rel := 
+ match goal with 
+  (* I: equalities *)
+  | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
+  | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
+  | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
+  | |- context [ @eq nat ?a ?b ] =>       rewrite (inj_eq_iff a b)
+  (* II: less than *)
+  | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
+  | |- (lt ?a ?b) => apply (inj_lt_rev a b)
+  | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
+  | |- context [ lt ?a ?b ] =>       rewrite (inj_lt_iff a b)
+  (* III: less or equal *)
+  | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
+  | |- (le ?a ?b) => apply (inj_le_rev a b)
+  | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
+  | |- context [ le ?a ?b ] =>       rewrite (inj_le_iff a b)
+  (* IV: greater than *)
+  | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
+  | |- (gt ?a ?b) => apply (inj_gt_rev a b)
+  | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
+  | |- context [ gt ?a ?b ] =>       rewrite (inj_gt_iff a b)
+  (* V: greater or equal *)
+  | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
+  | |- (ge ?a ?b) => apply (inj_ge_rev a b)
+  | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
+  | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
+ end.
+
+Ltac zify_nat_op := 
+ match goal with 
+  (* misc type conversions: positive/N/Z to nat *)
+  | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
+  | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
+  | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
+  | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
+  | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
+  | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)
+
+  (* plus -> Zplus *)
+  | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
+  | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)
+
+  (* min -> Zmin *)
+  | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
+  | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)
+
+  (* max -> Zmax *)
+  | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
+  | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)
+
+  (* minus -> Zmax (Zminus ... ...) 0 *)
+  | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
+  | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)
+
+  (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
+  | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
+  | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)
+
+  (* mult -> Zmult and a positivity hypothesis *)
+  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => 
+        let H:= fresh "H" in 
+        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+  | |- context [ Z_of_nat (mult ?a ?b) ] => 
+        let H:= fresh "H" in 
+        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+
+  (* O -> Z0 *)
+  | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
+  | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)
+
+  (* S -> number or Zsucc *)
+  | H : context [ Z_of_nat (S ?a) ] |- _ => 
+     let isnat := isnatcst a in 
+     match isnat with 
+      | true => simpl (Z_of_nat (S a)) in H
+      | _ => rewrite (inj_S a) in H
+     end
+  | |- context [ Z_of_nat (S ?a) ] => 
+     let isnat := isnatcst a in 
+     match isnat with 
+      | true => simpl (Z_of_nat (S a))
+      | _ => rewrite (inj_S a)
+     end
+
+  (* atoms of type nat : we add a positivity condition (if not already there) *) 
+  | H : context [ Z_of_nat ?a ] |- _ => 
+        match goal with 
+          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
+          | H' : 0 <= Z_of_nat' a |- _ => fail
+          | _ => let H:= fresh "H" in
+                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
+        end
+  | |- context [ Z_of_nat ?a ] => 
+        match goal with 
+          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
+          | H' : 0 <= Z_of_nat' a |- _ => fail
+          | _ => let H:= fresh "H" in
+                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
+        end
+ end.
+
+Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
+
+
+
+
+(* III) conversion from positive to Z *) 
+
+Definition Zpos' := Zpos.
+Definition Zneg' := Zneg.
+
+Ltac hide_Zpos t := 
+  let z := fresh "z" in set (z:=Zpos t) in *; 
+  change Zpos with Zpos' in z; 
+  unfold z in *; clear z.
+
+Ltac zify_positive_rel := 
+ match goal with 
+  (* I: equalities *)
+  | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
+  | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
+  | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
+  | |- context [ @eq positive ?a ?b ] =>       rewrite (Zpos_eq_iff a b)
+  (* II: less than *)
+  | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
+  | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
+  (* III: less or equal *)
+  | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
+  | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
+  (* IV: greater than *)
+  | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
+  | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
+  (* V: greater or equal *)
+  | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
+  | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
+ end.
+
+Ltac zify_positive_op := 
+ match goal with 
+  (* Zneg -> -Zpos (except for numbers) *)
+  | H : context [ Zneg ?a ] |- _ => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zneg a) with (Zneg' a) in H
+      | _ => change (Zneg a) with (- Zpos a) in H
+     end
+  | |- context [ Zneg ?a ] => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zneg a) with (Zneg' a)
+      | _ => change (Zneg a) with (- Zpos a)
+     end
+
+  (* misc type conversions: nat to positive *)
+  | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
+  | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)
+
+  (* Pplus -> Zplus *)
+  | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
+  | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))
+
+  (* Pmin -> Zmin *)
+  | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
+  | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)
+
+  (* Pmax -> Zmax *)
+  | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
+  | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)
+
+  (* Pminus -> Zmax 1 (Zminus ... ...) *)
+  | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
+  | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)
+
+  (* Psucc -> Zsucc *) 
+  | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
+  | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)
+
+  (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
+  | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
+  | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)
+ 
+  (* Pmult -> Zmult and a positivity hypothesis *)
+  | H : context [ Zpos (Pmult ?a ?b) ] |- _ => 
+        let H:= fresh "H" in 
+        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+  | |- context [ Zpos (Pmult ?a ?b) ] => 
+        let H:= fresh "H" in 
+        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+
+  (* xO *)
+  | H : context [ Zpos (xO ?a) ] |- _ => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
+      | _ => rewrite (Zpos_xO a) in H
+     end
+  | |- context [ Zpos (xO ?a) ] => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zpos (xO a)) with (Zpos' (xO a))
+      | _ => rewrite (Zpos_xO a)
+     end
+  (* xI *) 
+  | H : context [ Zpos (xI ?a) ] |- _ => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
+      | _ => rewrite (Zpos_xI a) in H
+     end
+  | |- context [ Zpos (xI ?a) ] => 
+     let isp := isPcst a in 
+     match isp with 
+      | true => change (Zpos (xI a)) with (Zpos' (xI a))
+      | _ => rewrite (Zpos_xI a)
+     end
+
+  (* xI : nothing to do, just prevent adding a useless positivity condition *)
+  | H : context [ Zpos xH ] |- _ => hide_Zpos xH
+  | |- context [ Zpos xH ] => hide_Zpos xH
+
+  (* atoms of type positive : we add a positivity condition (if not already there) *)
+  | H : context [ Zpos ?a ] |- _ => 
+        match goal with 
+         | H' : Zpos a > 0 |- _ => hide_Zpos a
+         | H' : Zpos' a > 0 |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
+        end
+  | |- context [ Zpos ?a ] => 
+        match goal with 
+         | H' : Zpos a > 0 |- _ => hide_Zpos a
+         | H' : Zpos' a > 0 |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
+        end
+ end.
+
+Ltac zify_positive := 
+ repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.
+
+
+
+
+
+(* IV) conversion from N to Z *) 
+
+Definition Z_of_N' := Z_of_N.
+
+Ltac hide_Z_of_N t := 
+  let z := fresh "z" in set (z:=Z_of_N t) in *; 
+  change Z_of_N with Z_of_N' in z; 
+  unfold z in *; clear z.
+
+Ltac zify_N_rel := 
+ match goal with 
+  (* I: equalities *)
+  | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
+  | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
+  | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
+  | |- context [ @eq N ?a ?b ] =>       rewrite (Z_of_N_eq_iff a b)
+  (* II: less than *)
+  | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
+  | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
+  | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
+  | |- context [ (?a<?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
+  (* III: less or equal *)
+  | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
+  | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b)
+  | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
+  | |- context [ (?a<=?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
+  (* IV: greater than *)
+  | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
+  | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b)
+  | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
+  | |- context [ (?a>?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
+  (* V: greater or equal *)
+  | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
+  | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b)
+  | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H
+  | |- context [ (?a>=?b)%N ] =>       rewrite (Z_of_N_ge_iff a b)
+ end.
+ 
+Ltac zify_N_op := 
+ match goal with 
+  (* misc type conversions: nat to positive *)
+  | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
+  | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
+  | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
+  | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
+  | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
+  | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
+  | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
+  | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0
+
+  (* Nplus -> Zplus *)
+  | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
+  | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)
+
+  (* Nmin -> Zmin *)
+  | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
+  | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)
+
+  (* Nmax -> Zmax *)
+  | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
+  | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)
+
+  (* Nminus -> Zmax 0 (Zminus ... ...) *)
+  | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
+  | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)
+
+  (* Nsucc -> Zsucc *) 
+  | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
+  | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)
+ 
+  (* Nmult -> Zmult and a positivity hypothesis *)
+  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => 
+        let H:= fresh "H" in 
+        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+  | |- context [ Z_of_N  (Nmult ?a ?b) ] => 
+        let H:= fresh "H" in 
+        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+
+  (* atoms of type N : we add a positivity condition (if not already there) *) 
+  | H : context [ Z_of_N ?a ] |- _ => 
+        match goal with 
+         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
+         | H' : 0 <= Z_of_N' a |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
+        end
+  | |- context [ Z_of_N ?a ] => 
+        match goal with 
+         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
+         | H' : 0 <= Z_of_N' a |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
+        end
+ end.
+
+Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
+
+
+
+(** The complete Z-ification tactic *)
+
+Ltac zify := 
+ repeat progress (zify_nat; zify_positive; zify_N); zify_op.
+
diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml
index be9ea5ae..84092812 100644
--- a/contrib/omega/coq_omega.ml
+++ b/contrib/omega/coq_omega.ml
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: coq_omega.ml 9963 2007-07-09 14:02:20Z letouzey $ *)
+(* $Id: coq_omega.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Util
 open Pp
@@ -128,12 +128,12 @@ let intern_id,unintern_id =
     
 let mk_then = tclTHENLIST
 
-let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c])
+let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c])
 
 let generalize_tac t = generalize_time (generalize t)
 let elim t = elim_time (simplest_elim t)
 let exact t = exact_time (Tactics.refine t)
-let unfold s = Tactics.unfold_in_concl [[], Lazy.force s]
+let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
  
 let rev_assoc k =
   let rec loop = function
@@ -180,8 +180,6 @@ let coq_Zneg = lazy (constant "Zneg")
 let coq_Z = lazy (constant "Z")
 let coq_comparison = lazy (constant "comparison")
 let coq_Gt = lazy (constant "Gt")
-let coq_INFEEIEUR = lazy (constant "Lt")
-let coq_Eq = lazy (constant "Eq")
 let coq_Zplus = lazy (constant "Zplus")
 let coq_Zmult = lazy (constant "Zmult")
 let coq_Zopp = lazy (constant "Zopp")
@@ -1227,7 +1225,7 @@ let replay_history tactic_normalisation =
 	      (clear [aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (exists_tac eq1) reflexivity ]
+            tclTHEN (exists_tac (inj_open eq1)) reflexivity ]
       | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
 	  let id1 = new_identifier () 
 	  and id2 = new_identifier () in
diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4
index 01592ebe..02545b30 100644
--- a/contrib/omega/g_omega.ml4
+++ b/contrib/omega/g_omega.ml4
@@ -15,10 +15,33 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_omega.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id: g_omega.ml4 10028 2007-07-18 22:38:06Z letouzey $ *)
 
 open Coq_omega
+open Refiner
+
+let omega_tactic l = 
+  let tacs = List.map 
+    (function  
+       | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
+       | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
+       | "N" -> Tacinterp.interp <:tactic<zify_N>>
+       | "Z" -> Tacinterp.interp <:tactic<zify_op>>
+       | s -> Util.error ("No Omega knowledge base for type "^s))
+    (Util.list_uniquize (List.sort compare l))
+  in 
+  tclTHEN
+    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
+    omega_solver
+
 
 TACTIC EXTEND omega
-  [ "omega" ] -> [ omega_solver ]
+|  [ "omega" ] -> [ omega_tactic [] ]
 END
+
+TACTIC EXTEND omega'
+| [ "omega" "with" ne_ident_list(l) ] -> 
+    [ omega_tactic (List.map Names.string_of_id l) ]
+| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ]
+END
+
diff --git a/contrib/ring/LegacyRing.v b/contrib/ring/LegacyRing.v
index dc8635bd..40323b3d 100644
--- a/contrib/ring/LegacyRing.v
+++ b/contrib/ring/LegacyRing.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 Require Export Bool.
 Require Export LegacyRing_theory.
diff --git a/contrib/ring/LegacyRing_theory.v b/contrib/ring/LegacyRing_theory.v
index 5df927a6..d15d18a6 100644
--- a/contrib/ring/LegacyRing_theory.v
+++ b/contrib/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *)
 
 Require Export Bool.
 
@@ -153,7 +153,7 @@ Notation "- x" := (Aopp x).
 Record Ring_Theory : Prop := 
   {Th_plus_comm : forall n m:A, n + m = m + n;
    Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   Th_mult_sym : forall n m:A, n * m = m * n;
+   Th_mult_comm : forall n m:A, n * m = m * n;
    Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
    Th_plus_zero_left : forall n:A, 0 + n = n;
    Th_mult_one_left : forall n:A, 1 * n = n;
@@ -165,7 +165,7 @@ Variable T : Ring_Theory.
 
 Let plus_comm := Th_plus_comm T.
 Let plus_assoc := Th_plus_assoc T.
-Let mult_comm := Th_mult_sym T.
+Let mult_comm := Th_mult_comm T.
 Let mult_assoc := Th_mult_assoc T.
 Let plus_zero_left := Th_plus_zero_left T.
 Let mult_one_left := Th_mult_one_left T. 
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
index 115ed5ca..c2467ebf 100644
--- a/contrib/ring/Ring_abstract.v
+++ b/contrib/ring/Ring_abstract.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *)
 
 Require Import LegacyRing_theory.
 Require Import Quote.
@@ -428,7 +428,7 @@ Fixpoint interp_ap (p:apolynomial) : A :=
 Hint Resolve (Th_plus_comm T).
 Hint Resolve (Th_plus_assoc T).
 Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_sym T).
+Hint Resolve (Th_mult_comm T).
 Hint Resolve (Th_mult_assoc T).
 Hint Resolve (Th_mult_assoc2 T).
 Hint Resolve (Th_plus_zero_left T).
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
index 4a082396..e8d9f1ee 100644
--- a/contrib/ring/Ring_normalize.v
+++ b/contrib/ring/Ring_normalize.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *)
 
 Require Import LegacyRing_theory.
 Require Import Quote.
@@ -774,7 +774,7 @@ Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
 Hint Resolve (Th_plus_comm T).
 Hint Resolve (Th_plus_assoc T).
 Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_sym T).
+Hint Resolve (Th_mult_comm T).
 Hint Resolve (Th_mult_assoc T).
 Hint Resolve (Th_mult_assoc2 T).
 Hint Resolve (Th_plus_zero_left T).
@@ -897,6 +897,6 @@ End rings.
 Infix "+" := Pplus : ring_scope.
 Infix "*" := Pmult : ring_scope.
 Notation "- x" := (Popp x) : ring_scope.
-Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope.
+Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
 
 Delimit Scope ring_scope with ring.
diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v
index 56329ade..8eb49a37 100644
--- a/contrib/ring/Setoid_ring_normalize.v
+++ b/contrib/ring/Setoid_ring_normalize.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_normalize.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
+(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *)
 
 Require Import Setoid_ring_theory.
 Require Import Quote.
@@ -1032,7 +1032,7 @@ Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.
 Hint Resolve (STh_plus_comm T).
 Hint Resolve (STh_plus_assoc T).
 Hint Resolve (STh_plus_assoc2 S T).
-Hint Resolve (STh_mult_sym T).
+Hint Resolve (STh_mult_comm T).
 Hint Resolve (STh_mult_assoc T).
 Hint Resolve (STh_mult_assoc2 S T).
 Hint Resolve (STh_plus_zero_left T).
diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v
index ae6610d3..88abd7de 100644
--- a/contrib/ring/Setoid_ring_theory.v
+++ b/contrib/ring/Setoid_ring_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_theory.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
+(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *)
 
 Require Export Bool.
 Require Export Setoid.
@@ -177,7 +177,7 @@ Section Theory_of_setoid_rings.
 Record Setoid_Ring_Theory : Prop := 
   {STh_plus_comm : forall n m:A, n + m == m + n;
    STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   STh_mult_sym : forall n m:A, n * m == m * n;
+   STh_mult_comm : forall n m:A, n * m == m * n;
    STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
    STh_plus_zero_left : forall n:A, 0 + n == n;
    STh_mult_one_left : forall n:A, 1 * n == n;
@@ -189,7 +189,7 @@ Variable T : Setoid_Ring_Theory.
 
 Let plus_comm := STh_plus_comm T.
 Let plus_assoc := STh_plus_assoc T.
-Let mult_comm := STh_mult_sym T.
+Let mult_comm := STh_mult_comm T.
 Let mult_assoc := STh_mult_assoc T.
 Let plus_zero_left := STh_plus_zero_left T.
 Let mult_one_left := STh_mult_one_left T. 
@@ -245,7 +245,7 @@ Lemma Saux1 : forall a:A, a + a == a -> a == 0.
 intros.
 rewrite <- (plus_zero_left a).
 rewrite (plus_comm 0 a).
-setoid_replace (a + 0) with (a + (a + - a)); auto.
+setoid_replace (a + 0) with (a + (a + - a)) by auto.
 rewrite (plus_assoc a a (- a)).
 rewrite H.
 apply opp_def.
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
index e0a6cba3..7cd22a36 100644
--- a/contrib/ring/quote.ml
+++ b/contrib/ring/quote.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *)
+(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
 
 (* The `Quote' tactic *)
 
@@ -191,8 +191,11 @@ let decomp_term c = kind_of_term (strip_outer_cast c)
   ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
   type [typ] *)
 
-let coerce_meta_out id = int_of_string (string_of_id id)
-let coerce_meta_in n = id_of_string (string_of_int n)
+let coerce_meta_out id = 
+  let s = string_of_id id in
+  int_of_string (String.sub s 1 (String.length s - 1))
+let coerce_meta_in n =
+  id_of_string ("M" ^ string_of_int n)
 
 let compute_lhs typ i nargsi =
   match kind_of_term typ with
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
index 6b82b75b..3d13a254 100644
--- a/contrib/ring/ring.ml
+++ b/contrib/ring/ring.ml
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: ring.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 (* ML part of the Ring tactic *)
 
 open Pp
 open Util
-open Options
+open Flags
 open Term
 open Names
 open Libnames
@@ -193,7 +193,7 @@ let _ =
 let subst_morph subst morph = 
   let plusm' = subst_mps subst morph.plusm in
   let multm' = subst_mps subst morph.multm in
-  let oppm' = option_smartmap (subst_mps subst) morph.oppm in
+  let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
     if plusm' == morph.plusm 
       && multm' == morph.multm 
       && oppm' == morph.oppm then 
@@ -215,15 +215,15 @@ let subst_set subst cset =
     if !same then cset else cset'
 
 let subst_theory subst th = 
-  let th_equiv' = option_smartmap (subst_mps subst) th.th_equiv in
-  let th_setoid_th' = option_smartmap (subst_mps subst) th.th_setoid_th in
-  let th_morph' = option_smartmap (subst_morph subst) th.th_morph in
+  let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in
+  let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in
+  let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in
   let th_a' = subst_mps subst th.th_a in                   
   let th_plus' = subst_mps subst th.th_plus in
   let th_mult' = subst_mps subst th.th_mult in
   let th_one' = subst_mps subst th.th_one in
   let th_zero' = subst_mps subst th.th_zero in
-  let th_opp' = option_smartmap (subst_mps subst) th.th_opp in
+  let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in
   let th_eq' = subst_mps subst th.th_eq in
   let th_t' = subst_mps subst th.th_t in          
   let th_closed' = subst_set subst th.th_closed in
@@ -826,9 +826,11 @@ let raw_polynom th op lc gl =
 				     c'''i; ci; c'i_eq_c''i |]))))
 	      (tclTHENS
 		 (tclORELSE
-                   (Setoid_replace.general_s_rewrite true c'i_eq_c''i
+                   (Setoid_replace.general_s_rewrite true
+		     Termops.all_occurrences c'i_eq_c''i
                      ~new_goals:[])
-                   (Setoid_replace.general_s_rewrite false c'i_eq_c''i
+                   (Setoid_replace.general_s_rewrite false 
+		     Termops.all_occurrences c'i_eq_c''i
                      ~new_goals:[]))
                  [tac]))
 	 else
diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v
index 19933873..68bc43bb 100644
--- a/contrib/romega/ROmega.v
+++ b/contrib/romega/ROmega.v
@@ -1,10 +1,11 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
 
 Require Import ReflOmegaCore.
-
+Require Export Setoid.
+Require Export PreOmega.
diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v
index d20cafc1..9d379548 100644
--- a/contrib/romega/ReflOmegaCore.v
+++ b/contrib/romega/ReflOmegaCore.v
@@ -7,32 +7,852 @@
 
  *************************************************************************)
 
-Require Import Arith.
-Require Import List.
-Require Import Bool.
-Require Import ZArith_base.
-Require Import OmegaLemmas.
-
-Open Scope Z_scope.
-
-(* \subsection{Definition of basic types} *)
-
-(* \subsubsection{Environment of propositions (lists) *)
-Inductive PropList : Type :=
-  | Pnil : PropList
-  | Pcons : Prop -> PropList -> PropList.
-
-(* Access function for the environment with a default *)
-Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} :
- Prop :=
-  match n, l with
-  | O, Pcons x l' => x
-  | O, other => default
-  | S m, Pnil => default
-  | S m, Pcons x t => nthProp m t default
-  end.
+Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable.
+Delimit Scope Int_scope with I.
+
+(* Abstract Integers. *)
+
+Module Type Int. 
+
+  Parameter int : Set. 
+
+  Parameter zero : int. 
+  Parameter one : int. 
+  Parameter plus : int -> int -> int. 
+  Parameter opp : int -> int.
+  Parameter minus : int -> int -> int. 
+  Parameter mult : int -> int -> int.
+
+  Notation "0" := zero : Int_scope.
+  Notation "1" := one : Int_scope. 
+  Infix "+" := plus : Int_scope.
+  Infix "-" := minus : Int_scope.
+  Infix "*" := mult : Int_scope.
+  Notation "- x" := (opp x) : Int_scope.
+
+  Open Scope Int_scope.
+
+  (* First, int is a ring: *)
+  Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int).
+
+  (* int should also be ordered: *)
+
+  Parameter le : int -> int -> Prop.
+  Parameter lt : int -> int -> Prop.
+  Parameter ge : int -> int -> Prop.
+  Parameter gt : int -> int -> Prop.
+  Notation "x <= y" := (le x y): Int_scope.
+  Notation "x < y" := (lt x y) : Int_scope.
+  Notation "x >= y" := (ge x y) : Int_scope.
+  Notation "x > y" := (gt x y): Int_scope.
+  Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
+  Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i).
+  Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i).
+
+  (* Basic properties of this order *)
+  Axiom lt_trans : forall i j k, i<j -> j<k -> i<k.
+  Axiom lt_not_eq : forall i j, i<j -> i<>j.
+
+  (* Compatibilities *)
+  Axiom lt_0_1 : 0<1.
+  Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l.
+  Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
+  Axiom mult_lt_compat_l : 
+   forall i j k, 0 < k -> i < j -> k*i<k*j.
+
+  (* We should have a way to decide the equality and the order*)  
+  Parameter compare : int -> int -> comparison.
+  Infix "?=" := compare (at level 70, no associativity) : Int_scope.
+  Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j.
+  Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j.
+  Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j.
+
+  (* Up to here, these requirements could be fulfilled 
+     by any totally ordered ring. Let's now be int-specific: *)
+  Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1).
+
+  (* Btw, lt_0_1 could be deduced from this last axiom *)
+
+End Int.
+
+
+
+(* Of course, Z is a model for our abstract int *)
+
+Module Z_as_Int <: Int.
+
+  Require Import ZArith_base.
+  Open Scope Z_scope.
+
+  Definition int := Z. 
+  Definition zero := 0. 
+  Definition one := 1. 
+  Definition plus := Zplus.
+  Definition opp := Zopp.
+  Definition minus := Zminus.
+  Definition mult := Zmult.
+
+  Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int).
+  Proof.
+  constructor.
+  exact Zplus_0_l.
+  exact Zplus_comm.
+  exact Zplus_assoc.
+  exact Zmult_1_l.
+  exact Zmult_comm.
+  exact Zmult_assoc.
+  exact Zmult_plus_distr_l.
+  unfold minus, Zminus; auto.
+  exact Zplus_opp_r.
+  Qed.
+
+  Definition le := Zle.
+  Definition lt := Zlt.
+  Definition ge := Zge.
+  Definition gt := Zgt.
+  Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
+  Proof.
+   split; intros.
+   apply Zle_not_lt; auto.
+   rewrite <- Zge_iff_le.
+   apply Znot_lt_ge; auto.
+  Qed.
+  Definition ge_le_iff := Zge_iff_le.
+  Definition gt_lt_iff := Zgt_iff_lt.
+
+  Definition lt_trans := Zlt_trans.
+  Definition lt_not_eq := Zlt_not_eq.
+
+  Definition lt_0_1 := Zlt_0_1.
+  Definition plus_le_compat := Zplus_le_compat.
+  Definition mult_lt_compat_l := Zmult_lt_compat_l.
+  Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
+  Proof.
+  unfold Zle; intros; rewrite <- Zcompare_opp; auto.
+  Qed.
+
+  Definition compare := Zcompare.
+  Definition compare_Eq := Zcompare_Eq_iff_eq.
+  Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j.
+  Proof. intros; unfold compare, Zlt; intuition. Qed.
+  Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j.
+  Proof. intros; unfold compare, Zgt; intuition. Qed.
+
+  Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1).
+  Proof.
+   intros; split; intros.
+   generalize (Zlt_left _ _ H); simpl; intros.
+   apply Zle_left_rev; auto.
+   apply Zlt_0_minus_lt.
+   generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H).
+   rewrite Zplus_opp_r.
+   rewrite <-Zplus_assoc.
+   rewrite (Zplus_permute (-1)).
+   simpl in *.
+   rewrite Zplus_0_r.
+   intro H'; apply H'.
+   replace (-x+1) with (Zsucc (-x)); auto.
+   apply Zlt_succ.
+  Qed.
+
+End Z_as_Int.  
+
+
+
+
+Module IntProperties (I:Int). 
+ Import I.
+ 
+ (* Primo, some consequences of being a ring theory... *)
+ 
+ Definition two := 1+1.
+ Notation "2" := two : Int_scope. 
+
+ (* Aliases for properties packed in the ring record. *)
+
+ Definition plus_assoc := ring.(Radd_assoc).
+ Definition plus_comm := ring.(Radd_comm).
+ Definition plus_0_l := ring.(Radd_0_l).
+ Definition mult_assoc := ring.(Rmul_assoc). 
+ Definition mult_comm := ring.(Rmul_comm).
+ Definition mult_1_l := ring.(Rmul_1_l).
+ Definition mult_plus_distr_r := ring.(Rdistr_l).
+ Definition opp_def := ring.(Ropp_def).
+ Definition minus_def := ring.(Rsub_def).
+
+ Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l 
+  mult_plus_distr_r opp_def minus_def.
+
+ (* More facts about plus *)
+
+ Lemma plus_0_r : forall x, x+0 = x.
+ Proof. intros; rewrite plus_comm; apply plus_0_l. Qed.
+
+ Lemma plus_0_r_reverse : forall x, x = x+0.
+ Proof. intros; symmetry; apply plus_0_r. Qed. 
+
+ Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z).
+ Proof. intros; symmetry; apply plus_assoc. Qed.
+
+ Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z).
+ Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed.
+
+ Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z.
+ Proof. 
+  intros.
+  rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x).
+  now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. 
+ Qed.
+
+ (* More facts about mult *) 
+   
+ Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z).
+ Proof. intros; symmetry; apply mult_assoc. Qed.
+
+ Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z.
+ Proof.
+  intros.
+  rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z).
+  apply mult_plus_distr_r.
+ Qed.
+
+ Lemma mult_0_l : forall x, 0*x = 0.
+ Proof. 
+  intros.
+  generalize (mult_plus_distr_r 0 1 x).
+  rewrite plus_0_l, mult_1_l, plus_comm; intros.
+  apply plus_reg_l with x.
+  rewrite <- H.
+  apply plus_0_r_reverse.
+ Qed.
+ 
+
+ (* More facts about opp *)
+
+ Definition plus_opp_r := opp_def.
+
+ Lemma plus_opp_l : forall x, -x + x = 0.
+ Proof. intros; now rewrite plus_comm, opp_def. Qed.
+
+ Lemma mult_opp_comm : forall x y, - x * y = x * - y.
+ Proof.
+  intros.
+  apply plus_reg_l with (x*y).
+  rewrite <- mult_plus_distr_l, <- mult_plus_distr_r.
+  now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l.
+ Qed.
+
+ Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1).
+ Proof.
+  intros; now rewrite mult_comm, mult_opp_comm, mult_1_l.
+ Qed.
+
+ Lemma opp_involutive : forall x, -(-x) = x.
+ Proof.
+  intros.
+  apply plus_reg_l with (-x).
+  now rewrite opp_def, plus_comm, opp_def.
+ Qed.
+
+ Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y.
+ Proof.
+  intros.
+  apply plus_reg_l with (x+y).
+  rewrite opp_def.
+  rewrite plus_permute.
+  do 2 rewrite plus_assoc.
+  now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def.
+ Qed.
+
+ Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y.
+ Proof.
+  intros.
+  rewrite <- mult_opp_comm.
+  apply plus_reg_l with (x*y).
+  now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l.
+ Qed.  
+
+ Lemma egal_left : forall n m, n=m -> n+-m = 0.
+ Proof. intros; subst; apply opp_def. Qed.
+
+ Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y).
+ Proof.
+ intros; contradict H.
+ apply (plus_reg_l (-y)).
+ now rewrite plus_opp_l, plus_comm, H.
+ Qed.
+
+ (* Special lemmas for factorisation. *)
+
+ Lemma red_factor0 : forall n, n = n*1.
+ Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed.
+
+ Lemma red_factor1 : forall n, n+n = n*2.
+ Proof. 
+  intros; unfold two.
+  now rewrite mult_comm, mult_plus_distr_r, mult_1_l.
+ Qed.
+
+ Lemma red_factor2 : forall n m, n + n*m = n * (1+m).
+ Proof.
+  intros; rewrite mult_plus_distr_l.
+  f_equal; now rewrite mult_comm, mult_1_l.
+ Qed.
+
+ Lemma red_factor3 : forall n m, n*m + n = n*(1+m).
+ Proof. intros; now rewrite plus_comm, red_factor2. Qed.
+
+ Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p).
+ Proof. 
+  intros; now rewrite mult_plus_distr_l.
+ Qed.
+ 
+ Lemma red_factor5 : forall n m , n * 0 + m = m.
+ Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed.
+
+ Definition red_factor6 := plus_0_r_reverse.
+
+
+ (* Specialized distributivities *)
+
+ Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int.
+ Hint Rewrite <- plus_assoc : int.
+
+ Lemma OMEGA10 :
+  forall v c1 c2 l1 l2 k1 k2 : int,
+  (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
+  v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
+ Proof.
+  intros; autorewrite with int; f_equal; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA11 :
+  forall v1 c1 l1 l2 k1 : int,
+  (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
+ Proof.
+  intros; now autorewrite with int.
+ Qed.
+
+ Lemma OMEGA12 :
+  forall v2 c2 l1 l2 k2 : int,
+  l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
+ Proof.
+  intros; autorewrite with int; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA13 :
+  forall v l1 l2 x : int,
+  v * -x + l1 + (v * x + l2) = l1 + l2.
+ Proof.
+ intros; autorewrite with int.
+ rewrite plus_permute; f_equal.
+ rewrite plus_assoc.
+ now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l.
+ Qed.
+
+ Lemma OMEGA15 :
+  forall v c1 c2 l1 l2 k2 : int,
+  v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
+ Proof.
+  intros; autorewrite with int; f_equal; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k.
+ Proof.
+  intros; now autorewrite with int.
+ Qed.
+
+ Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d.
+ Proof.
+ intros; elim H; elim H0; simpl in |- *; auto.
+ now rewrite mult_0_l, mult_0_l, plus_0_l.
+ Qed.
+
+
+ (* Secondo, some results about order (and equality) *)  
+
+ Lemma lt_irrefl : forall n, ~ n<n.
+ Proof.
+ intros n H.
+ elim (lt_not_eq _ _ H); auto.
+ Qed.
+
+ Lemma lt_antisym : forall n m, n<m -> m<n -> False.
+ Proof.
+ intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto.
+ Qed.
+
+ Lemma lt_le_weak : forall n m, n<m -> n<=m.
+ Proof.
+  intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto.
+ Qed.
+
+ Lemma le_refl : forall n, n<=n.
+ Proof.
+ intros; rewrite le_lt_iff; apply lt_irrefl; auto.
+ Qed.
+
+ Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m.
+ Proof.
+ intros n m; do 2 rewrite le_lt_iff; intros.
+ rewrite <- compare_Lt in H0.
+ rewrite <- gt_lt_iff, <- compare_Gt in H.
+ rewrite <- compare_Eq.
+ destruct compare; intuition.
+ Qed.
+
+ Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }.
+ Proof.
+  intros.
+  generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
+  destruct compare; [ left; right | left; left | right ]; intuition.
+  rewrite gt_lt_iff in H1; intuition.
+ Qed.
+
+ Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }.
+ Proof.
+  intros.
+  generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
+  destruct compare; [ right | left | right ]; intuition discriminate.
+ Qed.
+
+ Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n).
+ Proof.
+  intros.
+  rewrite le_lt_iff.
+  destruct (lt_dec n m); intuition.
+ Qed.
+
+ Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }.
+ Proof.
+  intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition.
+ Qed.
+
+ Lemma le_lt_dec : forall n m, { n<=m } + { m<n }.
+ Proof.
+  intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff.
+ Qed.
+
+
+ Definition beq i j := match compare i j with Eq => true | _ => false end.
+
+ Lemma beq_iff : forall i j, beq i j = true <-> i=j.
+ Proof.
+ intros; unfold beq; generalize (compare_Eq i j).
+ destruct compare; intuition discriminate.
+ Qed.
+                               
+ Lemma beq_true : forall i j, beq i j = true -> i=j.
+ Proof.
+ intros.
+ rewrite <- beq_iff; auto.
+ Qed.
+
+ Lemma beq_false : forall i j, beq i j = false -> i<>j.
+ Proof.
+ intros.
+ intro H'.
+ rewrite <- beq_iff in H'; rewrite H' in H; discriminate.
+ Qed.
+
+ Lemma eq_dec : forall n m:int, { n=m } + { n<>m }.
+ Proof.
+  intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition.
+ Qed.
+
+ Definition bgt i j := match compare i j with Gt => true | _ => false end.
+
+ Lemma bgt_iff : forall i j, bgt i j = true <-> i>j.
+ Proof.
+ intros; unfold bgt; generalize (compare_Gt i j).
+ destruct compare; intuition discriminate.
+ Qed.
+
+ Lemma bgt_true : forall i j, bgt i j = true -> i>j.
+ Proof. intros; now rewrite <- bgt_iff. Qed.
+
+ Lemma bgt_false : forall i j, bgt i j = false -> i<=j.
+ Proof. 
+  intros.
+  rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H.
+ Qed.
+
+ Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }.
+ Proof.
+  intros.
+  destruct (eq_dec n m) as [H'|H'].
+  right; intuition.
+  left; rewrite lt_le_iff.
+  contradict H'.
+  apply le_antisym; auto.
+ Qed.
+
+ Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m.
+ Proof.
+  intros.
+  destruct (le_is_lt_or_eq _ _ H); intuition.
+ Qed.
+
+ Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p.
+ Proof.
+  intros n m p; do 3 rewrite le_lt_iff; intros A B C.
+  destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto.
+  generalize (lt_trans _ _ _ H C); intuition.
+ Qed.
+ 
+ (* order and operations *)
+
+ Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0.
+ Proof.
+ intros.
+ pattern 0 at 2; rewrite <- (mult_0_l (-(1))).
+ rewrite <- opp_eq_mult_neg_1.
+ split; intros.
+ apply opp_le_compat; auto.
+ rewrite <-(opp_involutive 0), <-(opp_involutive n).
+ apply opp_le_compat; auto.
+ Qed.
+
+ Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n.
+ Proof.
+ intros; rewrite le_0_neg, opp_involutive; intuition.
+ Qed.
+
+ Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m.
+ Proof.
+ intros.
+ replace n with ((n+p)+-p).
+ replace m with ((m+p)+-p).
+ apply plus_le_compat; auto.
+ apply le_refl.
+ now rewrite <- plus_assoc, opp_def, plus_0_r.
+ now rewrite <- plus_assoc, opp_def, plus_0_r.
+ Qed.
+
+ Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q.
+ Proof.
+ intros.
+ apply le_neq_lt.
+ apply plus_le_compat; auto.
+ apply lt_le_weak; auto.
+ rewrite lt_le_iff in H0.
+ contradict H0.
+ apply plus_le_reg_r with m.
+ rewrite (plus_comm q m), <-H0, (plus_comm p m).
+ apply plus_le_compat; auto.
+ apply le_refl; auto.
+ Qed.
+
+ Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q.
+ Proof.
+ intros.
+ apply plus_le_lt_compat; auto.
+ apply lt_le_weak; auto.
+ Qed.
+
+ Lemma opp_lt_compat : forall n m, n<m -> -m < -n.
+ Proof.
+ intros n m; do 2 rewrite lt_le_iff; intros H; contradict H.
+ rewrite <-(opp_involutive m), <-(opp_involutive n).
+ apply opp_le_compat; auto.
+ Qed.
+
+ Lemma lt_0_neg : forall n, 0 < n <-> -n < 0.
+ Proof.
+ intros.
+ pattern 0 at 2; rewrite <- (mult_0_l (-(1))).
+ rewrite <- opp_eq_mult_neg_1.
+ split; intros.
+ apply opp_lt_compat; auto.
+ rewrite <-(opp_involutive 0), <-(opp_involutive n).
+ apply opp_lt_compat; auto.
+ Qed.
+
+ Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n.
+ Proof.
+ intros; rewrite lt_0_neg, opp_involutive; intuition.
+ Qed.
+
+ Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m.
+ Proof.
+ intros.
+ rewrite <- (mult_0_l n), mult_comm.
+ apply mult_lt_compat_l; auto.
+ Qed.
+
+ Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0.
+ Proof.
+ intros.
+ destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; 
+  destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; elimtype False.
+
+ rewrite lt_0_neg' in Hn.
+ rewrite lt_0_neg' in Hm.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive.
+ rewrite mult_comm, H.
+ exact (lt_irrefl 0).
+
+ rewrite lt_0_neg' in Hn.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite mult_comm, <- opp_mult_distr_r, mult_comm.
+ rewrite H.
+ rewrite opp_eq_mult_neg_1, mult_0_l.
+ exact (lt_irrefl 0).
+
+ rewrite lt_0_neg' in Hm.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite <- opp_mult_distr_r.
+ rewrite H.
+ rewrite opp_eq_mult_neg_1, mult_0_l.
+ exact (lt_irrefl 0).
+
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite H.
+ exact (lt_irrefl 0).
+ Qed.
+
+ Lemma mult_le_compat : 
+   forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l.
+ Proof.
+ intros.
+ destruct (le_is_lt_or_eq _ _ H1).
+
+ apply le_trans with (i*l).
+ destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_compat_l; auto.
+
+ generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
+ rewrite (mult_comm i), (mult_comm j).
+ destruct (le_is_lt_or_eq _ _ H0); 
+  [ | subst; do 2 rewrite mult_0_l; apply le_refl].
+ destruct (le_is_lt_or_eq _ _ H); 
+  [ | subst; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_compat_l; auto.
+
+ subst i.
+ rewrite mult_0_l.
+ generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
+ destruct (le_is_lt_or_eq _ _ H); 
+  [ | subst; rewrite mult_0_l; apply le_refl].
+ destruct (le_is_lt_or_eq _ _ H0); 
+  [ | subst; rewrite mult_comm, mult_0_l; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_0_compat; auto.
+ Qed.
+
+ Lemma sum5 :
+ forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
+ Proof.
+ intros.
+ subst b; rewrite mult_0_l, plus_0_r.
+ contradict H.
+ symmetry in H; destruct (mult_integral _ _ H); congruence.
+ Qed.
+
+ Lemma one_neq_zero : 1 <> 0.
+ Proof.
+ red; intro.
+ symmetry in H.
+ apply (lt_not_eq 0 1); auto.
+ apply lt_0_1.
+ Qed.
+
+ Lemma minus_one_neq_zero : -(1) <> 0.
+ Proof.
+ apply lt_not_eq.
+ rewrite <- lt_0_neg.
+ apply lt_0_1.
+ Qed.
+
+ Lemma le_left : forall n m, n <= m -> 0 <= m + - n.
+ Proof.
+  intros.
+  rewrite <- (opp_def m).
+  apply plus_le_compat.
+  apply le_refl.
+  apply opp_le_compat; auto.
+ Qed.
+
+ Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
+ Proof.
+ intros.
+ replace 0 with (0+0).
+ apply plus_le_compat; auto.
+ rewrite plus_0_l; auto.
+ Qed.
+
+ Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0.
+ Proof.
+ intros.
+ assert (y=-x).
+  subst x; symmetry; apply opp_involutive.
+ clear H1; subst y.
+ destruct (eq_dec 0 x) as [H'|H']; auto.
+ assert (H'':=le_neq_lt _ _ H H').
+ generalize (plus_le_lt_compat _ _ _ _ H0 H'').
+ rewrite plus_opp_l, plus_0_l.
+ intros.
+ elim (lt_not_eq _ _ H1); auto.
+ Qed.
+
+ Lemma sum2 :
+ forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
+ Proof.
+ intros.
+ subst a; rewrite mult_0_l, plus_0_l.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ Qed.
+
+ Lemma sum3 :
+ forall a b c d : int,
+  0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
+ Proof.
+ intros.
+ rewrite <- (plus_0_l 0).
+ apply plus_le_compat; auto.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ Qed.
+
+ Lemma sum4 : forall k : int, k>0 -> 0 <= k.
+ Proof.
+ intros k; rewrite gt_lt_iff; apply lt_le_weak.
+ Qed.
+
+ (* Lemmas specific to integers (they use lt_le_int) *)
+
+ Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n.
+ Proof.
+ intros; apply le_left.
+ now rewrite <- le_lt_int.
+ Qed.
+
+ Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y.
+ Proof.
+ intros.
+ generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H.
+ now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int.
+ Qed.
+
+ Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0.
+ Proof.
+ intros.
+ intro H'.
+ rewrite gt_lt_iff in H,H0.
+ destruct (lt_eq_lt_dec z 0) as [[G|G]|G].
+
+ rewrite lt_0_neg' in G.
+ generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0).
+ rewrite H'.
+ pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r.
+ intros.
+ rewrite le_lt_int in G.
+ rewrite <- opp_plus_distr in G.
+ assert (0 < y) by (apply lt_trans with x; auto).
+ generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)).
+ rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff.
+ intuition.
+
+ subst; rewrite mult_0_l, plus_0_l in H'; subst.
+ apply (lt_not_eq _ _ H); auto.
+
+ apply (lt_not_eq 0 (z*y+x)); auto.
+ rewrite <- (plus_0_l 0).
+ apply plus_lt_compat; auto.
+ apply mult_lt_0_compat; auto.
+ apply lt_trans with x; auto.
+ Qed. 
+
+ Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1).
+ Proof.
+ intros.
+ do 2 rewrite <- le_lt_int.
+ rewrite <- opp_eq_mult_neg_1.
+ destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H'].
+ auto.
+ congruence.
+ right.
+ rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0).
+ apply opp_lt_compat; auto.
+ Qed.
+
+ Lemma mult_le_approx : 
+  forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
+ Proof.
+ intros n m p.
+ do 2 rewrite gt_lt_iff.
+ do 2 rewrite le_lt_iff; intros.
+ contradict H1.
+ rewrite lt_0_neg' in H1.
+ rewrite lt_0_neg'.
+ rewrite opp_plus_distr.
+ rewrite mult_comm, opp_mult_distr_r.
+ rewrite le_lt_int.
+ rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc.
+ apply lt_left.
+ rewrite le_lt_int.
+ rewrite le_lt_int in H0.
+ apply le_trans with (n+-(1)); auto.
+ apply plus_le_compat; [ | apply le_refl ].
+ rewrite le_lt_int in H1.
+ generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)).
+ rewrite mult_0_l.
+ rewrite mult_plus_distr_l.
+ rewrite <- opp_eq_mult_neg_1.
+ intros.
+ generalize (plus_le_compat _ _ _ _ (le_refl n) H2).
+ now rewrite plus_permute, opp_def, plus_0_r, plus_0_r.
+ Qed.
+
+ (* Some decidabilities *)
+
+ Lemma dec_eq : forall i j:int, decidable (i=j).
+ Proof.
+  red; intros; destruct (eq_dec i j); auto.
+ Qed.
+
+ Lemma dec_ne : forall i j:int, decidable (i<>j).
+ Proof.
+  red; intros; destruct (eq_dec i j); auto.
+ Qed.
+
+ Lemma dec_le : forall i j:int, decidable (i<=j).
+ Proof.
+  red; intros; destruct (le_dec i j); auto.
+ Qed.
+
+ Lemma dec_lt : forall i j:int, decidable (i<j).
+ Proof.
+  red; intros; destruct (lt_dec i j); auto.
+ Qed.
+
+ Lemma dec_ge : forall i j:int, decidable (i>=j).
+ Proof.
+  red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto.
+ Qed.
+
+ Lemma dec_gt : forall i j:int, decidable (i>j).
+ Proof.
+  red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto.
+ Qed.
+
+End IntProperties.
+
+
+
+
+Module IntOmega (I:Int).
+Import I.
+Module IP:=IntProperties(I).
+Import IP.
    
-(* \subsubsection{Définition of reified integer expressions}
+(* \subsubsection{Definition of reified integer expressions}
    Terms are either:
    \begin{itemize}
    \item integers [Tint]
@@ -41,7 +861,7 @@ Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} :
    The last two are translated in additions and products. *)
 
 Inductive term : Set :=
-  | Tint : Z -> term
+  | Tint : int -> term
   | Tplus : term -> term -> term
   | Tmult : term -> term -> term
   | Tminus : term -> term -> term
@@ -49,6 +869,7 @@ Inductive term : Set :=
   | Tvar : nat -> term.
 
 Delimit Scope romega_scope with term.
+Arguments Scope Tint [Int_scope].
 Arguments Scope Tplus [romega_scope romega_scope].
 Arguments Scope Tmult [romega_scope romega_scope].
 Arguments Scope Tminus [romega_scope romega_scope].
@@ -58,20 +879,21 @@ Infix "+" := Tplus : romega_scope.
 Infix "*" := Tmult : romega_scope.
 Infix "-" := Tminus : romega_scope.
 Notation "- x" := (Topp x) : romega_scope.
-Notation "[ x ]" := (Tvar x) (at level 1) : romega_scope.
+Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope.
 
 (* \subsubsection{Definition of reified goals} *)
+
 (* Very restricted definition of handled predicates that should be extended
    to cover a wider set of operations.
    Taking care of negations and disequations require solving more than a
    goal in parallel. This is a major improvement over previous versions. *)
 
 Inductive proposition : Set :=
-  | EqTerm : term -> term -> proposition (* egalité entre termes *)
-  | LeqTerm : term -> term -> proposition (* plus petit ou egal *)
-  | TrueTerm : proposition (* vrai *)
-  | FalseTerm : proposition (* faux *)
-  | Tnot : proposition -> proposition (* négation *)
+  | EqTerm : term -> term -> proposition (* equality between terms *)
+  | LeqTerm : term -> term -> proposition (* less or equal on terms *)
+  | TrueTerm : proposition (* true *)
+  | FalseTerm : proposition (* false *)
+  | Tnot : proposition -> proposition (* negation *)
   | GeqTerm : term -> term -> proposition
   | GtTerm : term -> term -> proposition
   | LtTerm : term -> term -> proposition
@@ -87,7 +909,7 @@ Notation hyps := (list proposition).
 (* Definition of lists of subgoals  (set of open goals) *)
 Notation lhyps := (list hyps).
 
-(* a syngle goal packed in a subgoal list *)
+(* a single goal packed in a subgoal list *)
 Notation singleton := (fun a : hyps => a :: nil).
 
 (* an absurd goal *)
@@ -110,24 +932,22 @@ Inductive t_fusion : Set :=
 
 (* \subsubsection{Rewriting steps to normalize terms} *)
 Inductive step : Set := 
- (* apply the rewriting steps to both subterms of an operation *)
-  | C_DO_BOTH :
-      step -> step -> step
-              (* apply the rewriting step to the first branch *)
+  (* apply the rewriting steps to both subterms of an operation *)
+  | C_DO_BOTH : step -> step -> step
+  (* apply the rewriting step to the first branch *)
   | C_LEFT : step -> step
-             (* apply the rewriting step to the second branch *)
+  (* apply the rewriting step to the second branch *)
   | C_RIGHT : step -> step
-              (* apply two steps consecutively to a term *)
-  | C_SEQ : step -> step -> step
-                    (* empty step *)
-  | C_NOP : step
-      (* the following operations correspond to actual rewriting *)
+  (* apply two steps consecutively to a term *)
+  | C_SEQ : step -> step -> step 
+  (* empty step *)
+  | C_NOP : step 
+  (* the following operations correspond to actual rewriting *)
   | C_OPP_PLUS : step
   | C_OPP_OPP : step
   | C_OPP_MULT_R : step
-  | C_OPP_ONE :
-      step
-      (* This is a special step that reduces the term (computation) *)
+  | C_OPP_ONE : step
+  (* This is a special step that reduces the term (computation) *)
   | C_REDUCE : step
   | C_MULT_PLUS_DISTR : step
   | C_MULT_OPP_LEFT : step
@@ -152,261 +972,98 @@ Inductive step : Set :=
    the trace coming from the decision procedure Omega. *)
 
 Inductive t_omega : Set :=
- (* n = 0 n!= 0 *)
+  (* n = 0 and n!= 0 *)
   | O_CONSTANT_NOT_NUL : nat -> t_omega
-  | O_CONSTANT_NEG :
-      nat -> t_omega
-      (* division et approximation of an equation *)
-  | O_DIV_APPROX :
-      Z ->
-      Z ->
-      term ->
-      nat ->
-      t_omega -> nat -> t_omega
-                 (* no solution because no exact division *)
-  | O_NOT_EXACT_DIVIDE :
-      Z -> Z -> term -> nat -> nat -> t_omega
-                               (* exact division *)
-  | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega
-  | O_SUM : Z -> nat -> Z -> nat -> list t_fusion -> t_omega -> t_omega
+  | O_CONSTANT_NEG : nat -> t_omega
+  (* division and approximation of an equation *)
+  | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega
+  (* no solution because no exact division *)
+  | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega
+  (* exact division *)
+  | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega
+  | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega
   | O_CONTRADICTION : nat -> nat -> nat -> t_omega
   | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega
   | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega
   | O_CONSTANT_NUL : nat -> t_omega
   | O_NEGATE_CONTRADICT : nat -> nat -> t_omega
   | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega
-  | O_STATE : Z -> step -> nat -> nat -> t_omega -> t_omega.
+  | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega.
+
+(* \subsubsection{Rules for normalizing the hypothesis} *)
+(* These rules indicate how to normalize useful propositions 
+   of each useful hypothesis before the decomposition of hypothesis. 
+   The rules include the inversion phase for negation removal. *)
 
-(* \subsubsection{Règles pour normaliser les hypothèses} *)
-(* Ces règles indiquent comment normaliser les propositions utiles 
-   de chaque hypothèse utile avant la décomposition des hypothèses et 
-   incluent l'étape d'inversion pour la suppression des négations *)
 Inductive p_step : Set :=
   | P_LEFT : p_step -> p_step
   | P_RIGHT : p_step -> p_step
   | P_INVERT : step -> p_step
   | P_STEP : step -> p_step
   | P_NOP : p_step.
-(* Liste des normalisations a effectuer : avec un constructeur dans le
-   type [p_step] permettant
-   de parcourir à la fois les branches gauches et droit, on pourrait n'avoir
-   qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont 
-   utiles (sinon on ne les inclurait pas), on pourrait remplacer [h_step] 
-   par une simple liste *)
+
+(* List of normalizations to perform : with a constructor of type 
+   [p_step] allowing to visit both left and right branches, we would be  
+   able to restrict to only one normalization by hypothesis. 
+   And since all hypothesis are useful (otherwise they wouldn't be included), 
+   we would be able to replace [h_step] by a simple list. *)
 
 Inductive h_step : Set :=
     pair_step : nat -> p_step -> h_step.
 
-(* \subsubsection{Règles pour décomposer les hypothèses} *)
-(* Ce type permet de se diriger dans les constructeurs logiques formant les
-   prédicats des hypothèses pour aller les décomposer. Ils permettent
-   en particulier d'extraire une hypothèse d'une conjonction avec
-   éventuellement le bon niveau de négations. *)
+(* \subsubsection{Rules for decomposing the hypothesis} *)
+(* This type allows to navigate in the logical constructors that 
+   form the predicats of the hypothesis in order to decompose them. 
+   This allows in particular to extract one hypothesis from a 
+   conjonction with possibly the right level of negations. *)
 
 Inductive direction : Set :=
   | D_left : direction
   | D_right : direction
   | D_mono : direction.
 
-(* Ce type permet d'extraire les composants utiles des hypothèses : que ce
-   soit des hypothèses générées par éclatement d'une disjonction, ou 
-   des équations. Le constructeur terminal indique comment résoudre le système
-   obtenu en recourrant au type de trace d'Omega [t_omega] *)
+(* This type allows to extract useful components from hypothesis, either
+   hypothesis generated by splitting a disjonction, or equations. 
+   The last constructor indicates how to solve the obtained system 
+   via the use of the trace type of Omega [t_omega] *)
 
 Inductive e_step : Set :=
   | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step
   | E_EXTRACT : nat -> list direction -> e_step -> e_step
   | E_SOLVE : t_omega -> e_step.
 
-(* \subsection{Egalité décidable efficace} *)
-(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace.
-   Ce n'est pas le cas de celui rendu par [Decide Equality].
+(* \subsection{Efficient decidable equality} *)
+(* For each reified data-type, we define an efficient equality test. 
+   It is not the one produced by [Decide Equality].
    
-   Puis on prouve deux théorèmes permettant d'éliminer de telles égalités :
+   Then we prove two theorem allowing to eliminate such equalities : 
    \begin{verbatim}
    (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
    (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
    \end{verbatim} *)
 
-(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour
-   les théorèmes positifs, l'autre pour les théorèmes négatifs *)
-
-Ltac absurd_case := simpl in |- *; intros; discriminate.
-Ltac trivial_case := unfold not in |- *; intros; discriminate.
-
-(* \subsubsection{Entiers naturels} *)
-
-Fixpoint eq_nat (t1 t2 : nat) {struct t2} : bool :=
-  match t1 with
-  | O => match t2 with
-         | O => true
-         | _ => false
-         end
-  | S n1 => match t2 with
-            | O => false
-            | S n2 => eq_nat n1 n2
-            end
-  end.
-
-Theorem eq_nat_true : forall t1 t2 : nat, eq_nat t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intro t2; case t2; [ trivial | absurd_case ]
- | intros n H t2; case t2;
-    [ absurd_case
-    | simpl in |- *; intros; rewrite (H n0); [ trivial | assumption ] ] ].
-
-Qed.
-  
-Theorem eq_nat_false : forall t1 t2 : nat, eq_nat t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intro t2; case t2; [ simpl in |- *; intros; discriminate | trivial_case ]
- | intros n H t2; case t2; simpl in |- *; unfold not in |- *; intros;
-    [ discriminate | elim (H n0 H0); simplify_eq H1; trivial ] ].
-
-Qed.
-                                   
-
-(* \subsubsection{Entiers positifs} *)
+(* \subsubsection{Reified terms} *)
 
-Fixpoint eq_pos (p1 p2 : positive) {struct p2} : bool :=
-  match p1 with
-  | xI n1 => match p2 with
-             | xI n2 => eq_pos n1 n2
-             | _ => false
-             end
-  | xO n1 => match p2 with
-             | xO n2 => eq_pos n1 n2
-             | _ => false
-             end
-  | xH => match p2 with
-          | xH => true
-          | _ => false
-          end
-  end.
+Open Scope romega_scope.
 
-Theorem eq_pos_true : forall t1 t2 : positive, eq_pos t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intros p H t2; case t2;
-    [ simpl in |- *; intros; rewrite (H p0 H0); trivial
-    | absurd_case
-    | absurd_case ]
- | intros p H t2; case t2;
-    [ absurd_case
-    | simpl in |- *; intros; rewrite (H p0 H0); trivial
-    | absurd_case ]
- | intro t2; case t2; [ absurd_case | absurd_case | auto ] ].
-
-Qed.
-  
-Theorem eq_pos_false :
- forall t1 t2 : positive, eq_pos t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intros p H t2; case t2;
-    [ simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
-       simplify_eq H1; auto
-    | trivial_case
-    | trivial_case ]
- | intros p H t2; case t2;
-    [ trivial_case
-    | simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
-       simplify_eq H1; auto
-    | trivial_case ]
- | intros t2; case t2; [ trivial_case | trivial_case | absurd_case ] ].
-Qed.
-
-(* \subsubsection{Entiers relatifs} *)
-
-Definition eq_Z (z1 z2 : Z) : bool :=
-  match z1 with
-  | Z0 => match z2 with
-          | Z0 => true
-          | _ => false
-          end
-  | Zpos p1 => match z2 with
-               | Zpos p2 => eq_pos p1 p2
-               | _ => false
-               end
-  | Zneg p1 => match z2 with
-               | Zneg p2 => eq_pos p1 p2
-               | _ => false
-               end
+Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
+  match t1, t2 with
+  | Tint st1, Tint st2 => beq st1 st2
+  | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22
+  | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22
+  | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22
+  | (- st1), (- st2) => eq_term st1 st2
+  | [st1], [st2] => beq_nat st1 st2
+  | _, _ => false
   end.
 
-Theorem eq_Z_true : forall t1 t2 : Z, eq_Z t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intros t2; case t2; [ auto | absurd_case | absurd_case ]
- | intros p t2; case t2;
-    [ absurd_case
-    | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial
-    | absurd_case ]
- | intros p t2; case t2;
-    [ absurd_case
-    | absurd_case
-    | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial ] ].
-
-Qed.
-
-Theorem eq_Z_false : forall t1 t2 : Z, eq_Z t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intros t2; case t2; [ absurd_case | trivial_case | trivial_case ]
- | intros p t2; case t2;
-    [ absurd_case
-    | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
-       simplify_eq H0; auto
-    | trivial_case ]
- | intros p t2; case t2;
-    [ absurd_case
-    | trivial_case
-    | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
-       simplify_eq H0; auto ] ].
-Qed.
-
-(* \subsubsection{Termes réifiés} *)
-
-Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
-  match t1 with
-  | Tint st1 => match t2 with
-                | Tint st2 => eq_Z st1 st2
-                | _ => false
-                end
-  | (st11 + st12)%term =>
-      match t2 with
-      | (st21 + st22)%term => eq_term st11 st21 && eq_term st12 st22
-      | _ => false
-      end
-  | (st11 * st12)%term =>
-      match t2 with
-      | (st21 * st22)%term => eq_term st11 st21 && eq_term st12 st22
-      | _ => false
-      end
-  | (st11 - st12)%term =>
-      match t2 with
-      | (st21 - st22)%term => eq_term st11 st21 && eq_term st12 st22
-      | _ => false
-      end
-  | (- st1)%term =>
-      match t2 with
-      | (- st2)%term => eq_term st1 st2
-      | _ => false
-      end
-  | [st1]%term =>
-      match t2 with
-      | [st2]%term => eq_nat st1 st2
-      | _ => false
-      end
-  end.  
+Close Scope romega_scope.  
 
 Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
-
-
-simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *;
- [ intros; elim eq_Z_true with (1 := H); trivial
+Proof.
+ simple induction t1; intros until t2; case t2; simpl in *;
+ try (intros; discriminate; fail); 
+ [ intros; elim beq_true with (1 := H); trivial
  | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
     elim H with (1 := H4); elim H0 with (1 := H5); 
     trivial
@@ -417,16 +1074,17 @@ simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *;
     elim H with (1 := H4); elim H0 with (1 := H5); 
     trivial
  | intros t21 H3; elim H with (1 := H3); trivial
- | intros; elim eq_nat_true with (1 := H); trivial ].
-
+ | intros; elim beq_nat_true with (1 := H); trivial ].
 Qed.
 
+Ltac trivial_case := unfold not in |- *; intros; discriminate.
+
 Theorem eq_term_false :
  forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
+Proof.
+ simple induction t1;
  [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim eq_Z_false with (1 := H); simplify_eq H0; 
+    intros; elim beq_false with (1 := H); simplify_eq H0; 
     auto
  | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
     intros t21 t22 H3; unfold not in |- *; intro H4;
@@ -447,9 +1105,8 @@ simple induction t1;
     unfold not in |- *; intro H4; elim H1 with (1 := H3); 
     simplify_eq H4; auto
  | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim eq_nat_false with (1 := H); simplify_eq H0; 
+    intros; elim beq_nat_false with (1 := H); simplify_eq H0; 
     auto ].
-
 Qed.
 
 (* \subsubsection{Tactiques pour éliminer ces tests} 
@@ -463,54 +1120,29 @@ Qed.
    tel test préserve bien l'information voulue mais calculatoirement de
    telles fonctions sont trop lentes. *)
 
-(* Le théorème suivant permet de garder dans les hypothèses la valeur
-   du booléen lors de l'élimination. *)
-
-Theorem bool_ind2 :
- forall (P : bool -> Prop) (b : bool),
- (b = true -> P true) -> (b = false -> P false) -> P b.
-
-simple induction b; auto.
-Qed.
-
 (* Les tactiques définies si après se comportent exactement comme si on
    avait utilisé le test précédent et fait une elimination dessus. *)
 
 Ltac elim_eq_term t1 t2 :=
-  pattern (eq_term t1 t2) in |- *; apply bool_ind2; intro Aux;
+  pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux;
    [ generalize (eq_term_true t1 t2 Aux); clear Aux
    | generalize (eq_term_false t1 t2 Aux); clear Aux ].
 
-Ltac elim_eq_Z t1 t2 :=
-  pattern (eq_Z t1 t2) in |- *; apply bool_ind2; intro Aux;
-   [ generalize (eq_Z_true t1 t2 Aux); clear Aux
-   | generalize (eq_Z_false t1 t2 Aux); clear Aux ].
-
-Ltac elim_eq_pos t1 t2 :=
-  pattern (eq_pos t1 t2) in |- *; apply bool_ind2; intro Aux;
-   [ generalize (eq_pos_true t1 t2 Aux); clear Aux
-   | generalize (eq_pos_false t1 t2 Aux); clear Aux ].
+Ltac elim_beq t1 t2 :=
+  pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+   [ generalize (beq_true t1 t2 Aux); clear Aux
+   | generalize (beq_false t1 t2 Aux); clear Aux ].
 
-(* \subsubsection{Comparaison sur Z} *)
-
-(* Sujet très lié au précédent : on introduit la tactique d'élimination
-   avec son théorème *)
-
-Theorem relation_ind2 :
- forall (P : comparison -> Prop) (b : comparison),
- (b = Eq -> P Eq) ->
- (b = Lt -> P Lt) ->
- (b = Gt -> P Gt) -> P b.
-
-simple induction b; auto.
-Qed.
+Ltac elim_bgt t1 t2 := 
+  pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; 
+  [ generalize (bgt_true t1 t2 Aux); clear Aux
+  | generalize (bgt_false t1 t2 Aux); clear Aux ].
 
-Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2) in |- *; apply relation_ind2.
 
 (* \subsection{Interprétations}
    \subsubsection{Interprétation des termes dans Z} *)
 
-Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z :=
+Fixpoint interp_term (env : list int) (t : term) {struct t} : int :=
   match t with
   | Tint x => x
   | (t1 + t2)%term => interp_term env t1 + interp_term env t2
@@ -521,7 +1153,8 @@ Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z :=
   end.
 
 (* \subsubsection{Interprétation des prédicats} *) 
-Fixpoint interp_proposition (envp : PropList) (env : list Z)
+
+Fixpoint interp_proposition (envp : list Prop) (env : list int)
  (p : proposition) {struct p} : Prop :=
   match p with
   | EqTerm t1 t2 => interp_term env t1 = interp_term env t2
@@ -532,14 +1165,14 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
   | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2
   | GtTerm t1 t2 => interp_term env t1 > interp_term env t2
   | LtTerm t1 t2 => interp_term env t1 < interp_term env t2
-  | NeqTerm t1 t2 => Zne (interp_term env t1) (interp_term env t2)
+  | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2)
   | Tor p1 p2 =>
       interp_proposition envp env p1 \/ interp_proposition envp env p2
   | Tand p1 p2 =>
       interp_proposition envp env p1 /\ interp_proposition envp env p2
   | Timp p1 p2 =>
       interp_proposition envp env p1 -> interp_proposition envp env p2
-  | Tprop n => nthProp n envp True
+  | Tprop n => nth n envp True
   end.
 
 (* \subsubsection{Inteprétation des listes d'hypothèses}
@@ -547,7 +1180,7 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
    Interprétation sous forme d'une conjonction d'hypothèses plus faciles
    à manipuler individuellement *)
 
-Fixpoint interp_hyps (envp : PropList) (env : list Z) 
+Fixpoint interp_hyps (envp : list Prop) (env : list int) 
  (l : hyps) {struct l} : Prop :=
   match l with
   | nil => True
@@ -559,8 +1192,8 @@ Fixpoint interp_hyps (envp : PropList) (env : list Z)
    [Generalize] et qu'une conjonction est forcément lourde (répétition des
    types dans les conjonctions intermédiaires) *)
 
-Fixpoint interp_goal_concl (c : proposition) (envp : PropList) 
- (env : list Z) (l : hyps) {struct l} : Prop :=
+Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) 
+ (env : list int) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
   | p' :: l' =>
@@ -573,19 +1206,19 @@ Notation interp_goal := (interp_goal_concl FalseTerm).
    interprétations. *)
 
 Theorem goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : hyps),
+ forall (envp : list Prop) (env : list int) (l : hyps),
  (interp_hyps envp env l -> False) -> interp_goal envp env l.
-
-simple induction l;
+Proof.
+ simple induction l;
  [ simpl in |- *; auto
  | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ].
 Qed.
 
 Theorem hyps_to_goal :
- forall (envp : PropList) (env : list Z) (l : hyps),
+ forall (envp : list Prop) (env : list int) (l : hyps),
  interp_goal envp env l -> interp_hyps envp env l -> False.
-
-simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
+Proof.
+ simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
 Qed.
       
 (* \subsection{Manipulations sur les hypothèses} *)
@@ -593,7 +1226,7 @@ Qed.
 (* \subsubsection{Définitions de base de stabilité pour la réflexion} *)
 (* Une opération laisse un terme stable si l'égalité est préservée *)
 Definition term_stable (f : term -> term) :=
-  forall (e : list Z) (t : term), interp_term e t = interp_term e (f t).
+  forall (e : list int) (t : term), interp_term e t = interp_term e (f t).
 
 (* Une opération est valide sur une hypothèse, si l'hypothèse implique le
    résultat de l'opération. \emph{Attention : cela ne concerne que des 
@@ -602,11 +1235,11 @@ Definition term_stable (f : term -> term) :=
    en argument (cela suffit pour omega). *)
 
 Definition valid1 (f : proposition -> proposition) :=
-  forall (ep : PropList) (e : list Z) (p1 : proposition),
+  forall (ep : list Prop) (e : list int) (p1 : proposition),
   interp_proposition ep e p1 -> interp_proposition ep e (f p1).
 
 Definition valid2 (f : proposition -> proposition -> proposition) :=
-  forall (ep : PropList) (e : list Z) (p1 p2 : proposition),
+  forall (ep : list Prop) (e : list int) (p1 p2 : proposition),
   interp_proposition ep e p1 ->
   interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2).
 
@@ -615,31 +1248,31 @@ Definition valid2 (f : proposition -> proposition -> proposition) :=
    On reste contravariant *)
 
 Definition valid_hyps (f : hyps -> hyps) :=
-  forall (ep : PropList) (e : list Z) (lp : hyps),
+  forall (ep : list Prop) (e : list int) (lp : hyps),
   interp_hyps ep e lp -> interp_hyps ep e (f lp).
 
 (* Enfin ce théorème élimine la contravariance et nous ramène à une 
    opération sur les buts *)
 
- Theorem valid_goal :
-  forall (ep : PropList) (env : list Z) (l : hyps) (a : hyps -> hyps),
+Theorem valid_goal :
+  forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps),
   valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
-
-intros; simpl in |- *; apply goal_to_hyps; intro H1;
+Proof.
+ intros; simpl in |- *; apply goal_to_hyps; intro H1;
  apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
 Qed.
 
 (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *)
 
 
-Fixpoint interp_list_hyps (envp : PropList) (env : list Z) 
+Fixpoint interp_list_hyps (envp : list Prop) (env : list int) 
  (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => False
   | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l'
   end.
 
-Fixpoint interp_list_goal (envp : PropList) (env : list Z) 
+Fixpoint interp_list_goal (envp : list Prop) (env : list int) 
  (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => True
@@ -647,10 +1280,10 @@ Fixpoint interp_list_goal (envp : PropList) (env : list Z)
   end.
 
 Theorem list_goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
  (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
-
-simple induction l; simpl in |- *;
+Proof.
+ simple induction l; simpl in |- *;
  [ auto
  | intros h1 l1 H H1; split;
     [ apply goal_to_hyps; intro H2; apply H1; auto
@@ -658,37 +1291,37 @@ simple induction l; simpl in |- *;
 Qed.
 
 Theorem list_hyps_to_goal :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
  interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
-
-simple induction l; simpl in |- *;
+Proof.
+ simple induction l; simpl in |- *;
  [ auto
  | intros h1 l1 H (H1, H2) H3; elim H3; intro H4;
     [ apply hyps_to_goal with (1 := H1); assumption | auto ] ].
 Qed.
 
 Definition valid_list_hyps (f : hyps -> lhyps) :=
-  forall (ep : PropList) (e : list Z) (lp : hyps),
+  forall (ep : list Prop) (e : list int) (lp : hyps),
   interp_hyps ep e lp -> interp_list_hyps ep e (f lp).
 
 Definition valid_list_goal (f : hyps -> lhyps) :=
-  forall (ep : PropList) (e : list Z) (lp : hyps),
+  forall (ep : list Prop) (e : list int) (lp : hyps),
   interp_list_goal ep e (f lp) -> interp_goal ep e lp.
 
 Theorem goal_valid :
  forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
-
-unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
+Proof.
+ unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
  intro H2; apply list_hyps_to_goal with (1 := H1); 
  apply (H ep e lp); assumption.
 Qed.
  
 Theorem append_valid :
- forall (ep : PropList) (e : list Z) (l1 l2 : lhyps),
+ forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
  interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
  interp_list_hyps ep e (l1 ++ l2).
-
-intros ep e; simple induction l1;
+Proof.
+ intros ep e; simple induction l1;
  [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ]
  | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H];
     [ auto
@@ -703,10 +1336,10 @@ Qed.
 Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
 
 Theorem nth_valid :
- forall (ep : PropList) (e : list Z) (i : nat) (l : hyps),
+ forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
  interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
-
-unfold nth_hyps in |- *; simple induction i;
+Proof.
+ unfold nth_hyps in |- *; simple induction i;
  [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ]
  | intros n H; simple induction l;
     [ simpl in |- *; trivial
@@ -722,8 +1355,8 @@ Definition apply_oper_2 (i j : nat)
 Theorem apply_oper_2_valid :
  forall (i j : nat) (f : proposition -> proposition -> proposition),
  valid2 f -> valid_hyps (apply_oper_2 i j f).
-
-intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *;
+Proof.
+ intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *;
  intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ].
 Qed.
 
@@ -743,8 +1376,8 @@ Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
 Theorem apply_oper_1_valid :
  forall (i : nat) (f : proposition -> proposition),
  valid1 f -> valid_hyps (apply_oper_1 i f).
-
-unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
+Proof.
+ unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
  [ intro lp; case lp;
     [ simpl in |- *; trivial
     | simpl in |- *; intros p l' (H1, H2); split;
@@ -753,7 +1386,6 @@ unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
     [ simpl in |- *; auto
     | simpl in |- *; intros p l' (H1, H2); split;
        [ assumption | apply Hrec; assumption ] ] ].
-
 Qed.
 
 (* \subsubsection{Manipulations de termes} *)
@@ -789,31 +1421,31 @@ Definition apply_both (f g : term -> term) (t : term) :=
 
 Theorem apply_left_stable :
  forall f : term -> term, term_stable f -> term_stable (apply_left f).
-
-unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+Proof.
+ unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
  intros; elim H; trivial.
 Qed.
 
 Theorem apply_right_stable :
  forall f : term -> term, term_stable f -> term_stable (apply_right f).
-
-unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+Proof.
+ unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
  intros t0 t1; elim H; trivial.
 Qed.
 
 Theorem apply_both_stable :
  forall f g : term -> term,
  term_stable f -> term_stable g -> term_stable (apply_both f g).
-
-unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
+Proof.
+ unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
  intros t0 t1; elim H1; elim H2; trivial.
 Qed.
 
 Theorem compose_term_stable :
  forall f g : term -> term,
  term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)).
-
-unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
+Proof.
+ unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
 Qed.
 
 (* \subsection{Les règles de réécriture} *)
@@ -879,21 +1511,7 @@ Ltac loop t :=
     | Tand x x0 => _
     | Timp x x0 => _
     | Tprop x => _
-    end =>
-       case X1;
-       [ intro; intro
-       | intro; intro
-       | idtac
-       | idtac
-       | intro
-       | intro; intro
-       | intro; intro
-       | intro; intro
-       | intro; intro
-       | intro; intro
-       | intro; intro
-       | intro; intro
-       | intro ]; auto; Simplify
+    end => destruct X1; auto; Simplify
   | match ?X1 with
     | Tint x => _
     | (x + x0)%term => _
@@ -901,38 +1519,27 @@ Ltac loop t :=
     | (x - x0)%term => _
     | (- x)%term => _
     | [x]%term => _
-    end =>
-      case X1;
-       [ intro | intro; intro | intro; intro | intro; intro | intro | intro ];
-       auto; Simplify
-  | match ?X1 ?= ?X2 with
-    | Eq => _
-    | Lt => _
-    | Gt => _
-    end =>
-      elim_Zcompare X1 X2; intro; auto; Simplify
-  | match ?X1 with
-    | Z0 => _
-    | Zpos x => _
-    | Zneg x => _
-    end =>
-      case X1; [ idtac | intro | intro ]; auto; Simplify
-  | (if eq_Z ?X1 ?X2 then _ else _) =>
-      elim_eq_Z X1 X2; intro H; [ rewrite H; clear H | clear H ];
+    end => destruct X1; auto; Simplify
+  | (if beq ?X1 ?X2 then _ else _) =>
+      let H := fresh "H" in 
+      elim_beq X1 X2; intro H; try (rewrite H in *; clear H);
        simpl in |- *; auto; Simplify
+  | (if bgt ?X1 ?X2 then _ else _) =>
+      let H := fresh "H" in 
+      elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify
   | (if eq_term ?X1 ?X2 then _ else _) =>
-      elim_eq_term X1 X2; intro H; [ rewrite H; clear H | clear H ];
-       simpl in |- *; auto; Simplify
-  | (if eq_pos ?X1 ?X2 then _ else _) =>
-      elim_eq_pos X1 X2; intro H; [ rewrite H; clear H | clear H ];
+      let H := fresh "H" in 
+      elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); 
        simpl in |- *; auto; Simplify
+  | (if _ && _ then _ else _) => rewrite andb_if; Simplify
+  | (if negb _ then _ else _) => rewrite negb_if; Simplify
   | _ => fail
   end
- with Simplify := match goal with
-                  |  |- ?X1 => try loop X1
-                  | _ => idtac
-                  end.
 
+with Simplify := match goal with
+  |  |- ?X1 => try loop X1
+  | _ => idtac
+  end.
 
 Ltac prove_stable x th :=
   match constr:x with
@@ -949,8 +1556,8 @@ Definition Tplus_assoc_l (t : term) :=
   end.
 
 Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l.
-
-prove_stable Tplus_assoc_l Zplus_assoc.
+Proof.
+ prove_stable Tplus_assoc_l (ring.(Radd_assoc)).
 Qed.
 
 Definition Tplus_assoc_r (t : term) :=
@@ -960,8 +1567,8 @@ Definition Tplus_assoc_r (t : term) :=
   end.
 
 Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r.
-
-prove_stable Tplus_assoc_r Zplus_assoc_reverse.
+Proof.
+ prove_stable Tplus_assoc_r plus_assoc_reverse.
 Qed.
 
 Definition Tmult_assoc_r (t : term) :=
@@ -971,8 +1578,8 @@ Definition Tmult_assoc_r (t : term) :=
   end.
 
 Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r.
-
-prove_stable Tmult_assoc_r Zmult_assoc_reverse.
+Proof.
+ prove_stable Tmult_assoc_r mult_assoc_reverse.
 Qed.
 
 Definition Tplus_permute (t : term) :=
@@ -982,46 +1589,44 @@ Definition Tplus_permute (t : term) :=
   end.
 
 Theorem Tplus_permute_stable : term_stable Tplus_permute.
-
-prove_stable Tplus_permute Zplus_permute.
+Proof.
+ prove_stable Tplus_permute plus_permute.
 Qed.
 
-Definition Tplus_sym (t : term) :=
+Definition Tplus_comm (t : term) :=
   match t with
   | (x + y)%term => (y + x)%term
   | _ => t
   end.
 
-Theorem Tplus_sym_stable : term_stable Tplus_sym.
-
-prove_stable Tplus_sym Zplus_comm.
+Theorem Tplus_comm_stable : term_stable Tplus_comm.
+Proof.
+ prove_stable Tplus_comm plus_comm.
 Qed.
 
-Definition Tmult_sym (t : term) :=
+Definition Tmult_comm (t : term) :=
   match t with
   | (x * y)%term => (y * x)%term
   | _ => t
   end.
 
-Theorem Tmult_sym_stable : term_stable Tmult_sym.
-
-prove_stable Tmult_sym Zmult_comm.
+Theorem Tmult_comm_stable : term_stable Tmult_comm.
+Proof.
+ prove_stable Tmult_comm mult_comm.
 Qed.
 
 Definition T_OMEGA10 (t : term) :=
   match t with
   | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term =>
-      match eq_term v v' with
-      | true =>
-          (v * Tint (c1 * k1 + c2 * k2) + (l1 * Tint k1 + l2 * Tint k2))%term
-      | false => t
-      end
+      if eq_term v v' 
+      then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term
+      else t
   | _ => t
   end.
 
 Theorem T_OMEGA10_stable : term_stable T_OMEGA10.
-
-prove_stable T_OMEGA10 OMEGA10.
+Proof.
+ prove_stable T_OMEGA10 OMEGA10.
 Qed.
 
 Definition T_OMEGA11 (t : term) :=
@@ -1032,8 +1637,8 @@ Definition T_OMEGA11 (t : term) :=
   end.
 
 Theorem T_OMEGA11_stable : term_stable T_OMEGA11.
-
-prove_stable T_OMEGA11 OMEGA11.
+Proof.
+ prove_stable T_OMEGA11 OMEGA11.
 Qed.
 
 Definition T_OMEGA12 (t : term) :=
@@ -1044,52 +1649,37 @@ Definition T_OMEGA12 (t : term) :=
   end.
 
 Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
-
-prove_stable T_OMEGA12 OMEGA12.
+Proof.
+ prove_stable T_OMEGA12 OMEGA12.
 Qed. 
 
 Definition T_OMEGA13 (t : term) :=
   match t with
-  | (v * Tint (Zpos x) + l1 + (v' * Tint (Zneg x') + l2))%term =>
-      match eq_term v v' with
-      | true =>
-          match eq_pos x x' with
-          | true => (l1 + l2)%term
-          | false => t
-          end
-      | false => t
-      end
-  | (v * Tint (Zneg x) + l1 + (v' * Tint (Zpos x') + l2))%term =>
-      match eq_term v v' with
-      | true =>
-          match eq_pos x x' with
-          | true => (l1 + l2)%term
-          | false => t
-          end
-      | false => t
-      end
+  | (v * Tint x + l1 + (v' * Tint x' + l2))%term =>
+      if eq_term v v' && beq x (-x') 
+      then (l1+l2)%term
+      else t
   | _ => t
   end.
 
 Theorem T_OMEGA13_stable : term_stable T_OMEGA13.
-
-unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
- [ apply OMEGA13 | apply OMEGA14 ].
+Proof.
+ unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
+ apply OMEGA13.
 Qed.
 
 Definition T_OMEGA15 (t : term) :=
   match t with
   | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term =>
-      match eq_term v v' with
-      | true => (v * Tint (c1 + c2 * k2) + (l1 + l2 * Tint k2))%term
-      | false => t
-      end
+      if eq_term v v' 
+      then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term
+      else t
   | _ => t
   end.
 
 Theorem T_OMEGA15_stable : term_stable T_OMEGA15.
-
-prove_stable T_OMEGA15 OMEGA15.
+Proof.
+ prove_stable T_OMEGA15 OMEGA15.
 Qed.
 
 Definition T_OMEGA16 (t : term) :=
@@ -1100,20 +1690,19 @@ Definition T_OMEGA16 (t : term) :=
 
 
 Theorem T_OMEGA16_stable : term_stable T_OMEGA16.
-
-prove_stable T_OMEGA16 OMEGA16.
+Proof.
+ prove_stable T_OMEGA16 OMEGA16.
 Qed.
 
 Definition Tred_factor5 (t : term) :=
   match t with
-  | (x * Tint Z0 + y)%term => y
+  | (x * Tint c + y)%term => if beq c 0 then y else t
   | _ => t
   end.
 
 Theorem Tred_factor5_stable : term_stable Tred_factor5.
-
-
-prove_stable Tred_factor5 Zred_factor5.
+Proof.
+ prove_stable Tred_factor5 red_factor5.
 Qed.
 
 Definition Topp_plus (t : term) :=
@@ -1123,8 +1712,8 @@ Definition Topp_plus (t : term) :=
   end.
 
 Theorem Topp_plus_stable : term_stable Topp_plus.
-
-prove_stable Topp_plus Zopp_plus_distr.
+Proof.
+ prove_stable Topp_plus opp_plus_distr.
 Qed.
 
 
@@ -1135,8 +1724,8 @@ Definition Topp_opp (t : term) :=
   end.
 
 Theorem Topp_opp_stable : term_stable Topp_opp.
-
-prove_stable Topp_opp Zopp_involutive.
+Proof.
+ prove_stable Topp_opp opp_involutive.
 Qed.
 
 Definition Topp_mult_r (t : term) :=
@@ -1146,19 +1735,19 @@ Definition Topp_mult_r (t : term) :=
   end.
 
 Theorem Topp_mult_r_stable : term_stable Topp_mult_r.
-
-prove_stable Topp_mult_r Zopp_mult_distr_r.
+Proof.
+ prove_stable Topp_mult_r opp_mult_distr_r.
 Qed.
 
 Definition Topp_one (t : term) :=
   match t with
-  | (- x)%term => (x * Tint (-1))%term
+  | (- x)%term => (x * Tint (-(1)))%term
   | _ => t
   end.
 
 Theorem Topp_one_stable : term_stable Topp_one.
-
-prove_stable Topp_one Zopp_eq_mult_neg_1.
+Proof.
+ prove_stable Topp_one opp_eq_mult_neg_1.
 Qed.
 
 Definition Tmult_plus_distr (t : term) :=
@@ -1168,8 +1757,8 @@ Definition Tmult_plus_distr (t : term) :=
   end.
 
 Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr.
-
-prove_stable Tmult_plus_distr Zmult_plus_distr_l.
+Proof.
+ prove_stable Tmult_plus_distr mult_plus_distr_r.
 Qed.
 
 Definition Tmult_opp_left (t : term) :=
@@ -1179,8 +1768,8 @@ Definition Tmult_opp_left (t : term) :=
   end.
 
 Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left.
-
-prove_stable Tmult_opp_left Zmult_opp_comm.
+Proof.
+ prove_stable Tmult_opp_left mult_opp_comm.
 Qed.
 
 Definition Tmult_assoc_reduced (t : term) :=
@@ -1190,91 +1779,81 @@ Definition Tmult_assoc_reduced (t : term) :=
   end.
 
 Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced.
-
-prove_stable Tmult_assoc_reduced Zmult_assoc_reverse.
+Proof.
+ prove_stable Tmult_assoc_reduced mult_assoc_reverse.
 Qed.
 
 Definition Tred_factor0 (t : term) := (t * Tint 1)%term.
 
 Theorem Tred_factor0_stable : term_stable Tred_factor0.
-
-prove_stable Tred_factor0 Zred_factor0.
+Proof.
+ prove_stable Tred_factor0 red_factor0.
 Qed.
 
 Definition Tred_factor1 (t : term) :=
   match t with
   | (x + y)%term =>
-      match eq_term x y with
-      | true => (x * Tint 2)%term
-      | false => t
-      end
+      if eq_term x y 
+      then (x * Tint 2)%term
+      else t 
   | _ => t
   end.
 
 Theorem Tred_factor1_stable : term_stable Tred_factor1.
-
-prove_stable Tred_factor1 Zred_factor1.
+Proof.
+ prove_stable Tred_factor1 red_factor1.
 Qed.
 
 Definition Tred_factor2 (t : term) :=
   match t with
   | (x + y * Tint k)%term =>
-      match eq_term x y with
-      | true => (x * Tint (1 + k))%term
-      | false => t
-      end
+      if eq_term x y 
+      then (x * Tint (1 + k))%term
+      else t
   | _ => t
   end.
 
-(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique
-   de simplification n'aille trop loin et défasse [Zplus 1 k] *)
-
-Opaque Zplus.
-
 Theorem Tred_factor2_stable : term_stable Tred_factor2.
-prove_stable Tred_factor2 Zred_factor2.
+Proof.
+ prove_stable Tred_factor2 red_factor2.
 Qed.
 
 Definition Tred_factor3 (t : term) :=
   match t with
   | (x * Tint k + y)%term =>
-      match eq_term x y with
-      | true => (x * Tint (1 + k))%term
-      | false => t
-      end
+      if eq_term x y 
+      then (x * Tint (1 + k))%term
+      else t
   | _ => t
   end.
 
 Theorem Tred_factor3_stable : term_stable Tred_factor3.
-
-prove_stable Tred_factor3 Zred_factor3.
+Proof.
+ prove_stable Tred_factor3 red_factor3.
 Qed.
 
 
 Definition Tred_factor4 (t : term) :=
   match t with
   | (x * Tint k1 + y * Tint k2)%term =>
-      match eq_term x y with
-      | true => (x * Tint (k1 + k2))%term
-      | false => t
-      end
+      if eq_term x y 
+      then (x * Tint (k1 + k2))%term
+      else t
   | _ => t
   end.
 
 Theorem Tred_factor4_stable : term_stable Tred_factor4.
-
-prove_stable Tred_factor4 Zred_factor4.
+Proof.
+ prove_stable Tred_factor4 red_factor4.
 Qed.
 
 Definition Tred_factor6 (t : term) := (t + Tint 0)%term.
 
 Theorem Tred_factor6_stable : term_stable Tred_factor6.
-
-prove_stable Tred_factor6 Zred_factor6.
+Proof.
+ prove_stable Tred_factor6 red_factor6.
 Qed.
 
-Transparent Zplus.
-
 Definition Tminus_def (t : term) :=
   match t with
   | (x - y)%term => (x + - y)%term
@@ -1282,9 +1861,8 @@ Definition Tminus_def (t : term) :=
   end.
 
 Theorem Tminus_def_stable : term_stable Tminus_def.
-
-(* Le théorème ne sert à rien. Le but est prouvé avant. *)
-prove_stable Tminus_def False.
+Proof.
+ prove_stable Tminus_def minus_def.
 Qed.
 
 (* \subsection{Fonctions de réécriture complexes} *)
@@ -1332,8 +1910,8 @@ Fixpoint reduce (t : term) : term :=
   end.
 
 Theorem reduce_stable : term_stable reduce.
-
-unfold term_stable in |- *; intros e t; elim t; auto;
+Proof.
+ unfold term_stable in |- *; intros e t; elim t; auto;
  try
   (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1;
     (case (reduce t0);
@@ -1366,8 +1944,8 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
   end.
     
 Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
-
-simple induction t; simpl in |- *;
+Proof.
+ simple induction t; simpl in |- *;
  [ exact reduce_stable
  | intros stp l H; case stp;
     [ apply compose_term_stable;
@@ -1378,7 +1956,6 @@ simple induction t; simpl in |- *;
        [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ]
     | apply compose_term_stable;
        [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ].
-
 Qed.
 
 (* \paragraph{Fusion de deux équations dont une sans coefficient} *)
@@ -1405,8 +1982,8 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
   end.
 
 Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
-
-unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
+Proof.
+ unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
  [ exact (reduce_stable e)
  | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
 Qed. 
@@ -1422,8 +1999,8 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
 
 Theorem scalar_norm_add_stable :
  forall t : nat, term_stable (scalar_norm_add t).
-
-unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
+Proof.
+ unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (T_OMEGA11_stable e t) | exact H ] ].
@@ -1437,8 +2014,8 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
   end.
 
 Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
-
-unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
+Proof.
+ unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (T_OMEGA16_stable e t) | exact H ] ].
@@ -1452,8 +2029,8 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
   end.
 
 Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
-
-unfold term_stable, add_norm in |- *; intros trace; elim trace;
+Proof.
+ unfold term_stable, add_norm in |- *; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (Tplus_assoc_r_stable e t) | exact H ] ].
@@ -1480,7 +2057,7 @@ Fixpoint rewrite (s : step) : term -> term :=
   | C_PLUS_ASSOC_R => Tplus_assoc_r
   | C_PLUS_ASSOC_L => Tplus_assoc_l
   | C_PLUS_PERMUTE => Tplus_permute
-  | C_PLUS_COMM => Tplus_sym
+  | C_PLUS_COMM => Tplus_comm
   | C_RED0 => Tred_factor0
   | C_RED1 => Tred_factor1
   | C_RED2 => Tred_factor2
@@ -1490,12 +2067,12 @@ Fixpoint rewrite (s : step) : term -> term :=
   | C_RED6 => Tred_factor6
   | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
   | C_MINUS => Tminus_def
-  | C_MULT_COMM => Tmult_sym
+  | C_MULT_COMM => Tmult_comm
   end.
 
 Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
-
-simple induction s; simpl in |- *;
+Proof.
+ simple induction s; simpl in |- *;
  [ intros; apply apply_both_stable; auto
  | intros; apply apply_left_stable; auto
  | intros; apply apply_right_stable; auto
@@ -1512,7 +2089,7 @@ simple induction s; simpl in |- *;
  | exact Tplus_assoc_r_stable
  | exact Tplus_assoc_l_stable
  | exact Tplus_permute_stable
- | exact Tplus_sym_stable
+ | exact Tplus_comm_stable
  | exact Tred_factor0_stable
  | exact Tred_factor1_stable
  | exact Tred_factor2_stable
@@ -1522,7 +2099,7 @@ simple induction s; simpl in |- *;
  | exact Tred_factor6_stable
  | exact Tmult_assoc_reduced_stable
  | exact Tminus_def_stable
- | exact Tmult_sym_stable ].
+ | exact Tmult_comm_stable ].
 Qed.
 
 (* \subsection{tactiques de résolution d'un but omega normalisé} 
@@ -1532,20 +2109,18 @@ Qed.
 
 Definition constant_not_nul (i : nat) (h : hyps) :=
   match nth_hyps i h with
-  | EqTerm (Tint Z0) (Tint n) =>
-      match eq_Z n 0 with
-      | true => h
-      | false => absurd
-      end
+  | EqTerm (Tint Nul) (Tint n) =>
+      if beq n Nul then h else absurd
   | _ => h
   end.
 
 Theorem constant_not_nul_valid :
  forall i : nat, valid_hyps (constant_not_nul i).
-
-unfold valid_hyps, constant_not_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- elim_eq_Z ipattern:z0 0; auto; simpl in |- *; intros H1 H2; 
+Proof.
+ unfold valid_hyps, constant_not_nul in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *. 
+ 
+ elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; 
  elim H1; symmetry  in |- *; auto.
 Qed.   
 
@@ -1553,66 +2128,55 @@ Qed.
 
 Definition constant_neg (i : nat) (h : hyps) :=
   match nth_hyps i h with
-  | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd
+  | LeqTerm (Tint Nul) (Tint Neg) => 
+     if bgt Nul Neg then absurd else h
   | _ => h
   end.
 
 Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i).
-
-unfold valid_hyps, constant_neg in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- unfold Zle in |- *; simpl in |- *; intros H1; elim H1;
- [ assumption | trivial ].
-Qed.   
+Proof.
+ unfold valid_hyps, constant_neg in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
+ rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
+Qed.
 
 (* \paragraph{[NOT_EXACT_DIVIDE]} *)
-Definition not_exact_divide (k1 k2 : Z) (body : term) 
+Definition not_exact_divide (k1 k2 : int) (body : term) 
   (t i : nat) (l : hyps) :=
   match nth_hyps i l with
-  | EqTerm (Tint Z0) b =>
-      match
-        eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
-      with
-      | true =>
-          match k2 ?= 0 with
-          | Gt =>
-              match k1 ?= k2 with
-              | Gt => absurd
-              | _ => l
-              end
-          | _ => l
-          end
-      | false => l
-      end
+  | EqTerm (Tint Nul) b =>
+      if beq Nul 0 && 
+         eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && 
+         bgt k2 0 && 
+         bgt k1 k2 
+      then absurd
+      else l
   | _ => l
   end.
 
 Theorem not_exact_divide_valid :
- forall (k1 k2 : Z) (body : term) (t i : nat),
+ forall (k1 k2 : int) (body : term) (t i : nat),
  valid_hyps (not_exact_divide k1 k2 body t i).
-
-unfold valid_hyps, not_exact_divide in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify;
- elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; 
- auto; Simplify; intro H2; elim H2; simpl in |- *;
- elim (scalar_norm_add_stable t e); simpl in |- *; 
- intro H4; absurd (interp_term e body * k1 + k2 = 0);
- [ apply OMEGA4; assumption | symmetry  in |- *; auto ].
-
+Proof.
+ unfold valid_hyps, not_exact_divide in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify.
+ rewrite (scalar_norm_add_stable t e), <-H1.
+ do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros.
+ absurd (interp_term e body * k1 + k2 = 0); 
+ [ now apply OMEGA4 | symmetry; auto ].
 Qed.
 
 (* \paragraph{[O_CONTRADICTION]} *)
 
 Definition contradiction (t i j : nat) (l : hyps) :=
   match nth_hyps i l with
-  | LeqTerm (Tint Z0) b1 =>
+  | LeqTerm (Tint Nul) b1 =>
       match nth_hyps j l with
-      | LeqTerm (Tint Z0) b2 =>
+      | LeqTerm (Tint Nul') b2 =>
           match fusion_cancel t (b1 + b2)%term with
-          | Tint k => match 0 ?= k with
-                      | Gt => absurd
-                      | _ => l
-                      end
+          | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k 
+                      then absurd 
+                      else l
           | _ => l
           end
       | _ => l
@@ -1622,43 +2186,40 @@ Definition contradiction (t i j : nat) (l : hyps) :=
 
 Theorem contradiction_valid :
  forall t i j : nat, valid_hyps (contradiction t i j).
-
-unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
+Proof.
+ unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; intros z; case z; auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; intros z'; case z'; 
- auto; simpl in |- *; intros H1 H2;
+ auto; case (nth_hyps j l); 
+ auto; intros t3 t4; case t3; auto; 
+ simpl in |- *; intros z z' H1 H2;
  generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term)));
  pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *;
  case (fusion_cancel t (t2 + t4)%term); simpl in |- *; 
- auto; intro k; elim (fusion_cancel_stable t); simpl in |- *; 
- intro E; generalize (OMEGA2 _ _ H2 H1); rewrite E; 
- case k; auto; unfold Zle in |- *; simpl in |- *; intros p H3; 
- elim H3; auto.
-
+ auto; intro k; elim (fusion_cancel_stable t); simpl in |- *.
+ Simplify; intro H3.
+ generalize (OMEGA2 _ _ H2 H1); rewrite H3. 
+ rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
 Qed.
 
 (* \paragraph{[O_NEGATE_CONTRADICT]} *)
 
 Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
   match nth_hyps i1 h with
-  | EqTerm (Tint Z0) b1 =>
+  | EqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
-      | NeqTerm (Tint Z0) b2 =>
-          match eq_term b1 b2 with
-          | true => absurd
-          | false => h
-          end
+      | NeqTerm (Tint Nul') b2 =>
+          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
+          then absurd 
+          else h
       | _ => h
       end
-  | NeqTerm (Tint Z0) b1 =>
+  | NeqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
-      | EqTerm (Tint Z0) b2 =>
-          match eq_term b1 b2 with
-          | true => absurd
-          | false => h
-          end
+      | EqTerm (Tint Nul') b2 =>
+          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
+          then absurd 
+          else h 
       | _ => h
       end
   | _ => h
@@ -1666,22 +2227,22 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
 
 Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
   match nth_hyps i1 h with
-  | EqTerm (Tint Z0) b1 =>
+  | EqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
-      | NeqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
-          | true => absurd
-          | false => h
-          end
+      | NeqTerm (Tint Nul') b2 =>
+          if beq Nul 0 && beq Nul' 0 && 
+             eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
+          then absurd
+          else h
       | _ => h
       end
-  | NeqTerm (Tint Z0) b1 =>
+  | NeqTerm (Tint Nul) b1 =>
       match nth_hyps i2 h with
-      | EqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
-          | true => absurd
-          | false => h
-          end
+      | EqTerm (Tint Nul') b2 =>
+          if beq Nul 0 && beq Nul' 0 && 
+             eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
+          then absurd
+          else h
       | _ => h
       end
   | _ => h
@@ -1689,45 +2250,33 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
 
 Theorem negate_contradict_valid :
  forall i j : nat, valid_hyps (negate_contradict i j).
-
-unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
+Proof.
+ unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; intros z; case z; auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; intros z'; case z'; 
- auto; simpl in |- *; intros H1 H2;
- [ elim_eq_term t2 t4; intro H3;
-    [ elim H1; elim H3; assumption | assumption ]
- | elim_eq_term t2 t4; intro H3;
-    [ elim H2; rewrite H3; assumption | assumption ] ].
-
+ auto; intros z; auto; case (nth_hyps j l); 
+ auto; intros t3 t4; case t3; auto; intros z'; 
+ auto; simpl in |- *; intros H1 H2; Simplify.
 Qed.
 
 Theorem negate_contradict_inv_valid :
  forall t i j : nat, valid_hyps (negate_contradict_inv t i j).
-
-
-unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
+Proof.
+ unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1; 
- auto; intros z; case z; auto; case (nth_hyps j l); 
- auto; intros t3 t4; case t3; auto; intros z'; case z'; 
- auto; simpl in |- *; intros H1 H2;
- (pattern (eq_term t2 (scalar_norm t (t4 * Tint (-1))%term)) in |- *;
-   apply bool_ind2; intro Aux;
-   [ generalize (eq_term_true t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
-      clear Aux
-   | generalize (eq_term_false t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
-      clear Aux ]);
- [ intro H3; elim H1; generalize H2; rewrite H3;
-    rewrite <- (scalar_norm_stable t e); simpl in |- *;
-    elim (interp_term e t4); simpl in |- *; auto; intros p H4;
-    discriminate H4
- | auto
- | intro H3; elim H2; rewrite H3; elim (scalar_norm_stable t e);
-    simpl in |- *; elim H1; simpl in |- *; trivial
- | auto ].
-
+ auto; intros z; auto; case (nth_hyps j l); 
+ auto; intros t3 t4; case t3; auto; intros z'; 
+ auto; simpl in |- *; intros H1 H2; Simplify; 
+ [
+ rewrite <- scalar_norm_stable in H2; simpl in *;
+ elim (mult_integral (interp_term e t4) (-(1))); intuition;
+ elim minus_one_neq_zero; auto
+ | 
+ elim H2; clear H2;
+ rewrite <- scalar_norm_stable; simpl in *;
+ now rewrite <- H1, mult_0_l
+ ].
 Qed.
 
 (* \subsubsection{Tactiques générant une nouvelle équation} *)
@@ -1737,150 +2286,93 @@ Qed.
  preuve un peu compliquée. On utilise quelques lemmes qui sont des 
  généralisations des théorèmes utilisés par OMEGA. *)
 
-Definition sum (k1 k2 : Z) (trace : list t_fusion)
+Definition sum (k1 k2 : int) (trace : list t_fusion)
   (prop1 prop2 : proposition) :=
   match prop1 with
-  | EqTerm (Tint Z0) b1 =>
+  | EqTerm (Tint Null) b1 =>
       match prop2 with
-      | EqTerm (Tint Z0) b2 =>
-          EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-      | LeqTerm (Tint Z0) b2 =>
-          match k2 ?= 0 with
-          | Gt =>
-              LeqTerm (Tint 0)
+      | EqTerm (Tint Null') b2 =>
+          if beq Null 0 && beq Null' 0 
+          then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+          else TrueTerm
+      | LeqTerm (Tint Null') b2 =>
+          if beq Null 0 && beq Null' 0 && bgt k2 0 
+          then LeqTerm (Tint 0)
                 (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-          | _ => TrueTerm
-          end
+          else TrueTerm
       | _ => TrueTerm
       end
-  | LeqTerm (Tint Z0) b1 =>
-      match k1 ?= 0 with
-      | Gt =>
-          match prop2 with
-          | EqTerm (Tint Z0) b2 =>
+  | LeqTerm (Tint Null) b1 =>
+      if beq Null 0 && bgt k1 0
+      then match prop2 with
+          | EqTerm (Tint Null') b2 =>
+              if beq Null' 0 then 
               LeqTerm (Tint 0)
                 (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-          | LeqTerm (Tint Z0) b2 =>
-              match k2 ?= 0 with
-              | Gt =>
-                  LeqTerm (Tint 0)
+              else TrueTerm  
+          | LeqTerm (Tint Null') b2 =>
+              if beq Null' 0 && bgt k2 0 
+              then LeqTerm (Tint 0)
                     (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-              | _ => TrueTerm
-              end
+              else TrueTerm
           | _ => TrueTerm
           end
-      | _ => TrueTerm
-      end
-  | NeqTerm (Tint Z0) b1 =>
+      else TrueTerm 
+  | NeqTerm (Tint Null) b1 =>
       match prop2 with
-      | EqTerm (Tint Z0) b2 =>
-          match eq_Z k1 0 with
-          | true => TrueTerm
-          | false =>
-              NeqTerm (Tint 0)
-                (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
-          end
+      | EqTerm (Tint Null') b2 =>
+          if beq Null 0 && beq Null' 0 && (negb (beq k1 0))
+          then NeqTerm (Tint 0)
+                 (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+          else TrueTerm
       | _ => TrueTerm
       end
   | _ => TrueTerm
   end.
 
-Theorem sum1 : forall a b c d : Z, 0 = a -> 0 = b -> 0 = a * c + b * d.
-
-intros; elim H; elim H0; simpl in |- *; auto.
-Qed.
-  
-Theorem sum2 :
- forall a b c d : Z, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
-
-intros; elim H0; simpl in |- *; generalize H H1; case b; case d;
- unfold Zle in |- *; simpl in |- *; auto.  
-Qed.
-
-Theorem sum3 :
- forall a b c d : Z,
- 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
-
-intros a b c d; case a; case b; case c; case d; unfold Zle in |- *;
- simpl in |- *; auto. 
-Qed.
-
-Theorem sum4 : forall k : Z, (k ?= 0) = Gt -> 0 <= k.
-
-intro; case k; unfold Zle in |- *; simpl in |- *; auto; intros; discriminate.  
-Qed.
-
-Theorem sum5 :
- forall a b c d : Z, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
-
-intros a b c d H1 H2 H3; elim H3; simpl in |- *; rewrite Zplus_comm;
- simpl in |- *; generalize H1 H2; case a; case c; simpl in |- *; 
- intros; try discriminate; assumption.
-Qed.
-
 
 Theorem sum_valid :
- forall (k1 k2 : Z) (t : list t_fusion), valid2 (sum k1 k2 t).
-
-unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
+ forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t).
+Proof.
+ unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
  Simplify; simpl in |- *; auto; try elim (fusion_stable t); 
  simpl in |- *; intros;
  [ apply sum1; assumption
  | apply sum2; try assumption; apply sum4; assumption
- | rewrite Zplus_comm; apply sum2; try assumption; apply sum4; assumption
+ | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption
  | apply sum3; try assumption; apply sum4; assumption
- | elim_eq_Z k1 0; simpl in |- *; auto; elim (fusion_stable t); simpl in |- *;
-    intros; unfold Zne in |- *; apply sum5; assumption ].
+ | apply sum5; auto ].
 Qed.
 
 (* \paragraph{[O_EXACT_DIVIDE]}
    c'est une oper1 valide mais on préfère une substitution a ce point la *)
 
-Definition exact_divide (k : Z) (body : term) (t : nat)
+Definition exact_divide (k : int) (body : term) (t : nat)
   (prop : proposition) :=
   match prop with
-  | EqTerm (Tint Z0) b =>
-      match eq_term (scalar_norm t (body * Tint k)%term) b with
-      | true =>
-          match eq_Z k 0 with
-          | true => TrueTerm
-          | false => EqTerm (Tint 0) body
-          end
-      | false => TrueTerm
-      end
-  | NeqTerm (Tint Z0) b =>
-      match eq_term (scalar_norm t (body * Tint k)%term) b with
-      | true =>
-          match eq_Z k 0 with
-          | true => FalseTerm
-          | false => NeqTerm (Tint 0) body
-          end
-      | false => TrueTerm
-      end
+  | EqTerm (Tint Null) b =>
+      if beq Null 0 && 
+         eq_term (scalar_norm t (body * Tint k)%term) b && 
+         negb (beq k 0) 
+      then EqTerm (Tint 0) body
+      else TrueTerm
+  | NeqTerm (Tint Null) b =>
+      if beq Null 0 && 
+         eq_term (scalar_norm t (body * Tint k)%term) b &&
+         negb (beq k 0)
+      then NeqTerm (Tint 0) body
+      else TrueTerm
   | _ => TrueTerm
   end.
 
 Theorem exact_divide_valid :
- forall (k : Z) (t : term) (n : nat), valid1 (exact_divide k t n).
-
-
-unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify;
- simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1;
- simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *; 
- auto; intros H1 H2; elim H2; elim scalar_norm_stable;
- simpl in |- *; 
- [
- generalize H1; case (interp_term e k2); 
- try trivial;
- (case k1; simpl in |- *;
-   [ intros; absurd (0 = 0); assumption
-   | intros p2 p3 H3 H4; discriminate H4
-   | intros p2 p3 H3 H4; discriminate H4 ])
- |
- subst k1; rewrite Zmult_comm; simpl in *; intros; absurd (0=0); trivial
- |
- generalize H1; case (interp_term e k2); 
- try trivial; intros p2 p3 H3 H4; discriminate H4
+ forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n).
+Proof.
+ unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; 
+ Simplify; simpl; auto; subst; 
+ rewrite <- scalar_norm_stable; simpl; intros;
+ [ destruct (mult_integral _ _ (sym_eq H0)); intuition
+ | contradict H0; rewrite <- H0, mult_0_l; auto
  ].
 Qed.
 
@@ -1889,61 +2381,51 @@ Qed.
   La preuve reprend le schéma de la précédente mais on
   est sur une opération de type valid1 et non sur une opération terminale. *)
 
-Definition divide_and_approx (k1 k2 : Z) (body : term) 
+Definition divide_and_approx (k1 k2 : int) (body : term) 
   (t : nat) (prop : proposition) :=
   match prop with
-  | LeqTerm (Tint Z0) b =>
-      match
-        eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
-      with
-      | true =>
-          match k1 ?= 0 with
-          | Gt =>
-              match k1 ?= k2 with
-              | Gt => LeqTerm (Tint 0) body
-              | _ => prop
-              end
-          | _ => prop
-          end
-      | false => prop
-      end
+  | LeqTerm (Tint Null) b =>
+      if beq Null 0 && 
+         eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b &&
+         bgt k1 0 && 
+         bgt k1 k2 
+      then LeqTerm (Tint 0) body 
+      else prop
   | _ => prop
   end.
 
 Theorem divide_and_approx_valid :
- forall (k1 k2 : Z) (body : term) (t : nat),
+ forall (k1 k2 : int) (body : term) (t : nat),
  valid1 (divide_and_approx k1 k2 body t).
-
-unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
- Simplify;
- elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1;
- Simplify; auto; intro E; elim E; simpl in |- *;
- elim (scalar_norm_add_stable t e); simpl in |- *; 
- intro H1; apply Zmult_le_approx with (3 := H1); assumption.
+Proof.
+ unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
+ Simplify; simpl; auto; subst;
+ elim (scalar_norm_add_stable t e); simpl in |- *.
+ intro H2; apply mult_le_approx with (3 := H2); assumption.
 Qed.
 
 (* \paragraph{[MERGE_EQ]} *)
 
 Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
   match prop1 with
-  | LeqTerm (Tint Z0) b1 =>
+  | LeqTerm (Tint Null) b1 =>
       match prop2 with
-      | LeqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
-          | true => EqTerm (Tint 0) b1
-          | false => TrueTerm
-          end
+      | LeqTerm (Tint Null') b2 =>
+          if beq Null 0 && beq Null' 0 &&
+             eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) 
+          then EqTerm (Tint 0) b1
+          else TrueTerm
       | _ => TrueTerm
       end
   | _ => TrueTerm
   end.
 
 Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n).
-
-unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
+Proof.
+ unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
  auto; elim (scalar_norm_stable n e); simpl in |- *; 
  intros; symmetry  in |- *; apply OMEGA8 with (2 := H0);
- [ assumption | elim Zopp_eq_mult_neg_1; trivial ].
+ [ assumption | elim opp_eq_mult_neg_1; trivial ].
 Qed.
 
 
@@ -1952,36 +2434,39 @@ Qed.
 
 Definition constant_nul (i : nat) (h : hyps) :=
   match nth_hyps i h with
-  | NeqTerm (Tint Z0) (Tint Z0) => absurd
+  | NeqTerm (Tint Null) (Tint Null') => 
+      if beq Null Null' then absurd else h 
   | _ => h
   end.
 
 Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i).
-
-unfold valid_hyps, constant_nul in |- *; intros;
+Proof.
+ unfold valid_hyps, constant_nul in |- *; intros;
  generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- unfold Zne in |- *; intro H1; absurd (0 = 0); auto.
+ intro H1; absurd (0 = 0); intuition.
 Qed.
 
 (* \paragraph{[O_STATE]} *)
 
-Definition state (m : Z) (s : step) (prop1 prop2 : proposition) :=
+Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
   match prop1 with
-  | EqTerm (Tint Z0) b1 =>
+  | EqTerm (Tint Null) b1 =>
       match prop2 with
       | EqTerm b2 b3 =>
-          EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
+          if beq Null 0 
+          then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
+          else TrueTerm
       | _ => TrueTerm
       end
   | _ => TrueTerm
   end.
 
-Theorem state_valid : forall (m : Z) (s : step), valid2 (state m s).
-
-unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify;
+Theorem state_valid : forall (m : int) (s : step), valid2 (state m s).
+Proof.
+ unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify;
  simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; 
  intros H1 H2; elim H1.
- rewrite H2; rewrite Zplus_opp_l; simpl; reflexivity.
+ now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
 Qed.
 
 (* \subsubsection{Tactiques générant plusieurs but}
@@ -1991,11 +2476,13 @@ Qed.
 Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) 
   (l : hyps) :=
   match nth_hyps i l with
-  | NeqTerm (Tint Z0) b1 =>
-      f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-1))%term) :: l) ++
+  | NeqTerm (Tint Null) b1 =>
+      if beq Null 0 then 
+      f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++
       f2
         (LeqTerm (Tint 0)
-           (scalar_norm_add t (b1 * Tint (-1) + Tint (-1))%term) :: l)
+           (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l)
+       else l :: nil
   | _ => l :: nil
   end.
 
@@ -2003,17 +2490,18 @@ Theorem split_ineq_valid :
  forall (i t : nat) (f1 f2 : hyps -> lhyps),
  valid_list_hyps f1 ->
  valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
-
-unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
+Proof.
+ unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
  generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); 
  simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; 
- auto; intros z; case z; simpl in |- *; auto; intro H3; 
+ auto; intros z; simpl in |- *; auto; intro H3.
+ Simplify.
  apply append_valid; elim (OMEGA19 (interp_term e t2));
  [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t);
     simpl in |- *; auto
  | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t);
     simpl in |- *; auto
- | generalize H3; unfold Zne, not in |- *; intros E1 E2; apply E1;
+ | generalize H3; unfold not in |- *; intros E1 E2; apply E1;
     symmetry  in |- *; trivial ].
 Qed.
 
@@ -2046,8 +2534,8 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
   end.
 
 Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t).
-
-simple induction t; simpl in |- *;
+Proof.
+ simple induction t; simpl in |- *;
  [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
     apply (constant_not_nul_valid n ep e lp H)
  | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
@@ -2058,7 +2546,7 @@ simple induction t; simpl in |- *;
      (apply_oper_1_valid m (divide_and_approx k1 k2 body n)
         (divide_and_approx_valid k1 k2 body n) ep e lp H)
  | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
-    apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H)
+    apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H)
  | unfold valid_list_hyps, valid_hyps in |- *;
     intros k body n t' Ht' m ep e lp H; apply Ht';
     apply
@@ -2101,36 +2589,30 @@ Definition move_right (s : step) (p : proposition) :=
   | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
   | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term)
   | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
-  | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-1) + - t1)%term)
-  | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-1) + - t2)%term)
+  | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term)
+  | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term)
   | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
   | p => p
   end.
 
-Theorem Zne_left_2 : forall x y : Z, Zne x y -> Zne 0 (x + - y).
-unfold Zne, not in |- *; intros x y H1 H2; apply H1;
- apply (Zplus_reg_l (- y)); rewrite Zplus_comm; elim H2; 
- rewrite Zplus_opp_l; trivial.
-Qed.
-
 Theorem move_right_valid : forall s : step, valid1 (move_right s).
-
-unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
+Proof.
+ unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
  elim (rewrite_stable s e); simpl in |- *;
- [ symmetry  in |- *; apply Zegal_left; assumption
- | intro; apply Zle_left; assumption
- | intro; apply Zge_left; assumption
- | intro; apply Zgt_left; assumption
- | intro; apply Zlt_left; assumption
- | intro; apply Zne_left_2; assumption ].
+ [ symmetry  in |- *; apply egal_left; assumption
+ | intro; apply le_left; assumption
+ | intro; apply le_left; rewrite <- ge_le_iff; assumption
+ | intro; apply lt_left; rewrite <- gt_lt_iff; assumption
+ | intro; apply lt_left; assumption
+ | intro; apply ne_left_2; assumption ].
 Qed.
 
 Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s).
 
 Theorem do_normalize_valid :
  forall (i : nat) (s : step), valid_hyps (do_normalize i s).
-
-intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
+Proof.
+ intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
  apply move_right_valid.
 Qed.
 
@@ -2143,43 +2625,40 @@ Fixpoint do_normalize_list (l : list step) (i : nat)
 
 Theorem do_normalize_list_valid :
  forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
-
-simple induction l; simpl in |- *; unfold valid_hyps in |- *;
+Proof.
+ simple induction l; simpl in |- *; unfold valid_hyps in |- *;
  [ auto
  | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl';
     apply (do_normalize_valid i a ep e lp); assumption ].
 Qed.
 
 Theorem normalize_goal :
- forall (s : list step) (ep : PropList) (env : list Z) (l : hyps),
+ forall (s : list step) (ep : list Prop) (env : list int) (l : hyps),
  interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l.
-
-intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
+Proof.
+ intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
 Qed.
 
 (* \subsubsection{Exécution de la trace} *)
 
 Theorem execute_goal :
- forall (t : t_omega) (ep : PropList) (env : list Z) (l : hyps),
+ forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps),
  interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l.
-
-intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
+Proof.
+ intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
 Qed.
 
 
 Theorem append_goal :
- forall (ep : PropList) (e : list Z) (l1 l2 : lhyps),
+ forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
  interp_list_goal ep e l1 /\ interp_list_goal ep e l2 ->
  interp_list_goal ep e (l1 ++ l2).
-
-intros ep e; simple induction l1;
+Proof.
+ intros ep e; simple induction l1;
  [ simpl in |- *; intros l2 (H1, H2); assumption
  | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ].
-
 Qed.
 
-Require Import Decidable.
-
 (* A simple decidability checker : if the proposition belongs to the
    simple grammar describe below then it is decidable. Proof is by 
    induction and uses well known theorem about arithmetic and propositional
@@ -2203,30 +2682,29 @@ Fixpoint decidability (p : proposition) : bool :=
   end.
 
 Theorem decidable_correct :
- forall (ep : PropList) (e : list Z) (p : proposition),
+ forall (ep : list Prop) (e : list int) (p : proposition),
  decidability p = true -> decidable (interp_proposition ep e p).
-
-simple induction p; simpl in |- *; intros;
+Proof.
+ simple induction p; simpl in |- *; intros;
  [ apply dec_eq
- | apply dec_Zle
+ | apply dec_le
  | left; auto
  | right; unfold not in |- *; auto
  | apply dec_not; auto
- | apply dec_Zge
- | apply dec_Zgt
- | apply dec_Zlt
- | apply dec_Zne
+ | apply dec_ge
+ | apply dec_gt
+ | apply dec_lt
+ | apply dec_ne
  | apply dec_or; elim andb_prop with (1 := H1); auto
  | apply dec_and; elim andb_prop with (1 := H1); auto
  | apply dec_imp; elim andb_prop with (1 := H1); auto
  | discriminate H ].
-
 Qed.
 
 (* An interpretation function for a complete goal with an explicit
    conclusion. We use an intermediate fixpoint. *)
 
-Fixpoint interp_full_goal (envp : PropList) (env : list Z) 
+Fixpoint interp_full_goal (envp : list Prop) (env : list int) 
  (c : proposition) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
@@ -2234,7 +2712,7 @@ Fixpoint interp_full_goal (envp : PropList) (env : list Z)
       interp_proposition envp env p' -> interp_full_goal envp env c l'
   end.
 
-Definition interp_full (ep : PropList) (e : list Z) 
+Definition interp_full (ep : list Prop) (e : list int) 
   (lc : hyps * proposition) : Prop :=
   match lc with
   | (l, c) => interp_full_goal ep e c l
@@ -2244,12 +2722,11 @@ Definition interp_full (ep : PropList) (e : list Z)
    of its hypothesis and conclusion *)
 
 Theorem interp_full_false :
- forall (ep : PropList) (e : list Z) (l : hyps) (c : proposition),
+ forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition),
  (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c).
-
-simple induction l; unfold interp_full in |- *; simpl in |- *;
+Proof.
+ simple induction l; unfold interp_full in |- *; simpl in |- *;
  [ auto | intros a l1 H1 c H2 H3; apply H1; auto ].
-
 Qed.
 
 (* Push the conclusion in the list of hypothesis using a double negation
@@ -2265,11 +2742,11 @@ Definition to_contradict (lc : hyps * proposition) :=
    hypothesis implies the original goal *)
 
 Theorem to_contradict_valid :
- forall (ep : PropList) (e : list Z) (lc : hyps * proposition),
+ forall (ep : list Prop) (e : list int) (lc : hyps * proposition),
  interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
-
-intros ep e lc; case lc; intros l c; simpl in |- *;
- pattern (decidability c) in |- *; apply bool_ind2;
+Proof.
+ intros ep e lc; case lc; intros l c; simpl in |- *;
+ pattern (decidability c) in |- *; apply bool_eq_ind;
  [ simpl in |- *; intros H H1; apply interp_full_false; intros H2;
     apply not_not;
     [ apply decidable_correct; assumption
@@ -2333,19 +2810,19 @@ Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
   end.
 
 Theorem map_cons_val :
- forall (ep : PropList) (e : list Z) (p : proposition) (l : lhyps),
+ forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps),
  interp_proposition ep e p ->
  interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l).
-
-simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
+Proof.
+ simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
 Qed.
 
 Hint Resolve map_cons_val append_valid decidable_correct.
 
 Theorem destructure_hyps_valid :
  forall n : nat, valid_list_hyps (destructure_hyps n).
-
-simple induction n;
+Proof.
+ simple induction n;
  [ unfold valid_list_hyps in |- *; simpl in |- *; auto
  | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp;
     [ simpl in |- *; auto
@@ -2358,7 +2835,7 @@ simple induction n;
            (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
              auto);
           [ simpl in |- *; intros p1 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_ind2; 
+             pattern (decidability p1) in |- *; apply bool_eq_ind; 
              intro H3;
              [ apply H; simpl in |- *; split;
                 [ apply not_not; auto | assumption ]
@@ -2366,7 +2843,7 @@ simple induction n;
           | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *;
              elim not_or with (1 := H1); auto
           | simpl in |- *; intros p1 p2 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_ind2; 
+             pattern (decidability p1) in |- *; apply bool_eq_ind; 
              intro H3;
              [ apply append_valid; elim not_and with (2 := H1);
                 [ intro; left; apply H; simpl in |- *; auto
@@ -2378,18 +2855,17 @@ simple induction n;
           apply H; simpl in |- *; auto
        | simpl in |- *; intros; apply H; simpl in |- *; tauto
        | simpl in |- *; intros p1 p2 (H1, H2);
-          pattern (decidability p1) in |- *; apply bool_ind2; 
+          pattern (decidability p1) in |- *; apply bool_eq_ind; 
           intro H3;
           [ apply append_valid; elim imp_simp with (2 := H1);
              [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto
              | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto
              | auto ]
           | auto ] ] ] ].
-
 Qed.
 
 Definition prop_stable (f : proposition -> proposition) :=
-  forall (ep : PropList) (e : list Z) (p : proposition),
+  forall (ep : list Prop) (e : list int) (p : proposition),
   interp_proposition ep e p <-> interp_proposition ep e (f p).
 
 Definition p_apply_left (f : proposition -> proposition) 
@@ -2405,8 +2881,8 @@ Definition p_apply_left (f : proposition -> proposition)
 Theorem p_apply_left_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_apply_left f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
  (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto).
 Qed.
 
@@ -2423,8 +2899,8 @@ Definition p_apply_right (f : proposition -> proposition)
 Theorem p_apply_right_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_apply_right f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
  (case p; simpl in |- *; auto;
    [ intros p1; elim (H ep e p1); tauto
    | intros p1 p2; elim (H ep e p2); tauto
@@ -2447,67 +2923,55 @@ Definition p_invert (f : proposition -> proposition)
 Theorem p_invert_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_invert f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
  (case p; simpl in |- *; auto;
    [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *;
-      unfold Zne in |- *;
       generalize (dec_eq (interp_term e t1) (interp_term e t2));
       unfold decidable in |- *; tauto
    | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *;
-      unfold Zgt in |- *;
-      generalize (dec_Zgt (interp_term e t1) (interp_term e t2));
-      unfold decidable, Zgt, Zle in |- *; tauto
+      generalize (dec_gt (interp_term e t1) (interp_term e t2));
+      unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto
    | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *;
-      unfold Zlt in |- *;
-      generalize (dec_Zlt (interp_term e t1) (interp_term e t2));
-      unfold decidable, Zge in |- *; tauto
+      generalize (dec_lt (interp_term e t1) (interp_term e t2));
+      unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto
    | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *;
-      generalize (dec_Zgt (interp_term e t1) (interp_term e t2));
-      unfold Zle, Zgt in |- *; unfold decidable in |- *; 
-      tauto
+      generalize (dec_gt (interp_term e t1) (interp_term e t2));
+      unfold decidable in |- *; repeat rewrite le_lt_iff;
+      repeat rewrite gt_lt_iff; tauto
    | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *;
-      generalize (dec_Zlt (interp_term e t1) (interp_term e t2));
-      unfold Zge, Zlt in |- *; unfold decidable in |- *; 
-      tauto
+      generalize (dec_lt (interp_term e t1) (interp_term e t2));
+      unfold decidable in |- *; repeat rewrite ge_le_iff;
+      repeat rewrite le_lt_iff; tauto
    | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *;
       generalize (dec_eq (interp_term e t1) (interp_term e t2));
-      unfold decidable, Zne in |- *; tauto ]).
-Qed.
-
-Theorem Zlt_left_inv : forall x y : Z, 0 <= y + -1 + - x -> x < y.
-
-intros; apply Zsucc_lt_reg; apply Zle_lt_succ;
- apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); 
- rewrite Zplus_assoc; unfold Zsucc in |- *; rewrite (Zplus_assoc_reverse x);
- rewrite (Zplus_assoc y); simpl in |- *; rewrite Zplus_0_r;
- rewrite Zplus_opp_r; assumption.
+      unfold decidable; tauto ]).
 Qed.
 
 Theorem move_right_stable : forall s : step, prop_stable (move_right s).
-
-unfold move_right, prop_stable in |- *; intros s ep e p; split;
+Proof.
+ unfold move_right, prop_stable in |- *; intros s ep e p; split;
  [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *;
-    [ symmetry  in |- *; apply Zegal_left; assumption
-    | intro; apply Zle_left; assumption
-    | intro; apply Zge_left; assumption
-    | intro; apply Zgt_left; assumption
-    | intro; apply Zlt_left; assumption
-    | intro; apply Zne_left_2; assumption ]
+    [ symmetry  in |- *; apply egal_left; assumption
+    | intro; apply le_left; assumption
+    | intro; apply le_left; rewrite <- ge_le_iff; assumption
+    | intro; apply lt_left; rewrite <- gt_lt_iff; assumption
+    | intro; apply lt_left; assumption
+    | intro; apply ne_left_2; assumption ]
  | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s);
     simpl in |- *; intro H1;
-    [ rewrite (Zplus_0_r_reverse (interp_term e t0)); rewrite H1;
-       rewrite Zplus_permute; rewrite Zplus_opp_r; 
-       rewrite Zplus_0_r; trivial
-    | apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t));
-       rewrite Zplus_opp_r; assumption
-    | apply Zle_ge;
-       apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t0));
-       rewrite Zplus_opp_r; assumption
-    | apply Zlt_gt; apply Zlt_left_inv; assumption
-    | apply Zlt_left_inv; assumption
-    | unfold Zne, not in |- *; unfold Zne in H1; intro H2; apply H1;
-       rewrite H2; rewrite Zplus_opp_r; trivial ] ].
+    [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1;
+       rewrite plus_permute; rewrite plus_opp_r; 
+       rewrite plus_0_r; trivial
+    | apply (fun a b => plus_le_reg_r a b (- interp_term e t));
+       rewrite plus_opp_r; assumption
+    | rewrite ge_le_iff;
+       apply (fun a b => plus_le_reg_r a b (- interp_term e t0));
+       rewrite plus_opp_r; assumption
+    | rewrite gt_lt_iff; apply lt_left_inv; assumption
+    | apply lt_left_inv; assumption
+    | unfold not in |- *; intro H2; apply H1;
+       rewrite H2; rewrite plus_opp_r; trivial ] ].
 Qed.
 
 
@@ -2521,9 +2985,8 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
   end.
 
 Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
-
-
-simple induction s; simpl in |- *;
+Proof.
+ simple induction s; simpl in |- *;
  [ intros; apply p_apply_left_stable; trivial
  | intros; apply p_apply_right_stable; trivial
  | intros; apply p_invert_stable; apply move_right_stable
@@ -2539,8 +3002,8 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
 
 Theorem normalize_hyps_valid :
  forall l : list h_step, valid_hyps (normalize_hyps l).
-
-simple induction l; unfold valid_hyps in |- *; simpl in |- *;
+Proof.
+ simple induction l; unfold valid_hyps in |- *; simpl in |- *;
  [ auto
  | intros n_s r; case n_s; intros n s H ep e lp H1; apply H;
     apply apply_oper_1_valid;
@@ -2550,10 +3013,10 @@ simple induction l; unfold valid_hyps in |- *; simpl in |- *;
 Qed.
 
 Theorem normalize_hyps_goal :
- forall (s : list h_step) (ep : PropList) (env : list Z) (l : hyps),
+ forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps),
  interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l.
-
-intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
+Proof.
+ intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
 Qed.
 
 Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
@@ -2604,18 +3067,18 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
   end.
 
 Definition co_valid1 (f : proposition -> proposition) :=
-  forall (ep : PropList) (e : list Z) (p1 : proposition),
+  forall (ep : list Prop) (e : list int) (p1 : proposition),
   interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1).
 
 Theorem extract_valid :
  forall s : list direction,
  valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s).
-
-unfold valid1, co_valid1 in |- *; simple induction s;
+Proof.
+ unfold valid1, co_valid1 in |- *; simple induction s;
  [ split;
     [ simpl in |- *; auto
     | intros ep e p1; case p1; simpl in |- *; auto; intro p;
-       pattern (decidability p) in |- *; apply bool_ind2;
+       pattern (decidability p) in |- *; apply bool_eq_ind;
        [ intro H; generalize (decidable_correct ep e p H);
           unfold decidable in |- *; tauto
        | simpl in |- *; auto ] ]
@@ -2623,12 +3086,11 @@ unfold valid1, co_valid1 in |- *; simple induction s;
     case p; auto; simpl in |- *; intros;
     (apply H1; tauto) ||
       (apply H2; tauto) ||
-        (pattern (decidability p0) in |- *; apply bool_ind2;
+        (pattern (decidability p0) in |- *; apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e p0 H3);
              unfold decidable in |- *; intro H4; apply H1; 
              tauto
           | intro; tauto ]) ].
-
 Qed.
 
 Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
@@ -2655,13 +3117,13 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
 
 Theorem decompose_solve_valid :
  forall s : e_step, valid_list_goal (decompose_solve s).
-
-intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
+Proof.
+ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
  simpl in |- *; intros;
  [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp)));
     [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto;
        [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2;
-          pattern (decidability p1) in |- *; apply bool_ind2;
+          pattern (decidability p1) in |- *; apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
              apply append_valid; elim H4; intro H5;
              [ right; apply H0; simpl in |- *; tauto
@@ -2671,7 +3133,7 @@ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
           [ intros H3; left; apply H; simpl in |- *; auto
           | intros H3; right; apply H0; simpl in |- *; auto ] 
        | intros p1 p2 H2;
-         pattern (decidability p1) in |- *; apply bool_ind2;
+         pattern (decidability p1) in |- *; apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
              apply append_valid; elim H4; intro H5; 
              [ right; apply H0; simpl in |- *; tauto
@@ -2687,7 +3149,7 @@ Qed.
 (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
 
 Definition valid_lhyps (f : lhyps -> lhyps) :=
-  forall (ep : PropList) (e : list Z) (lp : lhyps),
+  forall (ep : list Prop) (e : list int) (lp : lhyps),
   interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp).
 
 Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
@@ -2698,8 +3160,8 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
   end.
 
 Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
-
-unfold valid_lhyps in |- *; intros ep e lp; elim lp;
+Proof.
+ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
  [ simpl in |- *; auto
  | intros a l HR; elim a;
     [ simpl in |- *; tauto
@@ -2707,10 +3169,10 @@ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
 Qed.
 
 Theorem do_reduce_lhyps :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
  interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
-
-intros envp env l H; apply list_goal_to_hyps; intro H1;
+Proof.
+ intros envp env l H; apply list_goal_to_hyps; intro H1;
  apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; 
  assumption.
 Qed.
@@ -2719,13 +3181,13 @@ Definition concl_to_hyp (p : proposition) :=
   if decidability p then Tnot p else TrueTerm.
 
 Definition do_concl_to_hyp :
-  forall (envp : PropList) (env : list Z) (c : proposition) (l : hyps),
+  forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps),
   interp_goal envp env (concl_to_hyp c :: l) ->
   interp_goal_concl c envp env l.
-
-simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
+Proof.
+ simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
  [ simpl in |- *; unfold concl_to_hyp in |- *;
-    pattern (decidability c) in |- *; apply bool_ind2;
+    pattern (decidability c) in |- *; apply bool_eq_ind;
     [ intro H; generalize (decidable_correct envp env c H);
        unfold decidable in |- *; simpl in |- *; tauto
     | simpl in |- *; intros H1 H2; elim H2; trivial ]
@@ -2737,12 +3199,19 @@ Definition omega_tactic (t1 : e_step) (t2 : list h_step)
   reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))).
 
 Theorem do_omega :
- forall (t1 : e_step) (t2 : list h_step) (envp : PropList) 
-   (env : list Z) (c : proposition) (l : hyps),
+ forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) 
+   (env : list int) (c : proposition) (l : hyps),
  interp_list_goal envp env (omega_tactic t1 t2 c l) ->
  interp_goal_concl c envp env l.
-
-unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
+Proof.
+ unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
  apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1);
  apply do_reduce_lhyps; assumption.
 Qed.
+
+End IntOmega.
+
+(* For now, the above modular construction is instanciated on Z, 
+   in order to retrieve the initial ROmega. *)
+
+Module ZOmega := IntOmega(Z_as_Int).
diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml
index 69b4b2de..bdec6bf4 100644
--- a/contrib/romega/const_omega.ml
+++ b/contrib/romega/const_omega.ml
@@ -48,64 +48,16 @@ let dest_const_apply t =
     | _ -> raise Destruct
   in  Nametab.id_of_global ref, args
 
-let recognize_number t =
-  let rec loop t =
-    let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
-       "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
-     | "xO",[t] -> Bigint.mult Bigint.two (loop t)
-     | "xH",[] -> Bigint.one
-     | _ -> failwith "not a number" in
-  let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
-        "Zpos",[t] -> loop t
-      | "Zneg",[t] -> Bigint.neg (loop t)
-      | "Z0",[] -> Bigint.zero
-      | _ -> failwith "not a number";;
-
-
 let logic_dir = ["Coq";"Logic";"Decidable"]
 
 let coq_modules =
   Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules
-    @ [["Coq"; "omega"; "OmegaLemmas"]]
     @ [["Coq"; "Lists"; "List"]]
     @ [module_refl_path]
-
+    @ [module_refl_path@["ZOmega"]]
 
 let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
 
-let coq_xH = lazy (constant "xH")
-let coq_xO = lazy (constant "xO")
-let coq_xI = lazy (constant "xI")
-let coq_Z0 = lazy (constant "Z0")
-let coq_Zpos = lazy (constant "Zpos")
-let coq_Zneg = lazy (constant "Zneg")
-let coq_Z = lazy (constant "Z")
-let coq_comparison = lazy (constant  "comparison")
-let coq_Gt = lazy (constant "Gt")
-let coq_Lt = lazy (constant "Lt")
-let coq_Eq = lazy (constant "Eq")
-let coq_Zplus = lazy (constant "Zplus")
-let coq_Zmult = lazy (constant  "Zmult")
-let coq_Zopp = lazy (constant "Zopp")
-
-let coq_Zminus = lazy (constant "Zminus")
-let coq_Zsucc = lazy (constant  "Zsucc")
-let coq_Zgt = lazy (constant "Zgt")
-let coq_Zle = lazy (constant "Zle")
-let coq_Z_of_nat = lazy (constant  "Z_of_nat")
-
-(* Peano *)
-let coq_le = lazy(constant "le")
-let coq_gt = lazy(constant "gt")
-
-(* Integers *)
-let coq_nat = lazy(constant "nat")
-let coq_S = lazy(constant "S")
-let coq_O = lazy(constant "O")
-let coq_minus = lazy(constant "minus")
-
 (* Logic *)
 let coq_eq = lazy(constant  "eq")
 let coq_refl_equal = lazy(constant  "refl_equal")
@@ -114,15 +66,9 @@ let coq_not = lazy(constant "not")
 let coq_or = lazy(constant "or")
 let coq_True = lazy(constant "True")
 let coq_False = lazy(constant "False")
-let coq_ex = lazy(constant "ex")
 let coq_I = lazy(constant "I")
 
-(* Lists *)
-let coq_cons =  lazy (constant "cons")
-let coq_nil =  lazy (constant "nil")
-
-let coq_pcons = lazy (constant "Pcons")
-let coq_pnil = lazy (constant "Pnil")
+(* ReflOmegaCore/ZOmega *)
 
 let coq_h_step = lazy (constant "h_step")
 let coq_pair_step = lazy (constant  "pair_step")
@@ -130,8 +76,6 @@ let coq_p_left = lazy (constant  "P_LEFT")
 let coq_p_right = lazy (constant  "P_RIGHT")
 let coq_p_invert = lazy (constant  "P_INVERT")
 let coq_p_step = lazy (constant  "P_STEP")
-let coq_p_nop = lazy (constant  "P_NOP")
-
 
 let coq_t_int = lazy (constant  "Tint")
 let coq_t_plus = lazy (constant  "Tplus")
@@ -140,6 +84,7 @@ let coq_t_opp = lazy (constant  "Topp")
 let coq_t_minus = lazy (constant  "Tminus")
 let coq_t_var = lazy (constant  "Tvar")
 
+let coq_proposition = lazy (constant  "proposition")
 let coq_p_eq = lazy (constant  "EqTerm")
 let coq_p_leq = lazy (constant  "LeqTerm")
 let coq_p_geq = lazy (constant  "GeqTerm")
@@ -154,14 +99,6 @@ let coq_p_and = lazy (constant  "Tand")
 let coq_p_imp = lazy (constant  "Timp")
 let coq_p_prop = lazy (constant  "Tprop")
 
-let coq_proposition = lazy (constant  "proposition")
-let coq_interp_sequent = lazy (constant  "interp_goal_concl")
-let coq_normalize_sequent = lazy (constant  "normalize_goal")
-let coq_execute_sequent = lazy (constant  "execute_goal")
-let coq_do_concl_to_hyp =  lazy (constant  "do_concl_to_hyp")
-let coq_sequent_to_hyps = lazy (constant  "goal_to_hyps")
-let coq_normalize_hyps_goal = lazy (constant  "normalize_hyps_goal")
-
 (* Constructors for shuffle tactic *)
 let coq_t_fusion =  lazy (constant  "t_fusion")
 let coq_f_equal =  lazy (constant  "F_equal")
@@ -170,7 +107,6 @@ let coq_f_left =  lazy (constant  "F_left")
 let coq_f_right =  lazy (constant  "F_right")
 
 (* Constructors for reordering tactics *)
-let coq_step = lazy (constant  "step")
 let coq_c_do_both = lazy (constant  "C_DO_BOTH")
 let coq_c_do_left = lazy (constant  "C_LEFT")
 let coq_c_do_right = lazy (constant  "C_RIGHT")
@@ -196,8 +132,7 @@ let coq_c_red4 = lazy (constant  "C_RED4")
 let coq_c_red5 = lazy (constant  "C_RED5")
 let coq_c_red6 = lazy (constant  "C_RED6")
 let coq_c_mult_opp_left = lazy (constant  "C_MULT_OPP_LEFT")
-let coq_c_mult_assoc_reduced = 
-  lazy (constant  "C_MULT_ASSOC_REDUCED")
+let coq_c_mult_assoc_reduced = lazy (constant  "C_MULT_ASSOC_REDUCED")
 let coq_c_minus = lazy (constant  "C_MINUS")
 let coq_c_mult_comm = lazy (constant  "C_MULT_COMM")
 
@@ -225,30 +160,11 @@ let coq_e_split = lazy  (constant  "E_SPLIT")
 let coq_e_extract = lazy  (constant  "E_EXTRACT")
 let coq_e_solve = lazy  (constant  "E_SOLVE")
 
-let coq_decompose_solve_valid = 
-  lazy (constant   "decompose_solve_valid")
-let coq_do_reduce_lhyps = lazy (constant   "do_reduce_lhyps")
+let coq_interp_sequent = lazy (constant  "interp_goal_concl")
 let coq_do_omega = lazy (constant  "do_omega")
 
 (* \subsection{Construction d'expressions} *)
 
-
-let mk_var v = Term.mkVar (Names.id_of_string v)
-let mk_plus t1 t2 = Term.mkApp (Lazy.force coq_Zplus,[|  t1; t2 |])
-let mk_times t1 t2 = Term.mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
-let mk_minus t1 t2 = Term.mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
-let mk_eq t1 t2 = Term.mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |])
-let mk_le t1 t2 = Term.mkApp (Lazy.force coq_Zle, [|t1; t2 |])
-let mk_gt t1 t2 = Term.mkApp (Lazy.force coq_Zgt, [|t1; t2 |])
-let mk_inv t = Term.mkApp (Lazy.force coq_Zopp, [|t |])
-let mk_and t1 t2 =  Term.mkApp (Lazy.force coq_and, [|t1; t2 |])
-let mk_or t1 t2 =  Term.mkApp (Lazy.force coq_or, [|t1; t2 |])
-let mk_not t = Term.mkApp (Lazy.force coq_not, [|t |])
-let mk_eq_rel t1 t2 = Term.mkApp (Lazy.force coq_eq, [|
-				Lazy.force coq_comparison; t1; t2 |])
-let mk_inj t = Term.mkApp (Lazy.force coq_Z_of_nat, [|t |])
-
-
 let do_left t = 
   if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
   else Term.mkApp (Lazy.force coq_c_do_left, [|t |] )
@@ -272,27 +188,20 @@ let rec do_list = function
   | [x] -> x
   | (x::l) -> do_seq x (do_list l)
 
-let mk_integer n =
-  let rec loop n = 
-    if n=Bigint.one then Lazy.force coq_xH else
-      let (q,r) = Bigint.euclid n Bigint.two in
-      Term.mkApp
-        ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI),
-	[| loop q |]) in
-    
-    if n = Bigint.zero then Lazy.force coq_Z0 
-    else
-      if Bigint.is_strictly_pos n then
-        Term.mkApp (Lazy.force coq_Zpos, [| loop n |])
-      else
-        Term.mkApp (Lazy.force coq_Zneg, [| loop (Bigint.neg n) |])
+(* Nat *)
 
-let mk_Z = mk_integer
+let coq_S = lazy(constant "S")
+let coq_O = lazy(constant "O")
 
 let rec mk_nat = function
   | 0 -> Lazy.force coq_O
   | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |])
 
+(* Lists *)
+
+let coq_cons =  lazy (constant "cons")
+let coq_nil =  lazy (constant "nil")
+
 let mk_list typ l =
   let rec loop = function
     | [] ->
@@ -301,14 +210,141 @@ let mk_list typ l =
 	Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
   loop l
 
-let mk_plist l =
-  let rec loop = function
-    | [] ->
-	(Lazy.force coq_pnil)
-    | (step :: l) -> 
-	Term.mkApp (Lazy.force coq_pcons, [| step; loop l |]) in
-  loop l
-
+let mk_plist l = mk_list Term.mkProp l
 
 let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
 
+
+type parse_term = 
+  | Tplus of Term.constr * Term.constr 
+  | Tmult of Term.constr * Term.constr
+  | Tminus of Term.constr * Term.constr
+  | Topp of Term.constr
+  | Tsucc of Term.constr
+  | Tnum of Bigint.bigint
+  | Tother 
+
+type parse_rel = 
+  | Req of Term.constr * Term.constr
+  | Rne of Term.constr * Term.constr
+  | Rlt of Term.constr * Term.constr
+  | Rle of Term.constr * Term.constr
+  | Rgt of Term.constr * Term.constr
+  | Rge of Term.constr * Term.constr
+  | Rtrue
+  | Rfalse
+  | Rnot of Term.constr
+  | Ror of Term.constr * Term.constr
+  | Rand of Term.constr * Term.constr
+  | Rimp of Term.constr * Term.constr
+  | Riff of Term.constr * Term.constr
+  | Rother
+
+let parse_logic_rel c = 
+ try match destructurate c with
+   | Kapp("True",[]) -> Rtrue
+   | Kapp("False",[]) -> Rfalse
+   | Kapp("not",[t]) -> Rnot t
+   | Kapp("or",[t1;t2]) -> Ror (t1,t2) 
+   | Kapp("and",[t1;t2]) -> Rand (t1,t2)
+   | Kimp(t1,t2) -> Rimp (t1,t2)
+   | Kapp("iff",[t1;t2]) -> Riff (t1,t2)
+   | _ -> Rother
+ with e when Logic.catchable_exception e -> Rother
+
+
+module type Int = sig
+  val typ : Term.constr Lazy.t
+  val plus : Term.constr Lazy.t 
+  val mult : Term.constr Lazy.t
+  val opp : Term.constr Lazy.t
+  val minus : Term.constr Lazy.t
+
+  val mk : Bigint.bigint -> Term.constr
+  val parse_term : Term.constr -> parse_term
+  val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
+  (* check whether t is built only with numbers and + * - *)
+  val is_scalar : Term.constr -> bool 
+end
+
+module Z : Int = struct 
+
+let typ = lazy (constant "Z")
+let plus = lazy (constant "Zplus")
+let mult = lazy (constant  "Zmult")
+let opp = lazy (constant "Zopp")
+let minus = lazy (constant "Zminus")
+
+let coq_xH = lazy (constant "xH")
+let coq_xO = lazy (constant "xO")
+let coq_xI = lazy (constant "xI")
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
+
+let recognize t =
+  let rec loop t =
+    let f,l = dest_const_apply t in
+    match Names.string_of_id f,l with
+       "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
+     | "xO",[t] -> Bigint.mult Bigint.two (loop t)
+     | "xH",[] -> Bigint.one
+     | _ -> failwith "not a number" in
+  let f,l = dest_const_apply t in
+    match Names.string_of_id f,l with
+        "Zpos",[t] -> loop t
+      | "Zneg",[t] -> Bigint.neg (loop t)
+      | "Z0",[] -> Bigint.zero
+      | _ -> failwith "not a number";;
+
+let rec mk_positive n = 
+  if n=Bigint.one then Lazy.force coq_xH 
+  else
+    let (q,r) = Bigint.euclid n Bigint.two in
+    Term.mkApp
+      ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI),
+       [| mk_positive q |]) 
+
+let mk_Z n =
+  if n = Bigint.zero then Lazy.force coq_Z0 
+  else if Bigint.is_strictly_pos n then
+    Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |])
+  else
+    Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |])
+
+let mk = mk_Z
+
+let parse_term t = 
+  try match destructurate t with
+    | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2)
+    | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2)
+    | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2)
+    | Kapp("Zopp",[t]) -> Topp t
+    | Kapp("Zsucc",[t]) -> Tsucc t
+    | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
+    | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> 
+	(try Tnum (recognize t) with _ -> Tother)
+    | _ -> Tother
+  with e when Logic.catchable_exception e -> Tother
+    
+let parse_rel gl t = 
+  try match destructurate t with 
+    | Kapp("eq",[typ;t1;t2]) 
+      when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2)
+    | Kapp("Zne",[t1;t2]) -> Rne (t1,t2)
+    | Kapp("Zle",[t1;t2]) -> Rle (t1,t2)
+    | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2)
+    | Kapp("Zge",[t1;t2]) -> Rge (t1,t2)
+    | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2)
+    | _ -> parse_logic_rel t 
+  with e when Logic.catchable_exception e -> Rother
+
+let is_scalar t =
+  let rec aux t = match destructurate t with
+    | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2
+    | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t
+    | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
+    | _ -> false in
+  try aux t with _ -> false
+
+end
diff --git a/contrib/romega/const_omega.mli b/contrib/romega/const_omega.mli
new file mode 100644
index 00000000..0f00e918
--- /dev/null
+++ b/contrib/romega/const_omega.mli
@@ -0,0 +1,176 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+
+(** Coq objects used in romega *)
+
+(* from Logic *)
+val coq_refl_equal : Term.constr lazy_t
+val coq_and : Term.constr lazy_t
+val coq_not : Term.constr lazy_t
+val coq_or : Term.constr lazy_t
+val coq_True : Term.constr lazy_t
+val coq_False : Term.constr lazy_t
+val coq_I : Term.constr lazy_t
+
+(* from ReflOmegaCore/ZOmega *)
+val coq_h_step : Term.constr lazy_t
+val coq_pair_step : Term.constr lazy_t
+val coq_p_left : Term.constr lazy_t
+val coq_p_right : Term.constr lazy_t
+val coq_p_invert : Term.constr lazy_t
+val coq_p_step : Term.constr lazy_t
+
+val coq_t_int : Term.constr lazy_t
+val coq_t_plus : Term.constr lazy_t
+val coq_t_mult : Term.constr lazy_t
+val coq_t_opp : Term.constr lazy_t
+val coq_t_minus : Term.constr lazy_t
+val coq_t_var : Term.constr lazy_t
+
+val coq_proposition : Term.constr lazy_t
+val coq_p_eq : Term.constr lazy_t
+val coq_p_leq : Term.constr lazy_t
+val coq_p_geq : Term.constr lazy_t
+val coq_p_lt : Term.constr lazy_t
+val coq_p_gt : Term.constr lazy_t
+val coq_p_neq : Term.constr lazy_t
+val coq_p_true : Term.constr lazy_t
+val coq_p_false : Term.constr lazy_t
+val coq_p_not : Term.constr lazy_t
+val coq_p_or : Term.constr lazy_t
+val coq_p_and : Term.constr lazy_t
+val coq_p_imp : Term.constr lazy_t
+val coq_p_prop : Term.constr lazy_t
+
+val coq_f_equal : Term.constr lazy_t
+val coq_f_cancel : Term.constr lazy_t
+val coq_f_left : Term.constr lazy_t
+val coq_f_right : Term.constr lazy_t
+
+val coq_c_do_both : Term.constr lazy_t
+val coq_c_do_left : Term.constr lazy_t
+val coq_c_do_right : Term.constr lazy_t
+val coq_c_do_seq : Term.constr lazy_t
+val coq_c_nop : Term.constr lazy_t
+val coq_c_opp_plus : Term.constr lazy_t
+val coq_c_opp_opp : Term.constr lazy_t
+val coq_c_opp_mult_r : Term.constr lazy_t
+val coq_c_opp_one : Term.constr lazy_t
+val coq_c_reduce : Term.constr lazy_t
+val coq_c_mult_plus_distr : Term.constr lazy_t
+val coq_c_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_l : Term.constr lazy_t
+val coq_c_plus_permute : Term.constr lazy_t
+val coq_c_plus_comm : Term.constr lazy_t
+val coq_c_red0 : Term.constr lazy_t
+val coq_c_red1 : Term.constr lazy_t
+val coq_c_red2 : Term.constr lazy_t
+val coq_c_red3 : Term.constr lazy_t
+val coq_c_red4 : Term.constr lazy_t
+val coq_c_red5 : Term.constr lazy_t
+val coq_c_red6 : Term.constr lazy_t
+val coq_c_mult_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_reduced : Term.constr lazy_t
+val coq_c_minus : Term.constr lazy_t
+val coq_c_mult_comm : Term.constr lazy_t
+
+val coq_s_constant_not_nul : Term.constr lazy_t
+val coq_s_constant_neg : Term.constr lazy_t
+val coq_s_div_approx : Term.constr lazy_t
+val coq_s_not_exact_divide : Term.constr lazy_t
+val coq_s_exact_divide : Term.constr lazy_t
+val coq_s_sum : Term.constr lazy_t
+val coq_s_state : Term.constr lazy_t
+val coq_s_contradiction : Term.constr lazy_t
+val coq_s_merge_eq : Term.constr lazy_t
+val coq_s_split_ineq : Term.constr lazy_t
+val coq_s_constant_nul : Term.constr lazy_t
+val coq_s_negate_contradict : Term.constr lazy_t
+val coq_s_negate_contradict_inv : Term.constr lazy_t
+
+val coq_direction : Term.constr lazy_t
+val coq_d_left : Term.constr lazy_t
+val coq_d_right : Term.constr lazy_t
+val coq_d_mono : Term.constr lazy_t
+
+val coq_e_split : Term.constr lazy_t
+val coq_e_extract : Term.constr lazy_t
+val coq_e_solve : Term.constr lazy_t
+
+val coq_interp_sequent : Term.constr lazy_t
+val coq_do_omega : Term.constr lazy_t
+
+(** Building expressions *)
+
+val do_left : Term.constr -> Term.constr
+val do_right : Term.constr -> Term.constr
+val do_both : Term.constr -> Term.constr -> Term.constr
+val do_seq : Term.constr -> Term.constr -> Term.constr
+val do_list : Term.constr list -> Term.constr
+
+val mk_nat : int -> Term.constr
+val mk_list : Term.constr -> Term.constr list -> Term.constr
+val mk_plist : Term.types list -> Term.types
+val mk_shuffle_list : Term.constr list -> Term.constr
+
+(** Analyzing a coq term *)
+
+(* The generic result shape of the analysis of a term.
+   One-level depth, except when a number is found *)
+type parse_term =
+    Tplus of Term.constr * Term.constr
+  | Tmult of Term.constr * Term.constr
+  | Tminus of Term.constr * Term.constr
+  | Topp of Term.constr
+  | Tsucc of Term.constr
+  | Tnum of Bigint.bigint
+  | Tother
+
+(* The generic result shape of the analysis of a relation.
+   One-level depth. *)
+type parse_rel =
+    Req of Term.constr * Term.constr
+  | Rne of Term.constr * Term.constr
+  | Rlt of Term.constr * Term.constr
+  | Rle of Term.constr * Term.constr
+  | Rgt of Term.constr * Term.constr
+  | Rge of Term.constr * Term.constr
+  | Rtrue
+  | Rfalse
+  | Rnot of Term.constr
+  | Ror of Term.constr * Term.constr
+  | Rand of Term.constr * Term.constr
+  | Rimp of Term.constr * Term.constr
+  | Riff of Term.constr * Term.constr
+  | Rother
+
+(* A module factorizing what we should now about the number representation *)
+module type Int =
+  sig
+    (* the coq type of the numbers *)
+    val typ : Term.constr Lazy.t
+    (* the operations on the numbers *)
+    val plus : Term.constr Lazy.t
+    val mult : Term.constr Lazy.t
+    val opp : Term.constr Lazy.t
+    val minus : Term.constr Lazy.t
+    (* building a coq number *)
+    val mk : Bigint.bigint -> Term.constr
+    (* parsing a term (one level, except if a number is found) *)
+    val parse_term : Term.constr -> parse_term
+    (* parsing a relation expression, including = < <= >= > *)
+    val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
+    (* Is a particular term only made of numbers and + * - ? *) 
+    val is_scalar : Term.constr -> bool
+  end
+
+(* Currently, we only use Z numbers *)
+module Z : Int
diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4
index 7cfc50f8..39b6c210 100644
--- a/contrib/romega/g_romega.ml4
+++ b/contrib/romega/g_romega.ml4
@@ -9,7 +9,34 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
 open Refl_omega
+open Refiner
 
-TACTIC EXTEND romelga
-  [ "romega" ] -> [ total_reflexive_omega_tactic ]
+let romega_tactic l = 
+  let tacs = List.map 
+    (function  
+       | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
+       | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
+       | "N" -> Tacinterp.interp <:tactic<zify_N>>
+       | "Z" -> Tacinterp.interp <:tactic<zify_op>>
+       | s -> Util.error ("No ROmega knowledge base for type "^s))
+    (Util.list_uniquize (List.sort compare l))
+  in 
+  tclTHEN
+    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
+    (tclTHEN 
+       (* because of the contradiction process in (r)omega, 
+          we'd better leave as little as possible in the conclusion,
+          for an easier decidability argument. *)
+       Tactics.intros 
+       total_reflexive_omega_tactic)
+
+
+TACTIC EXTEND romega
+|  [ "romega" ] -> [ romega_tactic [] ]
+END
+
+TACTIC EXTEND romega'
+| [ "romega" "with" ne_ident_list(l) ] -> 
+    [ romega_tactic (List.map Names.string_of_id l) ]
+| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ]
 END
diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml
index e7e7b3c5..fc4f7a8f 100644
--- a/contrib/romega/refl_omega.ml
+++ b/contrib/romega/refl_omega.ml
@@ -6,10 +6,7 @@
 
  *************************************************************************)
 
-(* The addition on int, since it while be hidden soon by the one on BigInt *)
-
-let (+.) = (+)
-
+open Util
 open Const_omega
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
 open OmegaSolver
@@ -26,65 +23,6 @@ let pp i = print_int i; print_newline (); flush stdout
 (* More readable than the prefix notation *)
 let (>>) = Tacticals.tclTHEN
 
-(* [list_index t l = i] \eqv $nth l i = t \wedge \forall j < i nth l j != t$ *)
-
-let list_index t = 
-  let rec loop i = function
-    | (u::l) -> if u = t then i else loop (succ i) l
-    | [] -> raise Not_found in
-  loop 0
-
-(* [list_uniq l = filter_i (x i -> nth l (i-1) != x) l] *)
-let list_uniq l  = 
-  let rec uniq = function
-      x :: ((y :: _) as l) when x = y -> uniq l
-    | x :: l -> x :: uniq l
-    | [] -> [] in
-  uniq (List.sort compare l)
-
-(* $\forall x. mem x  (list\_union l1 l2) \eqv x \in \{l1\} \cup \{l2\}$ *)
-let list_union l1 l2 =
-  let rec loop buf = function
-      x :: r -> if List.mem x l2 then loop buf r else loop (x :: buf) r
-    | [] -> buf in
-  loop l2 l1
-
-(* $\forall x. 
-      mem \;\; x \;\; (list\_intersect\;\; l1\;\;l2) \eqv x \in \{l1\} 
-       \cap \{l2\}$ *)
-let list_intersect l1 l2 =
-  let rec loop buf = function
-      x :: r -> if List.mem x l2 then loop (x::buf) r else loop buf r
-    | [] -> buf in
-  loop [] l1
-
-(* cartesian product. Elements are lists and are concatenated.
-   $cartesian [x_1 ... x_n] [y_1 ... y_p] = [x_1 @ y_1, x_2 @ y_1 ... x_n @ y_1 , x_1 @ y_2 ... x_n @ y_p]$ *)
-
-let rec cartesien l1 l2 =
-  let rec loop = function
-      (x2 :: r2) -> List.map (fun x1 -> x1 @ x2) l1 @ loop r2
-    | [] -> [] in
-  loop l2
-
-(* remove element e from list l *)
-let list_remove e l =
-  let rec loop = function
-      x :: l -> if x = e then loop l else x :: loop l
-    | [] -> [] in
-  loop l
-
-(* equivalent of the map function but no element is added when the function
-   raises an exception (and the computation silently continues) *)
-let map_exc f = 
-  let rec loop = function 
-    (x::l) -> 
-      begin match try Some (f x) with exc -> None with
-        Some v -> v :: loop l | None -> loop l
-      end
-    | [] -> [] in
-  loop 
-
 let mkApp = Term.mkApp
 
 (* \section{Types}
@@ -174,6 +112,7 @@ type environment = {
 (* \subsection{Solution tree}
    Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
    d'un ensemble d'équation dont dépend la solution et d'une trace *)
+(* La liste des dépendances est triée et sans redondance *)
 type solution = {
   s_index : int;
   s_equa_deps : int list;
@@ -280,7 +219,7 @@ let unintern_omega env id =
    calcul des variables utiles. *)
 
 let add_reified_atom t env =
-  try list_index t env.terms
+  try list_index0 t env.terms
   with Not_found ->
     let i = List.length env.terms in
     env.terms <- env.terms @ [t]; i
@@ -291,7 +230,7 @@ let get_reified_atom env =
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
 (* ajout d'une proposition *)
 let add_prop env t =
-  try list_index t env.props
+  try list_index0 t env.props
   with Not_found ->
     let i = List.length env.props in  env.props <- env.props @ [t]; i
 
@@ -362,13 +301,6 @@ let omega_of_oformula env kind =
 
 (* \subsection{Omega vers Oformula} *)
 
-let reified_of_atom env i =
-  try Hashtbl.find env.real_indices i
-  with Not_found -> 
-    Printf.printf "Atome %d non trouvé\n" i; 
-    Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
-    raise Not_found
-
 let rec oformula_of_omega env af = 
   let rec loop = function
     | ({v=v; c=n}::r) ->
@@ -382,20 +314,27 @@ let app f v = mkApp(Lazy.force f,v)
 
 let rec coq_of_formula env t =
   let rec loop = function
-  | Oplus (t1,t2) -> app coq_Zplus [| loop t1; loop t2 |]
-  | Oopp t -> app coq_Zopp [| loop t |]
-  | Omult(t1,t2) -> app coq_Zmult [| loop t1; loop t2 |]
-  | Oint v ->   mk_Z v
+  | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |]
+  | Oopp t -> app Z.opp [| loop t |]
+  | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |]
+  | Oint v ->   Z.mk v
   | Oufo t -> loop t
   | Oatom var ->
       (* attention ne traite pas les nouvelles variables si on ne les
        * met pas dans env.term *)
       get_reified_atom env var
-  | Ominus(t1,t2) -> app coq_Zminus [| loop t1; loop t2 |] in
+  | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in
   loop t
 
 (* \subsection{Oformula vers COQ reifié} *)
 
+let reified_of_atom env i =
+  try Hashtbl.find env.real_indices i
+  with Not_found -> 
+    Printf.printf "Atome %d non trouvé\n" i; 
+    Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
+    raise Not_found
+
 let rec reified_of_formula env = function
   | Oplus (t1,t2) ->
       app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |]
@@ -403,7 +342,7 @@ let rec reified_of_formula env = function
       app coq_t_opp [| reified_of_formula env t |]
   | Omult(t1,t2) ->
       app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Oint v ->  app coq_t_int [| mk_Z v |]
+  | Oint v ->  app coq_t_int [| Z.mk v |]
   | Oufo t -> reified_of_formula env t
   | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |]
   | Ominus(t1,t2) ->
@@ -448,12 +387,12 @@ let reified_of_proposition env f =
 
 let reified_of_omega env body constant = 
   let coeff_constant = 
-    app coq_t_int [| mk_Z constant |] in
+    app coq_t_int [| Z.mk constant |] in
   let mk_coeff {c=c; v=v} t =
     let coef = 
       app coq_t_mult 
 	[| reified_of_formula env (unintern_omega env v); 
-	   app coq_t_int [| mk_Z c |] |] in
+	   app coq_t_int [| Z.mk c |] |] in
     app coq_t_plus [|coef; t |] in
   List.fold_right mk_coeff body coeff_constant
 
@@ -469,22 +408,34 @@ Ces fonctions préparent les traces utilisées par la tactique réfléchie
 pour faire des opérations de normalisation sur les équations.  *)
 
 (* \subsection{Extractions des variables d'une équation} *)
-(* Extraction des variables d'une équation *)
+(* Extraction des variables d'une équation. *)
+(* Chaque fonction retourne une liste triée sans redondance *)
+
+let (@@) = list_merge_uniq compare
 
 let rec vars_of_formula = function
   | Oint _ -> []
-  | Oplus (e1,e2)  -> (vars_of_formula e1) @ (vars_of_formula e2)
-  | Omult (e1,e2)  -> (vars_of_formula e1) @ (vars_of_formula e2)
-  | Ominus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2)
-  | Oopp e -> (vars_of_formula e)
+  | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+  | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+  | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+  | Oopp e -> vars_of_formula e
   | Oatom i -> [i]
   | Oufo _ -> []
 
-let vars_of_equations l =
-  let rec loop = function
-      e :: l -> vars_of_formula e.e_left @ vars_of_formula e.e_right @ loop l
-    | [] -> [] in
-  list_uniq (List.sort compare (loop l))
+let rec vars_of_equations = function
+  | [] -> [] 
+  | e::l -> 
+      (vars_of_formula e.e_left) @@
+      (vars_of_formula e.e_right) @@
+      (vars_of_equations l)
+
+let rec vars_of_prop = function 
+  | Pequa(_,e) -> vars_of_equations [e]
+  | Pnot p -> vars_of_prop p
+  | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+  | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+  | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+  | Pprop _ | Ptrue | Pfalse -> []
 
 (* \subsection{Multiplication par un scalaire} *)
 
@@ -715,36 +666,23 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
 
 (* \section{Compilation des hypothèses} *)
 
-let is_scalar t =
-  let rec aux t = match destructurate t with
-    | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2
-    | Kapp(("Zopp"|"Zsucc"),[t]) -> aux t
-    | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize_number t in true
-    | _ -> false in
-  try aux t with _ -> false
-
 let rec oformula_of_constr env t =
-  try match destructurate t with
-  | Kapp("Zplus",[t1;t2]) -> binop env (fun x y -> Oplus(x,y)) t1 t2
-  | Kapp("Zminus",[t1;t2]) -> binop env (fun x y -> Ominus(x,y)) t1 t2
-  | Kapp("Zmult",[t1;t2]) when is_scalar t1 or is_scalar t2 ->
-      binop env (fun x y -> Omult(x,y)) t1 t2
-  | Kapp("Zopp",[t]) -> Oopp(oformula_of_constr env t)
-  | Kapp("Zsucc",[t]) -> Oplus(oformula_of_constr env t, Oint one)
-  | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> 
-      begin try Oint(recognize_number t)
-      with _ -> Oatom (add_reified_atom t env) end
-  | _ -> 
-      Oatom (add_reified_atom t env)
-  with e when Logic.catchable_exception e ->
-    Oatom (add_reified_atom t env)
-
-and  binop env c t1 t2 = 
-    let t1' = oformula_of_constr env t1 in
-    let t2' = oformula_of_constr env t2 in
-    c t1' t2'
-
-and  binprop env (neg2,depends,origin,path) 
+  match Z.parse_term t with 
+    | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2
+    | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2
+    | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> 
+	binop env (fun x y -> Omult(x,y)) t1 t2
+    | Topp t -> Oopp(oformula_of_constr env t)
+    | Tsucc t -> Oplus(oformula_of_constr env t, Oint one)
+    | Tnum n -> Oint n
+    | _ -> Oatom (add_reified_atom t env)
+
+and binop env c t1 t2 = 
+  let t1' = oformula_of_constr env t1 in
+  let t2' = oformula_of_constr env t2 in
+  c t1' t2'
+
+and binprop env (neg2,depends,origin,path) 
              add_to_depends neg1 gl c t1 t2 =
   let i = new_connector_id env in
   let depends1 = if add_to_depends then Left i::depends else depends in
@@ -767,40 +705,32 @@ and mk_equation env ctxt c connector t1 t2 =
   Pequa (c,omega)
 
 and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = 
-  try match destructurate c with
-    | Kapp("eq",[typ;t1;t2]) 
-      when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) ->
-         mk_equation env ctxt c Eq t1 t2
-    | Kapp("Zne",[t1;t2]) -> 
-	mk_equation env ctxt c Neq t1 t2
-    | Kapp("Zle",[t1;t2]) -> 
-	mk_equation env ctxt c Leq t1 t2
-    | Kapp("Zlt",[t1;t2]) -> 
-	mk_equation env ctxt c Lt t1 t2
-    | Kapp("Zge",[t1;t2]) -> 
-	mk_equation env ctxt c Geq t1 t2
-    | Kapp("Zgt",[t1;t2]) -> 
-	mk_equation env ctxt c Gt t1 t2
-    | Kapp("True",[]) -> Ptrue
-    | Kapp("False",[]) -> Pfalse
-    | Kapp("not",[t]) ->
-       let t' = 
-	 oproposition_of_constr 
-	   env (not negated, depends, origin,(O_mono::path)) gl t in 
-       Pnot t'
-    | Kapp("or",[t1;t2]) ->  
+  match Z.parse_rel gl c with 
+    | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2
+    | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2
+    | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2
+    | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2
+    | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2
+    | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2
+    | Rtrue -> Ptrue 
+    | Rfalse -> Pfalse
+    | Rnot t -> 
+	let t' = 
+	  oproposition_of_constr 
+	    env (not negated, depends, origin,(O_mono::path)) gl t in 
+	Pnot t'
+    | Ror (t1,t2) -> 
 	binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2
-    | Kapp("and",[t1;t2]) ->
+    | Rand (t1,t2) -> 
 	binprop env ctxt negated negated gl
 	  (fun i x y -> Pand(i,x,y)) t1 t2
-    | Kimp(t1,t2) ->
+    | Rimp (t1,t2) ->
 	binprop env ctxt (not negated) (not negated) gl 
 	  (fun i x y -> Pimp(i,x,y)) t1 t2
-    | Kapp("iff",[t1;t2]) ->
+    | Riff (t1,t2) ->
 	binprop env ctxt negated negated gl 
 	  (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
     | _ -> Pprop c
-  with e when Logic.catchable_exception e -> Pprop c
 
 (* Destructuration des hypothèses et de la conclusion *)
 
@@ -881,7 +811,7 @@ let destructurate_hyps syst =
       (i,t) :: l -> 
 	let l_syst1 = destructurate_pos_hyp i []  [] t in
 	let l_syst2 = loop l in
-	cartesien l_syst1 l_syst2
+	list_cartesian (@) l_syst1 l_syst2
     | [] -> [[]] in
   loop syst
 
@@ -924,9 +854,9 @@ let display_systems syst_list =
 let rec hyps_used_in_trace = function
   | act :: l -> 
       begin match act with
-	| HYP e -> e.id :: hyps_used_in_trace l
+	| HYP e -> [e.id] @@ (hyps_used_in_trace l)
 	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
-	    hyps_used_in_trace act1 @ hyps_used_in_trace act2
+	    hyps_used_in_trace act1 @@ hyps_used_in_trace act2
 	| _ -> hyps_used_in_trace l
       end
   | [] -> []
@@ -950,14 +880,15 @@ let rec variable_stated_in_trace = function
 ;;
 
 let add_stated_equations env tree = 
-  let rec loop = function
-      Tree(_,t1,t2) -> 
-	list_union (loop t1) (loop t2)
-    | Leaf s -> variable_stated_in_trace s.s_trace in
   (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
      de définir dans le mauvais ordre *)
   let stated_equations = 
-    List.sort (fun x y -> Pervasives.(-) x.st_var y.st_var) (loop tree) in
+    let cmpvar x y = Pervasives.(-) x.st_var y.st_var in 
+    let rec loop = function
+      | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2)
+      | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) 
+    in loop tree
+  in 
   let add_env st = 
     (* On retransforme la définition de v en formule reifiée *)
     let v_def = oformula_of_omega env st.st_def in
@@ -966,7 +897,7 @@ let add_stated_equations env tree =
     let coq_v = coq_of_formula env v_def in
     let v = add_reified_atom coq_v env in
     (* Le terme qu'il va falloir introduire *)
-    let term_to_generalize = app coq_refl_equal [|Lazy.force coq_Z; coq_v|] in
+    let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in
     (* sa représentation sous forme d'équation mais non réifié car on n'a pas
      * l'environnement pour le faire correctement *)
     let term_to_reify = (v_def,Oatom v) in
@@ -978,10 +909,15 @@ let add_stated_equations env tree =
 (* Calcule la liste des éclatements à réaliser sur les hypothèses 
    nécessaires pour extraire une liste d'équations donnée *)
 
+(* PL: experimentally, the result order of the following function seems 
+   _very_ crucial for efficiency. No idea why. Do not remove the List.rev
+   or modify the current semantics of Util.list_union (some elements of first 
+   arg, then second arg), unless you know what you're doing. *)
+
 let rec get_eclatement env = function
     i :: r -> 
       let l = try (get_equation env i).e_depends with Not_found -> [] in
-      list_union l (get_eclatement env r)
+      list_union (List.rev l) (get_eclatement env r)
   | [] -> []
 
 let select_smaller l = 
@@ -992,14 +928,13 @@ let filter_compatible_systems required systems =
   let rec select = function
       (x::l) -> 
 	if List.mem x required then select l
-	else if List.mem (barre x) required then raise Exit 
+	else if List.mem (barre x) required then failwith "Exit" 
 	else x :: select l
     | [] -> [] in
-  map_exc (function (sol,splits) -> (sol,select splits)) systems
+  map_succeed (function (sol,splits) -> (sol,select splits)) systems
 
 let rec equas_of_solution_tree = function
-    Tree(_,t1,t2) -> 
-      list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2)
+    Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2)
   | Leaf s -> s.s_equa_deps
 
 (* [really_useful_prop] pushes useless props in a new Pprop variable *)
@@ -1041,14 +976,6 @@ let really_useful_prop l_equa c =
     None -> Pprop (real_of c)
   | Some t -> t
 
-let rec vars_of_prop = function 
-  | Pequa(_,e) -> vars_of_equations [e]
-  | Pnot p -> vars_of_prop p
-  | Por(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
-  | Pand(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
-  | Pimp(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
-  | _ -> []
-
 let rec display_solution_tree ch = function
     Leaf t -> 
       output_string ch 
@@ -1103,7 +1030,7 @@ let mk_direction_list l =
 (* \section{Rejouer l'historique} *)
 
 let get_hyp env_hyp i =
-  try list_index (CCEqua i) env_hyp
+  try list_index0 (CCEqua i) env_hyp
   with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
 
 let replay_history env env_hyp =
@@ -1116,7 +1043,7 @@ let replay_history env env_hyp =
 		    mk_nat (get_hyp env_hyp e2.id) |])
       | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  mkApp (Lazy.force coq_s_div_approx,
-		 [| mk_Z k; mk_Z d; 
+		 [| Z.mk k; Z.mk d; 
 		    reified_of_omega env e2.body e2.constant;
 		    mk_nat (List.length e2.body); 
 		    loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |])
@@ -1125,7 +1052,7 @@ let replay_history env env_hyp =
 	  let d = e1.constant - e2_constant * k in
 	  let e2_body = map_eq_linear (fun c -> c / k) e1.body in
           mkApp (Lazy.force coq_s_not_exact_divide,
-		 [|mk_Z k; mk_Z d; 
+		 [|Z.mk k; Z.mk d; 
 		   reified_of_omega env e2_body e2_constant; 
 		   mk_nat (List.length e2_body); 
 		   mk_nat (get_hyp env_hyp e1.id)|])
@@ -1134,7 +1061,7 @@ let replay_history env env_hyp =
 	    map_eq_linear (fun c -> c / k) e1.body in
 	  let e2_constant = floor_div e1.constant k in
           mkApp (Lazy.force coq_s_exact_divide,
-		 [|mk_Z k; 
+		 [|Z.mk k; 
 		   reified_of_omega env e2_body e2_constant; 
 		   mk_nat (List.length e2_body);
 		   loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|])
@@ -1149,7 +1076,7 @@ let replay_history env env_hyp =
 	  and n2 = get_hyp env_hyp e2.id in
 	  let trace = shuffle_path k1 e1.body k2 e2.body in
           mkApp (Lazy.force coq_s_sum,
-		 [| mk_Z k1; mk_nat n1; mk_Z k2;
+		 [| Z.mk k1; mk_nat n1; Z.mk k2;
 		    mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |])
       | CONSTANT_NOT_NUL(e,k) :: l -> 
           mkApp (Lazy.force coq_s_constant_not_nul,
@@ -1169,7 +1096,7 @@ let replay_history env env_hyp =
 	     Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in
           let trace,_ = normalize_linear_term env body in
 	  mkApp (Lazy.force coq_s_state,
-		 [| mk_Z m; trace; mk_nat n1; mk_nat n2; 
+		 [| Z.mk m; trace; mk_nat n1; mk_nat n2; 
 		    loop (CCEqua new_eq.id :: env_hyp) l |])
       |	HYP _ :: l -> loop env_hyp l
       |	CONSTANT_NUL e :: l ->
@@ -1267,17 +1194,17 @@ let resolution env full_reified_goal systems_list =
     print_newline()
   end;
   (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
-  let useful_equa_id = list_uniq (equas_of_solution_tree solution_tree) in
+  let useful_equa_id = equas_of_solution_tree solution_tree in
   (* recupere explicitement ces equations *)
   let equations = List.map (get_equation env) useful_equa_id in
-  let l_hyps' = list_uniq (List.map (fun e -> e.e_origin.o_hyp) equations) in
+  let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
   let l_hyps = id_concl :: list_remove id_concl l_hyps' in
   let useful_hyps =
     List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
   let useful_vars = 
     let really_useful_vars = vars_of_equations equations in
     let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in     
-    list_uniq (List.sort compare (really_useful_vars @ concl_vars))
+    really_useful_vars @@ concl_vars
   in 
   (* variables a introduire *)
   let to_introduce = add_stated_equations env solution_tree in
@@ -1295,7 +1222,7 @@ let resolution env full_reified_goal systems_list =
 	  Hashtbl.add env.real_indices var i; t :: loop (succ i) l
       |	[] -> [] in
     loop 0 all_vars_env in
-  let env_terms_reified = mk_list (Lazy.force coq_Z) basic_env in
+  let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in
   (* On peut maintenant généraliser le but : env est a jour *)
   let l_reified_stated =
      List.map (fun (_,_,(l,r),_) -> 
@@ -1325,10 +1252,10 @@ let resolution env full_reified_goal systems_list =
       |	((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
       |	(O_right :: l) -> app coq_p_right [| loop l |] in
     let correct_index = 
-      let i = list_index e.e_origin.o_hyp l_hyps in 
+      let i = list_index0 e.e_origin.o_hyp l_hyps in 
       (* PL: it seems that additionnally introduced hyps are in the way during 
              normalization, hence this index shifting... *) 
-      if i=0 then 0 else i +. List.length to_introduce
+      if i=0 then 0 else Pervasives.(+) i (List.length to_introduce)
     in 	
     app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in
   let normalization_trace =
diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v
index f4b24d4b..e90fea84 100644
--- a/contrib/rtauto/Bintree.v
+++ b/contrib/rtauto/Bintree.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bintree.v 8881 2006-05-31 18:16:34Z jforest $ *)
+(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *)
 
 Require Export List.
 Require Export BinPos.
@@ -20,15 +20,6 @@ Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
 
 Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
 
-Lemma Prect : forall P : positive -> Type,
-       P 1 ->
-       (forall n : positive, P n -> P (Psucc n)) -> forall p : positive, P p.
-intros P H1 Hsucc n; induction n.
-rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption.
-rewrite <- plus_iter_xO; apply iterate_add; assumption.
-assumption.
-Qed.
-
 Lemma Gt_Eq_Gt : forall p q cmp,
        (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt.
 apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt));
@@ -116,7 +107,7 @@ intro ne;right;congruence.
 left;reflexivity.
 Defined.
 
-Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left (m<>m) (refl_equal m) .
+Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m).
 fix 1;intros [mm|mm|].
 simpl; rewrite  pos_eq_dec_refl; reflexivity.
 simpl; rewrite  pos_eq_dec_refl; reflexivity.
@@ -125,7 +116,7 @@ Qed.
 
 Theorem pos_eq_dec_ex : forall m n,
  pos_eq m n =true -> exists h:m=n,
- pos_eq_dec m n = left (m<>n) h.
+ pos_eq_dec m n = left _ h.
 fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
 simpl;intro e.
 elim (pos_eq_dec_ex _ _ e).
diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml
index a1f5e5aa..81256f4a 100644
--- a/contrib/rtauto/refl_tauto.ml
+++ b/contrib/rtauto/refl_tauto.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *)
 
 module Search = Explore.Make(Proof_search)
 
@@ -292,7 +292,7 @@ let rtauto_tac gls=
   let prf = 
     try project (search_fun (init_state [] formula)) 
     with Not_found ->
-      errorlabstrm "rtauto" (Pp.str "rtauto could'nt find any proof") in
+      errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in
   let search_end_time = System.get_time () in
   let _ = if !verbose then
     begin
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
index 074f6ef7..601cabe0 100644
--- a/contrib/setoid_ring/ArithRing.v
+++ b/contrib/setoid_ring/ArithRing.v
@@ -32,7 +32,7 @@ Qed.
 Ltac natcst t :=
   match isnatcst t with
     true => constr:(N_of_nat t)
-  | _ => InitialRing.NotConstant
+  | _ => constr:InitialRing.NotConstant
   end.
 
 Ltac Ss_to_add f acc :=
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
index aad3a580..cccee604 100644
--- a/contrib/setoid_ring/Field_tac.v
+++ b/contrib/setoid_ring/Field_tac.v
@@ -67,12 +67,12 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
   end 
  in TFV t fv.
 
-Ltac ParseFieldComponents lemma :=
+Ltac ParseFieldComponents lemma req :=
   match type of lemma with
   | context [
      (*   PCond _ _ _  _ _ _ _  _ _  _ _ -> *)
-        (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv 
-                 ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] =>
+        req (@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.
@@ -119,18 +119,18 @@ Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
       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 _] =>
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] =>
         compute_assertion vlmp_eq vlmp 
-            (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+            (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
          (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq)
-          || fail "type error when build the rewriting lemma");
+          || fail 1 "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.
+  ParseFieldComponents lemma req Main.
 
 Ltac Field_simplify_gen f := 
      fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
@@ -141,33 +141,35 @@ Ltac Field_simplify_gen f :=
 
 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(rl) :=
+  let G := Get_goal in
+  field_lookup Field_simplify [] rl G.
 
 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.
+  let G := Get_goal in
+  field_lookup Field_simplify [lH] rl G.
 
 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.
+  let G := Get_goal 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 := Get_goal 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:= 
@@ -176,12 +178,12 @@ Ltac Field_simplify_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].
+  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].
+  field_lookup (Field_simplify_in h) [lH] rl t.
 *)
 
 (** Generic tactic for solving equations *)
@@ -224,7 +226,7 @@ Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
                   [ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
       clear vlpe nlemma in
     OnEquation req Main_eq in
-  ParseFieldComponents lemma Main.
+  ParseFieldComponents lemma req Main.
 
 (* solve completely a field equation, leaving non-zero conditions to be
    proved (field) *)
@@ -239,14 +241,15 @@ Ltac FIELD :=
        post().
  
 Tactic Notation (at level 0) "field" :=
-  let G := getGoal in field_lookup FIELD [] [G].
+  let G := Get_goal in
+  field_lookup FIELD [] G.
 
 Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
-  let G := getGoal in field_lookup FIELD [lH] [G].
+  let G := Get_goal 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_SIMPL  :=
   let Simpl := (protect_fv "field") in
   fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl =>
@@ -256,17 +259,19 @@ Ltac FIELD_SIMPL  :=
        post().
 
 Tactic Notation (at level 0) "field_simplify_eq" :=  
-  let G := getGoal in field_lookup FIELD_SIMPL [] [G].
+  let G := Get_goal 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].
+  let G := Get_goal 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;
+    intro hyp;   
     match type of hyp with
     | req ?t1 ?t2 =>
       let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
@@ -306,7 +311,7 @@ Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
                clear hyp  
              end)
      end in
-  ParseFieldComponents lemma Main.
+  ParseFieldComponents lemma req Main.
 
 Ltac FIELD_SIMPL_EQ :=
  fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
@@ -318,7 +323,7 @@ Ltac FIELD_SIMPL_EQ :=
 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];
+  field_lookup FIELD_SIMPL_EQ [] t;
   [ try exact I
   | clear H;intro H].
 
@@ -327,7 +332,7 @@ 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];
+  field_lookup FIELD_SIMPL_EQ [lH] t;
   [ try exact I
   |clear H;intro H].
  
@@ -347,59 +352,55 @@ Ltac coerce_to_almost_field set ext f :=
   | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
   end.
 
-Ltac field_elements set ext fspec pspec sspec rk :=
+Ltac field_elements set ext fspec pspec sspec dspec rk :=
   let afth := coerce_to_almost_field set ext fspec in
   let rspec := ring_of_field fspec in
-  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 _ _ _  _ _ _  _ _ _ _ 
+  ring_elements set ext rspec pspec sspec dspec rk
+  ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec).
+
+Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
+  let get_lemma :=
+    match pspec with None => fun x y => x | _ => fun x y => y end in
+  let simpl_eq_lemma := get_lemma 
+       Field_simplify_eq_correct       Field_simplify_eq_pow_correct in
+  let simpl_eq_in_lemma := get_lemma
+       Field_simplify_eq_in_correct   Field_simplify_eq_pow_in_correct in
+  let rw_lemma := get_lemma
+       Field_rw_correct                    Field_rw_pow_correct in
+  field_elements set ext fspec pspec sspec dspec rk
+   ltac:(fun afth ext_r morph p_spec s_spec d_spec =>
+     match morph with
+     | _ =>
+       let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in
+       match p_spec with
+       | mkhypo ?pp_spec =>  
+         let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
+         match s_spec with
+         | mkhypo ?ss_spec => 
+           let field_ok3 := constr:(field_ok2 _ ss_spec) in
+           match d_spec with
+           | mkhypo ?dd_spec => 
+             let field_ok := constr:(field_ok3 _ dd_spec) in
+             let mk_lemma lemma :=     
+              constr:(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" 
+                   _ _ _ pp_spec _ ss_spec _ dd_spec) in 
+             let field_simpl_eq_ok := mk_lemma simpl_eq_lemma  in
+             let field_simpl_ok := mk_lemma rw_lemma in
+             let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in
+             let cond1_ok := 
+                constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in
+             let cond2_ok := 
+               constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_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 4 "field: bad coefficiant division specification"
+           end
+         | _ => fail 3 "field: bad sign specification"
+         end
+       | _ => fail 2 "field: bad power specification"
+       end  
+     | _ => fail 1 "field internal error : field_lemmas, please report"
      end).
-
diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v
index ea8421cf..65a397ac 100644
--- a/contrib/setoid_ring/Field_theory.v
+++ b/contrib/setoid_ring/Field_theory.v
@@ -74,7 +74,7 @@ Qed.
  Notation "[ x ]" := (phi x) (at level 0).
 
 
- (* Usefull tactics *)		  
+ (* Useful tactics *)		  
   Add Setoid R req Rsth as R_set1.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
   Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
@@ -102,10 +102,13 @@ Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
  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.
+ Variable get_sign_spec : sign_theory copp ceqb get_sign.
+
+ Variable cdiv:C -> C -> C*C.
+ Variable cdiv_th : div_theory req cadd cmul phi cdiv.
 
 Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
-Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb).
+Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
 
 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).
@@ -300,7 +303,30 @@ transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
 repeat rewrite rdiv_simpl in |- *; trivial.
 Qed.
 
- Theorem rdiv7:
+ Theorem rdiv4b:
+ forall r1 r2 r3 r4 r5 r6,
+ ~ r2 * r5 == 0 ->
+ ~ r4 * r6 == 0 ->
+ ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 r5 r6 H H0.
+rewrite rdiv4; auto.
+transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))).
+apply SRdiv_ext; ring.
+assert (HH: ~ r5*r6 == 0).
+  apply field_is_integral_domain.
+    intros H1; case H; rewrite H1; ring.
+    intros H1; case H0; rewrite H1; ring.
+rewrite <- rdiv4 ; auto.
+  rewrite rdiv_r_r; auto.
+
+  apply field_is_integral_domain.
+    intros H1; case H; rewrite H1; ring.
+    intros H1; case H0; rewrite H1; ring.
+Qed.
+
+
+Theorem rdiv7:
  forall r1 r2 r3 r4,
  ~ r2 == 0 ->
  ~ r3 == 0 ->
@@ -313,6 +339,29 @@ rewrite rdiv6 in |- *; trivial.
 apply rdiv4; trivial.
 Qed.
 
+Theorem rdiv7b:
+ forall r1 r2 r3 r4 r5 r6,
+ ~ r2 * r6 == 0 ->
+ ~ r3 * r5 == 0 ->
+ ~ r4 * r6 == 0 ->
+ ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3).
+Proof.
+intros.
+rewrite rdiv7; auto.
+transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))).
+apply SRdiv_ext; ring.
+assert (HH: ~ r5*r6 == 0).
+  apply field_is_integral_domain.
+    intros H2; case H0; rewrite H2; ring.
+    intros H2; case H1; rewrite H2; ring.
+rewrite <- rdiv4 ; auto.
+rewrite rdiv_r_r; auto.
+  apply field_is_integral_domain.
+    intros H2; case H; rewrite H2; ring.
+    intros H2; case H0; rewrite H2; ring.
+Qed.
+
+
 Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 ->  r1 / r2 == 0.
 intros r1 r2 H H0.
 transitivity (r1 * / r2); auto.
@@ -331,8 +380,7 @@ transitivity (r1 / r2 * (r4 / r4)).
    rewrite H1 in |- *.
    rewrite (ARmul_comm ARth r2 r4) in |- *.
    rewrite <- rdiv4 in |- *; trivial.
-   rewrite rdiv_r_r in |- *.
-  trivial.
+   rewrite rdiv_r_r in |- * by trivial.
   apply (ARmul_1_r Rsth ARth).
 Qed.
 
@@ -395,7 +443,7 @@ 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.
+Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph.
 intros x y H [|p];simpl;auto. apply pow_morph;trivial.
 Qed.
 (*
@@ -451,7 +499,7 @@ 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 apply eq_refl;
- try ring [(morph0 CRmorph)].
+ try (ring [(morph0 CRmorph)]).
  apply (morph_add CRmorph).
 Qed.
 
@@ -613,6 +661,8 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   | FEpow x n => rpow (FEeval l x) (Cp_phi n)
   end.
 
+Strategy expand [FEeval].
+
 (* The result of the normalisation *)
  
 Record linear : Type := mk_linear {
@@ -732,7 +782,7 @@ Proof.
   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)]].
+  rewrite H by trivial. ring [ (morph1 CRmorph)].
   fold (NPEpow e2 (Npos (p2 - p1))).
   rewrite NPEpow_correct;simpl.
   repeat rewrite pow_th.(rpow_pow_N);simpl.
@@ -813,7 +863,7 @@ destruct n.
      (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.
+ simpl. rewrite Pcompare_refl. simpl. 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). 
@@ -961,8 +1011,10 @@ Fixpoint Fnorm (e : FExpr) : linear :=
   | FEmul e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
-      mk_linear (NPEmul (num x) (num y))
-        (NPEmul (denum x) (denum y))
+      let s1 := split (num x) (denum y) in
+      let s2 := split (num y) (denum x) in
+      mk_linear (NPEmul (left s1) (left s2))
+        (NPEmul (right s2) (right s1))
         (condition x ++ condition y)
   | FEopp e1 =>
       let x := Fnorm e1 in
@@ -973,8 +1025,10 @@ Fixpoint Fnorm (e : FExpr) : linear :=
   | FEdiv e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
-      mk_linear (NPEmul (num x) (denum y))
-        (NPEmul (denum x) (num y))
+      let s1 := split (num x) (num y) in
+      let s2 := split (denum x) (denum y) in
+      mk_linear (NPEmul (left s1) (right s2))
+        (NPEmul (left s2) (right s1))
         (num y :: condition x ++ condition y)
   | FEpow e1 n =>
       let x := Fnorm e1 in
@@ -996,10 +1050,11 @@ 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. 
+  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp). 
+  reflexivity.
+  rewrite H1. ring. rewrite Hp;ring. 
   intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  rewrite Hp;ring. reflexivity. trivial.
+  reflexivity. rewrite Hp;ring. trivial.
 Qed.
  
 Theorem Pcond_Fnorm:
@@ -1040,10 +1095,14 @@ intros l e; elim e.
    rewrite NPEmul_correct in |- *.
    simpl in |- *.
    apply field_is_integral_domain.
-  apply Hrec1.
+  intros HH; apply Hrec1.
     apply PCond_app_inv_l with (1 := Hcond).
-  apply Hrec2.
+    rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
+    rewrite NPEmul_correct; simpl; rewrite HH; ring.
+  intros HH; apply Hrec2.
     apply PCond_app_inv_r with (1 := Hcond).
+    rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))).
+    rewrite NPEmul_correct; simpl; rewrite HH; ring.
  intros e1 Hrec1 Hcond.
    simpl condition in Hcond.
    simpl denum in |- *.
@@ -1058,10 +1117,14 @@ intros l e; elim e.
    rewrite NPEmul_correct in |- *.
    simpl in |- *.
    apply field_is_integral_domain.
-  apply Hrec1.
+    intros HH; apply Hrec1.
     specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
     apply PCond_app_inv_l with (1 := Hcond1).
-   apply PCond_cons_inv_l with (1:=Hcond).
+    rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+    rewrite NPEmul_correct; simpl; rewrite HH; ring.
+    intros HH; apply PCond_cons_inv_l with (1:=Hcond).
+    rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))).
+    rewrite NPEmul_correct; simpl; rewrite HH; ring.
  simpl;intros e1 Hrec1 n Hcond.
   rewrite NPEpow_correct.
   simpl;rewrite pow_th.(rpow_pow_N).
@@ -1124,7 +1187,16 @@ assert (HH2: PCond l (condition (Fnorm e2))).
 apply PCond_app_inv_r with ( 1 := HH ).
 rewrite (He1 HH1); rewrite (He2 HH2).
 repeat rewrite NPEmul_correct; simpl.
-apply rdiv4; auto.
+generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1)))
+   (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
+  rewrite U4; simpl.
+apply rdiv4b; auto.
+  rewrite <- U4; auto.
+  rewrite <- U2; auto.
 
 intros e1 He1 HH.
 rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
@@ -1144,8 +1216,18 @@ apply PCond_app_inv_r with (condition (Fnorm e1)).
 apply PCond_cons_inv_r with ( 1 := HH ).
 rewrite (He1 HH1); rewrite (He2 HH2).
 repeat rewrite NPEmul_correct;simpl.
-apply rdiv7; auto.
+generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2)))
+   (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2)))
+   (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
+  rewrite U4; simpl.
+apply rdiv7b; auto.
+  rewrite <- U3; auto.
+  rewrite <- U2; auto.
 apply PCond_cons_inv_l with ( 1 := HH ).
+  rewrite <- U4; auto.
 
 intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
 repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
@@ -1155,13 +1237,15 @@ 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 IHp. reflexivity.
+apply pow_pos_not_0;trivial.
+apply pow_pos_not_0;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.
+ reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. 
+rewrite <- rdiv4;trivial. 
 rewrite IHp;reflexivity.
+apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
 reflexivity.
 Qed.
 
@@ -1174,9 +1258,9 @@ Theorem Fnorm_crossproduct:
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval in |- *.
+rewrite Fnorm_FEeval_PEeval in |- * by
  apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval in |- *.
+ rewrite Fnorm_FEeval_PEeval in |- * by
   apply PCond_app_inv_r with (1 := Hcond).
   apply cross_product_eq; trivial.
    apply Pcond_Fnorm.
@@ -1187,7 +1271,7 @@ 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).
+Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
 
 Theorem Fnorm_correct:
  forall n l lpe fe,
@@ -1198,7 +1282,7 @@ 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.
-rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th n l lpe);auto.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_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.
@@ -1270,9 +1354,9 @@ intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
 apply Fnorm_crossproduct; trivial.
 match goal with 
  [ |- NPEeval l ?x == NPEeval l ?y] =>
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec 
        O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
  end.
 trivial.
@@ -1303,14 +1387,14 @@ 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_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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 
+    ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_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.
@@ -1343,14 +1427,14 @@ 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 
+ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_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 
+    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_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.
@@ -1394,18 +1478,18 @@ Proof.
  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.
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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.
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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).
+ repeat rewrite <- Fnorm_FEeval_PEeval ; trivial.
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
 Qed.
 
 Theorem Field_simplify_eq_in_correct :
@@ -1444,18 +1528,18 @@ Proof.
  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.
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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.
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by 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).
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). 
 Qed.
 
 
@@ -1524,7 +1608,7 @@ 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 pow_th O l nil a a0). simpl.
+generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_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.
diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v
index f5f845c2..c1fa963f 100644
--- a/contrib/setoid_ring/InitialRing.v
+++ b/contrib/setoid_ring/InitialRing.v
@@ -13,13 +13,13 @@ Require Import BinNat.
 Require Import Setoid.
 Require Import Ring_theory.
 Require Import Ring_polynom.
+Require Import ZOdiv_def.
 Import List.
 
 Set Implicit Arguments.
 
 Import RingSyntax.
 
-
 (* An object to return when an expression is not recognized as a constant *)
 Definition NotConstant := false.
 
@@ -101,19 +101,19 @@ Section ZMORPHISM.
   | _ => None
   end.
 
- Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ.
+ Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ.
  Proof.
   constructor.
   destruct c;intros;try discriminate.
   injection H;clear H;intros H1;subst c'.
-  simpl;rrefl.
+  simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial.
  Qed.
 
  
  Section ALMOST_RING.
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
    Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+   Ltac norm := gen_srewrite Rsth Reqe ARth.
    Ltac add_push := gen_add_push radd Rsth Reqe ARth.
  
  Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
@@ -161,7 +161,7 @@ Section ZMORPHISM.
  Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
  Let ARth := Rth_ARth Rsth Reqe Rth.
    Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+   Ltac norm := gen_srewrite Rsth Reqe ARth.
    Ltac add_push := gen_add_push radd Rsth Reqe ARth.
   
 (*morphisms are extensionaly equal*)
@@ -243,7 +243,7 @@ Section ZMORPHISM.
                   Zplus Zmult Zeq_bool gen_phiZ).
    apply mkRmorph;simpl;try rrefl.
    apply gen_phiZ_add.  apply gen_phiZ_mul. apply gen_Zeqb_ok.
-  apply  (Smorph_morph Rsth Reqe Rth Zsth Zth SRmorph gen_phiZ_ext).
+  apply  (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext).
  Qed.
 
 End ZMORPHISM.
@@ -317,8 +317,8 @@ Section NMORPHISM.
    Add Morphism rmul : rmul_ext4.  exact (Rmul_ext Reqe). Qed.
    Add Morphism ropp : ropp_ext4.  exact (Ropp_ext Reqe). Qed.
    Add Morphism rsub : rsub_ext5.  exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
-  
+   Ltac norm := gen_srewrite Rsth Reqe ARth.
+
  Definition gen_phiN1 x :=
   match x with
   | N0 => 0
@@ -433,7 +433,7 @@ Section NWORDMORPHISM.
 
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
    Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+   Ltac norm := gen_srewrite Rsth Reqe ARth.
    Ltac add_push := gen_add_push radd Rsth Reqe ARth.
 
  Fixpoint gen_phiNword (w : Nword) : R :=
@@ -515,12 +515,12 @@ induction x; intros.
 
   simpl Nwadd in |- *.
   repeat rewrite gen_phiNword_cons in |- *.
-  rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- *.
-   destruct Reqe; constructor; trivial.
+  rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by
+    (destruct Reqe; constructor; trivial).
 
-   rewrite IHx in |- *.
-   norm.
-   add_push (- gen_phiNword x); reflexivity.
+  rewrite IHx in |- *.
+  norm.
+  add_push (- gen_phiNword x); reflexivity.
 Qed.
 
 Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x.
@@ -537,8 +537,8 @@ induction x; intros.
 
  simpl Nwscal in |- *.
  repeat rewrite gen_phiNword_cons in |- *.
- rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *.
-  destruct Reqe; constructor; trivial.
+ rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *
+   by (destruct Reqe; constructor; trivial).
 
   rewrite IHx in |- *.
   norm.
@@ -592,7 +592,70 @@ Qed.
 
 End NWORDMORPHISM.
 
+Section GEN_DIV.
+  
+  Variables  (R : Type) (rO : R) (rI : R) (radd : R -> R -> R)
+              (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R)
+              (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C)
+              (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C)
+              (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R).
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+ Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi.
+ 
+  (* Useful tactics *)		  
+  Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+
+ Definition triv_div x y :=  
+   if ceqb x y then (cI, cO)
+   else (cO, x).
+
+ Ltac Esimpl :=repeat (progress (
+   match goal with
+   | |- context [phi cO] => rewrite (morph0 morph)
+   | |- context [phi cI] => rewrite (morph1 morph)
+   | |- context [phi (cadd ?x  ?y)] => rewrite ((morph_add morph) x y)
+   | |- context [phi (cmul ?x  ?y)] => rewrite ((morph_mul morph) x y)
+   | |- context [phi (csub ?x  ?y)] => rewrite ((morph_sub morph) x y)
+   | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x)
+   end)).
+
+ Lemma triv_div_th : Ring_theory.div_theory  req cadd cmul phi triv_div.
+ Proof.
+  constructor.
+  intros a b;unfold triv_div.
+  assert (X:= morph.(morph_eq) a b);destruct (ceqb a b).
+  Esimpl.
+  rewrite X; trivial.
+  rsimpl.
+  Esimpl;  rsimpl.
+Qed.
+
+ Variable zphi : Z -> R.
+
+ Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl.
+ Proof.
+  constructor.
+  intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst.
+  rewrite Zmult_comm; rsimpl.
+ Qed.
 
+ Variable nphi : N -> R.
+
+ Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl.
+  constructor.
+  intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst.
+  rewrite Nmult_comm; rsimpl.
+ Qed.
+
+End GEN_DIV.
 
  (* syntaxification of constants in an abstract ring:
     the inverse of gen_phiPOS *)
@@ -604,17 +667,17 @@ End NWORDMORPHISM.
    | (add rI (add rI rI)) => constr:3%positive
    | (mul (add rI rI) ?p) => (* 2p *)
        match inv_cst p with
-         NotConstant => NotConstant
-       | 1%positive => NotConstant (* 2*1 is not convertible to 2 *)
+         NotConstant => constr:NotConstant
+       | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
        | ?p => constr:(xO p)
        end
    | (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
        match inv_cst p with
-         NotConstant => NotConstant
-       | 1%positive => NotConstant
+         NotConstant => constr:NotConstant
+       | 1%positive => constr:NotConstant
        | ?p => constr:(xI p)
        end
-   | _ => NotConstant
+   | _ => constr:NotConstant
    end in
    inv_cst t.
 
@@ -624,7 +687,7 @@ End NWORDMORPHISM.
      rO => constr:NwO
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => NotConstant
+       NotConstant => constr:NotConstant
      | ?p => constr:(Npos p::nil)
      end
    end.
@@ -636,7 +699,7 @@ End NWORDMORPHISM.
      rO => constr:0%N
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => NotConstant
+       NotConstant => constr:NotConstant
      | ?p => constr:(Npos p)
      end
    end.
@@ -647,12 +710,12 @@ End NWORDMORPHISM.
      rO => constr:0%Z
    | (opp ?p) =>
      match inv_gen_phi_pos rI add mul p with
-       NotConstant => NotConstant
+       NotConstant => constr:NotConstant
      | ?p => constr:(Zneg p)
      end
    | _ =>
      match inv_gen_phi_pos rI add mul t with
-       NotConstant => NotConstant
+       NotConstant => constr:NotConstant
      | ?p => constr:(Zpos p)
      end
    end.
@@ -668,7 +731,7 @@ Ltac inv_gen_phi rO rI cO cI t :=
   end.
 
 (* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:(NotConstant).
+ Ltac inv_morph_nothing t := constr:NotConstant.
 
 Ltac coerce_to_almost_ring set ext rspec :=
   match type of rspec with
@@ -710,31 +773,42 @@ Ltac gen_ring_pow set arth pspec :=
  | Some ?t => constr:(t)
  end.
 
-Ltac default_sign_spec morph :=
+Ltac gen_ring_sign morph sspec :=
+  match sspec with
+  | None =>
+    match type of morph with
+    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req  
+               Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
+       constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th)
+    | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req  
+               ?C  ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
+        constr:(mkhypo (@get_sign_None_th C copp ceqb))
+    | _ => fail 2 "ring anomaly : default_sign_spec"
+    end
+ | Some ?t => constr:(t)
+ end.
+
+Ltac default_div_spec set reqe arth morph :=
  match type of morph with
  | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+               Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi =>
+      constr:(mkhypo (Ztriv_div_th set phi))
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+               N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi =>
+      constr:(mkhypo (Ntriv_div_th set phi)) 
+ | @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))
+      constr:(mkhypo (triv_div_th set reqe arth morph))
  | _ => 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
+Ltac gen_ring_div set reqe arth morph dspec  :=
+ match dspec with
+ | None => default_div_spec set reqe arth morph   
  | Some ?t => constr:(t)
  end.
-
-
-Ltac ring_elements set ext rspec pspec sspec rk :=
+ 
+Ltac ring_elements set ext rspec pspec sspec dspec rk :=
   let arth := coerce_to_almost_ring set ext rspec in
   let ext_r := coerce_to_ring_ext ext in
   let morph :=
@@ -756,42 +830,54 @@ Ltac ring_elements set ext rspec pspec sspec rk :=
     | _ => fail 1 "ill-formed ring kind"
     end in
   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.
+  let s_spec := gen_ring_sign morph sspec in
+  let d_spec := gen_ring_div set ext_r arth morph dspec in
+  fun f => f arth ext_r morph p_spec s_spec d_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 :=
+
+ Ltac ring_lemmas set ext rspec pspec sspec dspec 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" 
+  ring_elements set ext rspec pspec sspec dspec rk
+    ltac:(fun arth ext_r morph p_spec s_spec d_spec =>
+       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 =>
+          let gen_lemma2_0 := 
+              constr:(gen_lemma2 R  r0 rI  radd rmul rsub ropp req set ext_r arth 
+                                C  c0 c1 cadd cmul csub copp ceq_b phi morph) in
+          match p_spec with
+          | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec =>      
+             let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in
+             match d_spec with
+             | @mkhypo (div_theory _ _ _ _  ?cdiv) ?dd_spec =>
+                let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in
+                match s_spec with
+                | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec =>    
+                  let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in 
+                  let lemma1 := 
+                    constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in
+                  fun f => f arth ext_r morph lemma1 lemma2
+                | _ => fail 4 "ring: bad sign specification"
+                end
+             | _ => fail 3 "ring: bad coefficiant division specification"
+             end
+          | _ => fail 2 "ring: bad power specification"
+          end
+       | _ => fail 1 "ring internal error: ring_lemmas, please report"
        end).
- 
+
 (* Tactic for constant *)
 Ltac isnatcst t :=
   match t with
-    O => true
+    O => constr:true
   | S ?p => isnatcst p
-  | _ => false
+  | _ => constr:false
   end.
 
 Ltac isPcst t :=
@@ -801,7 +887,7 @@ Ltac isPcst t :=
   | xH => constr:true
   (* nat -> positive *)
   | P_of_succ_nat ?n => isnatcst n 
-  | _ => false
+  | _ => constr:false
   end.
 
 Ltac isNcst t :=
@@ -813,7 +899,7 @@ Ltac isNcst t :=
 
 Ltac isZcst t :=
   match t with
-    Z0 => true
+    Z0 => constr:true
   | Zpos ?p => isPcst p
   | Zneg ?p => isPcst p
   (* injection nat -> Z *)
@@ -821,7 +907,7 @@ Ltac isZcst t :=
   (* injection N -> Z *)
   | Z_of_N ?n => isNcst n
   (* *)
-  | _ => false
+  | _ => constr:false
   end.
 
 
diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v
index ae067a8a..0ba519fd 100644
--- a/contrib/setoid_ring/NArithRing.v
+++ b/contrib/setoid_ring/NArithRing.v
@@ -15,7 +15,7 @@ Set Implicit Arguments.
 Ltac Ncst t :=
   match isNcst t with
     true => t
-  | _ => NotConstant
+  | _ => constr:NotConstant
   end.
 
 Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v
index d0512dff..60641bcf 100644
--- a/contrib/setoid_ring/RealField.v
+++ b/contrib/setoid_ring/RealField.v
@@ -130,4 +130,5 @@ 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 1a4e1cc7..d01b1625 100644
--- a/contrib/setoid_ring/Ring.v
+++ b/contrib/setoid_ring/Ring.v
@@ -38,7 +38,7 @@ Ltac bool_cst t :=
   match t with
     true => constr:true
   | false => constr:false
-  | _ => NotConstant
+  | _ => constr:NotConstant
   end.
 
 Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v
index b79f2fe2..d8847036 100644
--- a/contrib/setoid_ring/Ring_polynom.v
+++ b/contrib/setoid_ring/Ring_polynom.v
@@ -43,6 +43,10 @@ Section MakeRingPol.
  Variable rpow : R -> Cpow -> R. 
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
 
+ (* division is ok *)
+ Variable cdiv: C -> C -> C * C.
+ Variable div_th: div_theory req cadd cmul phi cdiv.
+
 
  (* R notations *)
  Notation "0" := rO. Notation "1" := rI.
@@ -55,14 +59,14 @@ Section MakeRingPol.
  Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
  Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
 
- (* Usefull tactics *)		  
+ (* Useful tactics *)		  
   Add Setoid R req Rsth as R_set1.
  Ltac rrefl := gen_reflexivity Rsth.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
   Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
   Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
   Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
- Ltac rsimpl := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
  Ltac add_push := gen_add_push radd Rsth Reqe ARth.
  Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
 
@@ -411,63 +415,79 @@ Section MakeRingPol.
    | vmon i' m => vmon (i+i') m
    end.
 
- Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+ Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol :=
+   match P with
+   | Pc c1   => let (q,r) := cdiv c1 c in (Pc r, Pc q)
+   | Pinj j1 P1  =>
+     let (R,S) := CFactor P1 c in
+            (mkPinj j1 R, mkPinj j1 S)
+  | PX P1 i Q1 =>
+     let (R1, S1) := CFactor P1 c in
+     let (R2, S2) := CFactor Q1 c in
+        (mkPX R1 i R2, mkPX S1 i S2)
+   end.
+
+ Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol :=
    match P, M with
-        _, mon0 => (Pc cO, P)
+        _, mon0 =>
+            if (ceqb c cI) then (Pc cO, P) else
+(*            if (ceqb c (copp cI)) then (Pc cO, Popp P) else  Not in almost ring *)
+            CFactor P c
    | Pc _, _    => (P, Pc cO)
    | Pinj j1 P1, zmon j2 M1 =>
       match (j1 ?= j2) Eq with
-        Eq => let (R,S) := MFactor P1 M1 in
+        Eq => let (R,S) := MFactor P1 c M1 in
                  (mkPinj j1 R, mkPinj j1 S)
-      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+      | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in
                  (mkPinj j1 R, mkPinj j1 S)
       | Gt => (P, Pc cO)
       end
   | Pinj _ _, vmon _ _ => (P, Pc cO)
   | PX P1 i Q1, zmon j M1 =>
              let M2 := zmon_pred j M1 in
-             let (R1, S1) := MFactor P1 M in
-             let (R2, S2) := MFactor Q1 M2 in
+             let (R1, S1) := MFactor P1 c M in
+             let (R2, S2) := MFactor Q1 c M2 in
                (mkPX R1 i R2, mkPX S1 i S2)
   | PX P1 i Q1, vmon j M1 =>
       match (i ?= j) Eq with
-        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+        Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in
                  (mkPX R1 i Q1, S1)
-      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+      | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in
                  (mkPX R1 i Q1, S1)
-      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+      | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in
                  (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
       end
    end.
 
-  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
-    let (Q1,R1) := MFactor P1 M1 in
+  Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol :=
+    let (c,M1) := cM1 in
+    let (Q1,R1) := MFactor P1 c M1 in
     match R1 with 
      (Pc c) => if c ?=! cO then None 
                else Some (Padd Q1 (Pmul P2 R1))
     | _ => Some (Padd Q1 (Pmul P2 R1))
     end.
 
-  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
-    match POneSubst P1 M1 P2 with 
-     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+  Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+    match POneSubst P1 cM1 P2 with 
+     Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end
     | _ => P1
     end.
 
-  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
-    match POneSubst P1 M1 P2 with 
-     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+  Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol :=
+    match POneSubst P1 cM1 P2 with 
+     Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end
     | _ => None
     end.
             
-  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: 
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: 
      Pol :=
     match LM1 with 
      cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
     | _ => P1
     end.
 
-  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+  Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol :=
     match LM1 with 
      cons (M1,P2) LM2 =>
       match PNSubst P1 M1 P2 n with 
@@ -477,7 +497,7 @@ Section MakeRingPol.
     | _ => None
     end.
 
-  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+  Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol :=
     match PSubstL P1 LM1 n with 
      Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
     | _ => P1
@@ -579,16 +599,22 @@ Section MakeRingPol.
  Ltac Esimpl :=
   repeat (progress (
    match goal with
-   | |- context [P0@?l] => rewrite (Pphi0 l)
-   | |- context [P1@?l] => rewrite (Pphi1 l)
-   | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
-   | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
-   | |- context [[cO]] => rewrite (morph0 CRmorph)
-   | |- context [[cI]] => rewrite (morph1 CRmorph)
-   | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
-   | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
-   | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
-   | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+   | |- context [?P@?l] =>
+       match P with
+       | P0 => rewrite (Pphi0 l)
+       | P1 => rewrite (Pphi1 l)
+       | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P)
+       | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q)
+       end
+   | |- context [[?c]] =>
+       match c with
+       | cO => rewrite (morph0 CRmorph)
+       | cI => rewrite (morph1 CRmorph)
+       | ?x +! ?y => rewrite ((morph_add CRmorph) x y)
+       | ?x *! ?y => rewrite ((morph_mul CRmorph) x y)
+       | ?x -! ?y => rewrite ((morph_sub CRmorph) x y)
+       | -! ?x => rewrite ((morph_opp CRmorph) x)
+       end
    end));
   rsimpl; simpl. 
  
@@ -876,38 +902,82 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
   rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
  Qed.
 
-
- Lemma Mphi_ok: forall P M l, 
-    let (Q,R) := MFactor P M in
-      P@l == Q@l + (Mphi l M) * (R@l).
+ Lemma Mcphi_ok: forall P c l, 
+    let (Q,R) := CFactor P c in
+      P@l == Q@l + (phi c) * (R@l).
  Proof.
  intros P; elim P; simpl; auto; clear P.
-   intros c M l; case M; simpl; auto; try intro p; try intro m;
-   try rewrite (morph0 CRmorph); rsimpl.
+   intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv.
+   intros q r H; rewrite H.
+   Esimpl.
+   rewrite (ARadd_comm ARth); rsimpl.
+ intros i P Hrec c l.
+  generalize (Hrec c (jump i l)); case CFactor.
+  intros R1 S1; Esimpl; auto.
+ intros Q1 Qrec i R1 Rrec c l.
+   generalize (Qrec c l); case CFactor; intros S1 S2 HS.
+   generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1.
+   rewrite HS; rewrite HS1; Esimpl.
+   apply (Radd_ext Reqe); rsimpl.
+   repeat rewrite <- (ARadd_assoc ARth).
+   apply (Radd_ext Reqe); rsimpl.
+   rewrite (ARadd_comm ARth); rsimpl.
+ Qed.
 
-   intros i P Hrec M l; case M; simpl; clear M.
-     rewrite (morph0 CRmorph); rsimpl.
+ Lemma Mphi_ok: forall P (cM: C * Mon) l, 
+    let (c,M) := cM in
+    let (Q,R) := MFactor P c M in
+      P@l == Q@l + (phi c) * (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+   intros c (c1, M) l; case M; simpl; auto.
+   assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI).
+   rewrite (H1 (refl_equal true));Esimpl.
+    try rewrite (morph0 CRmorph); rsimpl.
+   generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1).
+   intros q r H; rewrite H; clear H H1.
+   Esimpl.
+   rewrite (ARadd_comm ARth); rsimpl.
+   intros p m; Esimpl.
+   intros p m; Esimpl.
+   intros i P Hrec (c,M) l; case M; simpl; clear M.
+     assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+     rewrite (H1 (refl_equal true));Esimpl.
+     Esimpl.
+   generalize (Mcphi_ok P c (jump i l)); case CFactor.
+   intros R1 Q1 HH; rewrite HH; Esimpl.
      intros j M.
      case_eq ((i ?= j) Eq); intros He; simpl.
        rewrite (Pcompare_Eq_eq _ _ He).
-       generalize (Hrec M (jump j l)); case (MFactor P M);
+       generalize (Hrec (c, M) (jump j l)); case (MFactor P c M);
         simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
-       generalize (Hrec (zmon (j -i) M) (jump i l)); 
-       case (MFactor P (zmon (j -i) M)); simpl.
+       generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); 
+       case (MFactor P c (zmon (j -i) M)); simpl.
        intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
        rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
        rewrite Pplus_comm; rewrite jump_Pplus; auto.
        rewrite (morph0 CRmorph); rsimpl.
        intros P2 m; rewrite (morph0 CRmorph); rsimpl.
 
-   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
-   rewrite (morph0 CRmorph); rsimpl.
+   intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto.
+     assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+     rewrite (H1 (refl_equal true));Esimpl.
+     Esimpl.
+    generalize (Mcphi_ok P2 c l); case CFactor.
+    intros S1 S2 HS.
+    generalize (Mcphi_ok Q2 c (tail l)); case CFactor.
+    intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1.
+    rsimpl.
+    apply (Radd_ext Reqe); rsimpl.
+    repeat rewrite <- (ARadd_assoc ARth).
+    apply (Radd_ext Reqe); rsimpl.
+    rewrite (ARadd_comm ARth); rsimpl.
    intros j M1.
-     generalize (Hrec1 (zmon j M1) l); 
-     case (MFactor P2 (zmon j M1)).
+     generalize (Hrec1 (c,zmon j M1) l); 
+     case (MFactor P2 c (zmon j M1)).
      intros R1 S1 H1.
-     generalize (Hrec2 (zmon_pred j M1) (List.tail l)); 
-     case (MFactor Q2 (zmon_pred j M1)); simpl.
+     generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); 
+     case (MFactor Q2 c (zmon_pred j M1)); simpl.
      intros R2 S2 H2; rewrite H1; rewrite H2.
      repeat rewrite mkPX_ok; simpl.
      rsimpl.  
@@ -919,7 +989,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    intros j M1.
      case_eq ((i ?= j) Eq); intros He; simpl.
        rewrite (Pcompare_Eq_eq _ _ He).
-       generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+       generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rewrite mkPX_ok; rsimpl.
        repeat (rewrite <-(ARadd_assoc ARth)).
@@ -929,9 +999,11 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        repeat (rewrite <-(ARmul_assoc ARth)).
        rewrite mkZmon_ok.
        apply rmul_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
        rewrite (ARmul_comm ARth); rsimpl.
-       generalize (Hrec1 (vmon (j - i) M1) l); 
-             case (MFactor P2 (vmon (j - i) M1));
+       generalize (Hrec1 (c, vmon (j - i) M1) l); 
+             case (MFactor P2 c (vmon (j - i) M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
        rewrite mkPX_ok; rsimpl.
@@ -943,10 +1015,13 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        apply rmul_ext; rsimpl.
        rewrite (ARmul_comm ARth); rsimpl.
        apply rmul_ext; rsimpl.
+       rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
        rewrite <- pow_pos_Pplus.
        rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
-       generalize (Hrec1 (mkZmon 1 M1) l); 
-             case (MFactor P2 (mkZmon 1 M1));
+       generalize (Hrec1 (c, mkZmon 1 M1) l); 
+             case (MFactor P2 c (mkZmon 1 M1));
         simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
        rewrite H; rsimpl.
        rewrite mkPX_ok; rsimpl.
@@ -963,6 +1038,9 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
        repeat (rewrite <-(ARmul_assoc ARth)).
        rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
        apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       repeat (rewrite <- (ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
        rewrite <- pow_pos_Pplus.
        rewrite (Pplus_minus _ _ He); rsimpl.
  Qed.
@@ -970,10 +1048,10 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
 (* 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.
+    POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd 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 P2 (cc,M1) P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto.
  intros Q1 R1; case R1.
    intros c H; rewrite H.
    generalize (morph_eq CRmorph c cO);
@@ -986,7 +1064,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
    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 PmulI_ok. intros;apply Pmul_ok. rewrite H1; rsimpl.
+   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. 
  intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
    assert (P4 = Q1 ++ P3 ** PX i P5 P6).
    injection H2; intros; subst;trivial.
@@ -1017,7 +1095,7 @@ Proof.
  Qed. 
 *)
  Lemma PNSubst1_ok: forall n P1 M1 P2 l,
-    Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+    [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
  Proof.
  intros n; elim n; simpl; auto.
    intros P2 M1 P3 l H.
@@ -1031,19 +1109,19 @@ Proof.
  Qed.
 
  Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
-    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+    PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
  Proof.
- intros n P2 M1 P3 l P4; unfold PNSubst.
- generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
- case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros n P2 (cc, M1) P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); 
+ case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate].
  intros P5 H1; case n; try (intros; discriminate). 
  intros n1 H2; injection H2; intros; subst.
  rewrite <- PNSubst1_ok; auto.
  Qed.
 
- Fixpoint MPcond (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
+ Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
     match LM1 with 
-     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+     cons (M1,P2) LM2 =>  ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l)
     | _ => True
     end.
 
@@ -1108,6 +1186,8 @@ Proof.
    | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
    end.
 
+Strategy expand [PEeval].
+
  (** Correctness proofs *)
  
  Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
@@ -1180,7 +1260,7 @@ Section POWER.
  
   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.
+  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl.  Qed.
     
  End POWER.
 
@@ -1188,7 +1268,7 @@ Section POWER.
 
  Section NORM_SUBST_REC.
   Variable n : nat.
-  Variable lmp:list (Mon*Pol).
+  Variable lmp:list (C*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.
@@ -1256,7 +1336,7 @@ Section POWER.
    rewrite IHpe1;rewrite IHpe2;rrefl.
    rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
    rewrite IHpe;rrefl.
-   rewrite Ppow_N_ok. intros;rrefl.
+   rewrite Ppow_N_ok by (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.
@@ -1282,24 +1362,24 @@ Section POWER.
      end
   end.
 
-  Fixpoint mon_of_pol (P:Pol) : option Mon :=
+  Fixpoint mon_of_pol (P:Pol) : option (C * Mon) :=
   match P with
-  | Pc c => if (c ?=! cI) then Some mon0 else None
+  | Pc c => if (c ?=! cO) then None else Some (c, mon0)
   | Pinj j P =>
     match mon_of_pol P with 
     | None => None
-    | Some m =>  Some (mkZmon j m) 
+    | Some (c,m) =>  Some (c, 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)
+      | Some (c,m) => Some (c, mkVmon i m)
       end
     else None
   end.
 
- Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) :=
+ Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) :=
   match lpe with
   | nil => nil
   | (me,pe)::lpe =>
@@ -1310,16 +1390,18 @@ Section POWER.
   end.
 
   Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
-              forall l, Mphi l m == P@l.
+              forall l, [fst m] * Mphi l (snd 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.
+    assert (H1 := (morph_eq CRmorph) c cO).
+    destruct (c ?=! cO).
     discriminate.
-    generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate.
-    inversion H0.
-    rewrite mkZmon_ok;simpl;auto.
+    inversion H;trivial;Esimpl.
+    generalize H;clear H;case_eq (mon_of_pol P).
+    intros (c1,P2) H0 H1; inversion H1; Esimpl.
+      generalize (IHP (c1, P2) H0 (jump p l)).
+      rewrite mkZmon_ok;simpl;auto.
+    intros; discriminate.
     generalize H;clear H;change match P3 with
         | Pc c => c ?=! cO
         | Pinj _ _ => false
@@ -1327,10 +1409,13 @@ Section POWER.
         end with (P3 ?== P0).
     assert (H := Peq_ok P3 P0).
     destruct (P3 ?== P0).
-    case_eq (mon_of_pol P2);intros.
+    case_eq (mon_of_pol P2);try intros (cc, pp); intros.
     inversion H1.
+    simpl.
     rewrite mkVmon_ok;simpl.
-    rewrite H;trivial;Esimpl.  rewrite IHP1;trivial;Esimpl. discriminate.
+    rewrite H;trivial;Esimpl.
+     generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl.
+    discriminate.
     intros;discriminate.
    Qed.
  
@@ -1342,7 +1427,7 @@ Section POWER.
    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.
+   rewrite <- norm_subst_spec by 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.
@@ -1371,7 +1456,7 @@ Section POWER.
 
   (** 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.
+ Variable get_sign_spec : sign_theory copp ceqb get_sign.
 
 
  Section EVALUATION.
@@ -1509,7 +1594,7 @@ Section POWER.
   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 (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial.
    rewrite <- r_list_pow_rev;trivial;Esimpl.
   apply mkmultm1_ok.
  rewrite <- r_list_pow_rev; apply mkmult_rec_ok.
@@ -1520,7 +1605,7 @@ Qed.
  Proof.
   intros;unfold mkadd_mult.
   case_eq (get_sign c);intros.
-  rewrite (get_sign_spec.(sign_spec) _ H).
+  rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl.
   rewrite mkmult_c_pos_ok;Esimpl.
   rewrite mkmult_c_pos_ok;Esimpl.
  Qed.
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
index d8bb9eae..46d106d3 100644
--- a/contrib/setoid_ring/Ring_tac.v
+++ b/contrib/setoid_ring/Ring_tac.v
@@ -16,11 +16,6 @@ Ltac compute_assertion id  id' t :=
   [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 *)
 
@@ -47,10 +42,10 @@ Ltac ApplyLemmaThen lemma expr tac :=
       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)).
+  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
@@ -143,13 +138,11 @@ Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
 
 Ltac ParseRingComponents lemma :=
   match type of lemma with
-  | context
-     [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+  | 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 relation_carrier req :=
@@ -175,7 +168,7 @@ Ltac mkHyp_tac C req mkPE lH :=
      let pe1 := mkPE r1 in
      let pe2 := mkPE r2 in
      constr:(cons (pe1,pe2) res)
-   | _ => fail "hypothesis is not a ring equality"
+   | _ => fail 1 "hypothesis is not a ring equality"
    end in
   list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
      
@@ -226,12 +219,6 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
     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
@@ -240,25 +227,34 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
       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 =>
+      match type of lemma2 with
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?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
+            (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
+         (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
+          || fail 1 "type error when build the rewriting lemma");   
+         RW_tac rr_lemma;
+         try clear rr_lemma vlmp_eq vlmp vlpe
+      | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
+      end 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.
 
+Ltac Get_goal := match goal with [|- ?G] => G end.
+
 Tactic Notation (at level 0) "ring" :=
-  let G := getGoal in ring_lookup Ring_gen [] [G].
+  let G := Get_goal 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].
+  let G := Get_goal in
+  ring_lookup Ring_gen [lH] G.
 
 (* Simplification *)
 
@@ -269,67 +265,89 @@ Ltac Ring_simplify_gen f :=
      generalize (refl_equal l);
      unfold l at 2;
      pre(); 
-     match goal with
-     | [|- l = ?RL -> _ ] =>
+     let Tac 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.
+       post() in
+     let Main :=
+       match goal with
+       | [|- l = ?RL -> _ ] => (fun f => f RL)
+       | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+       end in
+     Main Tac.
 
 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(rl) := 
+  let G := Get_goal in
+  ring_lookup Ring_simplify [] rl G.
 
 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].
+  let G := Get_goal in
+  ring_lookup Ring_simplify [lH] rl G.
 
+(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
 
 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.
+  let G := Get_goal 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 := Get_goal 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.
+
+
+
+(*     LE RESTE MARCHE PAS DOMMAGE  .....  *)
+
+
+
+
+
+
+
+
+
+
+
+
+
 
 
 (*
 
+
+
+
+
+
+
+
 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.
+  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.
+  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):= 
@@ -339,7 +357,7 @@ Tactic Notation (at level 0)
      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]. 
+  [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).
@@ -352,7 +370,7 @@ Tactic Notation (at level 0)
      pre(); 
      Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
      post())
- [] rl [t].
+ [] rl t.
 
 Ltac rw_in H Heq := rewrite Heq in H.
 
@@ -363,7 +381,7 @@ Ltac simpl_in H :=
      pre(); 
      Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
      post()) 
-   [] [t].
+   [] t.
 
 
 *)
diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v
index 5498911d..29feab5c 100644
--- a/contrib/setoid_ring/Ring_theory.v
+++ b/contrib/setoid_ring/Ring_theory.v
@@ -19,7 +19,7 @@ Reserved Notation "x -! y" (at level 50, left associativity).
 Reserved Notation "x *! y" (at level 40, left associativity).
 Reserved Notation "-! x" (at level 35, right associativity).
 
-Reserved Notation "[ x ]" (at level 1, no associativity).
+Reserved Notation "[ x ]" (at level 0).
 
 Reserved Notation "x ?== y" (at level 70, no associativity).
 Reserved Notation "x -- y" (at level 50, left associativity).
@@ -59,8 +59,7 @@ Section Power.
   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.
+  setoid_rewrite (mul_comm x (pow_pos x j)) at 2.
   repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
   repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
   apply (Seq_refl _ _ Rsth).
@@ -198,7 +197,7 @@ Section DEFINITIONS.
  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']
+    sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true
   }.
  End SIGN.
 
@@ -207,6 +206,13 @@ Section DEFINITIONS.
  Lemma get_sign_None_th : sign_theory get_sign_None.
  Proof. constructor;intros;discriminate. Qed.
 
+ Section DIV.
+  Variable cdiv: C -> C -> C*C.
+  Record div_theory : Prop := mkdiv_th {
+    div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r]
+  }.
+ End DIV.
+
  End MORPHISM. 
 
  (** Identity is a morphism *)
@@ -235,6 +241,7 @@ Section DEFINITIONS.
 
  Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
 
+ 
 End DEFINITIONS.
 
 
@@ -250,7 +257,7 @@ Section ALMOST_RING.
 
  (** Leibniz equality leads to a setoid theory and is extensional*)
  Lemma Eqsth : Setoid_Theory R (@eq R).
- Proof.  constructor;intros;subst;trivial. Qed.
+ Proof.  constructor;red;intros;subst;trivial. Qed.
 
  Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
  Proof. constructor;intros;subst;trivial. Qed.
@@ -442,7 +449,7 @@ Section ALMOST_RING.
 
  End RING.
 
- (** Usefull lemmas on almost ring *)
+ (** Useful lemmas on almost ring *)
  Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
 
  Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req.
@@ -564,7 +571,7 @@ End AddRing.
 (** Some simplification tactics*)
 Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
 
-Ltac gen_srewrite O I add mul sub opp eq Rsth Reqe ARth :=
+Ltac gen_srewrite Rsth Reqe ARth :=
   repeat first
      [ gen_reflexivity Rsth
      | progress rewrite (ARopp_zero Rsth Reqe ARth)
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
index 8de7021e..4a5b623b 100644
--- a/contrib/setoid_ring/ZArithRing.v
+++ b/contrib/setoid_ring/ZArithRing.v
@@ -17,14 +17,14 @@ Set Implicit Arguments.
 Ltac Zcst t :=
   match isZcst t with
     true => t
-  | _ => NotConstant
+  | _ => constr:NotConstant
   end.
 
 Ltac isZpow_coef t :=
   match t with 
   | Zpos ?p => isPcst p
-  | Z0 => true
-  | _ => false
+  | Z0 => constr:true
+  | _ => constr:false
   end.
 
 Definition N_of_Z x :=
@@ -36,7 +36,7 @@ Definition N_of_Z x :=
 Ltac Zpow_tac t :=
  match isZpow_coef t with
  | true => constr:(N_of_Z t)
- | _ => constr:(NotConstant)
+ | _ => constr:NotConstant
  end.
 
 Ltac Zpower_neg :=
@@ -49,8 +49,12 @@ Ltac Zpower_neg :=
     end
   end.   
 
-
 Add Ring Zr : Zth
   (decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
-   power_tac Zpower_theory [Zpow_tac]).
+   power_tac Zpower_theory [Zpow_tac],
+    (* The two following option are not needed, it is the default chose when the set of 
+        coefficiant is usual ring Z *)
+    div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
+   sign get_signZ_th).
+
 
diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4
index 134ba1a8..dd79801d 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 10047 2007-07-24 17:55:18Z barras $ i*)
+(*i $Id: newring.ml4 11094 2008-06-10 19:35:23Z herbelin $ i*)
 
 open Pp
 open Util
@@ -104,7 +104,8 @@ let protect_tac map =
   Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));;
+  Tactics.reduct_option (protect_red map,DEFAULTcast)
+    (Some((all_occurrences_expr,id),InHyp));;
 
 
 TACTIC EXTEND protect_fv
@@ -176,13 +177,9 @@ let ltac_lcall tac args =
 
 let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
 
-let dummy_goal env =
-  {Evd.it=
-    {Evd.evar_concl=mkProp;
-     Evd.evar_hyps=named_context_val env;
-     Evd.evar_body=Evd.Evar_empty;
-     Evd.evar_extra=None};
-   Evd.sigma=Evd.empty}
+let dummy_goal env = 
+  {Evd.it = Evd.make_evar (named_context_val env) mkProp;
+   Evd.sigma = Evd.empty}
 
 let exec_tactic env n f args =
   let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
@@ -205,7 +202,8 @@ let constr_of = function
 let stdlib_modules =
   [["Coq";"Setoids";"Setoid"];
    ["Coq";"Lists";"List"];
-   ["Coq";"Init";"Datatypes"]
+   ["Coq";"Init";"Datatypes"];
+   ["Coq";"Init";"Logic"];
   ]
 
 let coq_constant c =
@@ -216,6 +214,7 @@ 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 coq_eq = coq_constant "eq"
 
 let lapp f args = mkApp(Lazy.force f,args)
 
@@ -452,10 +451,12 @@ let (theory_to_obj, obj_to_theory) =
       export_function = export_th }
 
 
-let setoid_of_relation r =
+let setoid_of_relation env a r =
   lapp coq_mk_Setoid
-    [|r.rel_a; r.rel_aeq;
-      out_some r.rel_refl; out_some r.rel_sym; out_some r.rel_trans |]
+    [|a ; r ; 
+      Class_tactics.reflexive_proof env a r ; 
+      Class_tactics.symmetric_proof env a r ; 
+      Class_tactics.transitive_proof env a r |]
 
 let op_morph r add mul opp req m1 m2 m3 =
   lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
@@ -463,63 +464,110 @@ let op_morph r add mul opp req m1 m2 m3 =
 let op_smorph r add mul req m1 m2 =
   lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
 
-let default_ring_equality (r,add,mul,opp,req) =
-  let is_setoid = function
-      {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} ->
-        eq_constr req rel (* Qu: use conversion ? *)
-    | _ -> false in
-  match default_relation_for_carrier ~filter:is_setoid r with
-      Leibniz _ ->
-        let setoid = lapp coq_eq_setoid [|r|] in
-        let op_morph =
-          match opp with
+(* let default_ring_equality (r,add,mul,opp,req) = *)
+(*   let is_setoid = function *)
+(*       {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
+(*         eq_constr req rel (\* Qu: use conversion ? *\) *)
+(*     | _ -> false in *)
+(*   match default_relation_for_carrier ~filter:is_setoid r with *)
+(*       Leibniz _ -> *)
+(*         let setoid = lapp coq_eq_setoid [|r|] in *)
+(*         let op_morph = *)
+(*           match opp with *)
+(*               Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *)
+(*             | None -> lapp coq_eq_smorph [|r;add;mul|] in *)
+(*         (setoid,op_morph) *)
+(*     | Relation rel -> *)
+(*         let setoid = setoid_of_relation rel in *)
+(*         let is_endomorphism = function *)
+(*             { args=args } -> List.for_all *)
+(*                 (function (var,Relation rel) -> *)
+(*                   var=None && eq_constr req rel *)
+(*                   | _ -> false) args in *)
+(*         let add_m = *)
+(*           try default_morphism ~filter:is_endomorphism add *)
+(*           with Not_found -> *)
+(*             error "ring addition should be declared as a morphism" in *)
+(*         let mul_m = *)
+(*           try default_morphism ~filter:is_endomorphism mul *)
+(*           with Not_found -> *)
+(*             error "ring multiplication should be declared as a morphism" in *)
+(*         let op_morph = *)
+(*           match opp with *)
+(*             | Some opp -> *)
+(*             (let opp_m = *)
+(*               try default_morphism ~filter:is_endomorphism opp *)
+(*               with Not_found -> *)
+(*                 error "ring opposite should be declared as a morphism" in *)
+(*              let op_morph = *)
+(*                op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *)
+(*              msgnl *)
+(*                (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++   *)
+(*                str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(*                str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *)
+(*                str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *)
+(*                str"\""); *)
+(*              op_morph) *)
+(*             | None -> *)
+(*             (msgnl *)
+(*               (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++   *)
+(*                str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(*                str"\""++spc()++str"and \""++ *)
+(*                pr_constr mul_m.morphism_theory++str"\""); *)
+(*             op_smorph r add mul req add_m.lem mul_m.lem) in *)
+(*         (setoid,op_morph) *)
+
+let ring_equality (r,add,mul,opp,req) =
+  match kind_of_term req with
+    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
+	let setoid = lapp coq_eq_setoid [|r|] in
+	let op_morph =
+	  match opp with
               Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
             | None -> lapp coq_eq_smorph [|r;add;mul|] in
-        (setoid,op_morph)
-    | Relation rel ->
-        let setoid = setoid_of_relation rel in
-        let is_endomorphism = function
-            { args=args } -> List.for_all
-                (function (var,Relation rel) ->
-                  var=None && eq_constr req rel
-                  | _ -> false) args in
-        let add_m =
-          try default_morphism ~filter:is_endomorphism add
+	  (setoid,op_morph)
+    | _ ->
+	let setoid = setoid_of_relation (Global.env ()) r req in
+	let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+	let add_m, add_m_lem =
+	  try Class_tactics.default_morphism signature add
           with Not_found ->
             error "ring addition should be declared as a morphism" in
-        let mul_m =
-          try default_morphism ~filter:is_endomorphism mul
+	let mul_m, mul_m_lem =
+          try Class_tactics.default_morphism signature mul
           with Not_found ->
             error "ring multiplication should be declared as a morphism" in
         let op_morph =
           match opp with
             | Some opp ->
-            (let opp_m =
-              try default_morphism ~filter:is_endomorphism opp
-              with Not_found ->
-                error "ring opposite should be declared as a morphism" in
-             let op_morph =
-               op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in
-             msgnl
-               (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++  
-               str"and morphisms \""++pr_constr add_m.morphism_theory++
-               str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++
-               str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++
-               str"\"");
-             op_morph)
+		(let opp_m,opp_m_lem =
+		  try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (r,req))) opp
+		  with Not_found ->
+                    error "ring opposite should be declared as a morphism" in
+		let op_morph =
+		  op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
+		  Flags.if_verbose 
+		    msgnl
+		    (str"Using setoid \""++pr_constr req++str"\""++spc()++  
+			str"and morphisms \""++pr_constr add_m_lem ++
+			str"\","++spc()++ str"\""++pr_constr mul_m_lem++
+			str"\""++spc()++str"and \""++pr_constr opp_m_lem++
+			str"\"");
+		  op_morph)
             | None ->
-            (msgnl
-              (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++  
-               str"and morphisms \""++pr_constr add_m.morphism_theory++
-               str"\""++spc()++str"and \""++
-               pr_constr mul_m.morphism_theory++str"\"");
-            op_smorph r add mul req add_m.lem mul_m.lem) in
-        (setoid,op_morph)
-
+		(Flags.if_verbose
+		    msgnl
+		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++  
+			str"and morphisms \""++pr_constr add_m_lem ++
+			str"\""++spc()++str"and \""++
+			pr_constr mul_m_lem++str"\"");
+		 op_smorph r add mul req add_m_lem mul_m_lem) in
+          (setoid,op_morph)
+	    
 let build_setoid_params r add mul opp req eqth =
   match eqth with
       Some th -> th
-    | None -> default_ring_equality (r,add,mul,opp,req)
+    | None -> ring_equality (r,add,mul,opp,req)
 
 let dest_ring env sigma th_spec =
   let th_typ = Retyping.get_type_of env sigma th_spec in
@@ -569,7 +617,8 @@ type cst_tac_spec =
 let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
   match cst_tac with
       Some (CstTac t) -> Tacinterp.glob_tactic t
-    | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc)
+    | Some (Closed lc) ->
+        closed_term_ast (List.map Syntax_def.global_with_alias lc)
     | None ->
         (match rk, opp, kind with
             Abstract, None, _ ->
@@ -612,7 +661,8 @@ let interp_power env pow =
       let tac = 
         match tac with
         | CstTac t -> Tacinterp.glob_tactic t
-        | Closed lc -> closed_term_ast (List.map Nametab.global lc) in
+        | Closed lc ->
+            closed_term_ast (List.map Syntax_def.global_with_alias lc) in
       let spec = make_hyp env (ic spec) in
       (tac, lapp coq_Some [|carrier; spec|])
 
@@ -625,7 +675,16 @@ let interp_sign env sign =
       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 interp_div env div =
+  let carrier = Lazy.force coq_hypo in
+  match div 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 div =
   check_required_library (cdir@["Ring_base"]);
   let env = Global.env() in
   let sigma = Evd.empty in
@@ -633,10 +692,11 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign =
   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 dspec = interp_div env div in
   let rk = reflect_coeff morphth in
   let params =
     exec_tactic env 5 (zltac "ring_lemmas") 
-      (List.map carg[sth;ext;rth;pspec;sspec;rk]) in
+      (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
   let lemma1 = constr_of params.(3) in
   let lemma2 = constr_of params.(4) in
 
@@ -678,6 +738,7 @@ type ring_mod =
   | Pow_spec of cst_tac_spec * Topconstr.constr_expr
            (* Syntaxification tactic , correctness lemma *)
   | Sign_spec of Topconstr.constr_expr
+  | Div_spec of Topconstr.constr_expr
 
 
 VERNAC ARGUMENT EXTEND ring_mod
@@ -694,6 +755,7 @@ VERNAC ARGUMENT EXTEND ring_mod
            [ Pow_spec (Closed l, pow_spec) ]   
   | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
            [ Pow_spec (CstTac cst_tac, pow_spec) ]
+  | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
 END
 
 let set_once s r v =
@@ -707,6 +769,7 @@ let process_ring_mods l =
   let post = ref None in
   let sign = ref None in
   let power = ref None in
+  let div = 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
@@ -714,14 +777,15 @@ let process_ring_mods l =
     | Post_tac t -> set_once "postprocess tactic" post t
     | 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;
+    | Sign_spec t -> set_once "sign" sign t
+    | Div_spec t -> set_once "div" div t) l;
   let k = match !kind with Some k -> k | None -> Abstract in
-  (k, !set, !cst_tac, !pre, !post, !power, !sign)
+  (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
 
 VERNAC COMMAND EXTEND AddSetoidRing
   | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
-    [ 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 ]
+    [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
+      add_theory id (ic t) set k cst (pre,post) power sign div]
 END
 
 (*****************************************************************************)
@@ -759,15 +823,14 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl =
   let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
   Tacinterp.eval_tactic
     (TacLetIn
-      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+      (false,[(dummy_loc,id_of_string"f"),Tacexp f],
        ltac_lcall "f"
          [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(lH) "]" constr_list(lr)
-      "[" constr(t) "]" ] ->
-          [ring_lookup (fst f) lH lr t]
+| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
+    [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t]
 END
 
 
@@ -968,26 +1031,20 @@ let (ftheory_to_obj, obj_to_ftheory) =
       classify_function = (fun (_,x) -> Substitute x);
       export_function = export_th }
 
-let default_field_equality r inv req =
-  let is_setoid = function
-      {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
-    | _ -> false in
-  match default_relation_for_carrier ~filter:is_setoid r with
-      Leibniz _ ->
+let field_equality r inv req =
+  match kind_of_term req with
+    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
         mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
-    | Relation rel ->
-        let is_endomorphism = function
-            { args=args } -> List.for_all
-                (function (var,Relation rel) ->
-                  var=None && eq_constr req rel
-                  | _ -> false) args in
-        let inv_m =
-          try default_morphism ~filter:is_endomorphism inv
+    | _ ->
+	let _setoid = setoid_of_relation (Global.env ()) r req in
+	let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+	let inv_m, inv_m_lem =
+	  try Class_tactics.default_morphism signature inv
           with Not_found ->
             error "field inverse should be declared as a morphism" in
-        inv_m.lem
-
-let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign =
+	  inv_m_lem
+	    
+let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv =
   check_required_library (cdir@["Field_tac"]);
   let env = Global.env() in
   let sigma = Evd.empty in
@@ -995,14 +1052,15 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign =
     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) power sign in
+  let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv 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 dspec = interp_div env odiv in
+  let inv_m = field_equality r inv req in
   let rk = reflect_coeff morphth in
   let params =
     exec_tactic env 9 (field_ltac"field_lemmas")
-      (List.map carg[sth;ext;inv_m;fth;pspec;sspec;rk]) in
+      (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
   let lemma1 = constr_of params.(3) in
   let lemma2 = constr_of params.(4) in
   let lemma3 = constr_of params.(5) in
@@ -1059,6 +1117,7 @@ let process_field_mods l =
   let inj = ref None in  
   let sign = ref None in
   let power = ref None in
+  let div = ref None in
   List.iter(function
       Ring_mod(Ring_kind k) -> set_once "field kind" kind k
     | Ring_mod(Const_tac t) ->
@@ -1068,14 +1127,15 @@ let process_field_mods l =
     | 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
+    | Ring_mod(Div_spec t) -> set_once "div" div 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, !power, !sign)
+  (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
 
 VERNAC COMMAND EXTEND AddSetoidField
 | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> 
-  [ 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]
+  [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
+    add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
 END
 
 let field_lookup (f:glob_tactic_expr) lH rl t gl =
@@ -1097,13 +1157,12 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl =
   let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
   Tacinterp.eval_tactic
     (TacLetIn
-      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+      (false,[(dummy_loc,id_of_string"f"),Tacexp f],
        ltac_lcall "f"
         [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(lH) "]" constr_list(l) 
-     "[" constr(t) "]" ] -> 
-      [ field_lookup (fst f) lH l t ]
+| [ "field_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> 
+      [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ]
 END
diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v
deleted file mode 100644
index f047b729..00000000
--- a/contrib/subtac/FixSub.v
+++ /dev/null
@@ -1,147 +0,0 @@
-Require Import Wf.
-Require Import Coq.subtac.Utils.
-
-(** Reformulation of the Wellfounded module using subsets where possible. *)
-
-Section Well_founded.
-  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.
-
-    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.
-
-    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.
-
-    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 Well_founded.
-
-Extraction Inline Fix_F_sub Fix_sub.
-
-Require Import Wf_nat.
-Require Import Lt.
-
-Section Well_founded_measure.
-  Variable A : Type.
-  Variable m : A -> nat.
-  
-  Section Acc.
-    
-    Variable P : A -> Type.
-    
-    Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x.
-    
-    Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x :=
-      F_sub x (fun y: { y : A | m y < m x}  => Fix_measure_F_sub (proj1_sig y) 
-        (Acc_inv r (m (proj1_sig y)) (proj2_sig y))).
-    
-    Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)).
-  
-  End Acc.
-
-  Section FixPoint.
-    Variable P : A -> Type.
-    
-    Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x.
-    
-    Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *)
-    
-    Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)).
-    
-    Hypothesis
-      F_ext :
-      forall (x:A) (f g:forall y:{y:A | m y < m x}, P (`y)),
-        (forall y:{ y:A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g.
-
-    Lemma Fix_measure_F_eq :
-      forall (x:A) (r:Acc lt (m x)),
-        F_sub x (fun (y:{y:A|m y < m x}) => Fix_F (`y) (Acc_inv r (m (proj1_sig y)) (proj2_sig y))) = Fix_F x r.
-    Proof.
-      intros x.
-      set (y := m x).
-      unfold Fix_measure_F_sub.
-      intros r ; case r ; auto.
-    Qed.
-    
-    Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s.
-    Proof.
-      intros x r s.
-      rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto.
-    Qed.
-
-    Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)).
-    Proof.
-      intro x; unfold Fix_measure in |- *.
-      rewrite <- (Fix_measure_F_eq ).
-      apply F_ext; intros.
-      apply Fix_measure_F_inv.
-    Qed.
-
-    Lemma fix_measure_sub_eq :
-        forall x : A,
-          Fix_measure_sub P F_sub x =
-          let f_sub := F_sub in
-            f_sub x (fun  {y : A | m y < m x}=> Fix_measure (`y)).
-      exact Fix_measure_eq.
-    Qed.
-
- 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
deleted file mode 100644
index 4610f346..00000000
--- a/contrib/subtac/FunctionalExtensionality.v
+++ /dev/null
@@ -1,47 +0,0 @@
-Lemma equal_f : forall A B : Type, forall (f g : A -> B), 
-  f = g -> forall x, f x = g x.
-Proof.
-  intros.
-  rewrite H.
-  auto.
-Qed.
-
-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.
-
-Lemma fix_sub_measure_eq_ext :
-  forall (A : Type) (f : A -> nat) (P : A -> Type)
-    (F_sub : forall x : A, (forall  {y : A | f y < f x}, P (`y)) -> P x),
-    forall x : A,
-      Fix_measure_sub A f P F_sub x =
-        F_sub x (fun {y : A | f y < f x}=> Fix_measure_sub A f P F_sub (`y)).
-Proof.
-  intros ; apply Fix_measure_eq ; auto.
-  intros.
-  assert(f0 = g).
-  apply (fun_extensionality_dep _ _ _ _ H).
-  rewrite H0 ; auto.
-Qed.
diff --git a/contrib/subtac/Heq.v b/contrib/subtac/Heq.v
deleted file mode 100644
index f2b216d9..00000000
--- a/contrib/subtac/Heq.v
+++ /dev/null
@@ -1,34 +0,0 @@
-Require Export JMeq.
-
-(** Notation for heterogenous equality. *)
-
-Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level).
-
-(** Do something on an heterogeneous equality appearing in the context. *)
-
-Ltac on_JMeq tac := 
-  match goal with
-    | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H
-  end.
-
-(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *)
-
-Ltac simpl_one_JMeq :=
-  on_JMeq 
-  ltac:(fun H => let H' := fresh "H" in 
-    assert (H' := JMeq_eq H) ; clear H ; rename H' into H).
-
-(** Repeat it for every possible hypothesis. *)
-
-Ltac simpl_JMeq := repeat simpl_one_JMeq.
-
-(** Just simplify an h.eq. without clearing it. *)
-
-Ltac simpl_one_dep_JMeq :=
-  on_JMeq
-  ltac:(fun H => let H' := fresh "H" in 
-    assert (H' := JMeq_eq H)).
-
-
-
-
diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v
deleted file mode 100644
index 9912cd24..00000000
--- a/contrib/subtac/Subtac.v
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Export Coq.subtac.Utils.
-Require Export Coq.subtac.FixSub.
\ No newline at end of file
diff --git a/contrib/subtac/SubtacTactics.v b/contrib/subtac/SubtacTactics.v
deleted file mode 100644
index a00234dd..00000000
--- a/contrib/subtac/SubtacTactics.v
+++ /dev/null
@@ -1,158 +0,0 @@
-Ltac induction_with_subterm c H :=
-  let x := fresh "x" in
-  let y := fresh "y" in
-  (remember c as x ; rewrite <- y in H ; induction H ; subst).
-
-Ltac induction_on_subterm c :=
-  let x := fresh "x" in
-  let y := fresh "y" in
-  (set(x := c) ; assert(y:x = c) by reflexivity ; clearbody x ; induction x ; inversion y ; try subst ; 
-  clear y).
-
-Ltac induction_with_subterms c c' H :=
-  let x := fresh "x" in
-  let y := fresh "y" in
-  let z := fresh "z" in
-  let w := fresh "w" in
-  (set(x := c) ; assert(y:x = c) by reflexivity ;
-  set(z := c') ; assert(w:z = c') by reflexivity ;
-  rewrite <- y in H ; rewrite <- w in H ; 
-  induction H ; subst).
-
-
-Ltac destruct_one_pair :=
- match goal with
-   | [H : (_ /\ _) |- _] => destruct H
-   | [H : prod _ _ |- _] => destruct H
- end.
-
-Ltac destruct_pairs := repeat (destruct_one_pair).
-
-Ltac destruct_one_ex :=
-  let tac H := let ph := fresh "H" in destruct H as [H ph] in
-    match goal with
-      | [H : (ex _) |- _] => tac H
-      | [H : (sig ?P) |- _ ] => tac H
-      | [H : (ex2 _) |- _] => tac H
-    end.
-
-Ltac destruct_exists := repeat (destruct_one_ex).
-
-Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht].
-
-Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H].
-
-Tactic Notation "contradiction" "by" constr(t) := 
-  let H := fresh in assert t as H by auto with * ; contradiction.
-
-Ltac discriminates :=
-  match goal with
-    | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity
-    | _ => discriminate
-  end.
-
-Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex).
-
-Ltac on_last_hyp tac := 
-  match goal with
-    [ H : _ |- _ ] => tac H
-  end.
-
-Tactic Notation "on_last_hyp" tactic(t) := on_last_hyp t.
-
-Ltac revert_last := 
-  match goal with
-    [ H : _ |- _ ] => revert H
-  end.
-
-Ltac reverse := repeat revert_last.
-
-Ltac on_call f tac :=
-  match goal with
-    | H : ?T |- _  =>
-      match T with
-        | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u)
-        | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v)
-        | context [f ?x ?y ?z ?w] => tac (f x y z w)
-        | context [f ?x ?y ?z] => tac (f x y z)
-        | context [f ?x ?y] => tac (f x y) 
-        | context [f ?x] => tac (f x)
-      end
-    | |- ?T  =>
-      match T with
-        | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u)
-        | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v)
-        | context [f ?x ?y ?z ?w] => tac (f x y z w)
-        | context [f ?x ?y ?z] => tac (f x y z)
-        | context [f ?x ?y] => tac (f x y)
-        | context [f ?x] => tac (f x)
-      end
-  end.
-
-(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *)
-Ltac destruct_call f :=
-  let tac t := destruct t in on_call f tac.
-
-Ltac destruct_call_as f l :=
-  let tac t := destruct t as l in on_call f tac.
-
-Tactic Notation "destruct_call" constr(f) := destruct_call f.
-Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l.
-
-Ltac myinjection :=
-  let tac H := inversion H ; subst ; clear H in
-    match goal with
-      | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H
-      | [ H : ?f ?a ?b = ?f' ?a' ?b'  |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c = ?f' ?a' ?b' ?c' |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d' |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e' |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d ?e ?g= ?f' ?a' ?b' ?c' ?d' ?e' ?g'  |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d ?e ?g ?h= ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' |- _ ] => tac H
-      | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i ?j = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' ?j' |- _ ] => tac H
-      | _ => idtac
-    end.
-
-Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0.
-
-Ltac bang :=
-  match goal with
-    | |- ?x => 
-      match x with
-        | context [False_rect _ ?p] => elim p
-      end
-  end.
-
-Require Import Eqdep.
-
-Ltac elim_eq_rect :=
-  match goal with
-    | [ |- ?t ] => 
-      match t with
-        | context [ @eq_rect _ _ _ _ _ ?p ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
-	      try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
-        | context [ @eq_rect _ _ _ _ _ ?p _ ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
-	      try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
-      end
-  end.
-
-Ltac real_elim_eq_rect :=
-  match goal with
-    | [ |- ?t ] => 
-      match t with
-        | context [ @eq_rect _ _ _ _ _ ?p ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
-	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
-        | context [ @eq_rect _ _ _ _ _ ?p _ ] => 
-          let P := fresh "P" in 
-            set (P := p); simpl in P ; 
-	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
-      end
-  end.
- 
\ No newline at end of file
diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v
deleted file mode 100644
index 76f49dd3..00000000
--- a/contrib/subtac/Utils.v
+++ /dev/null
@@ -1,65 +0,0 @@
-Require Export Coq.subtac.SubtacTactics.
-
-Set Implicit Arguments.
-
-(** Wrap a proposition inside a subset. *)
-
-Notation " {{ x }} " := (tt : { y : unit | x }).
-
-(** A simpler notation for subsets defined on a cartesian product. *)
-
-Notation "{ ( x , y )  :  A  |  P }" := 
-  (sig (fun anonymous : A => let (x,y) := anonymous in P))
-  (x ident, y ident) : type_scope.
-
-(** Generates an obligation to prove False. *)
-
-Notation " ! " := (False_rect _ _).
-
-(** Abbreviation for first projection and hiding of proofs of subset objects. *)
-
-Notation " ` t " := (proj1_sig t) (at level 10) : core_scope.
-Notation "( x & ? )" := (@exist _ _ x _) : core_scope.
-
-(** Coerces objects to their support before comparing them. *)
-
-Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70).
-
-(** Quantifying over subsets. *)
-
-Notation "'fun' { x : A | P } => Q" :=
-  (fun x:{x:A|P} => Q)
-  (at level 200, x ident, right associativity).
-
-Notation "'forall' { x : A | P } , Q" :=
-  (forall x:{x:A|P}, Q)
-  (at level 200, x ident, right associativity).
-
-Require Import Coq.Bool.Sumbool.
-
-(** Construct a dependent disjunction from a boolean. *)
-
-Notation "'dec'" := (sumbool_of_bool) (at level 0). 
-
-(** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *)
-
-Notation in_right := (@right _ _ _).
-Notation in_left := (@left _ _ _).
-
-(** Default simplification tactic. *)
-
-Ltac subtac_simpl := simpl ; intros ; destruct_conjs ; simpl in * ; try subst ; 
-  try (solve [ red ; intros ; discriminate ]) ; auto with *.  
-
-(** Extraction directives *)
-Extraction Inline proj1_sig.
-Extract Inductive unit => "unit" [ "()" ].
-Extract Inductive bool => "bool" [ "true" "false" ].
-Extract Inductive sumbool => "bool" [ "true" "false" ].
-(* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *)
-(* Extract Inductive sigT => "prod" [ "" ]. *)
-
-Require Export ProofIrrelevance.
-Require Export Coq.subtac.Heq.
-
-Delimit Scope program_scope with program.
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
index 2a84fdd0..9bfb33ea 100644
--- a/contrib/subtac/eterm.ml
+++ b/contrib/subtac/eterm.ml
@@ -14,17 +14,21 @@ open Util
 open Subtac_utils
 
 let trace s = 
-  if !Options.debug then (msgnl s; msgerr s)
+  if !Flags.debug then (msgnl s; msgerr s)
   else ()
 
+let succfix (depth, fixrels) = 
+  (succ depth, List.map succ fixrels)
+
 (** Substitute evar references in t using De Bruijn indices, 
   where n binders were passed through. *)
 let subst_evar_constr evs n t = 
   let seen = ref Intset.empty in
+  let transparent = ref Idset.empty in
   let evar_info id = List.assoc id evs in
-  let rec substrec depth c = match kind_of_term c with
+  let rec substrec (depth, fixrels) c = match kind_of_term c with
     | Evar (k, args) ->
-	let (id, idstr), hyps, chop, _, _ = 
+	let (id, idstr), hyps, chop, _, _, _ = 
 	  try evar_info k
 	  with Not_found -> 
 	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
@@ -42,7 +46,7 @@ let subst_evar_constr evs n t =
 	  let rec aux hyps args acc =
 	     match hyps, args with
 		 ((_, None, _) :: tlh), (c :: tla) -> 
-		   aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
+		   aux tlh tla ((map_constr_with_binders succfix substrec (depth, fixrels) c) :: acc)
 	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
 		   aux tlh tla acc
 	       | [], [] -> acc
@@ -53,11 +57,15 @@ let subst_evar_constr evs n t =
 			int (List.length hyps) ++ str " hypotheses" ++ spc () ++
 			pp_list (fun x -> my_print_constr (Global.env ()) x) args);
  	   with _ -> ());
+	  if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then
+	    transparent := Idset.add idstr !transparent;
 	  mkApp (mkVar idstr, Array.of_list args)
-    | _ -> map_constr_with_binders succ substrec depth c
+    | Fix _ ->
+	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
+    | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
   in 
-  let t' = substrec 0 t in
-    t', !seen
+  let t' = substrec (0, []) t in
+    t', !seen, !transparent
 
       
 (** Substitute variable references in t using De Bruijn indices, 
@@ -74,26 +82,29 @@ let subst_vars acc n t =
     to a product : forall H1 : t1, ..., forall Hn : tn, concl.
     Changes evars and hypothesis references to variable references.
     A little optimization: don't include unnecessary let-ins and their dependencies.
-*)
+*) 
 let etype_of_evar evs hyps concl =
   let rec aux acc n = function
       (id, copt, t) :: tl ->
-	let t', s = subst_evar_constr evs n t in
+	let t', s, trans = subst_evar_constr evs n t in
 	let t'' = subst_vars acc 0 t' in
-	let rest, s' = aux (id :: acc) (succ n) tl in
+	let rest, s', trans' = aux (id :: acc) (succ n) tl in
 	let s' = Intset.union s s' in
+	let trans' = Idset.union trans trans' in
 	  (match copt with
 	      Some c -> 
-		if noccurn 1 rest then lift (-1) rest, s'
+		if noccurn 1 rest then lift (-1) rest, s', trans'
 		else
-		  let c', s'' = subst_evar_constr evs n c in
+		  let c', s'', trans'' = subst_evar_constr evs n c in
 		  let c' = subst_vars acc 0 c' in
-		    mkNamedProd_or_LetIn (id, Some c', t'') rest, Intset.union s'' s'
+		    mkNamedProd_or_LetIn (id, Some c', t'') rest, 
+		Intset.union s'' s', 
+		Idset.union trans'' trans'
 	    | None -> 
-		mkNamedProd_or_LetIn (id, None, t'') rest, s')
+		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
     | [] ->
-	let t', s = subst_evar_constr evs n concl in
-	  subst_vars acc 0 t', s
+	let t', s, trans = subst_evar_constr evs n concl in
+	  subst_vars acc 0 t', s, trans
   in aux [] 0 (rev hyps)
 
 
@@ -110,12 +121,14 @@ let rec chop_product n t =
       | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
       | _ -> None
 
-let eterm_obligations name nclen isevars evm fs t tycon = 
+let eterm_obligations env name isevars evm fs t ty = 
   (* 'Serialize' the evars, we assume that the types of the existentials
      refer to previous existentials in the list only *)
   trace (str " In eterm: isevars: " ++ my_print_evardefs isevars);
   trace (str "Term given to eterm" ++ spc () ++
 	    Termops.print_constr_env (Global.env ()) t);
+  let nc = Environ.named_context env in
+  let nc_len = Sign.named_context_length nc in
   let evl = List.rev (to_list evm) in
   let evn = 
     let i = ref (-1) in
@@ -128,9 +141,9 @@ let eterm_obligations name nclen isevars evm fs t tycon =
     (* Remove existential variables in types and build the corresponding products *)
     fold_right 
       (fun (id, (n, nstr), ev) l ->
-	 let hyps = Environ.named_context_of_val ev.evar_hyps in
-	 let hyps = trunc_named_context nclen hyps in
-	 let evtyp, deps = etype_of_evar l hyps ev.evar_concl in
+	 let hyps = Evd.evar_filtered_context ev in
+	 let hyps = trunc_named_context nc_len hyps in
+	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
 	 let evtyp, hyps, chop = 
 	   match chop_product fs evtyp with
 	       Some t -> 
@@ -145,26 +158,28 @@ let eterm_obligations name nclen isevars evm fs t tycon =
 	 let loc, k = evar_source id isevars in
 	 let opacity = match k with QuestionMark o -> o | _ -> true in
 	 let opaque = if not opacity || chop <> fs then None else Some chop in
-	 let y' = (id, ((n, nstr), hyps, opaque, evtyp, deps)) in
+	 let y' = (id, ((n, nstr), hyps, opaque, loc, evtyp, deps)) in
 	   y' :: l) 
       evn []
   in 
-  let t', _ = (* Substitute evar refs in the term by variables *)
+  let t', _, transparent = (* Substitute evar refs in the term by variables *)
     subst_evar_constr evts 0 t 
   in
+  let ty, _, _ = subst_evar_constr evts 0 ty in
   let evars = 
-    List.map (fun (_, ((_, name), _, opaque, typ, deps)) -> name, typ, not (opaque = None), deps) evts
+    List.map (fun (_, ((_, name), _, opaque, loc, typ, deps)) -> 
+      name, typ, loc, not (opaque = None) && not (Idset.mem name transparent), deps) evts
   in
     (try
        trace (str "Term constructed in eterm" ++ spc () ++
 		Termops.print_constr_env (Global.env ()) t');
        ignore(iter
-		(fun (name, typ, _, deps) ->
+		(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'
+    Array.of_list (List.rev evars), t', ty
 
 let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
 
diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli
index 76994c06..007e327c 100644
--- a/contrib/subtac/eterm.mli
+++ b/contrib/subtac/eterm.mli
@@ -6,8 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
-
+(*i $Id: eterm.mli 10889 2008-05-06 14:05:20Z msozeau $ i*)
+open Environ
 open Tacmach
 open Term
 open Evd
@@ -18,10 +18,11 @@ val mkMetas : int -> constr list
 
 (* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *)
 
-(* id, named context length, evars, number of
-   function prototypes to try to clear from evars contexts, object and optional type *)
-val eterm_obligations : identifier -> int -> evar_defs -> evar_map -> int -> constr -> types option -> 
-  (identifier * types * bool * Intset.t) array * constr
-    (* Obl. name, type as product, opacity (true = opaque) and dependencies as indexes into the array *)
+(* env, id, evars, number of
+   function prototypes to try to clear from evars contexts, object and type *)
+val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> constr -> types -> 
+  (identifier * types * loc * bool * Intset.t) array * constr * types
+    (* Obl. name, type as product, location of the original evar, 
+       opacity (true = opaque) and dependencies as indexes into the array *)
 
 val etermtac : open_constr -> tactic
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
index 43a3bec4..88243b60 100644
--- a/contrib/subtac/g_subtac.ml4
+++ b/contrib/subtac/g_subtac.ml4
@@ -6,15 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4use: "pa_extend.cmo" i*) 
+
+
 (*
   Syntax for the subtac terms and types.
   Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
 
-(* $Id: g_subtac.ml4 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: g_subtac.ml4 10919 2008-05-11 22:04:26Z msozeau $ *)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
 
-open Options
+open Flags
 open Util
 open Names
 open Nameops
@@ -41,17 +44,20 @@ struct
   let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
 end
 
+open Rawterm
 open SubtacGram 
 open Util
 open Pcoq
-
+open Prim
+open Constr
 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 subtac_nameopt;
+  GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt;
  
   subtac_gallina_loc:
-    [ [ g = Vernac.gallina -> loc, g ] ]
+    [ [ g = Vernac.gallina -> loc, g
+    | g = Vernac.gallina_ext -> loc, g ] ]
     ;
 
   subtac_nameopt:
@@ -60,31 +66,31 @@ GEXTEND Gram
     ;
 
   Constr.binder_let:
-    [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> 
-	  let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in
-	    LocalRawAssum ([id], typ)
+    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
+          [LocalRawAssum ([id], default_binder_kind, typ)]
     ] ];
 
   Constr.binder:
     [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
-          ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)]))
+          ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)]))
       | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
-          ([id],c)
+          ([id],default_binder_kind, c)
       | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
-          (id::lid,c)
+          (id::lid,default_binder_kind, c)
     ] ];
 
   END
 
 
-type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type
+type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) 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),
-  (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) =
+let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
+  (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
+  (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
   Genarg.create_arg "subtac_gallina_loc"
 
-type 'a nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type
+type 'a nameopt_argtype = (identifier option, 'a) Genarg.abstract_argument_type
 
 let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
   (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
@@ -133,10 +139,18 @@ VERNAC COMMAND EXTEND Subtac_Admit_Obligations
     END
 
 VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ]
+| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ 
+    Coqlib.check_required_library ["Coq";"Program";"Tactics"];
+    Tacinterp.add_tacdef false 
+      [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligations_tactic"), true, 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
+
+VERNAC COMMAND EXTEND Subtac_Show_Preterm
+| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ]
+| [ "Preterm" ] -> [ Subtac_obligations.show_term None ]
+END
diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml
index 8bc310d5..a59ad6f5 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 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac.ml 11150 2008-06-19 11:38:27Z msozeau $ *)
 
 open Global
 open Pp
@@ -49,24 +49,41 @@ open Decl_kinds
 open Tacinterp
 open Tacexpr
 
+let solve_tccs_in_type env id isevars evm c typ =
+  if not (evm = Evd.empty) then 
+    let stmt_id = Nameops.add_suffix id "_stmt" in
+    let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 c typ in
+    (** Make all obligations transparent so that real dependencies can be sorted out by the user *)
+    let obls = Array.map (fun (id, t, l, op, d) -> (id, t, l, false, d)) obls in
+      match Subtac_obligations.add_definition stmt_id c' typ obls with
+	  Subtac_obligations.Defined cst -> constant_value (Global.env()) 
+	    (match cst with ConstRef kn -> kn | _ -> assert false)
+	| _ -> 
+	    errorlabstrm "start_proof" 
+	      (str "The statement obligations could not be resolved automatically, " ++ spc () ++
+		  str "write a statement definition first.")
+  else
+    let _ = Typeops.infer_type env c in c
+
+
 let start_proof_com env isevars sopt kind (bl,t) hook =
   let id = match sopt with
-    | Some id ->
+    | Some (loc,id) ->
         (* We check existence here: it's a bit late at Qed time *)
         if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-          errorlabstrm "start_proof" (pr_id id ++ str " already exists");
+          user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
         id
     | None ->
 	next_global_ident_away false (id_of_string "Unnamed_thm")
  	  (Pfedit.get_all_proof_names ())
   in
-  let evm, c, typ = 
+  let evm, c, typ, _imps = 
     Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None 
   in
-  let _ = Typeops.infer_type env c in
-    Command.start_proof id kind c hook
+  let c = solve_tccs_in_type env id isevars evm c typ in
+    Command.start_proof id kind c hook	
       
-let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
+let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
 
 let start_proof_and_print env isevars idopt k t hook =
   start_proof_com env isevars idopt k t hook;
@@ -75,122 +92,157 @@ let start_proof_and_print env isevars idopt k t hook =
 let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
   
 let assumption_message id =
-  Options.if_verbose message ((string_of_id id) ^ " is assumed")
+  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
 
-let declare_assumption env isevars idl is_coe k bl c =
-  if not (Pfedit.refining ()) then 
-    let evm, c, typ = 
-      Subtac_pretyping.subtac_process env isevars (snd (List.hd idl)) [] (Command.generalize_constr_expr c bl) None 
+let declare_assumption env isevars idl is_coe k bl c nl =
+  if not (Pfedit.refining ()) then
+    let id = snd (List.hd idl) in
+    let evm, c, typ, imps = 
+      Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None 
     in
-      List.iter (Command.declare_one_assumption is_coe k c) idl
+    let c = solve_tccs_in_type env id isevars evm c typ in
+      List.iter (Command.declare_one_assumption is_coe k c imps false false nl) idl
   else
     errorlabstrm "Command.Assumption"
 	(str "Cannot declare an assumption while in proof editing mode.")
 
-let vernac_assumption env isevars kind l =
-  List.iter (fun (is_coe,(idl,c)) -> declare_assumption env isevars idl is_coe kind [] c) l
+let dump_definition (loc, id) s =
+  Flags.dump_string (Printf.sprintf "%s %d %s\n" s (fst (unloc loc)) (string_of_id id))
+
+let dump_constraint ty ((loc, n), _, _) =
+  match n with
+    | Name id -> dump_definition (loc, id) ty
+    | Anonymous -> ()
 
+let dump_variable lid = ()
 
+let vernac_assumption env isevars kind l nl =
+  let global = fst kind = Global in
+    List.iter (fun (is_coe,(idl,c)) -> 
+      if !Flags.dump then
+	List.iter (fun lid -> 
+	  if global then dump_definition lid "ax" 
+	  else dump_variable lid) idl;
+      declare_assumption env isevars idl is_coe kind [] c nl) l
+
+let check_fresh (loc,id) =
+  if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+    user_err_loc (loc,"",pr_id id ++ str " already exists")
+      
 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";
-  require_library "Coq.Logic.JMeq";
+  check_required_library ["Coq";"Program";"Tactics"];
   let env = Global.env () in
   let isevars = ref (create_evar_defs Evd.empty) in
   try
   match command with
-	VernacDefinition (defkind, (locid, id), expr, hook) -> 
-	    (match expr with
-		 ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None
-	       | DefineBody (bl, _, c, tycon) -> 
-		   Subtac_pretyping.subtac_proof env isevars id bl c tycon)
-      | VernacFixpoint (l, b) -> 
-	  let _ = trace (str "Building fixpoint") in
-	    ignore(Subtac_command.build_recursive l b)
-
-      | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) ->
-	  if not(Pfedit.refining ()) then
-	    if lettop then
-	      errorlabstrm "Subtac_command.StartProof"
-		(str "Let declarations can only be used in proof editing mode");
+  | VernacDefinition (defkind, (_, id as lid), expr, hook) -> 
+      check_fresh lid;
+      dump_definition lid "def";
+      (match expr with
+      | ProveBody (bl, t) -> 
 	  if Lib.is_modtype () then
 	    errorlabstrm "Subtac_command.StartProof"
 	      (str "Proof editing mode not supported in module types");
-	  start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
-
-
-      | VernacAssumption (stre,l) -> 
-	  vernac_assumption env isevars stre l
-
-      (*| VernacEndProof e -> 
-	  subtac_end_proof e*)
-
-      | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
-  with 
-    | Typing_error e ->
-	msg_warning (str "Type error in Program tactic:");
-	let cmds = 
-	  (match e with
-	     | NonFunctionalApp (loc, x, mux, e) ->
-		 str "non functional application of term " ++ 
-		 e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
-	     | NonSigma (loc, t) ->
-		 str "Term is not of Sigma type: " ++ t
-	     | NonConvertible (loc, x, y) ->
-		 str "Unconvertible terms:" ++ spc () ++
-		   x ++ spc () ++ str "and" ++ spc () ++ y
-	     | IllSorted (loc, t) ->
-		 str "Term is ill-sorted:" ++ spc () ++ t
-	  )
-	in msg_warning cmds
-	     
-    | Subtyping_error e ->
-	msg_warning (str "(Program tactic) Subtyping error:");
-	let cmds = 
-	  match e with
-	    | UncoercibleInferType (loc, x, y) ->
-		str "Uncoercible terms:" ++ spc ()
-		++ x ++ spc () ++ str "and" ++ spc () ++ y
-	    | UncoercibleInferTerm (loc, x, y, tx, ty) ->
-		str "Uncoercible terms:" ++ spc ()
-		++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
-		++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
-	    | UncoercibleRewrite (x, y) ->
-		str "Uncoercible terms:" ++ spc ()
-		++ x ++ spc () ++ str "and" ++ spc () ++ y
-	in msg_warning cmds
-
-    | Cases.PatternMatchingError (env, exn) as e ->
-	debug 2 (Himsg.explain_pattern_matching_error env exn);
-	raise e
-    
-    | Type_errors.TypeError (env, exn) as e ->
-	debug 2 (Himsg.explain_type_error env exn);
-	raise e
-	  
-    | Pretype_errors.PretypeError (env, exn) as e ->
-	debug 2 (Himsg.explain_pretype_error env exn);
-	raise e
+	  start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) 
+	    (fun _ _ -> ())
+      | DefineBody (bl, _, c, tycon) -> 
+	  ignore(Subtac_pretyping.subtac_proof defkind env isevars id bl c tycon))
+  | VernacFixpoint (l, b) -> 
+      List.iter (fun ((lid, _, _, _, _), _) -> 
+	check_fresh lid;
+	dump_definition lid "fix") l;
+      let _ = trace (str "Building fixpoint") in
+	ignore(Subtac_command.build_recursive l b)
 	  
-    | (Stdpp.Exc_located (loc, e')) as e ->
-	debug 2 (str "Parsing exception: ");
-	(match e' with
-	   | Type_errors.TypeError (env, exn) ->
-	       debug 2 (Himsg.explain_type_error env exn);
-	       raise e
-		 
-	   | Pretype_errors.PretypeError (env, exn) ->
-	       debug 2 (Himsg.explain_pretype_error env exn);
-	       raise e
-
-	   | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
-	       raise e)
-  
-    | e -> 
-	msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
-	raise e
-
-
+  | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) ->
+      if !Flags.dump then dump_definition id "prf";
+      if not(Pfedit.refining ()) then
+	if lettop then
+	  errorlabstrm "Subtac_command.StartProof"
+	    (str "Let declarations can only be used in proof editing mode");
+      if Lib.is_modtype () then
+	errorlabstrm "Subtac_command.StartProof"
+	  (str "Proof editing mode not supported in module types");
+      check_fresh id;
+      start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
+	
+  | VernacAssumption (stre,nl,l) -> 
+      vernac_assumption env isevars stre l nl
+	
+  | VernacInstance (glob, sup, is, props, pri) ->
+      if !Flags.dump then dump_constraint "inst" is;
+      ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
+	
+  | VernacCoFixpoint (l, b) ->
+      List.iter (fun ((lid, _, _, _), _) -> dump_definition lid "cofix") l;
+      ignore(Subtac_command.build_corecursive l b)
+	
+  (*| VernacEndProof e -> 
+    subtac_end_proof e*)
+
+  | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
+  with 
+  | Typing_error e ->
+      msg_warning (str "Type error in Program tactic:");
+      let cmds = 
+	(match e with
+	| NonFunctionalApp (loc, x, mux, e) ->
+	    str "non functional application of term " ++ 
+	      e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
+	| NonSigma (loc, t) ->
+	    str "Term is not of Sigma type: " ++ t
+	| NonConvertible (loc, x, y) ->
+	    str "Unconvertible terms:" ++ spc () ++
+	      x ++ spc () ++ str "and" ++ spc () ++ y
+	| IllSorted (loc, t) ->
+	    str "Term is ill-sorted:" ++ spc () ++ t
+	)
+      in msg_warning cmds
+	
+  | Subtyping_error e ->
+      msg_warning (str "(Program tactic) Subtyping error:");
+      let cmds = 
+	match e with
+	| UncoercibleInferType (loc, x, y) ->
+	    str "Uncoercible terms:" ++ spc ()
+	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
+	| UncoercibleInferTerm (loc, x, y, tx, ty) ->
+	    str "Uncoercible terms:" ++ spc ()
+	    ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
+	    ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
+	| UncoercibleRewrite (x, y) ->
+	    str "Uncoercible terms:" ++ spc ()
+	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
+      in msg_warning cmds
+
+  | Cases.PatternMatchingError (env, exn) as e ->
+      debug 2 (Himsg.explain_pattern_matching_error env exn);
+      raise e
+	
+  | Type_errors.TypeError (env, exn) as e ->
+      debug 2 (Himsg.explain_type_error env exn);
+      raise e
+	
+  | Pretype_errors.PretypeError (env, exn) as e ->
+      debug 2 (Himsg.explain_pretype_error env exn);
+      raise e
+	
+  | (Stdpp.Exc_located (loc, e')) as e ->
+      debug 2 (str "Parsing exception: ");
+      (match e' with
+      | Type_errors.TypeError (env, exn) ->
+	  debug 2 (Himsg.explain_type_error env exn);
+	  raise e
+	    
+      | Pretype_errors.PretypeError (env, exn) ->
+	  debug 2 (Himsg.explain_pretype_error env exn);
+	  raise e
+
+      | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+	  raise e)
+	
+  | e -> 
+      msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+      raise e
diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml
index 04cad7c0..c7182bd2 100644
--- a/contrib/subtac/subtac_cases.ml
+++ b/contrib/subtac/subtac_cases.ml
@@ -1,3 +1,4 @@
+(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *)
+(* $Id: subtac_cases.ml 11154 2008-06-19 18:42:19Z msozeau $ *)
 
 open Cases
 open Util
@@ -100,8 +101,7 @@ type equation =
       rhs          : rhs;
       alias_stack  : name list;
       eqn_loc      : loc;
-      used         : bool ref;
-      tag          : pattern_source }
+      used         : bool ref }
 
 type matrix = equation list
 
@@ -242,6 +242,7 @@ type pattern_matching_problem =
       history  : pattern_continuation;
       mat      : matrix;
       caseloc  : loc;
+      casestyle: case_style;
       typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
 
 (*--------------------------------------------------------------------------*
@@ -386,7 +387,7 @@ let mkDeclTomatch na = function
 
 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)
+  | 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
@@ -423,25 +424,6 @@ let remove_current_pattern eqn =
 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 *)
 
@@ -499,7 +481,7 @@ let extract_rhs pb =
     | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
     | eqn::_ ->
 	set_used_pattern eqn;
-	eqn.tag, eqn.rhs
+	eqn.rhs
 
 (**********************************************************************)
 (* Functions to deal with matrix factorization *)
@@ -676,26 +658,6 @@ let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n
 
 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 =
@@ -1126,7 +1088,6 @@ let group_equations pb ind current cstrs mat =
 	       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,_) ->
@@ -1148,22 +1109,22 @@ let rec generalize_problem pb = function
       let tomatch = regeneralize_index_tomatch (i+1) tomatch in
       { pb with
 	  tomatch = Abstract d :: tomatch;
-          pred = option_map (generalize_predicate i d) pb'.pred }
+          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 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
+    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;
+     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 }
 
@@ -1228,7 +1189,7 @@ let build_branch current deps pb eqns const_info =
   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
+  let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
     sign,
   { pb with
       env = env';
@@ -1279,33 +1240,30 @@ and match_current pb tomatch =
 	  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 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 ci = make_case_info pb.env mind pb.casestyle 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)
+  let j = compile pb in
+  (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;
+       pred = Option.map ungeneralize_predicate pb.pred;
        mat = List.map (push_rels_eqn [d]) pb.mat } in
-  let patstat,j = compile pb in
-  patstat, 
+  let j = compile pb in
   { uj_val = mkLambda_or_LetIn d j.uj_val;
     uj_type = mkProd_or_LetIn d j.uj_type }
 
@@ -1328,11 +1286,10 @@ and compile_alias pb (deppat,nondeppat,d,t) rest =
     {pb with
        env = newenv;
        tomatch = tomatch;
-       pred = option_map (lift_predicate n) pb.pred;
+       pred = Option.map (lift_predicate n) pb.pred;
        history = history;
        mat = mat } in
-  let patstat,j = compile pb in
-  patstat, 
+  let j = compile pb in
   List.fold_left mkSpecialLetInJudge j sign
 
 (* pour les alias des initiaux, enrichir les env de ce qu'il faut et
@@ -1352,7 +1309,6 @@ let matx_of_eqns env eqns =
 	it = rhs;
       } in
     { patterns = lpat;
-      tag = RegularPat;
       alias_stack = [];
       eqn_loc = loc;
       used = ref false;
@@ -1421,9 +1377,9 @@ let set_arity_signature dep n arsign tomatchl pred x =
   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) -> 
+      | RLambda (_,(Name id as na),k,_,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
+      | RLambda (_,(Anonymous as na),k,_,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) 
@@ -1513,7 +1469,7 @@ let extract_arity_signature env0 tomatchl tmsign =
     match tm with
       | NotInd (bo,typ) -> 
 	  (match t with
-	    | None -> [na,option_map (lift n) bo,lift n typ]
+	    | 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"))
@@ -1612,7 +1568,8 @@ let eq_id avoid id =
 
 let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
 let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq typ x typ' y = 
+  mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
 let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |])
     
 let hole = RHole (dummy_loc, Evd.QuestionMark true)
@@ -1626,18 +1583,14 @@ let context_of_arsign l =
 
 let constr_of_pat env isevars arsign pat avoid = 
   let rec typ env (ty, realargs) pat avoid = 
-    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) -> 
-	trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name)));
 	let name, avoid = match name with
 	    Name n -> name, avoid
 	  | Anonymous -> 
 	      let previd, id = prime avoid (Name (id_of_string "wildcard")) in
 		Name id, id :: avoid 
 	in
-	  trace (str "Treated pattern variable " ++ str (string_of_id (id_of_name name)));
 	  PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid
     | PatCstr (l,((_, i) as cstr),args,alias) ->
 	let cind = inductive_of_constructor cstr in
@@ -1665,11 +1618,8 @@ let constr_of_pat env isevars arsign pat avoid =
 	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 "Getting type of app: " ++ my_print_constr env app);
 	let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in	
-	  trace (str "Family and args of apptype: " ++ my_print_constr env apptype);
 	let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in
-	  trace (str "Got Family and args of apptype: " ++ my_print_constr env apptype);
 	  match alias with
 	      Anonymous ->
 		pat', sign, app, apptype, realargs, n, avoid
@@ -1680,8 +1630,6 @@ let constr_of_pat env isevars arsign pat avoid =
 		  try
 		    let env = push_rels sign env in
 		    isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars;
-		    trace (str "convertible types for alias : " ++ my_print_constr env (lift (succ m) ty)
-		    ++ my_print_constr env (lift 1 apptype));
 		    let eq_t = mk_eq (lift (succ m) ty)
 		      (mkRel 1) (* alias *)
 		      (lift 1 app) (* aliased term *)
@@ -1693,15 +1641,8 @@ let constr_of_pat env isevars arsign pat avoid =
 		  (* Mark the equality as a hole *)
 		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
   in 
-(*   let tycon, arity = mk_tycon_from_sign env isevars arsign arity in *)
   let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in 
-  let c = it_mkProd_or_LetIn patc sign in
-  trace (str "arity signature is : " ++ my_print_rel_context env arsign);
-  trace (str "signature is : " ++ my_print_rel_context env sign);
-  trace (str "patty, args are : " ++ my_print_constr env (applistc patty args));
-  trace (str "Constr_of_pat gives: " ++ my_print_constr env c);
-  trace (str "with args: " ++ pp_list (my_print_constr (push_rels sign env)) args);
-  pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
 
 
 (* shadows functional version *)
@@ -1729,7 +1670,7 @@ let vars_of_ctx ctx =
 	    match na with
 		Anonymous -> raise (Invalid_argument "vars_of_ctx")
 	      | Name n -> n, RVar (dummy_loc, n) :: vars)
-      ctx (id_of_string "vars_of_ctx: error", [])
+      ctx (id_of_string "vars_of_ctx_error", [])
   in List.rev y
 
 let rec is_included x y = 
@@ -1740,14 +1681,17 @@ let rec is_included x y =
 	if i = i' then List.for_all2 is_included args args'
 	else false
 
-(* liftsign is the current pattern's signature length *)
+(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its
+   full signature. However prevpatterns are in the original one signature per pattern form.
+ *)
 let build_ineqs prevpatterns pats liftsign =
   let _tomatchs = List.length pats in
   let diffs = 
     List.fold_left 
       (fun c eqnpats -> 
-	 let acc = List.fold_left2
-	   (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) 
+	  let acc = List.fold_left2
+	    (* ppat is the pattern we are discriminating against, curpat is the current one. *)
+	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) 
 	      (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
 	      match acc with
 		  None -> None
@@ -1757,21 +1701,16 @@ let build_ineqs prevpatterns pats liftsign =
 		      let lens = List.length ppat_sign in
 		      (* Accumulated length of previous pattern's signatures *)
 		      let len' = lens + len in
-			trace (str "Lifting " ++ my_print_constr Environ.empty_env curpat_c ++ str " by "
-				  ++ int len');
 		      let acc = 
 			((* Jump over previous prevpat signs *)
 			  lift_rel_context len ppat_sign @ sign, 
 			  len',
 			  succ n, (* nth pattern *)
 			  mkApp (Lazy.force eq_ind,
-				[| lift (lens + liftsign) ppat_ty ;
-				   liftn liftsign (succ lens) ppat_c ;
+				[| lift (len' + liftsign) curpat_ty;
+				   liftn (len + liftsign) (succ lens) ppat_c ;
 				   lift len' curpat_c |]) :: 
-			    List.map 
-			    (fun t -> 
-			      liftn (List.length curpat_sign) (succ len') (* Jump over the curpat signature *)
-			      (lift lens t (* Jump over this prevpat signature *))) c)
+			    List.map (lift lens (* Jump over this prevpat signature *)) c)
 		      in Some acc
 		    else None)
 	   (Some ([], 0, 0, [])) eqnpats pats
@@ -1790,20 +1729,19 @@ let subst_rel_context k ctx subst =
   let (_, ctx') =
     List.fold_right 
       (fun (n, b, t) (k, acc) ->
-	 (succ k, (n, option_map (substnl subst k) b, substnl subst k t) :: acc))
+	 (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc))
       ctx (k, [])
   in ctx'
 
 let lift_rel_contextn n k sign =
   let rec liftrec k = function
     | (na,c,t)::sign ->
-	(na,option_map (liftn n k) c,type_app (liftn n k) t)
-	::(liftrec (k-1) sign)
+	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
     | [] -> []
   in
   liftrec (rel_context_length sign + k) sign
 
-let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs arity =
+let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
   let i = ref 0 in
   let (x, y, z) = 
     List.fold_left
@@ -1815,71 +1753,53 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
 		  (idents, pat' :: newpatterns, cpat :: pats))
 	      ([], [], []) eqn.patterns sign
 	 in
-	 let newpatterns = List.rev newpatterns and pats = List.rev pats in
+	 let newpatterns = List.rev newpatterns and opats = List.rev pats in
 	 let rhs_rels, pats, signlen = 
 	   List.fold_left 
 	     (fun (renv, pats, n) (sign,c, (s, args), p) -> 
 	       (* Recombine signatures and terms of all of the row's patterns *)
-(* 	       trace (str "treating pattern:" ++ my_print_constr Environ.empty_env c); *)
 	       let sign' = lift_rel_context n sign in
 	       let len = List.length sign' in
 		 (sign' @ renv, 
 		 (* lift to get outside of previous pattern's signatures. *)
 		 (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats,
 		 len + n))
-	     ([], [], 0) pats in
+	     ([], [], 0) opats in
 	 let pats, _ = List.fold_left 
 	   (* lift to get outside of past patterns to get terms in the combined environment. *)
 	   (fun (pats, n) (sign, c, (s, args), p) ->
 	     let len = List.length sign in
 	       ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n))
-	   ([], 0) pats 
+	   ([], 0) pats
 	 in
+	 let ineqs = build_ineqs prevpatterns pats signlen in
 	 let rhs_rels' = rels_of_patsign rhs_rels in
 	 let _signenv = push_rel_context rhs_rels' env in
-(* 	   trace (str "Env with signature is: " ++ my_print_env _signenv);  *)
-	 let ineqs = build_ineqs prevpatterns pats signlen in
-	 let eqs_rels = 
-	   let eqs = (*List.concat (List.rev eqs)*) context_of_arsign eqs in
+	 let arity =
 	   let args, nargs = 
 	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
-(* 	       trace (str "treating arg:" ++ my_print_constr Environ.empty_env c); *)
 	       (args @ c :: allargs, List.length args + succ n))
 	       pats ([], 0)
 	   in
 	   let args = List.rev args in
-(* 	     trace (str " equalities " ++ my_print_rel_context Environ.empty_env eqs); *)
-(* 	     trace (str " args " ++ pp_list (my_print_constr _signenv) args); *)
-	     (* Make room for substitution of prime arguments by constr patterns *)
-	     let eqs' = lift_rel_contextn signlen nargs eqs in
-	     let eqs'' = subst_rel_context 0 eqs' args in
-(* 	       trace (str " new equalities " ++ my_print_rel_context Environ.empty_env eqs'); *)
-(* 	       trace (str " subtituted equalities " ++ my_print_rel_context _signenv eqs''); *)
-	     eqs''
+	     substl args (liftn signlen (succ nargs) arity)
 	 in
-	 let rhs_rels', lift_ineqs = 
-	   match ineqs with
-	       None -> eqs_rels @ rhs_rels', 0
-	     | Some ineqs -> 
-		 (* 		 let _ = trace (str"Generated inequalities: " ++ my_print_constr env ineqs) in *)
-		 lift_rel_context 1 eqs_rels @ ((Anonymous, None, ineqs) :: rhs_rels'), 1
+	 let rhs_rels', tycon = 
+	   let neqs_rels, arity =
+	     match ineqs with
+	     | None -> [], arity
+	     | Some ineqs ->
+		 [Anonymous, None, ineqs], lift 1 arity
+	   in
+	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
+	     eqs_rels @ neqs_rels @ rhs_rels', arity
 	 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_rels + lift_ineqs + 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 j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in
 	 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
@@ -1890,22 +1810,13 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
 	     Some _ -> RApp (dummy_loc, branch, [ hole ])
 	   | None -> branch
 	 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,
-	      pats :: prevpatterns))
+	 incr i;
+	 let rhs = { eqn.rhs with it = branch } in
+	   (branch_decl :: branches,
+	   { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
+	   opats :: prevpatterns))
       ([], [], []) eqns
   in x, y
-      
-
-(* 		   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
@@ -1920,11 +1831,6 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
 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
-(*     (try List.iter *)
-(*       (fun arsign -> *)
-(* 	 trace (str "arity signature: " ++ my_print_rel_context env arsign)) *)
-(*       arsign; *)
-(*     with _ -> trace (str "error in arity signature printing")); *)
   let env = List.fold_right push_rels arsign env in
   let allnames = List.rev (List.map (List.map pi1) arsign) in
     match rtntyp with
@@ -1984,15 +1890,10 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 	       (* Build the arity signature following the names in matched terms as much as possible *)
 	       let argsign = List.tl arsign in (* arguments in inverse application order *)
 	       let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
-(* 	       let _ = trace (str "Working on dependent arg: " ++ my_print_rel_context *)
-(* 				(push_rel_context argsign env) [_appsign]) *)
-(* 	       in *)
 	       let argsign = List.rev argsign in (* arguments in application order *)
 	       let env', nargeqs, argeqs, refl_args, slift, argsign' =
 		 List.fold_left2
 		   (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
-(* 		      trace (str "Matching indexes: " ++ my_print_constr env arg ++ *)
-(* 			       str " and " ++ my_print_rel_context env [(name,b,t)]); *)
 		      let argt = Retyping.get_type_of env evars arg in
 		      let eq, refl_arg = 
 			if Reductionops.is_conv env evars argt t then
@@ -2001,7 +1902,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 			     (lift (nargeqs + nar) arg),
 			   mk_eq_refl argt arg)
 			else
-			  (mk_JMeq (lift (nargeqs + slift) appt)
+			  (mk_JMeq (lift (nargeqs + slift) t)
 			     (mkRel (nargeqs + slift))
 			     (lift (nargeqs + nar) argt)
 			     (lift (nargeqs + nar) arg),
@@ -2022,10 +1923,6 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 			 (Name id, b, t) :: argsign'))
 		   (env, 0, [], [], slift, []) args argsign
 	       in
-(* 		 trace (str "neqs: " ++ int neqs ++ spc () ++ *)
-(* 			  str "nargeqs: " ++ int nargeqs ++spc () ++ *)
-(* 			  str "slift: " ++ int slift ++spc () ++ *)
-(* 			  str "nar: " ++ int nar); *)
 	       let eq = mk_JMeq 
 		 (lift (nargeqs + slift) appt)
 		 (mkRel (nargeqs + slift))
@@ -2045,15 +1942,10 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 	       let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
 	       let previd, id = make_prime avoid name in
 	       let arsign' = (Name id, b, typ) in
-(* 	       let _ = trace (str "Working on arg: " ++ my_print_rel_context *)
-(* 				env [arsign']) *)
-(* 	       in *)
 	       let tomatch_ty = type_of_tomatch ty in
 	       let eq = 
 		 mk_eq (lift nar tomatch_ty)
 		   (mkRel slift) (lift nar tm)
-(* 		 mk_eq (lift (neqs + nar) tomatch_ty)  *)
-(* 		   (mkRel (neqs + slift)) (lift (neqs + nar) tm)  *)
 	       in
 		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, 
 		  (mk_eq_refl tomatch_ty tm) :: refl_args,
@@ -2062,28 +1954,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
   in 
   let arsign'' = List.rev arsign' in
     assert(slift = 0); (* we must have folded over all elements of the arity signature *)
-(*     begin try  *)
-(*       List.iter  *)
-(* 	(fun arsign -> *)
-(* 	   trace (str "old arity signature: " ++ my_print_rel_context env arsign)) *)
-(* 	arsign; *)
-      List.iter
-	(fun c ->
-	   trace (str "new arity signature: " ++ my_print_rel_context env c))
-	(arsign'');
-(*     with _ -> trace (str "error in arity signature printing") *)
-(*     end; *)
-    let env' = push_rel_context (context_of_arsign arsign') env in
-    let _eqsenv = push_rel_context (context_of_arsign eqs) env' in
-      (try trace (str "Where env with eqs is: " ++ my_print_env _eqsenv);
-	 trace (str "args: " ++ List.fold_left (fun acc x -> acc ++ my_print_constr env x)
-		  (mt()) refls)
-       with _ -> trace (str "error in equalities signature printing"));
-      arsign'', allnames, nar, eqs, neqs, refls
-      
-(* 	       let len = List.length eqs in *)
-(* 		 it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len *)
-
+    arsign'', allnames, nar, eqs, neqs, refls
 
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
@@ -2091,8 +1962,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 let liftn_rel_context n k sign =  
   let rec liftrec k = function
     | (na,c,t)::sign ->
-	(na,option_map (liftn n k) c,type_app (liftn n k) t)
-	::(liftrec (k-1) sign)
+	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
     | [] -> []
   in
     liftrec (k + rel_context_length sign) sign
@@ -2101,73 +1971,109 @@ let nf_evars_env evar_defs (env : env) : env =
   let nf t = nf_isevar evar_defs t in
   let env0 : env = reset_context env in 
   let f e (na, b, t) e' : env =
-    Environ.push_named (na, option_map nf b, nf t) e'
+    Environ.push_named (na, Option.map nf b, nf t) e'
   in
   let env' = Environ.fold_named_context f ~init:env0 env in
-    Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, option_map nf b, nf t) e')
+    Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e')
      ~init:env' env
       
-let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
+(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
+
+let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
+  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+  let subst, len = 
+    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
+      let signlen = List.length sign in
+	match kind_of_term tm with
+	  | Rel n when dependent tm c 
+		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
+	      ((n, len) :: subst, len - signlen)
+	  | Rel _ when not (dependent tm c)
+		&& signlen > 1 (* The term is of a dependent type but does not appear in 
+				  the tycon, maybe some variable in its type does. *) ->
+	      (match tmtype with
+		  NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+		| IsInd (_, IndType(indf,realargs)) ->
+		    List.fold_left
+		      (fun (subst, len) arg -> 
+			match kind_of_term arg with
+			  | Rel n when dependent arg c ->
+			      ((n, len) :: subst, pred len)
+			  | _ -> (subst, pred len))
+		      (subst, len) realargs)
+	  | _ -> (subst, len - signlen))
+      ([], nar) tomatchs arsign
+  in
+  let rec predicate lift c =
+    match kind_of_term c with
+      | Rel n when n > lift -> 
+	  (try 
+	      (* Make the predicate dependent on the matched variable *)
+	      let idx = List.assoc (n - lift) subst in
+		mkRel (idx + lift)
+	    with Not_found -> 
+	      (* A variable that is not matched, lift over the arsign. *)
+	      mkRel (n + nar))
+      | _ ->
+	  map_constr_with_binders succ predicate lift c 
+  in
+    try 
+      (* The tycon may be ill-typed after abstraction. *)
+      let pred = predicate 0 c in
+      let env' = push_rel_context (context_of_arsign arsign) env in
+	ignore(Typing.sort_of env' evm pred); pred
+    with _ -> lift nar c
+
+let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
+
+  let typing_fun tycon env = typing_fun tycon env isevars 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
-(*   isevars := nf_evar_defs !isevars; *)
-(*   let env = nf_evars_env !isevars (env : env) in *)
-(*      trace (str "Evars : " ++ my_print_evardefs !isevars); *)
-(*     trace (str "Env : " ++ my_print_env env); *)
-    
-  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
   let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
     if predopt = None then
+      let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
+      let tomatchs_len = List.length tomatchs_lets in
+      let env = push_rel_context tomatchs_lets env in
       let len = List.length eqns in 
       let sign, allnames, signlen, eqs, neqs, args = 
 	(* The arity signature *)
 	let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in
 	  (* Build the dependent arity signature, the equalities which makes
 	     the first part of the predicate and their instantiations. *)
-	  trace (str "Arity signatures : " ++ my_print_rel_context env (context_of_arsign arsign));
 	let avoid = [] in
 	  build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign
 
       in
-      let tycon_constr = 
+      let tycon, arity = 
 	match valcon_of_tycon tycon with
-	  | None -> mkExistential env isevars 
-	  | Some t -> t
+	| None -> let ev = mkExistential env isevars in ev, ev
+	| Some t -> 
+	    t, prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars)
+	      tomatchs sign (lift tomatchs_len t)
+      in
+      let arity = 
+	it_mkProd_or_LetIn (lift neqs arity) (context_of_arsign eqs)
       in
       let lets, matx = 
 	(* Type the rhs under the assumption of equations *)
-	constrs_of_pats typing_fun tycon env isevars matx tomatchs sign neqs 
-	  (eqs : rel_context list) (lift (signlen + neqs) tycon_constr) in
-	
+	constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity 
+      in
       let matx = List.rev matx in
       let _ = assert(len = List.length lets) 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 tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
       let args = List.rev_map (lift len) args in
-      let sign = List.map (lift_rel_context len) sign in	
-      let pred = it_mkProd_wo_LetIn (lift (signlen + neqs) tycon_constr) 
-	(context_of_arsign eqs) in
+      let pred = liftn len (succ signlen) arity in
+      let pred = build_initial_predicate true allnames pred in
 
-      let pred = liftn len (succ signlen) pred in
-(* 	it_mkProd_wo_LetIn (lift (len + signlen + neqs) tycon_constr) (liftn_rel_context len signlen eqs) in*) 
-      (* We build the elimination predicate if any and check its consistency *)
-      (* with the type of arguments to match *)
-      let _signenv = List.fold_right push_rels sign env in
-(* 	trace (str "Using predicate: " ++ my_print_constr signenv pred ++ str " in env: " ++ my_print_env signenv ++ str " len is " ++ int len); *)
-
-      let pred =
-	(* prepare_predicate_from_tycon loc typing_fun isevars env tomatchs eqs allnames signlen sign tycon in *)
-	build_initial_predicate true allnames pred 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) *)
+      (* 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 =
@@ -2178,17 +2084,17 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e
 	  history  = start_history (List.length initial_pushed);
 	  mat      = matx;
 	  caseloc  = loc;
+	  casestyle= style;
 	  typing_function = typing_fun } in
 	
-      let _, j = compile pb in
+      let j = compile pb in
 	(* We check for unused patterns *)
 	List.iter (check_unused_pattern env) matx;
 	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 = lift (-tomatchs_len) (nf_isevar !isevars tycon_constr); }
+	    uj_type = nf_isevar !isevars tycon; }
 	in j
-(* 	  inh_conv_coerce_to_tycon loc env isevars j tycon0 *)
     else
       (* We build the elimination predicate if any and check its consistency *)
       (* with the type of arguments to match *)
@@ -2207,12 +2113,12 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e
 	      history  = start_history (List.length initial_pushed);
 	      mat      = matx;
 	      caseloc  = loc;
+	      casestyle= style;
 	      typing_function = typing_fun } in
 	    
-	  let _, j = compile pb 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
index 02fe016d..6b8a0981 100644
--- a/contrib/subtac/subtac_cases.mli
+++ b/contrib/subtac/subtac_cases.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*)
+(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
 
 (*i*)
 open Util
diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml
new file mode 100644
index 00000000..15addb44
--- /dev/null
+++ b/contrib/subtac/subtac_classes.ml
@@ -0,0 +1,210 @@
+(************************************************************************)
+(*  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: subtac_classes.ml 11047 2008-06-03 23:08:00Z msozeau $ i*)
+
+open Pretyping
+open Evd
+open Environ
+open Term
+open Rawterm
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+open Constrintern
+open Subtac_command
+open Typeclasses
+open Typeclasses_errors
+open Termops
+open Decl_kinds
+open Entries
+open Util
+
+module SPretyping = Subtac_pretyping.Pretyping
+
+let interp_binder_evars evdref env na t =
+  let t = Constrintern.intern_gen true (Evd.evars_of !evdref) env t in
+    SPretyping.understand_tcc_evars evdref env IsType t
+
+let interp_binders_evars isevars env avoid l =
+  List.fold_left
+    (fun (env, ids, params) ((loc, i), t) -> 
+      let n = Name i in
+      let t' = interp_binder_evars isevars env n t in
+      let d = (i,None,t') in
+	(push_named d env, i :: ids, d::params))
+    (env, avoid, []) l
+
+let interp_typeclass_context_evars isevars env avoid l =
+  List.fold_left
+    (fun (env, ids, params) (iid, bk, cl) -> 
+      let t' = interp_binder_evars isevars env (snd iid) cl in
+      let i = match snd iid with
+	| Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids
+	| Name id -> id
+      in
+      let d = (i,None,t') in
+	(push_named d env, i :: ids, d::params))
+    (env, avoid, []) l
+
+let interp_constrs_evars isevars env avoid l =
+  List.fold_left
+    (fun (env, ids, params) t -> 
+      let t' = interp_binder_evars isevars env Anonymous t in
+      let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in
+      let d = (id,None,t') in
+	(push_named d env, id :: ids, d::params))
+    (env, avoid, []) l
+    
+let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+  SPretyping.understand_tcc_evars evdref env kind
+    (intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c)
+
+let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
+  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
+
+let type_ctx_instance isevars env ctx inst subst =
+  List.fold_left2
+    (fun (subst, instctx) (na, _, t) ce ->
+      let t' = replace_vars subst t in
+      let c = interp_casted_constr_evars isevars env ce t' in
+      let d = na, Some c, t' in
+	(na, c) :: subst, d :: instctx)
+    (subst, []) (List.rev ctx) inst
+
+(*let superclass_ce = CRef (Ident (dummy_loc, id_of_string ".superclass"))*)
+
+let type_class_instance_params isevars env id n ctx inst subst =
+  List.fold_left2
+    (fun (subst, instctx) (na, _, t) ce ->
+      let t' = replace_vars subst t in
+      let c = 
+(* 	if ce = superclass_ce then *)
+	(* 	  (\* Control over the evars which are direct superclasses to avoid partial instanciations *)
+	(* 	     in instance search. *\) *)
+	(* 	  Evarutil.e_new_evar isevars env ~src:(dummy_loc, ImplicitArg (VarRef id, (n, Some na))) t' *)
+	(* 	else *)
+	interp_casted_constr_evars isevars env ce t' 
+      in
+      let d = na, Some c, t' in
+	(na, c) :: subst, d :: instctx)
+    (subst, []) (List.rev ctx) inst
+
+let substitution_of_constrs ctx cstrs =
+  List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx []
+
+let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=Classes.default_on_free_vars) pri =
+  let env = Global.env() in
+  let isevars = ref (Evd.create_evar_defs Evd.empty) in
+  let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in
+  let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in
+  let tclass =
+    match bk with
+      | Implicit ->
+	  let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in
+	  let k = class_info (Nametab.global id) in
+	  let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in
+	  let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in
+	    if needlen <> applen then 
+	      Classes.mismatched_params env (List.map fst par) (List.map snd k.cl_context);
+	    let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *)
+	      (fun avoid (clname, (id, _, t)) -> 
+		match clname with 
+		    Some (cl, b) -> 
+		      let t = 
+			if b then 
+			  let _k = class_info cl in
+			    CHole (Util.dummy_loc, Some Evd.InternalHole) (* (Evd.ImplicitArg (IndRef k.cl_impl, (1, None)))) *)
+			else CHole (Util.dummy_loc, None)
+		      in t, avoid
+		  | None -> failwith ("new instance: under-applied typeclass"))
+	      par (List.rev k.cl_context)
+	    in Topconstr.CAppExpl (loc, (None, id), pars)
+
+      | Explicit -> cl
+  in
+  let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in
+  let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in
+  let bound = Idset.union (Implicit_quantifiers.ids_of_list gen_ids) ctx_bound in
+  on_free_vars (List.rev (gen_ids @ fvs));
+  let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in
+  let ctx, avoid = Classes.name_typeclass_binders bound ctx in
+  let ctx = List.append ctx (List.rev gen_ctx) in
+  let k, ctx', imps, subst = 
+    let c = Command.generalize_constr_expr tclass ctx in
+    let c', imps = interp_type_evars_impls ~evdref:isevars env c in
+    let ctx, c = Classes.decompose_named_assum c' in
+    let cl, args = Typeclasses.dest_class_app c in
+      cl, ctx, imps, substitution_of_constrs (List.map snd cl.cl_context) (List.rev (Array.to_list args))
+  in
+  let id = 
+    match snd instid with
+	Name id -> 
+	  let sp = Lib.make_path id in
+	    if Nametab.exists_cci sp then
+	      errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
+	    id
+      | Anonymous -> 
+	  let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
+	    Termops.next_global_ident_away false i (Termops.ids_of_context env)
+  in
+  let env' = Classes.push_named_context ctx' env in
+  isevars := Evarutil.nf_evar_defs !isevars;
+  isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars;
+  let sigma = Evd.evars_of !isevars in
+  let substctx = Typeclasses.nf_substitution sigma subst in
+  let subst, _propsctx = 
+    let props = 
+      List.map (fun (x, l, d) -> 
+	x, Topconstr.abstract_constr_expr d (Classes.binders_of_lidents l))
+	props
+    in
+      if List.length props > List.length k.cl_props then 
+	Classes.mismatched_props env' (List.map snd props) k.cl_props;
+      let props, rest = 
+	List.fold_left
+	  (fun (props, rest) (id,_,_) -> 
+	    try 
+	      let ((loc, mid), c) = List.find (fun ((_,id'), c) -> id' = id) rest in
+	      let rest' = List.filter (fun ((_,id'), c) -> id' <> id) rest in
+		Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs));
+		c :: props, rest'
+	    with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest)
+	  ([], props) k.cl_props
+      in
+	if rest <> [] then 
+	  unbound_method env' k.cl_impl (fst (List.hd rest))
+	else
+	  type_ctx_instance isevars env' k.cl_props props substctx
+  in
+  let inst_constr, ty_constr = instance_constructor k (List.rev_map snd subst) in
+    isevars := Evarutil.nf_evar_defs !isevars;
+    let term = Evarutil.nf_isevar !isevars (it_mkNamedLambda_or_LetIn inst_constr ctx')
+    and termtype = Evarutil.nf_isevar !isevars (it_mkNamedProd_or_LetIn ty_constr ctx') 
+    in
+      isevars := undefined_evars !isevars;
+      Evarutil.check_evars env Evd.empty !isevars termtype;
+(*   let imps =  *)
+(*     Util.list_map_i  *)
+(*       (fun i binder -> *)
+(* 	match binder with *)
+(* 	ExplByPos (i, Some na), (true, true)) *)
+(*       1 ctx *)
+(*   in *)
+      let hook gr = 
+	let cst = match gr with ConstRef kn -> kn | _ -> assert false in
+	let inst = Typeclasses.new_instance k pri global cst in
+	  Impargs.declare_manual_implicits false gr false imps;
+	  Typeclasses.add_instance inst
+      in
+      let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in
+      let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in
+	ignore(Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls);
+	id
diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli
new file mode 100644
index 00000000..43f00107
--- /dev/null
+++ b/contrib/subtac/subtac_classes.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  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: subtac_classes.mli 10797 2008-04-15 13:19:33Z msozeau $ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Topconstr
+open Util
+open Typeclasses
+open Implicit_quantifiers
+open Classes
+(*i*)
+
+val type_ctx_instance :     Evd.evar_defs ref ->
+    Environ.env ->
+    (Names.identifier * 'a * Term.constr) list ->
+    Topconstr.constr_expr list ->
+    (Names.identifier * Term.constr) list ->
+    (Names.identifier * Term.constr) list *
+    (Names.identifier * Term.constr option * Term.constr) list
+
+val new_instance : 
+  ?global:bool ->
+  Topconstr.local_binder list ->
+  typeclass_constraint ->
+  binder_def_list ->
+  ?on_free_vars:(identifier list -> unit) ->
+  int option ->
+  identifier
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
index c764443f..b45e23d0 100644
--- a/contrib/subtac/subtac_coercion.ml
+++ b/contrib/subtac/subtac_coercion.ml
@@ -1,3 +1,4 @@
+(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,7 +6,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: subtac_coercion.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_coercion.ml 11143 2008-06-18 15:52:42Z msozeau $ *)
 
 open Util
 open Names
@@ -129,34 +130,45 @@ module Coercion = struct
 	with Reduction.NotConvertible -> coerce' env x y
     and coerce' env x y : (Term.constr -> Term.constr) option =
       let subco () = subset_coerce env isevars x y in
-      let rec coerce_application typ c c' l l' =
+      let rec coerce_application typ typ' c c' l l' =
 	let len = Array.length l in
-	let rec aux tele typ i co = 
+	let rec aux tele typ typ' i co = 
+(* 	  (try trace (str "coerce_application.aux from " ++ (my_print_constr env x) ++ *)
+(* 			 str " to "++ my_print_constr env y *)
+(* 		       ++ str "in env:" ++ my_print_env env); *)
+(* 	    with _ -> ()); *)
 	  if i < len then
 	    let hdx = l.(i) and hdy = l'.(i) in
 	      try isevars := the_conv_x_leq env hdx hdy !isevars;
 		let (n, eqT, restT) = destProd typ in
-		aux (hdx :: tele) (subst1 hdy restT) (succ i) co
+		let (n', eqT', restT') = destProd typ' in
+		aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
 	      with Reduction.NotConvertible ->
 		let (n, eqT, restT) = destProd typ in
+		let (n', eqT', restT') = destProd typ' in
+		let _ = 
+		  try isevars := the_conv_x_leq env eqT eqT' !isevars
+		  with Reduction.NotConvertible -> raise NoSubtacCoercion
+		in
+		(* Disallow equalities on arities *)
+		if Reduction.is_arity env eqT then raise NoSubtacCoercion;
 		let restargs = lift_args 1 
 		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
 		in 
 		let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in
 		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
 		let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
-(* 		let jmeq = mkApp (Lazy.force jmeq_ind, [| eqT; hdx; eqT; hdy |]) in *)
-		let evar = make_existential dummy_loc env isevars eq in
+		let evar = make_existential loc env isevars eq in
 		let eq_app x = mkApp (Lazy.force eq_rect,
 				      [| eqT; hdx; pred; x; hdy; evar|]) in
-		  trace (str"Inserting coercion at application");
-		  aux (hdy :: tele) (subst1 hdy restT) (succ i)  (fun x -> eq_app (co x))
-	  else co
-	in aux [] typ 0 (fun x -> x)
+		  aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
+	  else Some co
+	in aux [] typ typ' 0 (fun x -> x)
       in
-(* 	(try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++  *)
-(* 		    str " to "++ my_print_constr env y); *)
-(* 	 with _ -> ()); *)
+(* 	(try trace (str "coerce' from " ++ (my_print_constr env x) ++ *)
+(* 		       str " to "++ my_print_constr env y *)
+(* 		       ++ str "in env:" ++ my_print_env env); *)
+(* 	  with _ -> ()); *)
 	match (kind_of_term x, kind_of_term y) with
 	  | Sort s, Sort s' -> 
 	      (match s, s' with
@@ -167,24 +179,35 @@ module Coercion = struct
 	  | Prod (name, a, b), Prod (name', a', b') ->
 	      let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
 	      let env' = push_rel (name', None, a') env in
+		
+(* 	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in *)
+(* 	      let name'' = Name (Nameops.next_ident_away (id_of_string "x'") (Termops.ids_of_context env)) in *)
+(* 	      let env'' = push_rel (name'', Some (app_opt c1 (mkRel 1)), lift 1 a) env' in *)
+(* 	      let c2 = coerce_unify env'' (liftn 1 1 b) (lift 1 b') in *)
+(* 				     mkLetIn (name'', app_opt c1 (mkRel 1), (lift 1 a), *)
+
 	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
-	      let c2 = coerce_unify env' b b' in
+		(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
+	      let coec1 = app_opt c1 (mkRel 1) in
+		(* env, x : a' |- c1[x] : lift 1 a *)
+	      let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
+		(* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
 		(match c1, c2 with
 		     None, None -> failwith "subtac.coerce': Should have detected equivalence earlier"
 		   | _, _ ->
 		       Some
 			 (fun f -> 
-			    mkLambda (name', a',
-				      app_opt c2
-					(mkApp (Term.lift 1 f, 
-						[| app_opt c1 (mkRel 1) |])))))
+			   mkLambda (name', a',
+				    app_opt c2
+				      (mkApp (Term.lift 1 f, [| coec1 |])))))
 		  
 	  | App (c, l), App (c', l') ->
 	      (match kind_of_term c, kind_of_term c' with
-		   Ind i, Ind i' -> (* Sigma types *)
+		   Ind i, Ind i' -> (* Inductive types *)
 		     let len = Array.length l in
 		     let existS = Lazy.force existS in
 		     let prod = Lazy.force prod in
+		       (* Sigma types *)
 		       if len = Array.length l' && len = 2 && i = i'
 			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
 		       then 
@@ -248,21 +271,22 @@ module Coercion = struct
 		       else
 			 if i = i' && len = Array.length l' then
 			   let evm = evars_of !isevars in
-			   let typ = Typing.type_of env evm c in
 			     (try subco () 
-			      with NoSubtacCoercion ->
-				
-(* 			     if not (is_arity env evm typ) then *)
-			       Some (coerce_application typ c c' l l'))
-(* 			     else subco () *)
+			       with NoSubtacCoercion ->
+				 let typ = Typing.type_of env evm c in
+				 let typ' = Typing.type_of env evm c' in
+				   (* 			     if not (is_arity env evm typ) then *)
+				   coerce_application typ typ' c c' l l')
+			       (* 			     else subco () *)
 			 else
 			   subco ()
 		 | x, y when x = y ->
 		     if Array.length l = Array.length l' then
 		       let evm = evars_of !isevars in
 		       let lam_type = Typing.type_of env evm c in
+		       let lam_type' = Typing.type_of env evm c' in
 (* 			 if not (is_arity env evm lam_type) then ( *)
-			   Some (coerce_application lam_type c c' l l')
+			 coerce_application lam_type lam_type' c c' l l'
 (* 			 ) else subco () *)
 		     else subco ()
 		 | _ -> subco ())
@@ -284,7 +308,7 @@ module Coercion = struct
 		    Some 
 		      (fun x ->
 			 let cx = app_opt c x in
-			 let evar = make_existential dummy_loc env isevars (mkApp (p, [| cx |]))
+			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
 			 in
 			   (mkApp 
 			      ((Lazy.force sig_).intro, 
@@ -298,7 +322,7 @@ module Coercion = struct
   let coerce_itf loc env isevars v t c1 =
     let evars = ref isevars in
     let coercion = coerce loc env evars t c1 in
-      !evars, option_map (app_opt coercion) v, t
+      !evars, Option.map (app_opt coercion) v
 	
   (* Taken from pretyping/coercion.ml *)
 
@@ -360,7 +384,7 @@ module Coercion = struct
       match kind_of_term t with
 	| Prod (_,_,_) -> (isevars,j)
 	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',t) = define_evar_as_arrow isevars ev in
+	    let (isevars',t) = define_evar_as_product isevars ev in
 	      (isevars',{ uj_val = j.uj_val; uj_type = t })
 	| _ ->
        	    (try
@@ -400,11 +424,15 @@ module Coercion = struct
 		 uj_type = typ' }
 
 
-  let inh_coerce_to_fail env isevars c1 v t =
+  let inh_coerce_to_fail env evd rigidonly v t c1 =
+    if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
+    then
+      raise NoCoercion
+    else
     let v', t' =
       try 
-	let t1,i1 = class_of1 env (evars_of isevars) c1 in
-	let t2,i2 = class_of1 env (evars_of isevars) t in
+	let t1,i1 = class_of1 env (evars_of evd) c1 in
+	let t2,i2 = class_of1 env (evars_of evd) t in
 	let p = lookup_path_between (i2,i1) in
 	  match v with
 	      Some v -> 
@@ -413,132 +441,88 @@ module Coercion = struct
 	    | None -> None, t
       with Not_found -> raise NoCoercion 
     in
-      try (the_conv_x_leq env t' c1 isevars, v', t')
+      try (the_conv_x_leq env t' c1 evd, v')
       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 () ++ *)
-(* 	      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)
+
+  let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
+    try (the_conv_x_leq env t c1 evd, v)
     with Reduction.NotConvertible ->
-      (try 
-	 inh_coerce_to_fail env isevars c1 v t
-	 with NoCoercion ->
-	   (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
-	      kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
-		| Prod (_,t1,t2), Prod (name,u1,u2) -> 
-		    let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in
-		    let (evd',b) =
-		      match v' with 
-			  Some v' ->
-			    (match kind_of_term v' with
-			       | Lambda (x,v1,v2) ->
-				   (try the_conv_x env v1 u1 isevars, Some (x, v1, v2)  (* leq v1 u1? *)
-				    with Reduction.NotConvertible -> (isevars, None))
-			       | _  -> (isevars, None))
-			| None -> (isevars, None)
-		    in 
-		      (match b with
-			   Some (x, v1, v2) ->
-			     let env1 = push_rel (x,None,v1) env in
-			     let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
-						       (Some v2) t2 u2 in
-			       (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', 
-				mkProd (x, v1, t2'))
-			 | None ->
-			     (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
-			     (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
-			     (* has type (name:u1)u2 (with v' recursively obtained) *)
-			     let name = (match name with 
-					   | Anonymous -> Name (id_of_string "x")
-					   | _ -> name) in
-			     let env1 = push_rel (name,None,u1) env in
-			     let (evd', v1', t1') =
-			       inh_conv_coerce_to_fail loc env1 isevars
-				 (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) 
-			     in
-			     let (evd'', v2', t2') = 
-			       let v2 =
-				 match v with 
-				     Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1'
-				   | None -> None
-			       and evd', t2 =
-				 match v1' with 
-				     Some v1' -> evd', subst1 v1' t2
-				   | None -> 
-				       let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in
-					 evd', subst1 ev t2
-			       in
-				 inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
-			     in
-			       (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2',
-				mkProd (name, u1, t2')))
-		| _ -> raise NoCoercion))
+    try inh_coerce_to_fail env evd rigidonly v t c1
+    with NoCoercion ->
+    match
+      kind_of_term (whd_betadeltaiota env (evars_of evd) t),
+      kind_of_term (whd_betadeltaiota env (evars_of evd) c1)
+    with
+    | Prod (name,t1,t2), Prod (_,u1,u2) -> 
+        (* Conversion did not work, we may succeed with a coercion. *)
+        (* We eta-expand (hence possibly modifying the original term!) *)
+	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
+	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
+	let name = match name with 
+	  | Anonymous -> Name (id_of_string "x")
+	  | _ -> name in
+	let env1 = push_rel (name,None,u1) env in
+	let (evd', v1) =
+	  inh_conv_coerce_to_fail loc env1 evd rigidonly
+            (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
+        let v1 = Option.get v1 in
+	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
+        let t2 = Termops.subst_term v1 t2 in
+	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
+	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
+    | _ -> raise NoCoercion
 
-	
   (* 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 *)
-(*        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 _ -> ()); *)
+  let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
+    let evd = nf_evar_defs evd in
     match n with
 	None ->
-	  let (evd', val', type') = 
+	  let (evd', val') = 
 	    try 
-	      inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+	      inh_conv_coerce_to_fail loc env evd rigidonly
+		(Some (nf_isevar evd cj.uj_val))
+		(nf_isevar evd cj.uj_type) (nf_isevar evd t)
 	    with NoCoercion ->
-	      let sigma = evars_of isevars in
+	      let sigma = evars_of evd in
 		try
-		  coerce_itf loc env isevars (Some cj.uj_val) cj.uj_type t
+		  coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
 		with NoSubtacCoercion ->
 		  error_actual_type_loc loc env sigma cj t
 	  in
 	  let val' = match val' with Some v -> v | None -> assert(false) in
 	    (evd',{ uj_val = val'; uj_type = t })
       | Some (init, cur) ->
-	  (isevars, cj)
+	  (evd, cj)
+
+  let inh_conv_coerce_to = inh_conv_coerce_to_gen false
+  let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
 
   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 = 
+    let nabsinit, nabs =
       match abs with
 	  None -> 0, 0
 	| Some (init, cur) -> init, cur
     in
-      (* a little more effort to get products is needed *) 
+      (* a little more effort to get products is needed *)
       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', 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'
+	    try
+	      fst (try inh_conv_coerce_to_fail loc env' isevars false None t t'
 		   with NoCoercion ->
-		     coerce_itf loc env' isevars None t t') 
+		     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 
+	else isevars
       with _ -> isevars
- (* 	trace (str "decompose_prod_n failed"); *)
- (* 	raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *)
+(*  	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 86139039..5bff6ad1 100644
--- a/contrib/subtac/subtac_command.ml
+++ b/contrib/subtac/subtac_command.ml
@@ -39,6 +39,8 @@ open Tacticals
 open Tacinterp
 open Vernacexpr
 open Notation
+open Evd
+open Evarutil
 
 module SPretyping = Subtac_pretyping.Pretyping
 open Subtac_utils
@@ -53,22 +55,24 @@ let evar_nf isevars c =
   Evarutil.nf_isevar !isevars c
 
 let interp_gen kind isevars env 
-               ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[]))
+               ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
                c =
-  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in
-(*     (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *)
+  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars (Evd.evars_of !isevars) env c in
   let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in
     evar_nf isevars c'
-    
+
 let interp_constr isevars env c =
   interp_gen (OfType None) isevars env c 
 
-let interp_type isevars env ?(impls=([],[])) c =
+let interp_type_evars isevars env ?(impls=([],[])) c =
   interp_gen IsType isevars env ~impls c
 
 let interp_casted_constr isevars env ?(impls=([],[])) c typ =
   interp_gen (OfType (Some typ)) isevars env ~impls c 
 
+let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
+  interp_gen (OfType (Some typ)) isevars env ~impls c 
+
 let interp_open_constr isevars env c =
     msgnl (str "Pretyping " ++ my_print_constr_expr c);
   let c = Constrintern.intern_constr (Evd.evars_of !isevars) env c in
@@ -92,26 +96,31 @@ let locate_if_isevar loc na = function
 
 let interp_binder sigma env na t =
   let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in
-    SPretyping.understand_type (Evd.evars_of !sigma) env (locate_if_isevar (loc_of_rawconstr t) na t)
-      
-
-let interp_context sigma env params = 
-  List.fold_left
-    (fun (env,params) d -> match d with
-      | LocalRawAssum ([_,na],(CHole _ as t)) ->
-	  let t = interp_binder sigma env na t in
-	  let d = (na,None,t) in
-	  (push_rel d env, d::params)
-      | LocalRawAssum (nal,t) ->
-	  let t = interp_type sigma env t in
-	  let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
-	  let ctx = List.rev ctx in
-	  (push_rel_context ctx env, ctx@params)
-      | LocalRawDef ((_,na),c) ->
-	  let c = interp_constr_judgment sigma env c in
-	  let d = (na, Some c.uj_val, c.uj_type) in
-	  (push_rel d env,d::params))
-    (env,[]) params
+    SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t)
+
+let interp_context_evars evdref env params = 
+  let bl = Constrintern.intern_context (Evd.evars_of !evdref) env params in
+  let (env, par, _, impls) =
+    List.fold_left
+      (fun (env,params,n,impls) (na, k, b, t) ->
+	match b with
+	    None ->
+	      let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
+	      let d = (na,None,t) in
+	      let impls = 
+		if k = Implicit then
+		  let na = match na with Name n -> Some n | Anonymous -> None in
+		    (ExplByPos (n, na), (true, true)) :: impls
+		else impls
+	      in
+		(push_rel d env, d::params, succ n, impls)
+	  | Some b ->
+	      let c = SPretyping.understand_judgment_tcc evdref env b in
+	      let d = (na, Some c.uj_val, c.uj_type) in
+		(push_rel d env,d::params, succ n, impls))
+      (env,[],1,[]) (List.rev bl)
+  in (env, par), impls
 
 (* try to find non recursive definitions *)
 
@@ -126,7 +135,7 @@ let collect_non_rec env =
       let i = 
         list_try_find_i
           (fun i f ->
-             if List.for_all (fun (_, _, def) -> not (occur_var env f def)) ldefrec
+             if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
              then i else failwith "try_find_i")
           0 lnamerec 
       in
@@ -152,14 +161,14 @@ let collect_non_rec env =
 let list_of_local_binders l = 
   let rec aux acc = function
       Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
-    | Topconstr.LocalRawAssum (nl, c) :: tl -> 
+    | Topconstr.LocalRawAssum (nl, k, c) :: tl -> 
 	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
     | [] -> List.rev acc
   in aux [] l
 
 let lift_binders k n l =
   let rec aux n = function
-    | (id, t, c) :: tl -> (id, option_map (liftn k n) t, liftn k n c) :: aux (pred n) tl
+    | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
     | [] -> []
   in aux n l
 
@@ -172,11 +181,10 @@ let split_args n rel = match list_chop ((List.length rel) - n) rel with
   | _ -> assert(false)
 
 let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
+  Coqlib.check_required_library ["Coq";"Program";"Wf"];
   let sigma = Evd.empty in
   let isevars = ref (Evd.create_evar_defs sigma) in
   let env = Global.env() in 
-  let nc = named_context env in
-  let nc_len = named_context_length nc 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
@@ -188,8 +196,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
 (* 		 Ppconstr.pr_constr_expr body) *)
 (*     with _ -> () *)
     (*   in *)
-  let env', binders_rel = interp_context isevars env bl in
-  let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in
+  let (env', binders_rel), impls = interp_context_evars isevars env bl in
+  let after, ((argname, _, argtyp) as arg), before = 
+    let idx = list_index (Name (snd n)) (List.rev_map (fun (na, _, _) -> na) binders_rel) in
+      split_args idx 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,11 +236,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
 		     (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1))))
   in
   let top_bl = after @ (arg :: before) in
-  let intern_bl = liftafter @ (wfarg 1 :: arg :: before) in
-    (try trace (str "Intern bl: " ++ prr intern_bl) with _ -> ());
   let top_env = push_rel_context top_bl env in
+  let top_arity = interp_type_evars isevars top_env arityc in
+  let intern_bl = wfarg 1 :: arg :: before in
   let _intern_env = push_rel_context intern_bl env in
-  let top_arity = interp_type isevars top_env arityc in
   let proj = (Lazy.force sig_).Coqlib.proj1 in
   let projection = 
     mkApp (proj, [| argtyp ;
@@ -240,29 +249,21 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
 		 |])
   in
   let intern_arity = it_mkProd_or_LetIn top_arity after in
-    (try trace (str "After length: " ++ int after_length ++ str "Top env: " ++ prr top_bl ++ spc () ++ str "Top arity: " ++ my_print_constr top_env top_arity);
-       trace (str "Before lifting arity: " ++ my_print_constr env top_arity) with _ -> ());
-  (* Top arity is in top_env = after :: arg :: before *)
-(*   let intern_arity' = liftn 1 (succ after_length) top_arity in (\* arity in after :: wfarg :: arg :: before *\) *)
-(*       (try trace (str "projection: " "After lifting arity: " ++ my_print_constr env intern_arity' ++ spc ()); *)
-(* 	 trace (str "Intern env: " ++ prr intern_bl ++ str "intern_arity': " ++ my_print_constr _intern_env intern_arity') with _ -> ()); *)
-  let intern_arity = substl [projection] intern_arity in (* substitute the projection of wfarg for arg *)
-  (try trace (str "Top arity after subst: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ());
-(*   let intern_arity = liftn 1 (succ after_length) intern_arity in (\* back in after :: wfarg :: arg :: before (ie, jump over arg) *\) *)
-(*   (try trace (str "Top arity after subst and lift: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); *)
+  (* Intern arity is in top_env = arg :: before *)
+  let intern_arity = liftn 2 2 intern_arity in
+(*     trace (str "After lifting arity: " ++  *)
+(* 	      my_print_constr (push_rel (Name argid', None, lift 2 argtyp) intern_env) *)
+(* 	      intern_arity); *)
+  (* arity is now in something :: wfarg :: arg :: before 
+     where what refered to arg now refers to something *)
+  let intern_arity = substl [projection] intern_arity in
+  (* substitute the projection of wfarg for something *)
   let intern_before_env = push_rel_context before env in
-(*   let intern_fun_bl = liftafter @ [wfarg 1]  in (\* FixMe dependencies *\) *)
-(*   (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *)
-  (try trace (str "Intern arity: " ++
-		  my_print_constr _intern_env intern_arity) with _ -> ());
   let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  (try trace (str "Intern fun arity product: " ++
-		  my_print_constr (push_rel_context [arg] intern_before_env) intern_fun_arity_prod) with _ -> ());
   let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
   let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in
-(*   (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 fun_arity = interp_type_evars 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 _ =
@@ -274,161 +275,177 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
 (* 		   str "Intern body " ++ pr intern_body_lam) *)
     with _ -> ()
   in
-  let _impl = 
-    if Impargs.is_implicit_args()
-    then Impargs.compute_implicits top_env top_arity
-    else [] 
-  in
   let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in
+    (* Lift to get to constant arguments *)
+  let lift_cst = List.length after + 1 in
   let fix_def =
     match measure_fn with
 	None ->
-	  mkApp (constr_of_reference (Lazy.force fix_sub_ref), 
+	  mkApp (constr_of_global (Lazy.force fix_sub_ref), 
 		 [| argtyp ;
 		    wf_rel ;
-		    make_existential dummy_loc ~opaque:false intern_before_env isevars wf_proof ;
-		    prop ;
-		    intern_body_lam |])
+		    make_existential dummy_loc ~opaque:false env isevars wf_proof ;
+		    lift lift_cst prop ;
+		    lift lift_cst intern_body_lam |])
       | Some f ->
-	  lift (succ after_length) 
-	    (mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), 
-		    [| argtyp ; 
-		       f ;
-		       prop ;
-		       intern_body_lam |]))
+	  mkApp (constr_of_global (Lazy.force fix_measure_sub_ref), 
+		[| lift lift_cst argtyp ; 
+		   lift lift_cst f ;
+		   lift lift_cst prop ;
+		   lift lift_cst intern_body_lam |])
   in
   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
   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 evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in
   let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in
   let evm = non_instanciated_map env isevars evm 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 !isevars evm 0 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 _ -> ());     *)
-    Subtac_obligations.add_definition recname evars_def fullctyp evars
+  let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in
+    Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars
 
 let nf_evar_context isevars ctx = 
   List.map (fun (n, b, t) -> 
-    (n, option_map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx
+    (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx
     
-let build_mutrec l boxed = 
-  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 env protos (f, d))*)
-    l
-  in
-  let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef 
-  and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef
+let interp_fix_context evdref env fix =
+  interp_context_evars evdref env fix.Command.fix_binders
+
+let interp_fix_ccl evdref (env,_) fix =
+  interp_type_evars evdref env fix.Command.fix_type
+
+let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
+  let env = push_rel_context ctx env_rec in
+  let body = interp_casted_constr_evars evdref env ~impls fix.Command.fix_body ccl in
+  it_mkLambda_or_LetIn body ctx
+
+let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
+
+let prepare_recursive_declaration fixnames fixtypes fixdefs =
+  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
+  let names = List.map (fun id -> Name id) fixnames in
+  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
+
+let rel_index n ctx = 
+  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
+
+let rec unfold f b =
+  match f b with
+    | Some (x, b') -> x :: unfold f b'
+    | None -> []
+
+let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
+  match n with 
+  | Some (loc, n) -> [rel_index n fixctx]
+  | None -> 
+      (* If recursive argument was not given by user, we try all args.
+	 An earlier approach was to look only for inductive arguments,
+	 but doing it properly involves delta-reduction, and it finally 
+         doesn't seem to worth the effort (except for huge mutual 
+	 fixpoints ?) *)
+      let len = List.length fixctx in
+	unfold (function x when x = len -> None 
+	  | n -> Some (n, succ n)) 0
+
+let push_named_context = List.fold_right push_named
+
+let interp_recursive fixkind l boxed =
+  let env = Global.env() in
+  let fixl, ntnl = List.split l in
+  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
+
+  (* Interp arities allowing for unresolved types *)
+  let evdref = ref (Evd.create_evar_defs Evd.empty) in
+  let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
+  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
+  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
+  let rec_sign = 
+    List.fold_left2 (fun env id t -> (id,None,t) :: env)
+      [] fixnames fixtypes
   in
-    (* Build the recursive context and notations for the recursive types *)
-  let (rec_sign,rec_env,rec_impls,arityl) = 
-    List.fold_left 
-      (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 env arityc in
-	 let impl = 
-	   if Impargs.is_implicit_args()
-	   then Impargs.compute_implicits env arity
-	   else [] in
-	 let impls' =(recname,([],impl,compute_arguments_scope arity))::impls 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) 
-      lnameargsardef [] in
-
-  let recdef =
-
-    (* Declare local notations *)
-    let fs = States.freeze() in
+  let env_rec = push_named_context rec_sign env in
+
+  (* Get interpretation metadatas *)
+  let impls = Command.compute_interning_datas env [] fixnames fixtypes fiximps in
+  let notations = List.fold_right Option.List.cons ntnl [] in
+
+  (* Interp bodies with rollback because temp use of notations/implicit *)
+  let fixdefs = 
+    States.with_heavy_rollback (fun () -> 
+      List.iter (Command.declare_interning_data impls) notations;
+      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+      () in
+
+  (* Instantiate evars and check all are resolved *)
+  let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+  let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in
+  let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in
+  let rec_sign = nf_named_context_evar (evars_of evd) rec_sign in
+    
+  let recdefs = List.length rec_sign in
+(*   List.iter (check_evars env_rec Evd.empty evd) fixdefs; *)
+(*   List.iter (check_evars env Evd.empty evd) fixtypes; *)
+(*   check_mutuality env kind (List.combine fixnames fixdefs); *)
+
+  (* Russell-specific code *)
+
+  (* Get the interesting evars, those that were not instanciated *)
+  let isevars = Evd.undefined_evars evd in
+  trace (str "got undefined evars" ++ Evd.pr_evar_defs isevars);
+  let evm = Evd.evars_of isevars in
+  trace (str "got the evm, recdefs is " ++ int recdefs);
+  (* Solve remaining evars *)
+  let rec collect_evars id def typ imps = 
+    let _ = try trace (str "In collect evars, isevars is: " ++ Evd.pr_evar_defs isevars) with _ -> () in
+      (* Generalize by the recursive prototypes  *)
     let def = 
-      try
-	List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
-	 Metasyntax.add_notation_interpretation df rec_impls c None) notations;
-	List.map2
-	  (fun ((_,_,bl,_,def),_) (isevars, info, arity) ->
-	     match info with
-		 None ->
-		   let def = abstract_constr_expr def bl in
-		     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_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
-      with e ->
-	States.unfreeze fs; raise e in
-    States.unfreeze fs; def 
-  in
-  let (lnonrec,(namerec,defrec,arrec,nvrec)) = 
-    collect_non_rec env lrecnames recdef arityl nv in
-  let recdefs = Array.length defrec in
-    (* 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 def = evar_nf isevars def in
-      let x, y, typ = arrec.(i) in
-      let typ = evar_nf isevars typ in
-      arrec.(i) <- (x, y, typ);
-      let rec_sign = nf_evar_context !isevars rec_sign 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 evm = Evd.evars_of isevars in
-      let id = namerec.(i) in
-	(* Generalize by the recursive prototypes  *)
-      let def = 
-	Termops.it_mkNamedLambda_or_LetIn def rec_sign
-      and typ = 
-	Termops.it_mkNamedProd_or_LetIn typ rec_sign
-      in
-      let evars, def = Eterm.eterm_obligations id nc_len isevars evm recdefs def (Some typ) in
-	collect_evars (succ i) ((id, def, typ, evars) :: acc)
-    else acc
+      Termops.it_mkNamedLambda_or_LetIn def rec_sign
+    and typ =
+      Termops.it_mkNamedProd_or_LetIn typ rec_sign
+    in
+    let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
+    let evm' = Subtac_utils.evars_of_term evm evm' typ in
+    let evars, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
+      (id, def, typ, imps, evars)
   in 
-  let defs = collect_evars 0 [] in
-    Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec
-      
+  let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
+    (match fixkind with
+      | Command.IsFixpoint wfl ->
+	  let possible_indexes =
+	    list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
+	  let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), 
+	    Array.of_list fixtypes, 
+	    Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
+	  in
+	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
+	    list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
+      | Command.IsCoFixpoint -> ());
+    Subtac_obligations.add_mutual_definitions defs notations fixkind
+
 let out_n = function
     Some n -> n
-  | None -> 0
-
-let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed =
-  match lnameargsardef with
-    | ((id, (n, CWfRec r), bl, typ, body), no) :: [] -> 
-	build_wellfounded (id, out_n n, bl, typ, body) r false no boxed
-    | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] -> 
-	build_wellfounded (id, out_n n, bl, typ, body) r true no boxed
-    | l -> 
-	let lnameargsardef = 
-	  List.map (fun ((id, (n, ro), bl, typ, body), no) ->
-		 match ro with
-		     CStructRec -> (id, out_n n, bl, typ, body), no
-		   | CWfRec _ | CMeasureRec _ -> 
-		       errorlabstrm "Subtac_command.build_recursive"
-			 (str "Well-founded fixpoints not allowed in mutually recursive blocks"))
-	    lnameargsardef
-	in build_mutrec lnameargsardef boxed
-	  
-      
-      
+  | None -> raise Not_found
+
+let build_recursive l b =
+  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
+    match g, l with
+	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+	  ignore(build_wellfounded (id, out_n n, bl, typ, def) r false ntn false)
+
+      | [(n, CMeasureRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+	  ignore(build_wellfounded (id, out_n n, bl, typ, def) r true ntn false)
+
+      | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
+	  let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> 
+	    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l 
+	  in interp_recursive (Command.IsFixpoint g) fixl b
+      | _, _ -> 
+	  errorlabstrm "Subtac_command.build_recursive"
+	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
+
+let build_corecursive l b =
+  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> 
+    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn))
+    l in
+  interp_recursive Command.IsCoFixpoint fixl b
diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli
index 846e06cf..27520867 100644
--- a/contrib/subtac/subtac_command.mli
+++ b/contrib/subtac/subtac_command.mli
@@ -14,18 +14,18 @@ val interp_gen :
   evar_defs ref ->
   env ->
   ?impls:full_implicits_env ->
-  ?allow_soapp:bool ->
+  ?allow_patvar:bool ->
   ?ltacvars:ltac_sign ->
   constr_expr -> constr
 val interp_constr :
   evar_defs ref ->
   env -> constr_expr -> constr
-val interp_type :
+val interp_type_evars :
   evar_defs ref ->
   env ->
   ?impls:full_implicits_env ->
   constr_expr -> constr
-val interp_casted_constr :
+val interp_casted_constr_evars :
   evar_defs ref ->
   env ->
   ?impls:full_implicits_env ->
@@ -38,5 +38,12 @@ val interp_constr_judgment :
   constr_expr -> unsafe_judgment
 val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
 
+val interp_binder :     Evd.evar_defs ref ->
+    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
+
+
 val build_recursive :
   (fixpoint_expr * decl_notation) list -> bool -> unit
+
+val build_corecursive :
+  (cofixpoint_expr * decl_notation) list -> bool -> unit
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
index d182f7cd..55cdc7c4 100644
--- a/contrib/subtac/subtac_obligations.ml
+++ b/contrib/subtac/subtac_obligations.ml
@@ -1,7 +1,7 @@
-(* -*- default-directory: "~/research/coq/trunk/" -*- *)
 open Printf
 open Pp
 open Subtac_utils
+open Command
 
 open Term
 open Names
@@ -12,8 +12,11 @@ open Entries
 open Decl_kinds
 open Util
 open Evd
+open Declare
 
-let pperror cmd = Util.errorlabstrm "Subtac" cmd
+type definition_hook = global_reference -> unit
+
+let pperror cmd = Util.errorlabstrm "Program" cmd
 let error s = pperror (str s)
 
 exception NoObligations of identifier option
@@ -22,11 +25,12 @@ let explain_no_obligations = function
     Some ident -> str "No obligations for program " ++ str (string_of_id ident)
   | None -> str "No obligations remaining"
 
-type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array
+type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array
 
 type obligation =
     { obl_name : identifier;
       obl_type : types;
+      obl_location : loc;
       obl_body : constr option;
       obl_opaque : bool;
       obl_deps : Intset.t;
@@ -34,27 +38,46 @@ type obligation =
 
 type obligations = (obligation array * int)
 
+type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list
+
 type program_info = {
   prg_name: identifier;
   prg_body: constr;
   prg_type: constr;
   prg_obligations: obligations;
   prg_deps : identifier list;
-  prg_nvrec : int array;
+  prg_fixkind : Command.fixpoint_kind option ;
+  prg_implicits : (Topconstr.explicitation * (bool * bool)) list;
+  prg_notations : notations ;
+  prg_kind : definition_kind;
+  prg_hook : definition_hook;
 }
 
 let assumption_message id =
-  Options.if_verbose message ((string_of_id id) ^ " is assumed")
+  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
 
 let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC
 let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Obj.magic ())
 
 let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_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 }
+(* true = All transparent, false = Opaque if possible *)
+let proofs_transparency = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+open Goptions
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "transparency of Program obligations";
+      optkey   = (SecondaryTable ("Transparent","Obligations"));
+      optread  = get_proofs_transparency;
+      optwrite = set_proofs_transparency; } 
+
+let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
 
 let subst_deps obls deps t =
   Intset.fold
@@ -62,7 +85,7 @@ let subst_deps obls deps t =
        let xobl = obls.(x) in
 	 debug 3 (str "Trying to get body of obligation " ++ int x);
        let oblb = 
-	 try out_some xobl.obl_body
+	 try Option.get xobl.obl_body
 	 with _ ->
 	   debug 3 (str "Couldn't get body of obligation " ++ int x);
 	   assert(false)
@@ -96,7 +119,7 @@ let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
 let freeze () = !from_prg, !default_tactic_expr
 let unfreeze (v, t) = from_prg := v; set_default_tactic t
 let init () =
-  from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.utils_call "subtac_simpl" [])
+  from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.tactics_call "obligations_tactic" [])
 
 let _ = 
   Summary.declare_summary "program-tcc-table"
@@ -110,7 +133,7 @@ let progmap_union = ProgMap.fold ProgMap.add
 
 let cache (_, (infos, tac)) =
   from_prg := infos;
-  default_tactic_expr := tac
+  set_default_tactic tac
 
 let (input,output) = 
   declare_object
@@ -129,69 +152,112 @@ let rec intset_to = function
   
 let subst_body prg = 
   let obls, _ = prg.prg_obligations in
-    subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body
-
+  let ints = intset_to (pred (Array.length obls)) in
+    subst_deps obls ints prg.prg_body,
+  subst_deps obls ints (Termops.refresh_universes prg.prg_type)
+    
 let declare_definition prg =
-  let body = subst_body prg in
+  let body, typ = subst_body prg in
     (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++
 		  my_print_constr (Global.env()) body ++ str " : " ++ 
 		  my_print_constr (Global.env()) prg.prg_type);
      with _ -> ());
+  let (local, boxed, kind) = prg.prg_kind in
   let ce = 
     { const_entry_body = body;
-      const_entry_type = Some prg.prg_type;
+      const_entry_type = Some typ;
       const_entry_opaque = false;
-      const_entry_boxed = false} 
+      const_entry_boxed = boxed} 
   in
-  let _constant = Declare.declare_constant 
-    prg.prg_name (DefinitionEntry ce,IsDefinition Definition)
-  in
-    Subtac_utils.definition_message prg.prg_name
+    (Command.get_declare_definition_hook ()) ce;
+    match local with
+    | Local when Lib.sections_are_opened () ->
+        let c =
+          SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
+        let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in
+          print_message (Subtac_utils.definition_message prg.prg_name);
+          if Pfedit.refining () then 
+            Flags.if_verbose msg_warning 
+	      (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ 
+		  str" is not visible from current goals");
+          VarRef prg.prg_name
+    | (Global|Local) ->
+	let c =
+	  Declare.declare_constant 
+	    prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind))
+	in
+	let gr = ConstRef c in
+	  if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
+	    Impargs.declare_manual_implicits false gr (Impargs.is_implicit_args ()) prg.prg_implicits;
+	  print_message (Subtac_utils.definition_message prg.prg_name);
+	  prg.prg_hook gr;
+	  gr
 
 open Pp
 open Ppconstr
 
+let rec lam_index n t acc =
+  match kind_of_term t with
+    | Lambda (na, _, b) ->
+	if na = Name n then acc
+	else lam_index n b (succ acc)
+    | _ -> raise Not_found
+	
+let compute_possible_guardness_evidences (n,_) fixbody fixtype =
+  match n with 
+  | Some (loc, n) -> [lam_index n fixbody 0]
+  | None -> 
+      (* If recursive argument was not given by user, we try all args.
+	 An earlier approach was to look only for inductive arguments,
+	 but doing it properly involves delta-reduction, and it finally 
+         doesn't seem to worth the effort (except for huge mutual 
+	 fixpoints ?) *)
+      let m = Term.nb_prod fixtype in
+      let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in
+	list_map_i (fun i _ -> i) 0 ctx
+
 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 
+  let fixdefs, fixtypes, fiximps = 
+    list_split3
       (List.map (fun x -> 
-		   let subs = (subst_body x) in
-		     snd (decompose_lam_n len subs)) l)
+	let subs, typ = (subst_body x) in
+	  snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) 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 fixkind = Option.get (List.hd l).prg_fixkind in
+  let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
+  let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
+  let boxed = true (* TODO *) in
+  let fixnames = (List.hd l).prg_deps in
+  let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
+  let indexes, fixdecls =
+    match fixkind with
+      | IsFixpoint wfl ->
+	  let possible_indexes =
+	    list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in
+	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
+	    Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
+      | IsCoFixpoint ->
+	  None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
+  in      
+  (* Declare the recursive definitions *)
+  let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in
+    (* Declare notations *)
+    List.iter (Command.declare_interning_data ([],[])) (List.hd l).prg_notations;
+    Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames);
+    (match List.hd kns with ConstRef kn -> kn | _ -> assert false)
+      
 let declare_obligation obl body =
   let ce = 
     { const_entry_body = body;
       const_entry_type = Some obl.obl_type;
-      const_entry_opaque = obl.obl_opaque;
+      const_entry_opaque = if get_proofs_transparency () then false else obl.obl_opaque;
       const_entry_boxed = false} 
   in
   let constant = Declare.declare_constant obl.obl_name 
     (DefinitionEntry ce,IsProof Property)
   in
-    Subtac_utils.definition_message obl.obl_name;
+    print_message (Subtac_utils.definition_message obl.obl_name);
     { obl with obl_body = Some (mkConst constant) }
       
 let try_tactics obls = 
@@ -209,18 +275,19 @@ let try_tactics obls =
         
 let red = Reductionops.nf_betaiota
 
-let init_prog_info n b t deps nvrec obls =
+let init_prog_info n b t deps fixkind notations obls impls kind hook =
   let obls' = 
     Array.mapi
-      (fun i (n, t, o, d) ->
+      (fun i (n, t, l, o, 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_opaque = o;
+	   obl_location = l; obl_type = red t; obl_opaque = o;
 	   obl_deps = d })
       obls
   in
     { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
-      prg_deps = deps; prg_nvrec = nvrec; }
+      prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
+      prg_implicits = impls; prg_kind = kind; prg_hook = hook; }
     
 let get_prog name =
   let prg_infos = !from_prg in
@@ -244,44 +311,63 @@ let update_state s =
 (*   msgnl (str "Updating obligations info"); *)
   Lib.add_anonymous_leaf (input s)
 
-let obligations_message rem = 
+type progress = 
+    | Remain of int 
+    | Dependent
+    | Defined of global_reference
+	  
+let obligations_message rem =
   if rem > 0 then
     if rem = 1 then
-      Options.if_verbose msgnl (int rem ++ str " obligation remaining")
+      Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
     else
-      Options.if_verbose msgnl (int rem ++ str " obligations remaining")
+      Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
   else
-    Options.if_verbose msgnl (str "No more obligations remaining")
-      
+    Flags.if_verbose msgnl (str "No more obligations remaining")
+
 let update_obls prg obls rem = 
   let prg' = { prg with prg_obligations = (obls, rem) } in
     from_prg := map_replace prg.prg_name prg' !from_prg;
     obligations_message rem;
-    if rem > 0 then ()
-    else (
-      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));
-    update_state (!from_prg, !default_tactic_expr);
-    rem
+    let res = 
+      if rem > 0 then Remain rem
+      else (
+	match prg'.prg_deps with
+	    [] ->
+	      let kn = declare_definition prg' in
+		from_prg := ProgMap.remove prg.prg_name !from_prg;
+		Defined kn
+	  | 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 
+		  (let kn = declare_mutual_definition progs in
+		     from_prg := List.fold_left
+		       (fun acc x -> 
+			 ProgMap.remove x.prg_name acc) !from_prg progs;
+		    Defined (ConstRef kn))
+		else Dependent);
+    in
+      update_state (!from_prg, !default_tactic_expr);
+      res
 	    
 let is_defined obls x = obls.(x).obl_body <> None
 
 let deps_remaining obls deps = 
-    Intset.fold
-      (fun x acc -> 
-	 if is_defined obls x then acc
-	 else x :: acc)
-      deps []
-
+  Intset.fold
+    (fun x acc -> 
+      if is_defined obls x then acc
+      else x :: acc)
+    deps []
+
+let has_dependencies obls n =
+  let res = ref false in
+    Array.iteri
+      (fun i obl -> 
+	if i <> n && Intset.mem n obl.obl_deps then
+	  res := true)
+      obls;
+    !res
+      
 let kind_of_opacity o =
   if o then Subtac_utils.goal_proof_kind
   else Subtac_utils.goal_kind
@@ -293,6 +379,7 @@ let obligations_of_evars evars =
 	 (fun (n, t) ->
 	    { obl_name = n;
 	      obl_type = t;
+	      obl_location = dummy_loc;
 	      obl_body = None;
 	      obl_opaque = false;
 	      obl_deps = Intset.empty;
@@ -315,11 +402,15 @@ let rec solve_obligation prg num =
 		   let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in
 		   let obls = Array.copy obls in
 		   let _ = obls.(num) <- obl in
-		     if update_obls prg obls (pred rem) <> 0 then
-		       auto_solve_obligations (Some prg.prg_name));
+		     match update_obls prg obls (pred rem) with
+		     | Remain n when n > 0 ->
+			 if has_dependencies obls num then
+			   ignore(auto_solve_obligations (Some prg.prg_name))
+		     | _ -> ());
 	      trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
 		       Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
-	      Pfedit.by !default_tactic
+	      Pfedit.by !default_tactic;
+	      Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
 	| l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
 			++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
 
@@ -341,7 +432,7 @@ and solve_obligation_by_tac prg obls i tac =
       Some _ -> false
     | None -> 
 	(try
-	   if deps_remaining obls obl.obl_deps = [] then
+	    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
 	       if obl.obl_opaque then 
@@ -349,8 +440,12 @@ and solve_obligation_by_tac prg obls i tac =
 	       else
 		 obls.(i) <- { obl with obl_body = Some t };
 	       true		 
-	   else false
-	 with _ -> false)  
+	    else false
+	  with
+	    | Stdpp.Exc_located(_, Refiner.FailError (_, s))
+	    | Refiner.FailError (_, s) ->
+		user_err_loc (obl.obl_location, "solve_obligation", s)
+	    | e -> false)
 
 and solve_prg_obligations prg tac = 
   let obls, rem = prg.prg_obligations in
@@ -381,35 +476,66 @@ and try_solve_obligation n prg tac =
 and try_solve_obligations n tac = 
   try ignore (solve_obligations n tac) with NoObligations _ -> ()
 
-and auto_solve_obligations n : unit =
-  Options.if_verbose msgnl (str "Solving obligations automatically...");
-  try_solve_obligations n !default_tactic
+and auto_solve_obligations n : progress =
+  Flags.if_verbose msgnl (str "Solving obligations automatically...");
+  try solve_obligations n !default_tactic with NoObligations _ -> Dependent
       
-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
+open Pp
+let show_obligations ?(msg=true) n =
+  let prg = get_prog_err n in
+  let n = prg.prg_name in
+  let obls, rem = prg.prg_obligations in
+    if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
+    Array.iteri (fun i x -> 
+		   match x.obl_body with 
+		       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
+
+let show_term n =
+  let prg = get_prog_err n in
+  let n = prg.prg_name in
+    msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
+	    ++ my_print_constr (Global.env ()) prg.prg_body)
+
+let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook=fun x -> ()) obls =
+  Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
+  let prg = init_prog_info n b t [] None [] obls implicits kind hook 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)
+    Flags.if_verbose ppnl (str ".");    
+    let cst = declare_definition prg in 
+      from_prg := ProgMap.remove prg.prg_name !from_prg;
+      Defined cst)
   else (
     let len = Array.length obls in
-    let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
+    let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
       from_prg := ProgMap.add n prg !from_prg; 
-      auto_solve_obligations (Some n))
+      let res = auto_solve_obligations (Some n) in
+	match res with
+	  | Remain rem when rem < 5 -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
+	  | _ -> res)
 	
-let add_mutual_definitions l nvrec =
-  let deps = List.map (fun (n, b, t, obls) -> n) l in
+let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind =
+  let deps = List.map (fun (n, b, t, imps, 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)
+      (fun acc (n, b, t, imps, obls) ->
+	let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind (fun x -> ()) in
+	  ProgMap.add n prg acc)
       !from_prg l
   in
     from_prg := upd;
-    List.iter (fun x -> auto_solve_obligations (Some x)) deps
-
+    let _defined = 
+      List.fold_left (fun finished x -> 
+	if finished then finished 
+	else
+	  match auto_solve_obligations (Some x) with
+	      Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true
+	    | _ -> false) 
+	false deps
+    in ()
+	
 let admit_obligations n =
   let prg = get_prog_err n in
   let obls, rem = prg.prg_obligations in
@@ -417,7 +543,7 @@ let admit_obligations n =
 		 match x.obl_body with 
 		     None -> 
                        let x = subst_deps_obl obls x in
-		       let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in
+		       let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), IsAssumption Conjectural) in
 			 assumption_message x.obl_name;
 			 obls.(i) <- { x with obl_body = Some (mkConst kn) }
 		   | Some _ -> ())
@@ -438,18 +564,5 @@ let next_obligation n =
     array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = [])
       obls
   in solve_obligation prg i
-      
-open Pp
-let show_obligations n =
-  let prg = get_prog_err 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 (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
-			
+      			
 let default_tactic () = !default_tactic
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
index f015b80b..6d13e3bd 100644
--- a/contrib/subtac/subtac_obligations.mli
+++ b/contrib/subtac/subtac_obligations.mli
@@ -1,22 +1,42 @@
+open Names
 open Util
+open Libnames
 
-type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array
-    (* ident, type, opaque or transparent, dependencies *)
+type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array
+    (* ident, type, location, opaque or transparent, dependencies *)
 
+type progress = (* Resolution status of a program *)
+    | Remain of int  (* n obligations remaining *)
+    | Dependent (* Dependent on other definitions *)
+    | Defined of global_reference (* Defined as id *)
+	
 val set_default_tactic : Tacexpr.glob_tactic_expr -> unit
 val default_tactic : unit -> Proof_type.tactic
 
+val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
+val get_proofs_transparency : unit -> bool
+
+type definition_hook = global_reference -> unit
+
 val add_definition : Names.identifier ->  Term.constr -> Term.types -> 
-  obligation_info -> unit
+  ?implicits:(Topconstr.explicitation * (bool * bool)) list ->
+  ?kind:Decl_kinds.definition_kind ->
+  ?hook:definition_hook -> obligation_info -> progress
+
+type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list
 
 val add_mutual_definitions : 
-  (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit
+  (Names.identifier * Term.constr * Term.types *
+      (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> 
+  ?kind:Decl_kinds.definition_kind ->
+  notations ->
+  Command.fixpoint_kind -> 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 -> int 
+val solve_obligations : Names.identifier option -> Proof_type.tactic -> progress
 (* Number of remaining obligations to be solved for this program *)
 
 val solve_all_obligations : Proof_type.tactic -> unit 
@@ -25,7 +45,9 @@ val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic -
 
 val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit
 
-val show_obligations : Names.identifier option -> unit
+val show_obligations : ?msg:bool -> Names.identifier option -> unit
+
+val show_term : 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 cce9a358..0e987cf2 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 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_pretyping.ml 11047 2008-06-03 23:08:00Z msozeau $ *)
 
 open Global
 open Pp
@@ -70,7 +70,12 @@ let merge_evms x y =
 
 let interp env isevars c tycon = 
   let j = pretype tycon env isevars ([],[]) c in
-  let evm = evars_of !isevars in    
+  let _ = isevars := Evarutil.nf_evar_defs !isevars in
+  let evd,_ = consider_remaining_unif_problems env !isevars in
+(*   let unevd = undefined_evars evd in *)
+  let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env evd in
+  let evm = evars_of unevd' in
+    isevars := unevd';
     nf_evar evm j.uj_val, nf_evar evm j.uj_type
 
 let find_with_index x l =
@@ -98,7 +103,7 @@ let env_with_binders env isevars l =
 	let coqdef, deftyp = interp env isevars rawdef empty_tycon in
 	let reldecl = (name, Some coqdef, deftyp) in
 	  aux  (push_rel reldecl env, reldecl :: rels) tl
-    | Topconstr.LocalRawAssum (bl, typ) :: tl ->
+    | Topconstr.LocalRawAssum (bl, k, typ) :: tl ->
 	let rawtyp = coqintern_type !isevars env typ in
 	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
 	let acc = 
@@ -111,46 +116,28 @@ let env_with_binders env isevars l =
     | [] -> acc
   in aux (env, []) l
 
-let subtac_process env isevars id l c tycon =
-  let c = Command.abstract_constr_expr c l in
-(*   let env_binders, binders_rel = env_with_binders env isevars l in *)
+let subtac_process env isevars id bl c tycon =
+(*   let bl = Implicit_quantifiers.ctx_of_class_binders (vars_of_env env) cbl @ l in *)
+  let c = Command.abstract_constr_expr c bl in
   let tycon = 
     match tycon with
 	None -> empty_tycon
       | Some t -> 
-	  let t = Command.generalize_constr_expr t l in
+	  let t = Command.generalize_constr_expr t bl in
 	  let t = coqintern_type !isevars env t in
 	  let coqt, ttyp = interp env isevars t empty_tycon in
 	    mk_tycon coqt
   in    
   let c = coqintern_constr !isevars env c in
+  let imps = Implicit_quantifiers.implicits_of_rawterm c in
   let coqc, ctyp = interp env isevars c tycon in
-(*   let _ = try trace (str "Interpreted term: " ++ my_print_constr env coqc ++ spc () ++ *)
-(* 		 str "Coq type: " ++ my_print_constr env ctyp) *)
-(*   with _ -> () *)
-(*   in *)
-(*   let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars_of !isevars))  with _ -> () in *)
-    
-(*   let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel  *)
-(*   and fullctyp = it_mkProd_or_LetIn ctyp binders_rel *)
-(*   in *)
-  let fullcoqc = Evarutil.nf_evar (evars_of !isevars) coqc in
-  let fullctyp = Evarutil.nf_evar (evars_of !isevars) ctyp in
-(*   let evm = evars_of_term (evars_of !isevars) Evd.empty fullctyp in *)
-(*   let evm = evars_of_term (evars_of !isevars) evm fullcoqc in *)
-(*   let _ = try trace (str "After evar normalization remain: " ++ spc () ++ *)
-(* 		       Evd.pr_evar_map evm) *)
-(*   with _ -> () *)
-(*   in *)
   let evm = non_instanciated_map env isevars (evars_of !isevars) in
-(*   let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in *)
-    evm, fullcoqc, fullctyp
+    evm, coqc, (match tycon with Some (None, c) -> c | _ -> ctyp), imps
 
 open Subtac_obligations
 
-let subtac_proof env isevars id l c tycon =
-  let nc = named_context env in
-  let nc_len = named_context_length nc in
-  let evm, coqc, coqt = subtac_process env isevars id l c tycon in
-  let evars, def = Eterm.eterm_obligations id nc_len !isevars evm 0 coqc (Some coqt) in
-    add_definition id def coqt evars
+let subtac_proof kind env isevars id bl c tycon =
+  let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in
+  let evm = Subtac_utils.evars_of_term evm Evd.empty coqc in
+  let evars, def, ty = Eterm.eterm_obligations env id !isevars evm 0 coqc coqt in
+    add_definition id def ty ~implicits:imps ~kind:kind evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli
index b62a8766..1d8eb250 100644
--- a/contrib/subtac/subtac_pretyping.mli
+++ b/contrib/subtac/subtac_pretyping.mli
@@ -5,11 +5,19 @@ open Sign
 open Evd
 open Global
 open Topconstr
+open Implicit_quantifiers
+open Impargs
 
 module Pretyping : Pretyping.S
 
+val interp :
+    Environ.env ->
+    Evd.evar_defs ref ->
+    Rawterm.rawconstr ->
+    Evarutil.type_constraint -> Term.constr * Term.constr
+
 val subtac_process : env -> evar_defs ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> evar_map * constr * types
+  constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
 
-val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> unit
+val subtac_proof : Decl_kinds.definition_kind -> env -> evar_defs ref -> identifier -> local_binder list ->
+  constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml
index 53eec0b6..afa5817f 100644
--- a/contrib/subtac/subtac_pretyping_F.ml
+++ b/contrib/subtac/subtac_pretyping_F.ml
@@ -1,3 +1,4 @@
+(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac_pretyping_F.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_pretyping_F.ml 11143 2008-06-18 15:52:42Z msozeau $ *)
 
 open Pp
 open Util
@@ -67,8 +68,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	
   let mt_evd = Evd.empty
     
-  let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-      
   (* Utilisé pour inférer le prédicat des Cases *)
   (* Semble exagérement fort *)
   (* Faudra préférer une unification entre les types de toutes les clauses *)
@@ -113,7 +112,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     let id = strip_meta id in (* May happen in tactics defined by Grammar *)
       try
 	let (n,typ) = lookup_rel_id id (rel_context env) in
-	  { uj_val  = mkRel n; uj_type = type_app (lift n) typ }
+	  { uj_val  = mkRel n; uj_type = lift n typ }
       with Not_found ->
 	try
 	  List.assoc id lvar
@@ -202,11 +201,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     | RRec (loc,fixkind,names,bl,lar,vdef) ->
 	let rec type_bl env ctxt = function
             [] -> ctxt
-          | (na,None,ty)::bl ->
+          | (na,k,None,ty)::bl ->
               let ty' = pretype_type empty_valcon env isevars lvar ty in
               let dcl = (na,None,ty'.utj_val) in
 		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-          | (na,Some bd,ty)::bl ->
+          | (na,k,Some bd,ty)::bl ->
               let ty' = pretype_type empty_valcon env isevars lvar ty in
               let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
               let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
@@ -223,43 +222,47 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	let names = Array.map (fun id -> Name id) names in
 	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
 	let newenv = push_rec_types (names,ftys,[||]) env in
+	let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in
 	let vdefj =
 	  array_map2_i 
 	    (fun i ctxt def ->
-               (* we lift nbfix times the type in tycon, because of
-		* the nbfix variables pushed to newenv *)
-               let (ctxt,ty) =
-		 decompose_prod_n_assum (rel_context_length ctxt)
-                   (lift nbfix ftys.(i)) in
-               let nenv = push_rel_context ctxt newenv in
-               let j = pretype (mk_tycon ty) nenv isevars lvar def in
-		 { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
-		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+	      let fty = 
+		let ty = ftys.(i) in
+		  if i = fixi then (
+		    Option.iter (fun tycon ->
+		      isevars := Coercion.inh_conv_coerces_to loc env !isevars ftys.(i) tycon)
+		      tycon;
+		    nf_isevar !isevars ty)
+		  else ty
+	      in
+              (* we lift nbfix times the type in tycon, because of
+	       * the nbfix variables pushed to newenv *)
+              let (ctxt,ty) =
+		decompose_prod_n_assum (rel_context_length ctxt)
+                  (lift nbfix fty) in
+              let nenv = push_rel_context ctxt newenv in
+              let j = pretype (mk_tycon ty) nenv isevars lvar def in
+		{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+		  uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
             ctxtv vdef in
 	evar_type_fixpoint loc env isevars names ftys vdefj;
 	let fixj = match fixkind with
 	  | RFix (vn,i) ->
-	      let guard_indexes = Array.mapi 
+	      (* First, let's find the guard indexes. *)
+	      (* If recursive argument was not given by user, we try all args.
+	         An earlier approach was to look only for inductive arguments,
+		 but doing it properly involves delta-reduction, and it finally 
+                 doesn't seem worth the effort (except for huge mutual 
+		 fixpoints ?) *)
+	      let possible_indexes = Array.to_list (Array.mapi 
 		(fun i (n,_) -> match n with 
-		   | Some n -> n 
-		   | None -> 
-		       (* Recursive argument was not given by the user : We
-			  check that there is only one inductive argument *)
-		       let ctx = ctxtv.(i) in 
-		       let isIndApp t = 
-			 isInd (fst (decompose_app (strip_head_cast t))) in
-			 (* This could be more precise (e.g. do some delta) *)
-		       let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
-		       try (list_unique_index true lb) - 1
-		       with Not_found -> 
-			 Util.user_err_loc
-			   (loc,"pretype",
-			    Pp.str "cannot guess decreasing argument of fix"))
-		vn 
-	      in
-	      let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in
-	      (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
-	      make_judge (mkFix fix) ftys.(i)
+		   | Some n -> [n]
+		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
+		vn)
+	      in 
+	      let fixdecls = (names,ftys,Array.map j_val vdefj) in 
+	      let indexes = search_guard loc env possible_indexes fixdecls in 
+	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
 	  | RCoFix i -> 
 	      let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
 	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
@@ -292,7 +295,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
 		      let typ' = nf_isevar !isevars typ in
 		      let tycon = 
-			option_map 
+			Option.map 
 			  (fun (abs, ty) ->
 			     match abs with
 				 None ->
@@ -308,7 +311,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 			apply_rec env (n+1) 
 			  { uj_val = nf_isevar !isevars value;
 			    uj_type = nf_isevar !isevars typ' }
-			  (option_map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
+			  (Option.map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
 
 		  | _ ->
 		      let hj = pretype empty_tycon env isevars lvar c in
@@ -316,7 +319,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 			  (join_loc floc argloc) env (evars_of !isevars)
 	      		  resj [hj]
 	in
-	let ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon in
+	let ftycon = Option.map (lift_abstr_tycon_type (-1)) ftycon in
 	let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
 	let resj =
 	  match kind_of_term resj.uj_val with
@@ -328,7 +331,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  | _ -> resj in
 	  inh_conv_coerce_to_tycon loc env isevars resj tycon
 
-    | RLambda(loc,name,c1,c2)      ->
+    | RLambda(loc,name,k,c1,c2)      ->
 	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
 	let dom_valcon = valcon_of_tycon dom in
 	let j = pretype_type dom_valcon env isevars lvar c1 in
@@ -336,7 +339,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
 	  judge_of_abstraction env name j j'
 
-    | RProd(loc,name,c1,c2)        ->
+    | RProd(loc,name,k,c1,c2)        ->
 	let j = pretype_type empty_valcon env isevars lvar c1 in
 	let var = (name,j.utj_val) in
 	let env' = push_rel_assum var env in
@@ -397,7 +400,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
-		       let ci = make_default_case_info env LetStyle mis in
+		       let ci = make_case_info env mis LetStyle in
 			 mkCase (ci, p, cj.uj_val,[|f|]) in 
 		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
 
@@ -415,7 +418,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
 		     let v =
 		       let mis,_ = dest_ind_family indf in
-		       let ci = make_default_case_info env LetStyle mis in
+		       let ci = make_case_info env mis LetStyle in
 			 mkCase (ci, p, cj.uj_val,[|f|] ) 
 		     in
 		       { uj_val = v; uj_type = ccl })
@@ -485,14 +488,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	  let b2 = f cstrs.(1) b2 in
 	  let v =
 	    let mis,_ = dest_ind_family indf in
-	    let ci = make_default_case_info env IfStyle mis in
+	    let ci = make_case_info env mis IfStyle in
 	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
 	  in
 	    { uj_val = v; uj_type = p }
 
-    | RCases (loc,po,tml,eqns) ->
-	Cases.compile_cases loc
-	  ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+    | RCases (loc,sty,po,tml,eqns) ->
+	Cases.compile_cases loc sty
+	  ((fun vtyc env isevars -> pretype vtyc env isevars lvar),isevars)
 	  tycon env (* loc *) (po,tml,eqns)
 
     | RCast(loc,c,k) ->
@@ -552,15 +555,22 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		  error_unexpected_type_loc
                     (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
 
-  let pretype_gen isevars env lvar kind c =
+  let pretype_gen_aux isevars env lvar kind c =
     let c' = match kind with
       | OfType exptyp ->
 	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
 	    (pretype tycon env isevars lvar c).uj_val
       | IsType ->
 	  (pretype_type empty_valcon env isevars lvar c).utj_val in
+    let evd,_ = consider_remaining_unif_problems env !isevars in
+      isevars:=evd;
       nf_evar (evars_of !isevars) c'
 
+  let pretype_gen isevars env lvar kind c =
+    let c = pretype_gen_aux isevars env lvar kind c in
+      isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !isevars;
+      nf_evar (evars_of !isevars) c
+
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
      retourne aussi le nouveau sigma...
@@ -587,11 +597,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   let ise_pretype_gen fail_evar sigma env lvar kind c =
     let isevars = ref (Evd.create_evar_defs sigma) in
     let c = pretype_gen isevars env lvar kind c in
-    let isevars,_ = consider_remaining_unif_problems env !isevars in
-    let c = nf_evar (evars_of isevars) c in
-      if fail_evar then check_evars env sigma isevars c;
-      isevars, c
-
+    let evd = !isevars in
+      if fail_evar then check_evars env Evd.empty evd c;
+      evd, c
+	
   (** Entry points of the high-level type synthesis algorithm *)
 
   let understand_gen kind sigma env c =
@@ -601,16 +610,23 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
     snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
 
   let understand_type sigma env c =
-    snd (ise_pretype_gen true sigma env ([],[]) IsType c)
+    snd (ise_pretype_gen false sigma env ([],[]) IsType c)
 
   let understand_ltac sigma env lvar kind c =
     ise_pretype_gen false sigma env lvar kind c
       
-  let understand_tcc_evars isevars env kind c =
-    pretype_gen isevars env ([],[]) kind c
-
-  let understand_tcc sigma env ?expected_type:exptyp c =
-    let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
+  let understand_tcc_evars evdref env kind c =
+    pretype_gen evdref env ([],[]) kind c 
+
+  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
+    let ev, t = 
+      if resolve_classes then
+	ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c 
+      else
+	let isevars = ref (Evd.create_evar_defs sigma) in
+	let c = pretype_gen_aux isevars env ([],[]) (OfType exptyp) c in
+	  !isevars, c
+    in
       Evd.evars_of ev, t
 end
 
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
index 28fe6352..bae2731a 100644
--- a/contrib/subtac/subtac_utils.ml
+++ b/contrib/subtac/subtac_utils.ml
@@ -10,10 +10,10 @@ let ($) f x = f x
 (****************************************************************************)
 (* Library linking *)
 
-let contrib_name = "subtac"
+let contrib_name = "Program"
 
 let subtac_dir = [contrib_name]
-let fix_sub_module = "FixSub"
+let fix_sub_module = "Wf"
 let utils_module = "Utils"
 let fixsub_module = subtac_dir @ [fix_sub_module]
 let utils_module = subtac_dir @ [utils_module]
@@ -28,8 +28,8 @@ let make_ref l s = lazy (init_reference l s)
 let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
 let acc_ref = make_ref  ["Init";"Wf"] "Acc"
 let acc_inv_ref = make_ref  ["Init";"Wf"] "Acc_inv"
-let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub"
-let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub"
+let fix_sub_ref = make_ref fixsub_module "Fix_sub"
+let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
 let lt_ref = make_ref ["Init";"Peano"] "lt"
 let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf"
 let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
@@ -64,9 +64,15 @@ 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_refl = lazy (init_constant ["Logic";"JMeq"] "JMeq_refl")
+let jmeq_ind =   
+  lazy (check_required_library ["Coq";"Logic";"JMeq"]; 
+	init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec = 
+  lazy (check_required_library ["Coq";"Logic";"JMeq"]; 
+	init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_refl = 
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq_refl")
 
 let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
 let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
@@ -113,20 +119,20 @@ let debug_on = true
 
 let debug n s = 
   if debug_on then
-    if !Options.debug && n >= debug_level then
+    if !Flags.debug && n >= debug_level then
       msgnl s
     else ()
   else ()
 
 let debug_msg n s = 
   if debug_on then
-    if !Options.debug  && n >= debug_level then s
+    if !Flags.debug  && n >= debug_level then s
     else mt ()
   else mt ()
 
 let trace s = 
   if debug_on then
-    if !Options.debug  && debug_level > 0 then msgnl s
+    if !Flags.debug  && debug_level > 0 then msgnl s
     else ()
   else ()
 
@@ -163,7 +169,7 @@ let make_existential loc ?(opaque = true) env isevars c =
 
 let make_existential_expr loc env c =
   let key = Evarutil.new_untyped_evar () in
-  let evar = Topconstr.CEvar (loc, key) in
+  let evar = Topconstr.CEvar (loc, key, None) in
     debug 2 (str "Constructed evar " ++ int key);
     evar
 
@@ -174,6 +180,8 @@ let string_of_hole_kind = function
   | CasesType -> "CasesType"
   | InternalHole -> "InternalHole"
   | TomatchTypeParameter _ -> "TomatchTypeParameter"
+  | GoalEvar -> "GoalEvar"
+  | ImpossibleCase -> "ImpossibleCase"
 
 let evars_of_term evc init c = 
   let rec evrec acc c =
@@ -194,7 +202,7 @@ let non_instanciated_map env evd evm =
 	     QuestionMark _ -> Evd.add evm key evi
 	   | _ ->
 	       debug 2 (str " and is an implicit");
-	       Pretype_errors.error_unsolvable_implicit loc env evm k)
+	       Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
     Evd.empty (Evarutil.non_instantiated evm)
     
 let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
@@ -231,8 +239,8 @@ let build_dependent_sum l =
 	     (tclTHENS tac
 		([intros;
 		  (tclTHENSEQ 
-		     [constructor_tac (Some 1) 1 
-			(Rawterm.ImplicitBindings [mkVar n]);
+		     [constructor_tac false (Some 1) 1 
+			(Rawterm.ImplicitBindings [inj_open (mkVar n)]);
 		      cont]);
 		 ])))
 	in
@@ -342,29 +350,44 @@ let id_of_name = function
   | Anonymous -> raise (Invalid_argument "id_of_name")
 
 let definition_message id =
-  Options.if_verbose message ((string_of_id id) ^ " is defined")
-
+  Nameops.pr_id id ++ str " is defined"
+    
 let recursive_message v =
   match Array.length v with
     | 0 -> error "no recursive definition"
-    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+    | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
+    | _ -> hov 0 (prvect_with_sep pr_coma (Printer.pr_constant (Global.env ())) v ++
 		    spc () ++ str "are recursively defined")
 
+let print_message m =
+  Flags.if_verbose ppnl m
+
 (* Solve an obligation using tactics, return the corresponding proof term *)
 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 
+  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 
+    let _,(const,_,_) = Pfedit.cook_proof ignore in
       Pfedit.delete_current_proof (); const.Entries.const_entry_body
-  with e -> 
+  with e ->
     Pfedit.delete_current_proof();
-    raise Exit
+    raise e
+
+(* let apply_tac t goal = t goal *)
+
+(* let solve_by_tac evi t = *)
+(*   let ev = 1 in *)
+(*   let evm = Evd.add Evd.empty ev evi in *)
+(*   let goal = {it = evi; sigma = evm } in *)
+(*   let (res, valid) = apply_tac t goal in *)
+(*     if res.it = [] then *)
+(*       let prooftree = valid [] in *)
+(*       let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *)
+(* 	if obls = [] then proofterm *)
+(* 	else raise Exit *)
+(*     else raise Exit *)
 
 let rec string_of_list sep f = function
     [] -> ""
@@ -395,7 +418,7 @@ let pr_meta_map evd =
     | (mv,Clval(na,b,_)) ->
       	hov 0 
 	  (pr_meta mv ++ pr_name na ++ str " := " ++
-             print_constr b.rebus ++ fnl ())
+             print_constr (fst b).rebus ++ fnl ())
   in
   prlist pr_meta_binding ml    
 
@@ -440,11 +463,11 @@ let pr_evar_defs evd =
       str"METAS:"++brk(0,1)++pr_meta_map evd in
   v 0 (pp_evm ++ pp_met)
 
-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 contrib_tactics_path =
+  make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"])
+let tactics_tac s =
+  lazy(make_kn (MPfile contrib_tactics_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 tactics_call tac args =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
 
diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli
index 5a5dd427..49335211 100644
--- a/contrib/subtac/subtac_utils.mli
+++ b/contrib/subtac/subtac_utils.mli
@@ -89,11 +89,11 @@ val string_of_hole_kind : hole_kind -> string
 val evars_of_term : evar_map -> evar_map -> constr -> evar_map
 val non_instanciated_map : env -> evar_defs ref -> evar_map -> evar_map
 val global_kind : logical_kind
-val goal_kind : locality_flag * goal_object_kind
+val goal_kind : locality * goal_object_kind
 val global_proof_kind : logical_kind
-val goal_proof_kind : locality_flag * goal_object_kind
+val goal_proof_kind : locality * goal_object_kind
 val global_fix_kind : logical_kind
-val goal_fix_kind : locality_flag * goal_object_kind
+val goal_fix_kind : locality * goal_object_kind
 
 val mkSubset : name -> constr -> constr -> constr
 val mkProj1 : constr -> constr -> constr -> constr
@@ -115,8 +115,10 @@ val destruct_ex : constr -> constr -> constr list
 
 val id_of_name : name -> identifier
 
-val definition_message : identifier -> unit
-val recursive_message : global_reference array -> std_ppcmds
+val definition_message : identifier -> std_ppcmds
+val recursive_message : constant array -> std_ppcmds
+
+val print_message : std_ppcmds -> unit
 
 val solve_by_tac : evar_info -> Tacmach.tactic -> constr
 
@@ -125,6 +127,6 @@ val string_of_intset : Intset.t -> string
 
 val pr_evar_defs : evar_defs -> Pp.std_ppcmds
 
-val utils_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
+val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
 
 val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds
diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v
index 97cef9a5..da612c43 100644
--- a/contrib/subtac/test/ListDep.v
+++ b/contrib/subtac/test/ListDep.v
@@ -1,6 +1,6 @@
 (* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
 Require Import List.
-Require Import Coq.subtac.Utils.
+Require Import Coq.Program.Program.
 
 Set Implicit Arguments.
 
@@ -23,13 +23,13 @@ Section Map_DependentRecursor.
   Variable f : { x : U | In x l } -> V.
 
   Obligations Tactic := unfold sub_list in * ; 
-    subtac_simpl ; intuition.
+    program_simpl ; intuition.
 
   Program Fixpoint map_rec ( l' : list U | sub_list l' l )
     { measure length l' } : { r : list V | length r = length l' } :=
     match l' with
-    nil => nil
-    | cons x tl => let tl' := map_rec tl in
+      | nil => nil
+      | cons x tl => let tl' := map_rec tl in
 	f x :: tl'
     end.
     
diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v
index 0b40ef82..ac49ca96 100644
--- a/contrib/subtac/test/Mutind.v
+++ b/contrib/subtac/test/Mutind.v
@@ -1,13 +1,20 @@
-Program Fixpoint f (a : nat) : nat := 
+Require Import List.
+
+Program Fixpoint f a : { x : nat | x > 0 } := 
   match a with
-  | 0 => 0
+  | 0 => 1
   | S a' => g a a'
   end
-with g (a b : nat) { struct b } : nat := 
+with g a b : { x : nat | x > 0 } := 
   match b with
-  | 0 => 0
+  | 0 => 1
   | S b' => f b'
   end.
 
 Check f.
-Check g.
\ No newline at end of file
+Check g.
+
+
+
+
+
diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v
index a5a8b85f..501aa798 100644
--- a/contrib/subtac/test/euclid.v
+++ b/contrib/subtac/test/euclid.v
@@ -1,20 +1,17 @@
-Require Import Coq.subtac.Utils.
+Require Import Coq.Program.Program.
 Require Import Coq.Arith.Compare_dec.
 Notation "( x & y )" := (existS _ x y) : core_scope.
   
+Require Import Omega.
+
 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).
 
-Require Import Omega.
-
-Obligations.
-Solve Obligations using subtac_simpl ; omega.
-
 Next Obligation.
-  assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega.
+  assert(b * S q' = b * q' + b) by auto with arith ; omega.
 Defined.
 
 Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v
index 4764037d..4f938f4f 100644
--- a/contrib/subtac/test/measure.v
+++ b/contrib/subtac/test/measure.v
@@ -2,7 +2,7 @@ Notation "( x & y )" := (@existS _ _ x y) : core_scope.
 Unset Printing All.
 Require Import Coq.Arith.Compare_dec.
 
-Require Import Coq.subtac.Utils.
+Require Import Coq.Program.Program.
 
 Fixpoint size (a : nat) : nat :=
   match a with
@@ -10,15 +10,11 @@ Fixpoint size (a : nat) : nat :=
   | S n => S (size n)
   end.
 
-Program Fixpoint test_measure (a : nat) {measure a size}  : nat :=
+Program Fixpoint test_measure (a : nat) {measure size a}  : nat :=
   match a with
   | S (S n) => S (test_measure n)
-  | x => x
+  | 0 | S 0 => a
   end.
-subst.
-unfold n0.
-auto with arith.
-Qed.
 
 Check test_measure.
 Print test_measure.
\ No newline at end of file
diff --git a/contrib/subtac/test/take.v b/contrib/subtac/test/take.v
new file mode 100644
index 00000000..87ab47d6
--- /dev/null
+++ b/contrib/subtac/test/take.v
@@ -0,0 +1,38 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import JMeq.
+Require Import List.
+Require Import Coq.subtac.Utils.
+
+Set Implicit Arguments.
+
+Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } :=
+  match n with
+  | 0 => nil
+  | S p => 
+    match l with
+    | cons hd tl => let rest := take tl p in cons hd rest
+    | nil => !
+    end
+  end.
+
+Require Import Omega.
+
+Next Obligation.
+  intros.
+  simpl in l0.
+  apply le_S_n ; exact l0.
+Defined.
+
+Next Obligation.
+  intros.
+  destruct_call take ; subtac_simpl.
+Defined.
+
+Next Obligation.
+  intros.
+  inversion l0.
+Defined.
+
+
+
+
diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
index 8a5967a2..1a6cb9c8 100644
--- a/contrib/xml/cic2acic.ml
+++ b/contrib/xml/cic2acic.ml
@@ -55,18 +55,8 @@ let remove_module_dirpath_from_dirpath ~basedir dir =
 
 
 let get_uri_of_var v pvars =
- let module D = Declare in
+ let module D = Decls in
  let module N = Names in
-  let rec search_in_pvars names =
-   function
-      [] -> None
-    | ((name,l)::tl) ->
-       let names' = name::names in
-        if List.mem v l then
-         Some names'
-        else
-         search_in_pvars names' tl
-  in
   let rec search_in_open_sections =
    function
       [] -> Util.error ("Variable "^v^" not found")
@@ -78,9 +68,10 @@ let get_uri_of_var v pvars =
          search_in_open_sections tl
   in
    let path =
-    match search_in_pvars [] pvars with
-       None -> search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
-     | Some path -> path
+    if List.mem v pvars then
+      []
+    else
+      search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
    in
     "cic:" ^
      List.fold_left
@@ -241,16 +232,15 @@ let typeur sigma metamap =
     | T.Var id ->
         (try
           let (_,_,ty) = Environ.lookup_named id env in
-          T.body_of_type ty
+          ty
         with Not_found ->
           Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
     | T.Const c ->
         let cb = Environ.lookup_constant c env in
         Typeops.type_of_constant_type env (cb.Declarations.const_type)
     | T.Evar ev -> Evd.existential_type sigma ev
-    | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind)
-    | T.Construct cstr ->
-       T.body_of_type (Inductiveops.type_of_constructor env cstr)
+    | T.Ind ind -> Inductiveops.type_of_inductive env ind
+    | T.Construct cstr -> Inductiveops.type_of_constructor env cstr
     | T.Case (_,p,c,lf) ->
         let Inductiveops.IndType(_,realargs) =
           try Inductiveops.find_rectype env sigma (type_of env c)
@@ -273,7 +263,7 @@ let typeur sigma metamap =
        match sort_of env cstr with
           Coq_sort T.InProp -> T.mkProp
         | Coq_sort T.InSet -> T.mkSet
-        | Coq_sort T.InType -> T.mkType Univ.prop_univ (* ERROR HERE *)
+        | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
         | CProp -> T.mkConst DoubleTypeInference.cprop
                                                                                 
   and sort_of env t =
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
index cce78891..de8c540c 100644
--- a/contrib/xml/doubleTypeInference.ml
+++ b/contrib/xml/doubleTypeInference.ml
@@ -51,7 +51,7 @@ let type_judgment env sigma j =
 ;;
 
 let type_judgment_cprop env sigma j =
-  match Term.kind_of_term(whd_betadeltaiotacprop env sigma (Term.body_of_type j.Environ.uj_type)) with
+  match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with
     | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s }
     | _ -> None  (* None means the CProp constant *)
 ;;
diff --git a/contrib/xml/dumptree.ml4 b/contrib/xml/dumptree.ml4
new file mode 100644
index 00000000..407f86b3
--- /dev/null
+++ b/contrib/xml/dumptree.ml4
@@ -0,0 +1,152 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module provides the "Dump Tree" command that allows dumping the
+    current state of the proof stree in XML format *)
+
+(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+open Tacexpr;;
+open Decl_mode;;
+open Printer;;
+open Pp;;
+open Environ;;
+open Format;;
+open Proof_type;;
+open Evd;;
+open Termops;;
+open Ppconstr;;
+open Names;;
+
+exception Different
+
+let xmlstream s =
+  (* In XML we want to print the whole stream so we can force the evaluation *)
+  Stream.of_list (List.map xmlescape (Stream.npeek max_int s))
+;;
+
+let thin_sign osign sign =
+  Sign.fold_named_context
+    (fun (id,c,ty as d) sign ->
+       try
+        if Sign.lookup_named id osign = (id,c,ty) then sign
+         else raise Different
+       with Not_found | Different -> Environ.push_named_context_val d sign)
+    sign ~init:Environ.empty_named_context_val
+;;
+
+let pr_tactic_xml = function
+  | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" 
+  | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
+;;
+
+let pr_proof_instr_xml instr =
+  Ppdecl_proof.pr_proof_instr (Global.env()) instr
+;;
+
+let pr_rule_xml pr = function
+  | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>"
+  | Nested(cmpd, subtree) ->
+      hov 2 (str "<cmpdrule>" ++ fnl () ++
+        begin match cmpd with
+          Tactic (texp, _) -> pr_tactic_xml texp
+        | Proof_instr (_,instr) -> pr_proof_instr_xml instr
+        end ++ fnl ()
+        ++ pr subtree
+      ) ++ fnl () ++ str "</cmpdrule>"
+  | Daimon -> str "<daimon/>"
+  | Decl_proof _ -> str "<proof/>"
+(*  | Change_evars -> str "<chgevars/>"*)
+;;
+
+let pr_var_decl_xml env (id,c,typ) =
+  let ptyp = print_constr_env env typ in
+  match c with
+  | None -> 
+      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
+  | Some c ->
+      (* Force evaluation *) 
+      let pb = print_constr_env env c in
+      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
+         xmlstream pb ++ str "\"/>")
+;;
+
+let pr_rel_decl_xml env (na,c,typ) =
+  let pbody = match c with
+    | None -> mt ()
+    | Some c ->
+	(* Force evaluation *) 
+	let pb = print_constr_env env c in
+	  (str" body=\"" ++ xmlstream pb ++ str "\"") in
+  let ptyp = print_constr_env env typ in
+  let pid =
+    match na with
+    | Anonymous -> mt ()
+    | Name id -> str " id=\"" ++ pr_id id ++ str "\""
+  in
+  (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>")
+;;
+
+let pr_context_xml env =
+  let sign_env =
+    fold_named_context
+      (fun env d pp -> pp ++ pr_var_decl_xml env d)
+      env ~init:(mt ())
+  in
+  let db_env =
+    fold_rel_context
+      (fun env d pp -> pp ++ pr_rel_decl_xml env d)
+      env ~init:(mt ())
+  in
+  (sign_env ++ db_env)
+;;
+
+let pr_subgoal_metas_xml metas env=
+  let pr_one (meta, typ) = 
+    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ 
+      str "\"/>"
+  in
+  List.fold_left (++) (mt ()) (List.map pr_one metas)
+;;
+
+let pr_goal_xml g =
+  let env = try evar_env g with _ -> empty_env in
+  if g.evar_extra = None then
+    (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
+    xmlstream (pr_ltype_env_at_top env g.evar_concl) ++
+    str "\"/>" ++
+    (pr_context_xml env)) ++
+    fnl () ++ str "</goal>")
+  else
+    (hov 2 (str "<goal type=\"declarative\">" ++ 
+    (pr_context_xml env)) ++
+    fnl () ++ str "</goal>")
+;;
+
+let rec print_proof_xml sigma osign pf =
+  let hyps = Environ.named_context_of_val pf.goal.evar_hyps in
+  let hyps' = thin_sign osign hyps in
+  match pf.ref with
+    | None -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>"
+    | Some(r,spfl) ->
+        hov 2 (str "<tree>" ++ fnl () ++
+        (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++
+        (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>"
+;;
+
+let print_proof_xml () = 
+  let pp = print_proof_xml Evd.empty Sign.empty_named_context 
+      (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ())))
+  in
+  msgnl pp
+;;
+
+VERNAC COMMAND EXTEND DumpTree
+  [ "Dump" "Tree" ] -> [ print_proof_xml () ] 
+END 
diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
index 01271323..3c4b01f5 100644
--- a/contrib/xml/xmlcommand.ml
+++ b/contrib/xml/xmlcommand.ml
@@ -73,11 +73,7 @@ let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
   let tag = Libobject.object_tag o in
    print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
    match tag with
-      "CONSTANT" ->
-        (match D.constant_strength sp with
-          | DK.Local  -> false (* a local definition *)
-          | DK.Global -> true  (* a non-local one    *)
-        )
+      "CONSTANT"        -> true   (* constants/parameters are non global *)
     | "INDUCTIVE"       -> true   (* mutual inductive types are never local   *)
     | "VARIABLE"        -> false  (* variables are local, so no namesakes     *)
     | _                 -> false  (* uninteresting thing that won't be printed*)
@@ -89,8 +85,7 @@ let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
 (* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT   *)
 (* SECTION, WHOSE PATH IS namei                                     *)
 
-let pvars =
- ref ([Names.id_of_string "",[]] : (Names.identifier * string list) list);;
+let pvars = ref ([] : string list);;
 let cumenv = ref Environ.empty_env;;
 
 (* filter_params pvars hyps *)
@@ -138,9 +133,7 @@ let add_to_pvars x =
          E.push_named (Names.id_of_string v, None, typ) !cumenv ;
        v
   in
-   match !pvars with
-      []       -> assert false
-    | ((name,l)::tl) -> pvars := (name,v::l)::tl
+  pvars := v::!pvars
 ;;
 
 (* The computation is very inefficient, but we can't do anything *)
@@ -157,7 +150,7 @@ let search_variables () =
      | he::tl as modules ->
         let one_section_variables =
          let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in
-          let t = List.map N.string_of_id (Declare.last_section_hyps dirpath) in
+          let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in
            [he,t]
         in
          one_section_variables @ aux tl
@@ -329,14 +322,13 @@ let mk_variable_obj id body typ =
   let variables = search_variables () in
   let params = filter_params variables hyps'' in
    Acic.Variable
-    (Names.string_of_id id, unsharedbody,
-     (Unshare.unshare (Term.body_of_type typ)), params)
+    (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params)
 ;;
 
 (* Unsharing is not performed on the body, that must be already unshared. *)
 (* The evar map and the type, instead, are unshared by this function.     *)
 let mk_current_proof_obj is_a_variable id bo ty evar_map env =
- let unshared_ty = Unshare.unshare (Term.body_of_type ty) in
+ let unshared_ty = Unshare.unshare ty in
  let metasenv =
   List.map
    (function
@@ -384,7 +376,7 @@ let mk_current_proof_obj is_a_variable id bo ty evar_map env =
 
 let mk_constant_obj id bo ty variables hyps =
  let hyps = string_list_of_named_context_list hyps in
- let ty = Unshare.unshare (Term.body_of_type ty) in
+ let ty = Unshare.unshare ty in
  let params = filter_params variables hyps in
   match bo with
      None ->
@@ -413,7 +405,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite =
         let cons =
          (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
           (Array.mapi
-           (fun j x ->(x,Unshare.unshare (Term.body_of_type lc.(j)))) consnames)
+           (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
           []
          )
         in
@@ -447,7 +439,7 @@ let kind_of_inductive isrecord kn =
 
 let kind_of_variable id =
   let module DK = Decl_kinds in
-  match Declare.variable_kind id with
+  match Decls.variable_kind id with
     | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
     | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
     | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
@@ -458,7 +450,7 @@ let kind_of_variable id =
 
 let kind_of_constant kn = 
   let module DK = Decl_kinds in
-  match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with
+  match Decls.constant_kind kn with
     | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
     | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
     | DK.IsAssumption DK.Conjectural ->
@@ -492,6 +484,12 @@ let kind_of_constant kn =
     | DK.IsDefinition DK.IdentityCoercion ->
         Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)";
         "DEFINITION","Definition"
+    | DK.IsDefinition DK.Instance ->
+        Pp.warning "Instance not supported in dtd (used Definition instead)";
+        "DEFINITION","Definition" 
+    | DK.IsDefinition DK.Method ->
+        Pp.warning "Method not supported in dtd (used Definition instead)";
+        "DEFINITION","Definition" 
     | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) ->
         "THEOREM",DK.string_of_theorem_kind thm
     | DK.IsProof _ ->
@@ -541,11 +539,10 @@ let print internal glob_ref kind xml_library_root =
   let tag,obj =
    match glob_ref with
       Ln.VarRef id ->
-       let sp = Declare.find_section_variable id in
        (* this kn is fake since it is not provided by Coq *)
        let kn = 
         let (mod_path,dir_path) = Lib.current_prefix () in
-        N.make_kn mod_path dir_path (N.label_of_id (Ln.basename sp))
+        N.make_kn mod_path dir_path (N.label_of_id id)
        in
        let (_,body,typ) = G.lookup_named id in
         Cic2acic.Variable kn,mk_variable_obj id body typ
@@ -692,11 +689,11 @@ let _ =
              Buffer.output_buffer ch theory_buffer ;
              close_out ch
        end ;
-       Util.option_iter 
+       Option.iter 
 	(fun fn ->
 	  let coqdoc = Coq_config.bindir^"/coqdoc" in
 	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
-	  let dir = Util.out_some xml_library_root in
+	  let dir = Option.get xml_library_root in
           let command cmd =
            if Sys.command cmd <> 0 then
             Util.anomaly ("Error executing \"" ^ cmd ^ "\"")