266 files changed, 0 insertions, 87200 deletions

diff --git a/contrib/cc/README b/contrib/cc/README
deleted file mode 100644
index 073b140e..00000000
--- a/contrib/cc/README
+++ /dev/null
@@ -1,20 +0,0 @@
-
-cctac: congruence-closure for coq
-
-author: Pierre Corbineau, 
-	Stage de DEA au LSV, ENS Cachan
-	Thèse au LRI, Université Paris Sud XI 
-
-Files :
-
-- ccalgo.ml : congruence closure algorithm
-- ccproof.ml : proof generation code
-- cctac.ml4 : the tactic itself
-- CCSolve.v : a small Ltac tactic based on congruence 
-
-Known Bugs : the congruence tactic can fail due to type dependencies.
-
-Related documents:
-	Peter J. Downey, Ravi Sethi, and Robert E. Tarjan.
-	Variations on the common subexpression problem.
-	JACM, 27(4):758-771, October 1980.	
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
deleted file mode 100644
index e67797e4..00000000
--- a/contrib/cc/ccalgo.ml
+++ /dev/null
@@ -1,884 +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        *)
-(************************************************************************)
-
-(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *)
-
-(* This file implements the basic congruence-closure algorithm by *)
-(* Downey,Sethi and Tarjan. *)
-
-open Util
-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 f x = 
-  if !cc_verbose then f x
-
-let _=
-  let gdopt=
-    { optsync=true;
-      optname="Congruence Verbose";
-      optkey=SecondaryTable("Congruence","Verbose"); 
-      optread=(fun ()-> !cc_verbose); 
-      optwrite=(fun b -> cc_verbose := b)}  
-  in
-    declare_bool_option gdopt
-
-(* Signature table *)
-
-module ST=struct
-  
-  (* l: sign -> term r: term -> sign *)
-	
-  type t = {toterm:(int*int,int) Hashtbl.t;
-	    tosign:(int,int*int) Hashtbl.t}
-	
-  let empty ()=
-    {toterm=Hashtbl.create init_size;
-     tosign=Hashtbl.create init_size}
-      
-  let enter t sign st=
-    if Hashtbl.mem st.toterm sign then 
-	anomaly "enter: signature already entered"
-    else 
-	Hashtbl.replace st.toterm sign t;
-	Hashtbl.replace st.tosign t sign
-	  
-  let query sign st=Hashtbl.find st.toterm sign
-
-  let rev_query term st=Hashtbl.find st.tosign term
-	  
-  let delete st t=
-    try let sign=Hashtbl.find st.tosign t in
-	Hashtbl.remove st.toterm sign;
-	Hashtbl.remove st.tosign t
-    with
-	Not_found -> ()
-
-  let rec delete_set st s = Intset.iter (delete st) s
-	  
-end
-
-type pa_constructor=
-    { cnode : int;
-      arity : int;
-      args  : int list}
-
-type pa_fun=
-    {fsym:int;
-     fnargs:int}
-
-type pa_mark=
-    Fmark of pa_fun
-  | Cmark of pa_constructor
-
-module PacMap=Map.Make(struct 
-			 type t=pa_constructor 
-			 let compare=Pervasives.compare end) 
-
-module PafMap=Map.Make(struct 
-			 type t=pa_fun
-			 let compare=Pervasives.compare end)
-
-type cinfo=
-    {ci_constr: constructor; (* inductive type *)
-     ci_arity: int;     (* # args *)
-     ci_nhyps: int}     (* # projectable args *)
-
-type term=
-    Symb of constr
-  | Product of sorts_family * sorts_family
-  | Eps of identifier
-  | Appli of term*term
-  | Constructor of cinfo (* constructor arity + nhyps *)
-
-type ccpattern =
-    PApp of term * ccpattern list (* arguments are reversed *)
-  | PVar of int 
-
-type rule=
-    Congruence
-  | Axiom of constr * bool 
-  | Injection of int * pa_constructor * int * pa_constructor * int
-
-type from=
-    Goal
-  | Hyp of constr
-  | HeqG of constr
-  | HeqnH of constr * constr
-
-type 'a eq = {lhs:int;rhs:int;rule:'a}
-
-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:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
-let swap eq : equality =
-  let swap_rule=match eq.rule with
-      Congruence -> Congruence
-    | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k)
-    | Axiom (id,reversed) -> Axiom (id,not reversed)
-  in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
-    
-type inductive_status =
-    Unknown
-  | Partial of pa_constructor
-  | Partial_applied
-  | Total of (int * pa_constructor)
-
-type representative=
-    {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) *)
-
-type cl = Rep of representative| Eqto of int*equality
-  
-type vertex = Leaf| Node of (int*int) 
-
-type node = 
-    {mutable clas:cl;
-     mutable cpath: int; 
-     vertex:vertex;
-     term:term}
-    
-type forest=
-    {mutable max_size:int;
-     mutable size:int;
-     mutable map: node array;
-     axioms: (constr,term*term) Hashtbl.t;
-     mutable epsilons: pa_constructor list;
-     syms:(term,int) Hashtbl.t}
-
-type state = 
-    {uf: forest;
-     sigtable:ST.t;
-     mutable terms: Intset.t; 
-     combine: equality Queue.t; 
-     marks: (int * pa_mark) Queue.t;
-     mutable diseq: disequality list;
-     mutable quant: quant_eq list;
-     mutable pa_classes: Intset.t;
-     q_history: (identifier,int array) Hashtbl.t;
-     mutable rew_depth:int;
-     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});
-   cpath=min_int;
-   vertex=Leaf;
-   term=Symb (mkRel min_int)}
-
-let empty depth gls:state =
-  {uf=
-     {max_size=init_size;
-      size=0;
-      map=Array.create init_size dummy_node;
-      epsilons=[];
-      axioms=Hashtbl.create init_size;
-      syms=Hashtbl.create init_size};
-  terms=Intset.empty;
-  combine=Queue.create ();
-  marks=Queue.create ();
-  sigtable=ST.empty ();
-  diseq=[];
-  quant=[];
-  pa_classes=Intset.empty;
-  q_history=Hashtbl.create init_size;
-  rew_depth=depth;
-  by_type=Hashtbl.create init_size;
-  changed=false;
-  gls=gls}
-
-let forest state = state.uf 
-       
-let compress_path uf i j = uf.map.(j).cpath<-i
-			     
-let rec find_aux uf visited i=  
-  let j = uf.map.(i).cpath in 
-    if j<0 then let _ = List.iter (compress_path uf i) visited in i else
-      find_aux uf (i::visited) j
-	
-let find uf i= find_aux uf [] i
-		 
-let get_representative uf i=
-  match uf.map.(i).clas with
-      Rep r -> r
-    | _ -> anomaly "get_representative: not a representative"
-
-let find_pac uf i pac =
-  PacMap.find pac (get_representative uf i).constructors
-
-let get_constructor_info uf i=
-  match uf.map.(i).term with
-      Constructor cinfo->cinfo
-    | _ -> anomaly "get_constructor: not a constructor"
-	
-let size uf i=
-  (get_representative uf i).weight
-
-let axioms uf = uf.axioms
-
-let epsilons uf = uf.epsilons
-
-let add_lfather uf i t=
-  let r=get_representative uf i in
-    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.weight<-r.weight+1;
-    r.fathers <-Intset.add t r.fathers
-
-exception Discriminable of int * pa_constructor * int * pa_constructor 
-
-let append_pac t p =
-  {p with arity=pred p.arity;args=t::p.args} 
-
-let tail_pac p=
-  {p with arity=succ p.arity;args=List.tl p.args}
-
-let fsucc paf =
-  {paf with fnargs=succ paf.fnargs}
-    
-let add_pac rep pac t =
-  if not (PacMap.mem pac rep.constructors) then
-    rep.constructors<-PacMap.add pac t rep.constructors
-
-let add_paf rep paf t =
-  let already = 
-    try PafMap.find paf rep.functions with Not_found -> Intset.empty in
-    rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
-
-let term uf i=uf.map.(i).term
-		
-let subterms uf i=
-  match uf.map.(i).vertex with
-      Node(j,k) -> (j,k)
-    | _ -> anomaly "subterms: not a node"
-	
-let signature uf i=
-  let j,k=subterms uf i in (find uf j,find uf k)
-			     
-let next uf=
-  let size=uf.size in
-  let nsize= succ size in
-    if nsize=uf.max_size then
-      let newmax=uf.max_size * 3 / 2 + 1 in
-      let newmap=Array.create newmax dummy_node in
-	begin
-	  uf.max_size<-newmax;
-	  Array.blit uf.map 0 newmap 0 size;
-	  uf.map<-newmap
-	end 
-    else ();
-    uf.size<-nsize; 
-    size
-	
-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
-  | 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
-and make_app l=function
-    Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1    
-  | other -> applistc (constr_of_term other) l 
-
-(* rebuild a term from a pattern and a substitution *)
-
-let build_subst uf subst =
-  Array.map (fun i -> 
-	       try term uf i 
-	       with _ -> anomaly "incomplete matching") subst
-
-let rec inst_pattern subst = function
-    PVar i -> 
-      subst.(pred i) 
-  | PApp (t, args) -> 
-      List.fold_right
-	(fun spat f -> Appli (f,inst_pattern subst spat))
-	   args t  
-
-let 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 _ | Product (_,_) ->
-		  let paf =
-		    {fsym=b;
-		     fnargs=0} in
-		    Queue.add (b,Fmark paf) state.marks;
-		    {clas= Rep (new_representative typ);
-		     cpath= -1;
-		     vertex= Leaf;
-		     term= t}
-	      | Eps id -> 
-		  {clas= Rep (new_representative typ);
-		   cpath= -1;
-		   vertex= Leaf;
-		   term= t}
-	      | Appli (t1,t2) -> 
-		  let i1=add_term state t1 and i2=add_term state t2 in
-		    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 typ);
-		     cpath= -1;
-		     vertex= Node(i1,i2);
-		     term= t}
-	      | Constructor cinfo ->
-		  let paf =
-		    {fsym=b;
-		     fnargs=0} in
-		    Queue.add (b,Fmark paf) state.marks;
-		  let pac =
-		    {cnode= b;
-		     arity= cinfo.ci_arity;
-		     args=[]} in
-		    Queue.add (b,Cmark pac) state.marks;
-		    {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=
-  let i = add_term state s in
-  let j = add_term state t in
-    Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine;
-    Hashtbl.add state.uf.axioms c (s,t)
-
-let add_disequality state from s t =
-  let i = add_term state s in
-  let j = add_term state t in
-    state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq
-
-let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
-  state.quant<-
-    {qe_hyp_id= id;
-     qe_pol= pol;
-     qe_nvars=nvars;
-     qe_lhs= patt1;
-     qe_lhs_valid=valid1;
-     qe_rhs= patt2;
-     qe_rhs_valid=valid2}::state.quant
-
-let 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) = 
-  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 
-    node.clas<-Eqto (j,eq);
-    node.cpath<-j
-	
-let rec down_path uf i l=
-  match uf.map.(i).clas with
-      Eqto(j,t)->down_path uf j (((i,j),t)::l)
-    | Rep _ ->l
-	
-let rec min_path=function
-    ([],l2)->([],l2)
-  | (l1,[])->(l1,[])
-  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) 
-  | cpl -> cpl
-      
-let join_path uf i j=
-  assert (find uf i=find uf j);
-  min_path (down_path uf i [],down_path uf j [])
-
-let union state i1 i2 eq=
-  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.weight<-Intset.cardinal f;
-      r2.fathers<-f;
-      r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
-      ST.delete_set state.sigtable r1.fathers;
-      state.terms<-Intset.union state.terms r1.fathers;       
-      PacMap.iter 
-	(fun pac b -> Queue.add (b,Cmark pac) state.marks) 
-	r1.constructors;
-      PafMap.iter 
-	(fun paf -> Intset.iter 
-	   (fun b -> Queue.add (b,Fmark paf) state.marks)) 
-	r1.functions;
-      match r1.inductive_status,r2.inductive_status with 
-	  Unknown,_ -> ()
-	| Partial pac,Unknown -> 
-	    r2.inductive_status<-Partial pac;
-	    state.pa_classes<-Intset.remove i1 state.pa_classes;
-	    state.pa_classes<-Intset.add i2 state.pa_classes
-	| Partial _ ,(Partial _ |Partial_applied) -> 
-	    state.pa_classes<-Intset.remove i1 state.pa_classes
-	| Partial_applied,Unknown -> 
-	    r2.inductive_status<-Partial_applied	      
-	| Partial_applied,Partial _ -> 
-	    state.pa_classes<-Intset.remove i2 state.pa_classes;
-	    r2.inductive_status<-Partial_applied
-	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
-	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks    
-	| _,_ -> () 
-            
-let merge eq state = (* merge and no-merge *)
-  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
-    if i<>j then 
-      if (size uf i)<(size uf j) then
-	union state i j eq
-      else
-	union state j i (swap eq)
-
-let update t state = (* update 1 and 2 *)
-  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
-    begin
-      match rep.inductive_status with 
-	  Partial _ ->
-	    rep.inductive_status <- Partial_applied;
-	    state.pa_classes <- Intset.remove i state.pa_classes
-	| _ -> ()
-    end;
-    PacMap.iter 
-      (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) 
-      rep.constructors; 
-    PafMap.iter 
-      (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) 
-      rep.functions; 
-    try 
-      let s = ST.query sign state.sigtable in 
-	Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
-    with 
-	Not_found -> ST.enter t sign state.sigtable
-
-let process_function_mark t rep paf state  =
-  add_paf rep paf t;
-  state.terms<-Intset.union rep.lfathers state.terms
-    
-let process_constructor_mark t i rep pac state =
-    match rep.inductive_status with
-	Total (s,opac) ->
-	  if pac.cnode <> opac.cnode then (* Conflict *) 
-	    raise (Discriminable (s,opac,t,pac)) 
-	  else (* Match *)
-	    let cinfo = get_constructor_info state.uf pac.cnode in
-	    let rec f n oargs args=
-	      if n > 0 then 
-		match (oargs,args) with
-		    s1::q1,s2::q2->
-		      Queue.add 
-			{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
-			state.combine;
-		      f (n-1) q1 q2 
-		  | _-> anomaly 
-		      "add_pacs : weird error in injection subterms merge" 
-	    in f cinfo.ci_nhyps opac.args pac.args
-      | Partial_applied | Partial _ ->
-	  add_pac rep pac t;
-	  state.terms<-Intset.union rep.lfathers state.terms
-      | Unknown ->
-	  if pac.arity = 0 then
-	    rep.inductive_status <- Total (t,pac)
-	  else
-	    begin
-	      add_pac rep pac t;
-	      state.terms<-Intset.union rep.lfathers state.terms;
-	      rep.inductive_status <- Partial pac;
-	      state.pa_classes<- Intset.add i state.pa_classes
-	    end
-
-let process_mark t m state = 
-  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
-	Fmark paf -> process_function_mark t rep paf state
-      | Cmark pac -> process_constructor_mark t i rep pac state
-
-type explanation =
-    Discrimination of (int*pa_constructor*int*pa_constructor)
-  | Contradiction of disequality
-  | Incomplete
-
-let check_disequalities state =
-  let uf=state.uf in
-  let rec check_aux = function
-      dis::q -> 
-	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
-	  begin debug msgnl (str "No");check_aux q end
-    | [] -> None 
-  in
-    check_aux state.diseq
-
-let one_step state =
-    try
-      let eq = Queue.take state.combine in
-	merge eq state;
-	true
-    with Queue.Empty -> 
-      try 
-	let (t,m) = Queue.take state.marks in
-	  process_mark t m state;
-	  true
-      with Queue.Empty ->
-	try
-	  let t = Intset.choose state.terms in
-	    state.terms<-Intset.remove t state.terms;
-	    update t state;
-	    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 typ n = 
-	  if n<=0 then t else
-	    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 ct)
-    | _ -> anomaly "wrong incomplete class" 
-
-let complete state =
-  Intset.iter (complete_one_class state) state.pa_classes
-
-type matching_problem = 
-{mp_subst : int array;
- mp_inst : quant_eq;
- mp_stack : (ccpattern*int) list }
-
-let make_fun_table state =
-  let uf= state.uf in
-  let funtab=ref PafMap.empty in
-  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
-  
-
-let rec do_match state res pb_stack =
-  let mp=Stack.pop pb_stack in
-    match mp.mp_stack with
-	[] -> 
-	  res:= (mp.mp_inst,mp.mp_subst) :: !res
-      | (patt,cl)::remains ->
-	  let uf=state.uf in
-	    match patt with
-		PVar i -> 
-		  if mp.mp_subst.(pred i)<0 then  
-		    begin
-		      mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *)
-		      Stack.push {mp with mp_stack=remains} pb_stack
-		    end
-		  else
-		    if mp.mp_subst.(pred i) = cl then
-		      Stack.push {mp with mp_stack=remains} pb_stack
-		    else (* mismatch for non-linear variable in pattern *) ()
-	      | PApp (f,[]) ->
-		  begin
-		    try let j=Hashtbl.find uf.syms f in
-		      if find uf j =cl then
-			Stack.push {mp with mp_stack=remains} pb_stack
-		    with Not_found -> ()
-		  end
-	      | PApp(f, ((last_arg::rem_args) as args)) ->
-		  try 
-		    let j=Hashtbl.find uf.syms f in 
-		    let paf={fsym=j;fnargs=List.length args} in
-		    let rep=get_representative uf cl in
-		    let good_terms = PafMap.find paf rep.functions in
-		    let aux i = 
-		      let (s,t) = 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
-		  with Not_found -> ()
-
-let paf_of_patt syms = function
-    PVar _ -> invalid_arg "paf_of_patt: pattern is trivial"
-  | PApp (f,args) ->
-      {fsym=Hashtbl.find syms f;
-       fnargs=List.length args}
-
-let init_pb_stack state = 
-  let syms= state.uf.syms in
-  let pb_stack = Stack.create () in
-  let funtab = make_fun_table state in
-  let aux inst =
-    begin
-      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 
-      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
-
-let find_instances state = 
-  let pb_stack= init_pb_stack state in
-  let res =ref [] in
-  let _ =
-    debug msgnl (str "Running E-matching algorithm ... ");
-    try
-      while true do
-	check_for_interrupt ();
-	do_match state res pb_stack 
-      done;
-      anomaly "get out of here !"
-    with Stack.Empty -> () in
-    !res
-
-let rec execute first_run state =
-  debug msgnl (str "Executing ... ");
-  try
-    while 
-      check_for_interrupt ();
-      one_step state do ()
-    done;
-    match check_disequalities state with
-	None -> 
-	  if not(Intset.is_empty state.pa_classes) then
-	    begin 
-	      debug msgnl (str "First run was incomplete, completing ... ");
-	      complete state;
-	      execute false state
-	    end
-	  else 
-	    if state.rew_depth>0 then
-	      let l=find_instances state in
-		List.iter (add_inst state) l;
-		if state.changed then 
-		  begin
-		    state.changed <- false;
-		    execute true state
-		  end
-		else
-	      begin 
-		debug msgnl (str "Out of instances ... ");
-		None
-	      end
-	    else 
-	      begin 
-		debug msgnl (str "Out of depth ... ");
-		None
-	      end
-      | Some dis -> Some
-	  begin
-	    if first_run then Contradiction dis
-	    else Incomplete
-	  end
-  with Discriminable(s,spac,t,tpac) -> Some
-    begin
-      if first_run then Discrimination (s,spac,t,tpac)
-      else Incomplete
-    end
-
-
diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli
deleted file mode 100644
index cdc0065e..00000000
--- a/contrib/cc/ccalgo.mli
+++ /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        *)
-(************************************************************************)
-
-(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *)
-
-open Util
-open Term
-open Names
-
-type cinfo =
-    {ci_constr: constructor; (* inductive type *)
-     ci_arity: int;     (* # args *)
-     ci_nhyps: int}     (* # projectable args *)
-
-type term =
-    Symb of constr
-  | 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 
-
-type pa_constructor =
-    { cnode : int;
-      arity : int;
-      args  : int list}
-
-module PacMap : Map.S with type key = pa_constructor  
-
-type forest
-
-type state 
-
-type rule=
-    Congruence
-  | Axiom of constr * bool 
-  | Injection of int * pa_constructor * int * pa_constructor * int
-
-type from=
-    Goal
-  | Hyp of constr
-  | HeqG of constr
-  | HeqnH of constr*constr 
-
-type 'a eq = {lhs:int;rhs:int;rule:'a}
-
-type equality = rule eq
-
-type disequality = from eq
-
-type explanation =
-    Discrimination of (int*pa_constructor*int*pa_constructor)
-  | Contradiction of disequality
-  | Incomplete
-
-val constr_of_term : term -> constr
-
-val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
-
-val forest : state -> forest
-
-val axioms : forest -> (constr, term * term) Hashtbl.t
-
-val epsilons : forest -> pa_constructor list
-
-val empty : int -> Proof_type.goal Tacmach.sigma -> state
-
-val add_term : state -> term -> int
-
-val add_equality : state -> constr -> term -> term -> unit
-
-val add_disequality : state -> from -> term -> term -> unit
-
-val add_quant : state -> identifier -> bool -> 
-  int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
-
-val tail_pac : pa_constructor -> pa_constructor
-
-val find : forest -> int -> int
-
-val find_pac : forest -> int -> pa_constructor -> int
-
-val term : forest -> int -> term
-
-val get_constructor_info : forest -> int -> cinfo
-
-val subterms : forest -> int -> int * int
-
-val join_path : forest -> int -> int -> 
-  ((int * int) * equality) list * ((int * int) * equality) list
-
-type quant_eq=
-    {qe_hyp_id: identifier;
-     qe_pol: bool;
-     qe_nvars:int;
-     qe_lhs: ccpattern;
-     qe_lhs_valid:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
-
-type pa_fun=
-    {fsym:int;
-     fnargs:int}
-
-type matching_problem
- 
-module PafMap: Map.S with type key = pa_fun
-
-val make_fun_table : state -> Intset.t PafMap.t 
-
-val do_match :  state ->
-    (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
-
-val init_pb_stack : state -> matching_problem Stack.t
-
-val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
-
-val find_instances : state -> (quant_eq * int array) list
-
-val execute : bool -> state -> explanation option
-
-
-
-
-
-
-
-
-
-
-
-
-
-(*type pa_constructor
-
-
-module PacMap:Map.S with type key=pa_constructor
-
-type term = 
-    Symb of Term.constr 
-  | Eps
-  | Appli of term * term 
-  | Constructor of Names.constructor*int*int
-
-type rule = 
-    Congruence 
-  | Axiom of Names.identifier
-  | Injection of int*int*int*int
-
-type equality =
-    {lhs : int; 
-     rhs : int; 
-     rule : rule}
-
-module ST :
-sig
-  type t
-  val empty : unit -> t
-  val enter : int -> int * int -> t -> unit
-  val query : int * int -> t -> int
-  val delete : int -> t -> unit
-  val delete_list : int list -> t -> unit
-end
-  
-module UF :
-sig
-  type t 
-  exception Discriminable of int * int * int * int * t 
-  val empty : unit -> t
-  val find : t -> int -> int
-  val size : t -> int -> int
-  val get_constructor : t -> int -> Names.constructor
-  val pac_arity : t -> int -> int * int -> int
-  val mem_node_pac : t -> int -> int * int -> int 
-  val add_pacs : t -> int -> pa_constructor PacMap.t -> 
-    int list * equality list
-  val term : t -> int -> term    
-  val subterms : t -> int -> int * int
-  val add : t -> term -> int
-  val union : t -> int -> int -> equality -> int list * equality list
-  val join_path : t -> int -> int -> 
-    ((int*int)*equality) list*
-    ((int*int)*equality) list
-end
-  
-
-val combine_rec : UF.t -> int list -> equality list
-val process_rec : UF.t -> equality list -> int list
-
-val cc : UF.t -> unit
-  
-val make_uf :
-  (Names.identifier * (term * term)) list -> UF.t
-
-val add_one_diseq : UF.t -> (term * term) -> int * int
-
-val add_disaxioms : 
-  UF.t -> (Names.identifier * (term * term)) list -> 
-  (Names.identifier * (int * int)) list
-  
-val check_equal : UF.t -> int * int -> bool
-
-val find_contradiction : UF.t -> 
-  (Names.identifier * (int * int)) list -> 
-  (Names.identifier * (int * int))
-*)
-
-
diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml
deleted file mode 100644
index a459b18f..00000000
--- a/contrib/cc/ccproof.ml
+++ /dev/null
@@ -1,153 +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        *)
-(************************************************************************)
-
-(* $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   *)
-
-open Util
-open Names
-open Term
-open Ccalgo
-  
-type rule=
-    Ax of constr
-  | SymAx of constr
-  | Refl of term
-  | Trans of proof*proof
-  | Congr of proof*proof
-  | Inject of proof*constructor*int*int 
-and proof = 
-    {p_lhs:term;p_rhs:term;p_rule:rule}
-
-let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t}
-
-let pcongr p1 p2 = 
-  match p1.p_rule,p2.p_rule with 
-    Refl t1, Refl t2 -> prefl (Appli (t1,t2))
-  | _, _ -> 
-      {p_lhs=Appli (p1.p_lhs,p2.p_lhs);
-       p_rhs=Appli (p1.p_rhs,p2.p_rhs);
-       p_rule=Congr (p1,p2)}
-
-let rec ptrans p1 p3=
-  match p1.p_rule,p3.p_rule with
-      Refl _, _ ->p3
-    | _, Refl _ ->p1
-    | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3)
-    | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4)
-    | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) ->
-	ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5
-  | _, _ -> 
-      if p1.p_rhs = p3.p_lhs then 
-	{p_lhs=p1.p_lhs;
-	 p_rhs=p3.p_rhs;
-	 p_rule=Trans (p1,p3)}
-      else anomaly "invalid cc transitivity"
-	
-let rec psym p = 
-  match p.p_rule with 
-      Refl _ -> p 
-    | SymAx s ->
-	{p_lhs=p.p_rhs;
-	 p_rhs=p.p_lhs;
-	 p_rule=Ax s}
-    | Ax s->      
-	{p_lhs=p.p_rhs;
-	 p_rhs=p.p_lhs;
-	 p_rule=SymAx s}
-  | Inject (p0,c,n,a)-> 
-      {p_lhs=p.p_rhs;
-       p_rhs=p.p_lhs;
-       p_rule=Inject (psym p0,c,n,a)}
-  | Trans (p1,p2)-> ptrans (psym p2) (psym p1)
-  | Congr (p1,p2)-> pcongr (psym p1) (psym p2)
-
-let pax axioms s =
-  let l,r = Hashtbl.find axioms s in
-    {p_lhs=l;
-     p_rhs=r;
-     p_rule=Ax s}
-
-let psymax axioms s =
-  let l,r = Hashtbl.find axioms s in
-    {p_lhs=r;
-     p_rhs=l;
-     p_rule=SymAx s}
-
-let rec nth_arg t n=
-  match t with 
-      Appli (t1,t2)-> 
-	if n>0 then 
-	  nth_arg t1 (n-1)
-	else t2
-    | _ -> anomaly "nth_arg: not enough args"
-
-let pinject p c n a =
-  {p_lhs=nth_arg p.p_lhs (n-a);
-   p_rhs=nth_arg p.p_rhs (n-a);
-   p_rule=Inject(p,c,n,a)}
-
-let build_proof uf=
-
-  let axioms = axioms uf in
-
-  let rec equal_proof i j=
-    if i=j then prefl (term uf i) else 
-      let (li,lj)=join_path uf i j in
-	ptrans (path_proof i li) (psym (path_proof j lj))
-  
-  and edge_proof ((i,j),eq)=
-    let pi=equal_proof i eq.lhs in
-    let pj=psym (equal_proof j eq.rhs) in
-    let pij=
-      match eq.rule with 
-	  Axiom (s,reversed)->
-	    if reversed then psymax axioms s 
-	    else pax axioms s
-	| Congruence ->congr_proof eq.lhs eq.rhs
-	| Injection (ti,ipac,tj,jpac,k) ->
-	    let p=ind_proof ti ipac tj jpac in
-	    let cinfo= get_constructor_info uf ipac.cnode in
-	      pinject p cinfo.ci_constr cinfo.ci_nhyps k	
-    in  ptrans (ptrans pi pij) pj
-
-  and constr_proof i t ipac=
-    if ipac.args=[] then
-      equal_proof i t
-    else
-      let npac=tail_pac ipac in
-      let (j,arg)=subterms uf t in
-      let targ=term uf arg in
-      let rj=find uf j in
-      let u=find_pac uf rj npac in
-      let p=constr_proof j u npac in
-	ptrans (equal_proof i t) (pcongr p (prefl targ))
-
-  and path_proof i=function
-      [] -> prefl (term uf i)
-    | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x)
-  
-  and congr_proof i j=
-    let (i1,i2) = subterms uf i
-    and (j1,j2) = subterms uf j in   
-      pcongr (equal_proof i1 j1) (equal_proof i2 j2)
-	
-  and ind_proof i ipac j jpac=
-    let p=equal_proof i j 
-    and p1=constr_proof i i ipac 
-    and p2=constr_proof j j jpac in
-      ptrans (psym p1) (ptrans p p2)
-  in
-    function
-	`Prove (i,j) -> equal_proof i j
-      | `Discr (i,ci,j,cj)-> ind_proof i ci j cj
-
-
-
diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli
deleted file mode 100644
index 0eb97efe..00000000
--- a/contrib/cc/ccproof.mli
+++ /dev/null
@@ -1,31 +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        *)
-(************************************************************************)
-
-(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *)
-
-open Ccalgo
-open Names
-open Term
-
-type rule=
-    Ax of constr
-  | SymAx of constr
-  | Refl of term
-  | Trans of proof*proof
-  | Congr of proof*proof
-  | Inject of proof*constructor*int*int 
-and proof = 
-    private {p_lhs:term;p_rhs:term;p_rule:rule}
-
-val build_proof : 
-  forest -> 
-  [ `Discr of int * pa_constructor * int * pa_constructor
-  | `Prove of int * int ] -> proof
-
-
-
diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml
deleted file mode 100644
index 00cbbeee..00000000
--- a/contrib/cc/cctac.ml
+++ /dev/null
@@ -1,465 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: cctac.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
-
-(* This file is the interface between the c-c algorithm and Coq *)
-
-open Evd
-open Proof_type
-open Names
-open Libnames
-open Nameops
-open Inductiveops
-open Declarations
-open Term
-open Termops
-open Tacmach
-open Tactics
-open Tacticals
-open Typing
-open Ccalgo
-open Tacinterp
-open Ccproof
-open Pp
-open Util
-open Format
-
-let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
-
-let _f_equal = constant ["Init";"Logic"] "f_equal"
-
-let _eq_rect = constant ["Init";"Logic"] "eq_rect"
-
-let _refl_equal = constant ["Init";"Logic"] "refl_equal"
-
-let _sym_eq = constant ["Init";"Logic"] "sym_eq"
-
-let _trans_eq = constant ["Init";"Logic"] "trans_eq"
-
-let _eq = constant ["Init";"Logic"] "eq"
-
-let _False = constant ["Init";"Logic"] "False"
-
-let whd env=
-  let infos=Closure.create_clos_infos Closure.betaiotazeta env in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
-
-let whd_delta env=
-   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
-
-(* decompose member of equality in an applicative format *)
-
-let sf_of env sigma c = family_of_sort (destSort (whd_delta env (type_of env sigma c)))
-
-let rec decompose_term env sigma t=
-    match kind_of_term (whd env t) with
-      App (f,args)->
-	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
-	  Constructor {ci_constr=c;
-		       ci_arity=nargs;
-		       ci_nhyps=nargs-oib.mind_nparams}
-    | _ ->if closed0 t then (Symb t) else raise Not_found
-	
-(* decompose equality in members and type *)
-	
-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 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 sigma c =
-  match kind_of_term (whd env c) with
-      App (f,args)->
-	let pf = decompose_term env sigma f in
-	let pargs,lrels = List.split 
-	  (array_map_to_list (pattern_of_constr env sigma) args) in
-	  PApp (pf,List.rev pargs),
-	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 sigma c in
-	  PApp (pf,[]),Intset.empty
-
-let non_trivial = function
-    PVar _ -> false
-  | _ -> true
-
-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 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 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 sigma nrels atom in
-	      `Nrule patts
-	else 
-	  quantified_atom_of_constr env sigma (succ nrels) ff
-    | _ ->  
-	let patts=patterns_of_constr env sigma nrels term in
-	    `Rule patts	  
-
-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 sigma atom) with
-	      `Eq(t,a,b) -> `Neq(t,a,b)
-	    | `Other(p) -> `Nother(p)
-	else
-	  begin
-	    try 
-	      quantified_atom_of_constr env sigma 1 ff  
-	    with Not_found ->
-	      `Other (decompose_term env sigma term)
-	  end
-    | _ -> 
-	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 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 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 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 ->
-		 List.iter 
-		   (fun (cidn,nh) -> 
-		      add_disequality state (HeqnH (cid,cidn)) ph nh) 
-		   !neg_hyps;
-		 pos_hyps:=(cid,ph):: !pos_hyps
-	     | `Nother nh ->
-		 List.iter 
-		   (fun (cidp,ph) -> 
-		      add_disequality state (HeqnH (cidp,cid)) ph nh) 
-		   !pos_hyps;
-		 neg_hyps:=(cid,nh):: !neg_hyps
-	     | `Rule patts -> add_quant state id true patts
-	     | `Nrule patts -> add_quant state id false patts
-	 end) (Environ.named_context_of_val gls.it.evar_hyps);
-    begin
-      match atom_of_constr env sigma gls.it.evar_concl with
-	  `Eq (t,a,b) -> add_disequality state Goal a b
-	|	`Other g ->  
-		  List.iter 
-	      (fun (idp,ph) -> 
-		 add_disequality state (HeqG idp) ph g) !pos_hyps
-    end;
-    state
-
-(* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
-
-let build_projection intype outtype (cstr:constructor) special default gls=
-  let env=pf_env gls in 
-  let (h,argv) = 
-    try destApp intype with 
-	Invalid_argument _ -> (intype,[||])  in
-  let ind=destInd h in 
-  let types=Inductiveops.arities_of_constructors env ind in
-  let lp=Array.length types in
-  let ci=pred (snd cstr) in
-  let branch i=
-    let ti=Term.prod_appvect types.(i) argv in
-    let rc=fst (Sign.decompose_prod_assum ti) in
-    let head=
-      if i=ci then special else default in  
-      Sign.it_mkLambda_or_LetIn head rc in
-  let branches=Array.init lp branch in
-  let casee=mkRel 1 in
-  let pred=mkLambda(Anonymous,intype,outtype) 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)
-  
-(* generate an adhoc tactic following the proof tree  *)
-
-let _M =mkMeta
-
-let rec proof_tac p gls =
-  match p.p_rule with
-      Ax c -> exact_check c gls
-    | SymAx c -> 
-	let l=constr_of_term p.p_lhs and 
-	    r=constr_of_term p.p_rhs 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 = 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 = 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
-    | Congr (p1,p2)->
-	let tf1=constr_of_term p1.p_lhs 
-	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 = 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
-	let prf = 
-	  mkApp(Lazy.force _trans_eq,
-		[|typfx;
-		  mkApp(tf1,[|tx1|]);
-		  mkApp(tf2,[|tx1|]);
-		  mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in
-	  tclTHENS (refine prf)
-	    [tclTHEN (refine lemma1) (proof_tac p1);
-  	     tclFIRST
-	       [tclTHEN (refine lemma2) (proof_tac p2);
-		reflexivity;
-		fun gls ->
-		  errorlabstrm  "Congruence" 
-		    (Pp.str 
-		       "I don't know how to handle dependent equality")]] gls
-  | Inject (prf,cstr,nargs,argind) ->
-	 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=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=
-	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in 
-	   tclTHEN (refine injt) (proof_tac prf) gls
-
-let refute_tac c t1 t2 p gls =      
-  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let intype=refresh_universes (pf_type_of gls tt1) in
-  let neweq=
-    mkApp(Lazy.force _eq,
-	  [|intype;tt1;tt2|]) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
-  let false_t=mkApp (c,[|mkVar hid|]) in
-    tclTHENS (assert_tac (Name hid) neweq)
-      [proof_tac p; simplest_elim false_t] 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=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
-  let identity=mkLambda (Name x,sort,mkRel 1) in 
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
-    tclTHENS (assert_tac (Name e) neweq) 
-      [proof_tac p;exact_check endt] gls
-
-let convert_to_hyp_tac c1 t1 c2 t2 p gls =
-  let tt2=constr_of_term t2 in
-  let h=pf_get_new_id (id_of_string "H") gls in
-  let false_t=mkApp (c2,[|mkVar h|]) in
-    tclTHENS (assert_tac (Name h) tt2)
-      [convert_to_goal_tac c1 t1 t2 p;
-       simplest_elim false_t] 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=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
-  let tid=pf_get_new_id (id_of_string "t") gls in
-  let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
-  let trivial=pf_type_of gls identity in
-  let outtype=mkType (new_univ ()) in
-  let pred=mkLambda(Name xid,outtype,mkRel 1) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in     
-  let proj=build_projection intype outtype cstr trivial concl gls in
-  let injt=mkApp (Lazy.force _f_equal,
-		  [|intype;outtype;proj;t1;t2;mkVar hid|]) in   
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|outtype;trivial;pred;identity;concl;injt|]) in
-  let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in
-    tclTHENS (assert_tac (Name hid) neweq) 
-      [proof_tac p;exact_check endt] gls
-      
-(* wrap everything *)
-	
-let build_term_to_complete uf meta pac =
-  let cinfo = get_constructor_info uf pac.cnode in
-  let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
-  let dummy_args = List.rev (list_tabulate meta pac.arity) in
-  let all_args = List.rev_append real_args dummy_args in
-    applistc (mkConstruct cinfo.ci_constr) all_args
-      
-let cc_tactic depth additionnal_terms gls=
-  Coqlib.check_required_library ["Coq";"Init";"Logic"];
-  let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
-  let state = make_prb gls depth additionnal_terms in
-  let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
-  let sol = execute true state in
-  let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
-  let uf=forest state in
-    match sol with
-	None -> tclFAIL 0 (str "congruence failed") gls  
-      | Some reason ->
-	  debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
-	  match reason with
-	      Discrimination (i,ipac,j,jpac) ->
-		let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
-		let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
-		  discriminate_tac cstr p gls
-	    | Incomplete ->
-		let metacnt = ref 0 in
-		let newmeta _ = incr metacnt; _M !metacnt in
-		let terms_to_complete = 
-		  List.map 
-		    (build_term_to_complete uf newmeta) 
-		    (epsilons uf) in 
-		  Pp.msgnl
-		    (Pp.str "Goal is solvable by congruence but \
- some arguments are missing.");
-		  Pp.msgnl
-		    (Pp.str "  Try " ++
-		     hov 8
-		       begin 
-			 str "\"congruence with (" ++  
-			 prlist_with_sep 
-			   (fun () -> str ")" ++ pr_spc () ++ str "(")
-			   (print_constr_env (pf_env gls))
-			   terms_to_complete ++ 
-			 str ")\","
-		       end);
-		  Pp.msgnl
-		    (Pp.str "  replacing metavariables by arbitrary terms.");
-		  tclFAIL 0 (str "Incomplete") gls
-	    | Contradiction dis ->
-		let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
-		let ta=term uf dis.lhs and tb=term uf dis.rhs in
-		  match dis.rule with
-		      Goal -> proof_tac p gls
-		    | Hyp id -> refute_tac id ta tb p gls
-		    | HeqG id -> 
-			convert_to_goal_tac id ta tb p gls
-		    | HeqnH (ida,idb) -> 
-			convert_to_hyp_tac ida ta idb tb p gls
-		    
-
-let cc_fail gls =
-  errorlabstrm  "Congruence" (Pp.str "congruence failed.")     
-
-let congruence_tac depth l = 
-  tclORELSE 
-    (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) 
-    cc_fail
-
-(* Beware: reflexivity = constructor 1 = apply refl_equal
-   might be slow now, let's rather do something equivalent
-   to a "simple apply refl_equal" *)
-
-let simple_reflexivity () = apply (Lazy.force _refl_equal)
-
-(* 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|])))
-      (simple_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
deleted file mode 100644
index 57ad0558..00000000
--- a/contrib/cc/cctac.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        *)
-(************************************************************************)
-
-(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *)
-
-open Term 
-open Proof_type
-
-val proof_tac: Ccproof.proof -> Proof_type.tactic
-
-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
deleted file mode 100644
index 9877e6fc..00000000
--- a/contrib/cc/g_congruence.ml4
+++ /dev/null
@@ -1,29 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *)
-
-open Cctac
-open Tactics
-open Tacticals
-
-(* Tactic registration *)
-      
-TACTIC EXTEND cc
- [ "congruence" ] -> [ congruence_tac 1000 [] ]
- |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
- |[ "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/ArrayPermut.v b/contrib/correctness/ArrayPermut.v
deleted file mode 100644
index 30f5ac8f..00000000
--- a/contrib/correctness/ArrayPermut.v
+++ /dev/null
@@ -1,175 +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: ArrayPermut.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(****************************************************************************)
-(*                    Permutations of elements in arrays                    *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require Import ProgInt.
-Require Import Arrays.
-Require Export Exchange.
-
-Require Import Omega.
-
-Set Implicit Arguments.
-
-(* We define "permut" as the smallest equivalence relation which contains
- * transpositions i.e. exchange of two elements.
- *)
-
-Inductive permut (n:Z) (A:Set) : array n A -> array n A -> Prop :=
-  | exchange_is_permut :
-      forall (t t':array n A) (i j:Z), exchange t t' i j -> permut t t'
-  | permut_refl : forall t:array n A, permut t t
-  | permut_sym : forall t t':array n A, permut t t' -> permut t' t
-  | permut_trans :
-      forall t t' t'':array n A, permut t t' -> permut t' t'' -> permut t t''.
-
-Hint Resolve exchange_is_permut permut_refl permut_sym permut_trans: v62
-  datatypes.
-
-(* We also define the permutation on a segment of an array, "sub_permut",
- * the other parts of the array being unchanged
- *
- * One again we define it as the smallest equivalence relation containing
- * transpositions on the given segment.
- *)
-
-Inductive sub_permut (n:Z) (A:Set) (g d:Z) :
-array n A -> array n A -> Prop :=
-  | exchange_is_sub_permut :
-      forall (t t':array n A) (i j:Z),
-        (g <= i <= d)%Z ->
-        (g <= j <= d)%Z -> exchange t t' i j -> sub_permut g d t t'
-  | sub_permut_refl : forall t:array n A, sub_permut g d t t
-  | sub_permut_sym :
-      forall t t':array n A, sub_permut g d t t' -> sub_permut g d t' t
-  | sub_permut_trans :
-      forall t t' t'':array n A,
-        sub_permut g d t t' -> sub_permut g d t' t'' -> sub_permut g d t t''.
-
-Hint Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym
-  sub_permut_trans: v62 datatypes.
-
-(* To express that some parts of arrays are equal we introduce the
- * property "array_id" which says that a segment is the same on two
- * arrays.
- *)
-
-Definition array_id (n:Z) (A:Set) (t t':array n A) 
-  (g d:Z) := forall i:Z, (g <= i <= d)%Z -> #t [i] = #t' [i].
-
-(* array_id is an equivalence relation *)
-
-Lemma array_id_refl :
- forall (n:Z) (A:Set) (t:array n A) (g d:Z), array_id t t g d.
-Proof.
-unfold array_id in |- *.
-auto with datatypes.
-Qed.
-
-Hint Resolve array_id_refl: v62 datatypes.
-
-Lemma array_id_sym :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   array_id t t' g d -> array_id t' t g d.
-Proof.
-unfold array_id in |- *. intros.
-symmetry  in |- *; auto with datatypes.
-Qed.
-
-Hint Resolve array_id_sym: v62 datatypes.
-
-Lemma array_id_trans :
- forall (n:Z) (A:Set) (t t' t'':array n A) (g d:Z),
-   array_id t t' g d -> array_id t' t'' g d -> array_id t t'' g d.
-Proof.
-unfold array_id in |- *. intros.
-apply trans_eq with (y := #t' [i]); auto with datatypes.
-Qed.
-
-Hint Resolve array_id_trans: v62 datatypes.
-
-(* Outside the segment [g,d] the elements are equal *)
-
-Lemma sub_permut_id :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' ->
-   array_id t t' 0 (g - 1) /\ array_id t t' (d + 1) (n - 1).
-Proof.
-intros n A t t' g d. simple induction 1; intros.
-elim H2; intros.
-unfold array_id in |- *; split; intros.
-apply H7; omega.
-apply H7; omega.
-auto with datatypes.
-decompose [and] H1; auto with datatypes.
-decompose [and] H1; decompose [and] H3; eauto with datatypes.
-Qed.
-
-Hint Resolve sub_permut_id.
-
-Lemma sub_permut_eq :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' ->
-   forall i:Z, (0 <= i < g)%Z \/ (d < i < n)%Z -> #t [i] = #t' [i].
-Proof.
-intros n A t t' g d Htt' i Hi.
-elim (sub_permut_id Htt'). unfold array_id in |- *. 
-intros.
-elim Hi; [ intro; apply H; omega | intro; apply H0; omega ].
-Qed.
-
-(* sub_permut is a particular case of permutation *)
-
-Lemma sub_permut_is_permut :
- forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
-   sub_permut g d t t' -> permut t t'.
-Proof.
-intros n A t t' g d. simple induction 1; intros; eauto with datatypes.
-Qed.
-
-Hint Resolve sub_permut_is_permut.
-
-(* If we have a sub-permutation on an empty segment, then we have a 
- * sub-permutation on any segment.
- *)
-
-Lemma sub_permut_void :
- forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
-   (d < g)%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
-Proof.
-intros N A t t' g g' d d' Hdg.
-simple induction 1; intros.
-absurd (g <= d)%Z; omega.
-auto with datatypes.
-auto with datatypes.
-eauto with datatypes.
-Qed.
-
-(* A sub-permutation on a segment may be extended to any segment that
- * contains the first one.
- *)
-
-Lemma sub_permut_extension :
- forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
-   (g' <= g)%Z -> (d <= d')%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
-Proof.
-intros N A t t' g g' d d' Hgg' Hdd'.
-simple induction 1; intros.
-apply exchange_is_sub_permut with (i := i) (j := j);
- [ omega | omega | assumption ].
-auto with datatypes.
-auto with datatypes.
-eauto with datatypes.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v
deleted file mode 100644
index 3a6aaaf8..00000000
--- a/contrib/correctness/Arrays.v
+++ /dev/null
@@ -1,78 +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: Arrays.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(**********************************************)
-(* Functional arrays, for use in Correctness. *)
-(**********************************************)
-
-(* This is an axiomatization of arrays.
- *
- * The type (array N T) is the type of arrays ranging from 0 to N-1 
- * which elements are of type T.
- *
- * Arrays are created with new, accessed with access and modified with store. 
- *
- * Operations of accessing and storing are not guarded, but axioms are.
- * So these arrays can be viewed as arrays where accessing and storing
- * out of the bounds has no effect.
- *)
-
-
-Require Export ProgInt.
-
-Set Implicit Arguments.
-
-
-(* The type of arrays *)
-
-Parameter array : Z -> Set -> Set.
-
-
-(* Functions to create, access and modify arrays *)
-
-Parameter new : forall (n:Z) (T:Set), T -> array n T.
-
-Parameter access : forall (n:Z) (T:Set), array n T -> Z -> T.
-
-Parameter store : forall (n:Z) (T:Set), array n T -> Z -> T -> array n T.
-
-
-(* Axioms *)
-
-Axiom
-  new_def :
-    forall (n:Z) (T:Set) (v0:T) (i:Z),
-      (0 <= i < n)%Z -> access (new n v0) i = v0.
-
-Axiom
-  store_def_1 :
-    forall (n:Z) (T:Set) (t:array n T) (v:T) (i:Z),
-      (0 <= i < n)%Z -> access (store t i v) i = v.
-
-Axiom
-  store_def_2 :
-    forall (n:Z) (T:Set) (t:array n T) (v:T) (i j:Z),
-      (0 <= i < n)%Z ->
-      (0 <= j < n)%Z -> i <> j -> access (store t i v) j = access t j.
-
-Hint Resolve new_def store_def_1 store_def_2: datatypes v62.
-
-(* A tactic to simplify access in arrays *)
-
-Ltac array_access i j H :=
-  elim (Z_eq_dec i j);
-   [ intro H; rewrite H; rewrite store_def_1
-   | intro H; rewrite store_def_2; [ idtac | idtac | idtac | exact H ] ].
-
-(* Symbolic notation for access *)
-
-Notation "# t [ c ]" := (access t c) (at level 0, t at level 0).
\ No newline at end of file
diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v
deleted file mode 100644
index a8a2858f..00000000
--- a/contrib/correctness/Arrays_stuff.v
+++ /dev/null
@@ -1,16 +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: Arrays_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Exchange.
-Require Export ArrayPermut.
-Require Export Sorted.
-
diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v
deleted file mode 100644
index b7513d09..00000000
--- a/contrib/correctness/Correctness.v
+++ /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: Correctness.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(* Correctness is base on the tactic Refine (developped on purpose) *)
-
-Require Export Tuples.
-
-Require Export ProgInt.
-Require Export ProgBool.
-Require Export Zwf.
-
-Require Export Arrays.
-
-(*
-Token "'".
-*)
\ No newline at end of file
diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v
deleted file mode 100644
index 035a98f2..00000000
--- a/contrib/correctness/Exchange.v
+++ /dev/null
@@ -1,95 +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: Exchange.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(****************************************************************************)
-(*                   Exchange of two elements in an array                   *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require Import ProgInt.
-Require Import Arrays.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Inductive exchange (n:Z) (A:Set) (t t':array n A) (i j:Z) : Prop :=
-    exchange_c :
-      (0 <= i < n)%Z ->
-      (0 <= j < n)%Z ->
-      #t [i] = #t' [j] ->
-      #t [j] = #t' [i] ->
-      (forall k:Z, (0 <= k < n)%Z -> k <> i -> k <> j -> #t [k] = #t' [k]) ->
-      exchange t t' i j.
-    
-(* Properties about exchanges *)
-
-Lemma exchange_1 :
- forall (n:Z) (A:Set) (t:array n A) (i j:Z),
-   (0 <= i < n)%Z ->
-   (0 <= j < n)%Z -> #(store (store t i #t [j]) j #t [i]) [i] = #t [j].
-Proof.
-intros n A t i j H_i H_j.
-case (dec_eq j i).
-intro eq_i_j. rewrite eq_i_j.
-auto with datatypes.
-intro not_j_i.
-rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_i not_j_i).
-auto with datatypes.
-Qed.
-
-Hint Resolve exchange_1: v62 datatypes.
-
-
-Lemma exchange_proof :
- forall (n:Z) (A:Set) (t:array n A) (i j:Z),
-   (0 <= i < n)%Z ->
-   (0 <= j < n)%Z -> exchange (store (store t i #t [j]) j #t [i]) t i j.
-Proof.
-intros n A t i j H_i H_j.
-apply exchange_c; auto with datatypes.
-intros k H_k not_k_i not_k_j.
-cut (j <> k); auto with datatypes. intro not_j_k.
-rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_k not_j_k).
-auto with datatypes.
-Qed.
-
-Hint Resolve exchange_proof: v62 datatypes.
-
-
-Lemma exchange_sym :
- forall (n:Z) (A:Set) (t t':array n A) (i j:Z),
-   exchange t t' i j -> exchange t' t i j.
-Proof.
-intros n A t t' i j H1.
-elim H1. clear H1. intros.
-constructor 1; auto with datatypes.
-intros. rewrite (H3 k); auto with datatypes.
-Qed.
-
-Hint Resolve exchange_sym: v62 datatypes.
-
-
-Lemma exchange_id :
- forall (n:Z) (A:Set) (t t':array n A) (i j:Z),
-   exchange t t' i j ->
-   i = j -> forall k:Z, (0 <= k < n)%Z -> #t [k] = #t' [k].
-Proof.
-intros n A t t' i j Hex Heq k Hk.
-elim Hex. clear Hex. intros.
-rewrite Heq in H1. rewrite Heq in H2.
-case (Z_eq_dec k j). 
-  intro Heq'. rewrite Heq'. assumption.
-  intro Hnoteq. apply (H3 k); auto with datatypes. rewrite Heq. assumption.
-Qed.
-
-Hint Resolve exchange_id: v62 datatypes.
\ No newline at end of file
diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v
deleted file mode 100644
index 38448efc..00000000
--- a/contrib/correctness/ProgBool.v
+++ /dev/null
@@ -1,66 +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: ProgBool.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Import ZArith.
-Require Export Bool_nat.
-Require Export Sumbool.
-
-Definition annot_bool :
-  forall b:bool, {b' : bool | if b' then b = true else b = false}.
-Proof.
-intro b.
-exists b. case b; trivial.
-Qed.
-
-
-(* Logical connectives *)
-
-Definition spec_and (A B C D:Prop) (b:bool) := if b then A /\ C else B \/ D.
-
-Definition prog_bool_and :
-  forall Q1 Q2:bool -> Prop,
-    sig Q1 ->
-    sig Q2 ->
-    {b : bool | if b then Q1 true /\ Q2 true else Q1 false \/ Q2 false}.
-Proof.
-intros Q1 Q2 H1 H2.
-elim H1. intro b1. elim H2. intro b2. 
-case b1; case b2; intros.
-exists true; auto.
-exists false; auto. exists false; auto. exists false; auto.
-Qed.
-
-Definition spec_or (A B C D:Prop) (b:bool) := if b then A \/ C else B /\ D.
-
-Definition prog_bool_or :
-  forall Q1 Q2:bool -> Prop,
-    sig Q1 ->
-    sig Q2 ->
-    {b : bool | if b then Q1 true \/ Q2 true else Q1 false /\ Q2 false}.
-Proof.
-intros Q1 Q2 H1 H2.
-elim H1. intro b1. elim H2. intro b2. 
-case b1; case b2; intros.
-exists true; auto. exists true; auto. exists true; auto.
-exists false; auto.
-Qed.
-
-Definition spec_not (A B:Prop) (b:bool) := if b then B else A.
-
-Definition prog_bool_not :
-  forall Q:bool -> Prop, sig Q -> {b : bool | if b then Q false else Q true}.
-Proof.
-intros Q H.
-elim H. intro b.
-case b; intro.
-exists false; auto. exists true; auto.
-Qed.
diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v
deleted file mode 100644
index b1eaaea7..00000000
--- a/contrib/correctness/ProgInt.v
+++ /dev/null
@@ -1,19 +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: ProgInt.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export ZArith.
-Require Export ZArith_dec.
-
-Theorem Znotzero : forall x:Z, {x <> 0%Z} + {x = 0%Z}.
-Proof.
-intro x. elim (Z_eq_dec x 0); auto.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
deleted file mode 100644
index 70f4b730..00000000
--- a/contrib/correctness/ProgramsExtraction.v
+++ /dev/null
@@ -1,28 +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: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *)
-
-Extract Inductive unit => unit [ "()" ].
-Extract Inductive bool => bool [ true false ].
-Extract Inductive sumbool => bool [ true false ].
-
-Require Export Correctness.
-
-Declare ML Module "pextract".
-
-Grammar vernac vernac : ast :=
-  imperative_ocaml [ "Write" "Caml" "File" stringarg($file) 
-    "[" ne_identarg_list($idl) "]" "." ]
-     -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ]
-
-| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ]
-     -> [ (INITIALIZE $id $c) ]
-.
diff --git a/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v
deleted file mode 100644
index 6489de81..00000000
--- a/contrib/correctness/Programs_stuff.v
+++ /dev/null
@@ -1,13 +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: Programs_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Arrays_stuff.
diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v
deleted file mode 100644
index ca4ed880..00000000
--- a/contrib/correctness/Sorted.v
+++ /dev/null
@@ -1,202 +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        *)
-(************************************************************************)
-
-(*  Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *)
-
-(* $Id: Sorted.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Arrays.
-Require Import ArrayPermut.
-
-Require Import ZArithRing.
-Require Import Omega.
-Open Local Scope Z_scope.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Definition sorted_array (N:Z) (A:array N Z) (deb fin:Z) :=
-  deb <= fin -> forall x:Z, x >= deb -> x < fin -> #A [x] <= #A [x + 1].
-
-(* Elements of a sorted sub-array are in increasing order *)
-
-(* one element and the next one *)
-
-Lemma sorted_elements_1 :
- forall (N:Z) (A:array N Z) (n m:Z),
-   sorted_array A n m ->
-   forall k:Z,
-     k >= n -> forall i:Z, 0 <= i -> k + i <= m -> #A [k] <= #A [k + i].
-Proof.
-intros N A n m H_sorted k H_k i H_i.
-pattern i in |- *. apply natlike_ind.
-intro.
-replace (k + 0) with k; omega. (*** Ring `k+0` => BUG ***)
-
-intros.
-apply Zle_trans with (m := #A [k + x]).
-apply H0; omega.
-
-unfold Zsucc in |- *.
-replace (k + (x + 1)) with (k + x + 1).
-unfold sorted_array in H_sorted.
-apply H_sorted; omega.
-
-omega.
-
-assumption.
-Qed.
-
-(* one element and any of the following *)
-
-Lemma sorted_elements :
- forall (N:Z) (A:array N Z) (n m k l:Z),
-   sorted_array A n m ->
-   k >= n -> l < N -> k <= l -> l <= m -> #A [k] <= #A [l].
-Proof.
-intros.
-replace l with (k + (l - k)).
-apply sorted_elements_1 with (n := n) (m := m);
- [ assumption | omega | omega | omega ].
-omega.
-Qed.
-
-Hint Resolve sorted_elements: datatypes v62.
-
-(* A sub-array of a sorted array is sorted *)
-
-Lemma sub_sorted_array :
- forall (N:Z) (A:array N Z) (deb fin i j:Z),
-   sorted_array A deb fin ->
-   i >= deb -> j <= fin -> i <= j -> sorted_array A i j.
-Proof.
-unfold sorted_array in |- *.
-intros.
-apply H; omega.
-Qed.
-
-Hint Resolve sub_sorted_array: datatypes v62.
-
-(* Extension on the left of the property of being sorted *)
-
-Lemma left_extension :
- forall (N:Z) (A:array N Z) (i j:Z),
-   i > 0 ->
-   j < N ->
-   sorted_array A i j -> #A [i - 1] <= #A [i] -> sorted_array A (i - 1) j.
-Proof.
-intros; unfold sorted_array in |- *; intros.
-elim (Z_ge_lt_dec x i).   (* (`x >= i`) + (`x < i`) *)
-intro Hcut.
-apply H1; omega.
-
-intro Hcut.
-replace x with (i - 1).
-replace (i - 1 + 1) with i; [ assumption | omega ].
-
-omega.
-Qed.
-
-(* Extension on the right *)
-
-Lemma right_extension :
- forall (N:Z) (A:array N Z) (i j:Z),
-   i >= 0 ->
-   j < N - 1 ->
-   sorted_array A i j -> #A [j] <= #A [j + 1] -> sorted_array A i (j + 1).
-Proof.
-intros; unfold sorted_array in |- *; intros.
-elim (Z_lt_ge_dec x j).
-intro Hcut. 
-apply H1; omega.
-
-intro HCut.
-replace x with j; [ assumption | omega ].
-Qed.
-
-(* Substitution of the leftmost value by a smaller value *) 
-
-Lemma left_substitution :
- forall (N:Z) (A:array N Z) (i j v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j -> v <= #A [i] -> sorted_array (store A i v) i j.
-Proof.
-intros N A i j v H_i H_j H_sorted H_v.
-unfold sorted_array in |- *; intros.
-
-cut (x = i \/ x > i).
-intro Hcut; elim Hcut; clear Hcut; intro.
-rewrite H2.
-rewrite store_def_1; try omega.
-rewrite store_def_2; try omega.
-apply Zle_trans with (m := #A [i]); [ assumption | apply H_sorted; omega ].
-
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H_sorted; omega.
-omega.
-Qed.
-
-(* Substitution of the rightmost value by a larger value *)
-
-Lemma right_substitution :
- forall (N:Z) (A:array N Z) (i j v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j -> #A [j] <= v -> sorted_array (store A j v) i j.
-Proof.
-intros N A i j v H_i H_j H_sorted H_v.
-unfold sorted_array in |- *; intros.
-
-cut (x = j - 1 \/ x < j - 1).
-intro Hcut; elim Hcut; clear Hcut; intro.
-rewrite H2.
-replace (j - 1 + 1) with j; [ idtac | omega ]. (*** Ring `j-1+1`. => BUG ***)
-rewrite store_def_2; try omega.
-rewrite store_def_1; try omega.
-apply Zle_trans with (m := #A [j]). 
-apply sorted_elements with (n := i) (m := j); try omega; assumption.
-assumption.
-
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H_sorted; omega.
-
-omega.
-Qed.
-
-(* Affectation outside of the sorted region *)
-
-Lemma no_effect :
- forall (N:Z) (A:array N Z) (i j k v:Z),
-   i >= 0 ->
-   j < N ->
-   sorted_array A i j ->
-   0 <= k < i \/ j < k < N -> sorted_array (store A k v) i j.
-Proof.
-intros.
-unfold sorted_array in |- *; intros. 
-rewrite store_def_2; try omega.
-rewrite store_def_2; try omega.
-apply H1; assumption.
-Qed.
-
-Lemma sorted_array_id :
- forall (N:Z) (t1 t2:array N Z) (g d:Z),
-   sorted_array t1 g d -> array_id t1 t2 g d -> sorted_array t2 g d.
-Proof.
-intros N t1 t2 g d Hsorted Hid.
-unfold array_id in Hid.
-unfold sorted_array in Hsorted. unfold sorted_array in |- *.
-intros Hgd x H1x H2x.
-rewrite <- (Hid x); [ idtac | omega ].
-rewrite <- (Hid (x + 1)); [ idtac | omega ].
-apply Hsorted; assumption.
-Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v
deleted file mode 100644
index c7071f32..00000000
--- a/contrib/correctness/Tuples.v
+++ /dev/null
@@ -1,98 +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: Tuples.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(* Tuples *)
-
-Definition tuple_1 (X:Set) := X.
-Definition tuple_2 := prod.
-Definition Build_tuple_2 := pair.
-Definition proj_2_1 := fst.
-Definition proj_2_2 := snd.
-
-Record tuple_3 (T1 T2 T3:Set) : Set := 
-  {proj_3_1 : T1; proj_3_2 : T2; proj_3_3 : T3}.
-
-Record tuple_4 (T1 T2 T3 T4:Set) : Set := 
-  {proj_4_1 : T1; proj_4_2 : T2; proj_4_3 : T3; proj_4_4 : T4}.
-
-Record tuple_5 (T1 T2 T3 T4 T5:Set) : Set := 
-  {proj_5_1 : T1; proj_5_2 : T2; proj_5_3 : T3; proj_5_4 : T4; proj_5_5 : T5}.
-
-Record tuple_6 (T1 T2 T3 T4 T5 T6:Set) : Set := 
-  {proj_6_1 : T1;
-   proj_6_2 : T2;
-   proj_6_3 : T3;
-   proj_6_4 : T4;
-   proj_6_5 : T5;
-   proj_6_6 : T6}.
-
-Record tuple_7 (T1 T2 T3 T4 T5 T6 T7:Set) : Set := 
-  {proj_7_1 : T1;
-   proj_7_2 : T2;
-   proj_7_3 : T3;
-   proj_7_4 : T4;
-   proj_7_5 : T5;
-   proj_7_6 : T6;
-   proj_7_7 : T7}.
-
-
-(* Existentials *)
-
-Definition sig_1 := sig.
-Definition exist_1 := exist.
-
-Inductive sig_2 (T1 T2:Set) (P:T1 -> T2 -> Prop) : Set :=
-    exist_2 : forall (x1:T1) (x2:T2), P x1 x2 -> sig_2 T1 T2 P.
-
-Inductive sig_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Prop) : Set :=
-    exist_3 : forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> sig_3 T1 T2 T3 P.
-
-
-Inductive sig_4 (T1 T2 T3 T4:Set) (P:T1 -> T2 -> T3 -> T4 -> Prop) : Set :=
-    exist_4 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4),
-        P x1 x2 x3 x4 -> sig_4 T1 T2 T3 T4 P.
-
-Inductive sig_5 (T1 T2 T3 T4 T5:Set) (P:T1 -> T2 -> T3 -> T4 -> T5 -> Prop) :
-Set :=
-    exist_5 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5),
-        P x1 x2 x3 x4 x5 -> sig_5 T1 T2 T3 T4 T5 P.
-
-Inductive sig_6 (T1 T2 T3 T4 T5 T6:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> Prop) : Set :=
-    exist_6 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6), P x1 x2 x3 x4 x5 x6 -> sig_6 T1 T2 T3 T4 T5 T6 P.
-
-Inductive sig_7 (T1 T2 T3 T4 T5 T6 T7:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> Prop) : Set :=
-    exist_7 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6) (x7:T7),
-        P x1 x2 x3 x4 x5 x6 x7 -> sig_7 T1 T2 T3 T4 T5 T6 T7 P.
-
-Inductive sig_8 (T1 T2 T3 T4 T5 T6 T7 T8:Set)
-(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> T8 -> Prop) : Set :=
-    exist_8 :
-      forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) 
-        (x6:T6) (x7:T7) (x8:T8),
-        P x1 x2 x3 x4 x5 x6 x7 x8 -> sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P.      
-
-Inductive dep_tuple_2 (T1 T2:Set) (P:T1 -> T2 -> Set) : Set :=
-    Build_dep_tuple_2 :
-      forall (x1:T1) (x2:T2), P x1 x2 -> dep_tuple_2 T1 T2 P.
-
-Inductive dep_tuple_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Set) : Set :=
-    Build_dep_tuple_3 :
-      forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> dep_tuple_3 T1 T2 T3 P.
-
diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v
deleted file mode 100644
index abb1cc76..00000000
--- a/contrib/correctness/examples/Handbook.v
+++ /dev/null
@@ -1,232 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \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: Handbook.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* This file contains proofs of programs taken from the
- * "Handbook of Theoretical Computer Science", volume B,
- * chapter "Methods and Logics for Proving Programs", by P. Cousot,
- * pp 841--993, Edited by J. van Leeuwen (c) Elsevier Science Publishers B.V.
- * 1990.
- * 
- * Programs are refered to by numbers and pages.
- *)
-
-Require Correctness.
-
-Require Sumbool.
-Require Omega.
-Require Zcomplements.
-Require Zpower.
-
-(****************************************************************************)
-
-(* program (2) page 853 to compute x^y (annotated version is (25) page 860) *)
-
-(* en attendant... *)
-Parameter Zdiv2  : Z->Z.
-
-Parameter Zeven_odd_dec : (x:Z){`x=2*(Zdiv2 x)`}+{`x=2*(Zdiv2 x)+1`}.
-Definition Zodd_dec := [z:Z](sumbool_not ? ? (Zeven_odd_dec z)).
-Definition Zodd_bool := [z:Z](bool_of_sumbool ? ? (Zodd_dec z)).
-
-Axiom axiom1 : (x,y:Z) `y>0` -> `x*(Zpower x (Zpred y)) = (Zpower x y)`.
-Axiom axiom2 : (x:Z)`x>0` -> `(Zdiv2 x)<x`.
-Axiom axiom3 : (x,y:Z) `y>=0` -> `(Zpower (x*x) (Zdiv2 y)) = (Zpower x y)`.
-
-Global Variable X : Z ref.
-Global Variable Y : Z ref.
-Global Variable Z_ : Z ref.
-
-Correctness pgm25
-  { `Y >= 0` }
-  begin
-    Z_ := 1;
-    while !Y <> 0 do
-      { invariant `Y >= 0` /\ `Z_ * (Zpower X Y) = (Zpower X@0 Y@0)`
-        variant Y }
-      if (Zodd_bool !Y) then begin
-      	Y := (Zpred !Y);
-	Z_ := (Zmult !Z_ !X)
-      end else begin
-      	Y := (Zdiv2 !Y);	
-	X := (Zmult !X !X)
-      end
-    done
-  end
-  { Z_ = (Zpower X@ Y@) }.
-Proof.
-Split.
-Unfold Zpred; Unfold Zwf; Omega.
-Split.
-Unfold Zpred; Omega.
-Decompose [and] Pre2.
-Rewrite <- H0.
-Replace `Z_1*X0*(Zpower X0 (Zpred Y0))` with `Z_1*(X0*(Zpower X0 (Zpred Y0)))`.
-Apply f_equal with f := (Zmult Z_1).
-Apply axiom1.
-Omega.
-
-Auto.
-Symmetry.
-Apply Zmult_assoc_r.
-
-Split.
-Unfold Zwf.
-Repeat (Apply conj).
-Omega.
-
-Omega.
-
-Apply axiom2. Omega.
-
-Split.
-Omega.
-
-Decompose [and] Pre2.
-Rewrite <- H0.
-Apply f_equal with f:=(Zmult Z_1).
-Apply axiom3. Omega.
-
-Omega.
-
-Decompose [and] Post6.
-Rewrite <- H2.
-Rewrite H0.
-Simpl.
-Omega.
-
-Save.
-
-
-(****************************************************************************)
-
-(* program (178) page 934 to compute the factorial using global variables
- * annotated version is (185) page 939
- *)
-
-Parameter Zfact : Z -> Z.
-
-Axiom axiom4 : `(Zfact 0) = 1`.
-Axiom axiom5 : (x:Z) `x>0` -> `(Zfact (x-1))*x=(Zfact x)`.
-
-Correctness pgm178
-let rec F (u:unit) : unit { variant X } =
-  { `X>=0` }
-  (if !X = 0 then
-    Y := 1
-  else begin
-    label L;
-    X := (Zpred !X);
-    (F tt);
-    X := (Zs !X);
-    Y := (Zmult !Y !X)
-  end)
-  { `X=X@` /\ `Y=(Zfact X@)` }.
-Proof.
-Rewrite Test1. Rewrite axiom4. Auto.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Unfold Zs. Unfold Zpred in Post3. Split.
-Omega.
-Decompose [and] Post3.
-Rewrite H.
-Replace `X0+(-1)+1` with X0.
-Rewrite H0.
-Replace `X0+(-1)` with `X0-1`.
-Apply axiom5.
-Omega.
-Omega.
-Omega.
-Save.
-
-
-(****************************************************************************)
-
-(* program (186) page 939 "showing the usefulness of auxiliary variables" ! *)
-
-Global Variable N : Z ref.
-Global Variable S : Z ref.
-
-Correctness pgm186
-let rec F (u:unit) : unit { variant N } =
-  { `N>=0` }
-  (if !N > 0 then begin
-    label L;
-    N := (Zpred !N);
-    (F tt);
-    S := (Zs !S);
-    (F tt);
-    N := (Zs !N)
-  end)
-  { `N=N@` /\ `S=S@+(Zpower 2 N@)-1` }.
-Proof.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Decompose [and] Post5. Rewrite H. Unfold Zwf. Unfold Zpred. Omega.
-Decompose [and] Post5. Rewrite H. Unfold Zpred. Omega.
-Split.
-Unfold Zpred in Post5. Omega.
-Decompose [and] Post4. Rewrite H0. 
-Decompose [and] Post5. Rewrite H2. Rewrite H1. 
-Replace `(Zpower 2 N0)` with `2*(Zpower 2 (Zpred N0))`. Omega.
-Symmetry.
-Replace `(Zpower 2 N0)` with `(Zpower 2 (1+(Zpred N0)))`.
-Replace `2*(Zpower 2 (Zpred N0))` with `(Zpower 2 1)*(Zpower 2 (Zpred N0))`.
-Apply Zpower_exp.
-Omega.
-Unfold Zpred. Omega.
-Auto.
-Replace `(1+(Zpred N0))` with N0; [ Auto | Unfold Zpred; Omega ].
-Split.
-Auto.
-Replace N0 with `0`; Simpl; Omega.
-Save.
-
-
-(****************************************************************************)
-
-(* program (196) page 944 (recursive factorial procedure with value-result
- * parameters)
- *)
-
-Correctness pgm196
-let rec F (U:Z) (V:Z ref) : unit { variant U } =
-  { `U >= 0` }
-  (if U = 0 then
-    V := 1
-  else begin
-    (F (Zpred U) V);	
-    V := (Zmult !V U)
-  end)
-  { `V = (Zfact U)` }.
-Proof.
-Symmetry. Rewrite Test1. Apply axiom4.
-Unfold Zwf. Unfold Zpred. Omega.
-Unfold Zpred. Omega.
-Rewrite Post3. 
-Unfold Zpred. Replace `U0+(-1)` with `U0-1`. Apply axiom5.
-Omega.
-Omega.
-Save.
-
-(****************************************************************************)
-
-(* program (197) page 945 (L_4 subset of Pascal) *)
-
-(*
-procedure P(X:Z; procedure Q(Z:Z));
-  procedure L(X:Z); begin Q(X-1) end;
-  begin if X>0 then P(X-1,L) else Q(X) end;
-
-procedure M(N:Z);
-  procedure R(X:Z); begin writeln(X) (* => RES := !X *) end;
-  begin P(N,R) end.
-*)
diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v
deleted file mode 100644
index 3142e906..00000000
--- a/contrib/correctness/examples/exp.v
+++ /dev/null
@@ -1,204 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \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: exp.v 1577 2001-04-11 07:56:19Z filliatr $ i*)
-
-(* Efficient computation of X^n using
- * 
- *    X^(2n)   =     (X^n) ^ 2
- *    X^(2n+1) = X . (X^n) ^ 2
- *
- * Proofs of both fonctional and imperative programs.
- *)
-
-Require Even.
-Require Div2.
-Require Correctness.
-Require ArithRing.
-Require ZArithRing.
-
-(* The specification uses the traditional definition of X^n *)
-
-Fixpoint power [x,n:nat] : nat :=
-  Cases n of
-    O      => (S O)
-  | (S n') => (mult x (power x n'))
-  end.
-
-Definition square := [n:nat](mult n n).
-
-
-(* Three lemmas are necessary to establish the forthcoming proof obligations *)
-
-(* n = 2*(n/2) => (x^(n/2))^2 = x^n *)
-
-Lemma exp_div2_0 : (x,n:nat)
-     n=(double (div2 n)) 
-  -> (square (power x (div2 n)))=(power x n).
-Proof.
-Unfold square.
-Intros x n. Pattern n. Apply ind_0_1_SS.
-Auto.
-
-Intro. (Absurd (1)=(double (0)); Auto).
-
-Intros. Simpl.
-Cut n0=(double (div2 n0)).
-Intro. Rewrite <- (H H1).
-Ring.
-
-Simpl in H0.
-Unfold double in H0.
-Simpl in H0.
-Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
-(Injection H0; Auto).
-Save.
-
-(* n = 2*(n/2)+1 => x*(x^(n/2))^2 = x^n *)
-
-Lemma exp_div2_1 : (x,n:nat) 
-     n=(S (double (div2 n)))
-  -> (mult x (square (power x (div2 n))))=(power x n).
-Proof.
-Unfold square.
-Intros x n. Pattern n. Apply ind_0_1_SS.
-
-Intro. (Absurd (0)=(S (double (0))); Auto).
-
-Auto.
-
-Intros. Simpl.
-Cut n0=(S (double (div2 n0))).
-Intro. Rewrite <- (H H1).
-Ring.
-
-Simpl in H0.
-Unfold double in H0.
-Simpl in H0.
-Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
-(Injection H0; Auto).
-Save.
-
-(* x^(2*n) = (x^2)^n *)
-
-Lemma power_2n : (x,n:nat)(power x (double n))=(power (square x) n).
-Proof.
-Unfold double. Unfold square.
-Induction n.
-Auto.
-
-Intros.
-Simpl.
-Rewrite <- H.
-Rewrite <- (plus_n_Sm n0 n0).
-Simpl.
-Auto with arith.
-Save.
-
-Hints Resolve exp_div2_0 exp_div2_1.
-
-
-(* Functional version.
- * 
- * Here we give the functional program as an incomplete CIC term,
- * using the tactic Refine.
- *
- * On this example, it really behaves as the tactic Program.
- *)
-
-(*
-Lemma f_exp : (x,n:nat) { y:nat | y=(power x n) }.
-Proof.
-Refine [x:nat]
-  (well_founded_induction nat lt lt_wf
-    [n:nat]{y:nat | y=(power x n) }
-    [n:nat]
-    [f:(p:nat)(lt p n)->{y:nat | y=(power x p) }]
-      	     Cases (zerop n) of 
-               (left _) => (exist ? ? (S O) ?)
-      	     | (right _) => 
-      	       	  let (y,H) = (f (div2 n) ?) in 
-      	       	  Cases (even_odd_dec n) of
-      	       	    (left _) => (exist ? ? (mult y y) ?)
-                  | (right _) => (exist ? ? (mult x (mult y y)) ?)
-		  end
-	     end).
-Proof.
-Rewrite a. Auto.
-Exact (lt_div2 n a).
-Change (square y)=(power x n). Rewrite H. Auto with arith.
-Change (mult x (square y))=(power x n). Rewrite H. Auto with arith.
-Save.
-*)
-
-(* Imperative version. *)
-
-Definition even_odd_bool := [x:nat](bool_of_sumbool ? ? (even_odd_dec x)).
-
-Correctness i_exp
-  fun (x:nat)(n:nat) ->
-    let y = ref (S O) in
-    let m = ref x in
-    let e = ref n in
-    begin
-      while (notzerop_bool !e) do
-        { invariant (power x n)=(mult y (power m e)) as Inv
-          variant e for lt }
-        (if not (even_odd_bool !e) then y := (mult !y !m))
-          { (power x n) = (mult y (power m (double (div2 e)))) as Q };
-        m := (square !m);
-        e := (div2 !e)
-      done;
-      !y
-    end
-    { result=(power x n) }
-.
-Proof.
-Rewrite (odd_double e0 Test1) in Inv. Rewrite Inv. Simpl. Auto with arith.
-
-Rewrite (even_double e0 Test1) in Inv. Rewrite Inv. Reflexivity.
-
-Split.
-Exact (lt_div2 e0 Test2).
-
-Rewrite Q. Unfold double. Unfold square.
-Simpl. 
-Change (mult y1 (power m0 (double (div2 e0))))
-     = (mult y1 (power (square m0) (div2 e0))).
-Rewrite (power_2n m0 (div2 e0)). Reflexivity.
-
-Auto with arith.
-
-Decompose [and] Inv.
-Rewrite H. Rewrite H0.
-Auto with arith.
-Save.
-
-
-(* Recursive version. *)
-
-Correctness r_exp
-  let rec exp (x:nat) (n:nat) : nat { variant n for lt} =
-    (if (zerop_bool n) then
-       (S O)
-     else
-       let y = (exp x (div2 n)) in
-       if (even_odd_bool n) then
-         (mult y y)
-       else
-         (mult x (mult y y))
-    ) { result=(power x n) }
-.
-Proof.
-Rewrite Test2. Auto.
-Exact (lt_div2 n0 Test2).
-Change (square y)=(power x0 n0). Rewrite Post7. Auto with arith.
-Change (mult x0 (square y))=(power x0 n0). Rewrite Post7. Auto with arith.
-Save.
diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v
deleted file mode 100644
index 044263ca..00000000
--- a/contrib/correctness/examples/exp_int.v
+++ /dev/null
@@ -1,218 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \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: exp_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Efficient computation of X^n using
- * 
- *    X^(2n)   =     (X^n) ^ 2
- *    X^(2n+1) = X . (X^n) ^ 2
- *
- * Proofs of both fonctional and imperative programs.
- *)
-
-Require Zpower.
-Require Zcomplements.
-
-Require Correctness.
-Require ZArithRing.
-Require Omega.
-
-Definition Zdouble := [n:Z]`2*n`.
-
-Definition Zsquare := [n:Z](Zmult n n).
-
-(* Some auxiliary lemmas about Zdiv2 are necessary *)
-
-Lemma Zdiv2_ge_0 : (x:Z) `x >= 0` -> `(Zdiv2 x) >= 0`.
-Proof.
-Destruct x; Auto with zarith.
-Destruct p; Auto with zarith.
-Simpl. Omega.
-Intros. (Absurd `(NEG p) >= 0`; Red; Auto with zarith).
-Save.
-
-Lemma Zdiv2_lt : (x:Z) `x > 0` -> `(Zdiv2 x) < x`.
-Proof.
-Destruct x.
-Intro. Absurd `0 > 0`; [ Omega | Assumption ].
-Destruct p; Auto with zarith.
-
-Simpl.
-Intro p0.
-Replace (POS (xI p0)) with `2*(POS p0)+1`.
-Omega.
-Simpl. Auto with zarith.
-
-Intro p0.
-Simpl.
-Replace (POS (xO p0)) with `2*(POS p0)`.
-Omega.
-Simpl. Auto with zarith.
-
-Simpl. Omega.
-
-Intros. 
-Absurd `(NEG p) > 0`; Red; Auto with zarith.
-Elim p; Auto with zarith.
-Omega.
-Save.
-
-(* A property of Zpower:  x^(2*n) = (x^2)^n *)
-
-Lemma Zpower_2n : 
-  (x,n:Z)`n >= 0` -> (Zpower x (Zdouble n))=(Zpower (Zsquare x) n).
-Proof.
-Unfold Zdouble.
-Intros x n Hn.
-Replace `2*n` with `n+n`.
-Rewrite Zpower_exp.
-Pattern n.
-Apply natlike_ind.
-
-Simpl. Auto with zarith.
-
-Intros.
-Unfold Zs.
-Rewrite Zpower_exp.
-Rewrite Zpower_exp.
-Replace (Zpower x `1`) with x.
-Replace (Zpower (Zsquare x) `1`) with (Zsquare x).
-Rewrite <- H0.
-Unfold Zsquare.
-Ring.
-
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-
-Omega.
-Omega.
-Omega.
-Omega.
-Omega.
-Assumption.
-Assumption.
-Omega.
-Save.
-
-
-(* The program *)
-
-Correctness i_exp
-  fun (x:Z)(n:Z) ->
-    { `n >= 0` }
-   (let y = ref 1 in
-    let m = ref x in
-    let e = ref n in
-    begin
-      while !e > 0 do
-        { invariant (Zpower x n)=(Zmult y (Zpower m e)) /\ `e>=0` as Inv
-          variant e }
-        (if not (Zeven_odd_bool !e) then y := (Zmult !y !m))
-          { (Zpower x n) = (Zmult y (Zpower m (Zdouble (Zdiv2 e)))) as Q };
-        m := (Zsquare !m);
-        e := (Zdiv2 !e)
-      done;
-      !y
-    end)
-    { result=(Zpower x n) }
-.
-Proof.
-(* Zodd *)
-Decompose [and] Inv.
-Rewrite (Zodd_div2 e0 H0 Test1) in H. Rewrite H.
-Rewrite Zpower_exp.
-Unfold Zdouble.
-Replace (Zpower m0 `1`) with m0.
-Ring.
-Unfold Zpower; Unfold Zpower_pos; Simpl; Ring.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Omega.
-(* Zeven *)
-Decompose [and] Inv.
-Rewrite (Zeven_div2 e0 Test1) in H. Rewrite H.
-Auto with zarith.
-Split.
-(* Zwf *)
-Unfold Zwf.
-Repeat Split.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Omega.
-Exact (Zdiv2_lt e0 Test2).
-(* invariant *)
-Split.
-Rewrite Q. Unfold Zdouble. Unfold Zsquare.
-Rewrite (Zpower_2n).
-Trivial.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Generalize (Zdiv2_ge_0 e0); Omega.
-Split; [ Ring | Assumption ].
-(* exit fo loop *)
-Decompose [and] Inv.
-Cut `e0 = 0`. Intro.
-Rewrite H1. Rewrite H.
-Simpl; Ring.
-Omega.
-Save.
-
-
-(* Recursive version. *)
-
-Correctness r_exp
-  let rec exp (x:Z) (n:Z) : Z { variant n } =
-    { `n >= 0` }
-    (if n = 0 then
-       1
-     else
-       let y = (exp x (Zdiv2 n)) in
-       (if (Zeven_odd_bool n) then
-       	  (Zmult y y)
-        else
-          (Zmult x (Zmult y y))) { result=(Zpower x n) as Q }
-    ) 
-    { result=(Zpower x n) }
-.
-Proof.
-Rewrite Test2. Auto with zarith.
-(* w.f. *)
-Unfold Zwf.
-Repeat Split.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Generalize (Zdiv2_lt n0) ; Omega.
-(* rec. call *)
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-(* invariant: case even *)
-Generalize (Zeven_div2 n0 Test1).
-Intro Heq. Rewrite Heq.
-Rewrite Post4.
-Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
-Rewrite Zpower_exp.
-Auto with zarith.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-(* invariant: cas odd *)
-Generalize (Zodd_div2 n0 Pre1 Test1).
-Intro Heq. Rewrite Heq.
-Rewrite Post4.
-Rewrite Zpower_exp.
-Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
-Rewrite Zpower_exp.
-Replace `(Zpower x0 1)` with x0.
-Ring.
-Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Generalize (Zdiv2_ge_0 n0) ; Omega.
-Omega.
-Save.
diff --git a/contrib/correctness/examples/extract.v b/contrib/correctness/examples/extract.v
deleted file mode 100644
index e225ba18..00000000
--- a/contrib/correctness/examples/extract.v
+++ /dev/null
@@ -1,43 +0,0 @@
-
-(* Tests d'extraction *)
-
-Require ProgramsExtraction.
-Save State Ici "test extraction".
-
-(* exp *)
-
-Require exp.
-Write Caml File "exp" [ i_exp r_exp ].
-
-(* exp_int *)
-
-Restore State Ici.
-Require exp_int.
-Write Caml File "exp_int" [ i_exp r_exp ].
-
-(* fact *)
-
-Restore State Ici.
-Require fact.
-Initialize x with (S (S (S O))).
-Initialize y with O.
-Write Caml File "fact" [ factorielle ].
-
-(* fact_int *)
-
-Restore State Ici.
-Require fact_int.
-Initialize x with `3`.
-Initialize y with `0`.
-Write Caml File "fact_int" [ factorielle ].
-
-(* Handbook *)
-
-Restore State Ici.
-Require Handbook.
-Initialize X with `3`.
-Initialize Y with `3`.
-Initialize Z with `3`.
-Initialize N with `3`.
-Initialize S with `3`.
-Write Caml File "Handbook" [ pgm178 pgm186 pgm196 ].
diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v
deleted file mode 100644
index 07e77140..00000000
--- a/contrib/correctness/examples/fact.v
+++ /dev/null
@@ -1,69 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \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: fact.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Proof of an imperative program computing the factorial (over type nat) *)
-
-Require Correctness.
-Require Omega.
-Require Arith.
-
-Fixpoint fact [n:nat] : nat :=
-  Cases n of
-    O     => (S O)
-  | (S p) => (mult n (fact p))
-  end.
-
-(* (x * y) * (x-1)! = y * x!  *)
-
-Lemma fact_rec : (x,y:nat)(lt O x) ->
-  (mult (mult x y) (fact (pred x))) = (mult y (fact x)).
-Proof.
-Intros x y H.
-Generalize (mult_sym x y). Intro H1. Rewrite H1.
-Generalize (mult_assoc_r y x (fact (pred x))). Intro H2. Rewrite H2.
-Apply (f_equal nat nat [x:nat](mult y x)).
-Generalize H. Elim x; Auto with arith.
-Save.
-
-
-(* we declare two variables x and y *)
-
-Global Variable x : nat ref.
-Global Variable y : nat ref.
-
-(* we give the annotated program *)
-
-Correctness factorielle 
-  begin
-    y := (S O);
-    while (notzerop_bool !x) do
-      { invariant (mult y (fact x)) = (fact x@0) as I
-        variant x for lt }
-      y := (mult !x !y);
-      x := (pred !x)
-    done
-  end
-  { y = (fact x@0) }.
-Proof.
-Split.
-(* decreasing of the variant *)
-Omega.
-(* preservation of the invariant *)
-Rewrite <- I. Exact (fact_rec x0 y1 Test1).
-(* entrance of loop *)
-Auto with arith.
-(* exit of loop *)
-Elim I. Intros H1 H2.
-Rewrite H2 in H1.
-Rewrite <- H1.
-Auto with arith.
-Save.
diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v
deleted file mode 100644
index f463ca80..00000000
--- a/contrib/correctness/examples/fact_int.v
+++ /dev/null
@@ -1,195 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \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: fact_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
-
-(* Proof of an imperative program computing the factorial (over type Z) *)
-
-Require Correctness.
-Require Omega.
-Require ZArithRing.
-
-(* We define the factorial as a relation... *)
-
-Inductive fact : Z -> Z -> Prop :=
-    fact_0 : (fact `0` `1`)
-  | fact_S : (z,f:Z) (fact z f) -> (fact (Zs z) (Zmult (Zs z) f)).
-
-(* ...and then we prove that it contains a function *)
-
-Lemma fact_function : (z:Z) `0 <= z` -> (EX f:Z | (fact z f)).
-Proof.
-Intros.
-Apply natlike_ind with P:=[z:Z](EX f:Z | (fact z f)).
-Split with `1`.
-Exact fact_0.
-
-Intros.
-Elim H1.
-Intros.
-Split with `(Zs x)*x0`.
-Exact (fact_S x x0 H2).
-
-Assumption.
-Save.
-
-(* This lemma should belong to the ZArith library *)
-
-Lemma Z_mult_1 : (x,y:Z)`x>=1`->`y>=1`->`x*y>=1`.
-Proof.
-Intros.
-Generalize H.
-Apply natlike_ind with P:=[x:Z]`x >= 1`->`x*y >= 1`.
-Omega.
-
-Intros.
-Simpl.
-Elim (Z_le_lt_eq_dec `0` x0 H1).
-Simpl.
-Unfold Zs.
-Replace `(x0+1)*y` with `x0*y+y`.
-Generalize H2.
-Generalize `x0*y`.
-Intro.
-Intros.
-Omega.
-
-Ring.
-
-Intros.
-Rewrite <- b.
-Omega.
-
-Omega.
-Save.
-
-(* (fact x f) implies x>=0 and f>=1 *)
-
-Lemma fact_pos : (x,f:Z)(fact x f)-> `x>=0` /\ `f>=1`.
-Proof.
-Intros.
-(Elim H; Auto).
-Omega.
-
-Intros.
-(Split; Try Omega).
-(Apply Z_mult_1; Try Omega).
-Save.
-
-(* (fact 0 x) implies x=1 *)
-
-Lemma fact_0_1 : (x:Z)(fact `0` x) -> `x=1`.
-Proof.
-Intros.
-Inversion H.
-Reflexivity.
-
-Elim (fact_pos z f H1).
-Intros.
-(Absurd `z >= 0`; Omega).
-Save.
-
-
-(* We define the loop invariant : y * x! = x0! *)
-
-Inductive invariant [y,x,x0:Z] : Prop :=
-  c_inv : (f,f0:Z)(fact x f)->(fact x0 f0)->(Zmult y f)=f0
-       -> (invariant y x x0).
-
-(* The following lemma is used to prove the preservation of the invariant *)
-
-Lemma fact_rec : (x0,x,y:Z)`0 < x` ->
-    (invariant y x x0) 
- -> (invariant `x*y` (Zpred x) x0).
-Proof.
-Intros x0 x y H H0.
-Elim H0.
-Intros.
-Generalize H H0 H3.
-Elim H1.
-Intros.
-Absurd `0 < 0`; Omega.
-
-Intros.
-Apply c_inv with f:=f1 f0:=f0.
-Cut `z+1+-1 = z`. Intro eq_z. Rewrite <- eq_z in H4.
-Assumption.
-
-Omega.
-
-Assumption.
-
-Rewrite (Zmult_sym (Zs z) y).                     
-Rewrite (Zmult_assoc_r y (Zs z) f1).
-Auto.
-Save.
-
-
-(* This one is used to prove the proof obligation at the exit of the loop *)
-
-Lemma invariant_0 : (x,y:Z)(invariant y `0` x)->(fact x y).
-Proof.
-Intros.
-Elim H.
-Intros.
-Generalize (fact_0_1 f H0).
-Intro.
-Rewrite H3 in H2.
-Simpl in H2.
-Replace y with `y*1`.
-Rewrite H2.
-Assumption.
-
-Omega.
-Save.
-
-
-(* At last we come to the proof itself *************************************)
-
-(* we declare two variable x and y *)
-
-Global Variable x : Z ref.
-Global Variable y : Z ref.
-
-(* and we give the annotated program *)
-
-Correctness factorielle 
-  { `0 <= x` }
-  begin
-    y := 1;
-    while !x <> 0 do
-      { invariant `0 <= x` /\ (invariant y x x@0) as Inv
-        variant x for (Zwf ZERO) }
-      y := (Zmult !x !y);
-      x := (Zpred !x)
-    done
-  end
-  { (fact x@0 y) }.
-Proof.
-Split.
-(* decreasing *)
-Unfold Zwf. Unfold Zpred. Omega.
-(* preservation of the invariant *)
-Split.
-  Unfold Zpred; Omega.
-  Cut `0 < x0`. Intro Hx0.
-  Decompose [and] Inv.
-  Exact (fact_rec x x0 y1 Hx0 H0).
-  Omega.
-(* entrance of the loop *)
-Split; Auto.
-Elim (fact_function x Pre1). Intros.
-Apply c_inv with f:=x0 f0:=x0; Auto.
-Omega.
-(* exit of the loop *)
-Decompose [and] Inv.
-Rewrite H0 in H2.
-Exact (invariant_0 x y1 H2).
-Save.
diff --git a/contrib/correctness/preuves.v b/contrib/correctness/preuves.v
deleted file mode 100644
index 33659b43..00000000
--- a/contrib/correctness/preuves.v
+++ /dev/null
@@ -1,128 +0,0 @@
-
-(* Quelques preuves sur des programmes simples,
- * juste histoire d'avoir un petit bench.
- *)
-
-Require Correctness.
-Require Omega.
-
-Global Variable x : Z ref.
-Global Variable y : Z ref.
-Global Variable z : Z ref.
-Global Variable i : Z ref.
-Global Variable j : Z ref.
-Global Variable n : Z ref.
-Global Variable m : Z ref.
-Variable r : Z.
-Variable N : Z.
-Global Variable t : array N of Z.
-
-(**********************************************************************)
-
-Require Exchange.
-Require ArrayPermut.
-
-Correctness swap
-  fun (N:Z)(t:array N of Z)(i,j:Z) ->
-    { `0 <= i < N` /\ `0 <= j < N` }
-    (let v = t[i] in
-     begin
-       t[i] := t[j];
-       t[j] := v
-     end)
-    { (exchange t t@ i j) }.
-Proof.
-Auto with datatypes.
-Save.
-
-Correctness downheap
-  let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } =
-    (swap N t 0 0) { True }
-.
-
-(**********************************************************************)
-
-Global Variable x : Z ref.
-Debug on.
-Correctness assign0 (x := 0) { `x=0` }.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }.
-
-(**********************************************************************)
-
-Correctness echange
-  { `0 <= i < N` /\ `0 <= j < N` }
-  begin
-    label B;
-    x := t[!i]; t[!i] := t[!j]; t[!j] := !x;
-    assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] }
-  end.
-Proof.
-Auto with datatypes.
-Save.
-
-  
-(**********************************************************************)
-
-(*
- *   while x <= y do x := x+1 done { y < x }
- *)
-
-Correctness incrementation
-  while !x < !y do
-    { invariant True variant `(Zs y)-x` }
-    x := !x + 1
-  done
-  { `y < x` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Save.
-
-
-(************************************************************************)
-
-Correctness pivot1
-  begin
-    while (Z_lt_ge_dec !i r) do
-      { invariant True variant (Zminus (Zs r) i) } i := (Zs !i)
-    done;
-    while (Z_lt_ge_dec r !j) do
-      { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j)
-    done
-  end
-  { `j <= r` /\ `r <= i` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Unfold Zpred. Omega.
-Exact I.
-Omega.
-Save.
-
-
-
diff --git a/contrib/dp/Dp.v b/contrib/dp/Dp.v
deleted file mode 100644
index 857c182c..00000000
--- a/contrib/dp/Dp.v
+++ /dev/null
@@ -1,120 +0,0 @@
-(* 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
deleted file mode 100644
index 44349e21..00000000
--- a/contrib/dp/TODO
+++ /dev/null
@@ -1,24 +0,0 @@
-
-TODO
-----
-
-- axiomes pour les prédicats récursifs comme
-
-  Fixpoint even (n:nat) : Prop :=
-  match n with 
-  O => True
-  | S O => False
-  | S (S p) => even p
-  end.
-
-  ou encore In sur les listes du module Coq List.
-
-- discriminate
-
-- inversion (Set et Prop)
-
-
-BUGS
-----
-
-
diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml
deleted file mode 100644
index d8803847..00000000
--- a/contrib/dp/dp.ml
+++ /dev/null
@@ -1,991 +0,0 @@
-(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
-(* Tactics to call decision procedures *)
-
-(* Works in two steps: 
-
-   - first the Coq context and the current goal are translated in
-     Polymorphic First-Order Logic (see fol.mli in this directory)
-
-   - then the resulting query is passed to the Why tool that translates
-     it to the syntax of the selected prover (Simplify, CVC Lite, haRVey,
-     Zenon)
-*)
-
-open Util
-open Pp
-open Libobject
-open Summary
-open Term
-open Tacmach
-open Tactics
-open Tacticals
-open Fol
-open Names
-open Nameops
-open Termops
-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
-
-let coq_Z = lazy (constant "Z")
-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_Zdiv = lazy (constant "Zdiv")
-let coq_Zs = lazy (constant "Zs")
-let coq_Zgt = lazy (constant "Zgt")
-let coq_Zle = lazy (constant "Zle")
-let coq_Zge = lazy (constant "Zge")
-let coq_Zlt = lazy (constant "Zlt")
-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_iff = lazy (constant "iff")
-
-(* not Prop typed expressions *)
-exception NotProp
-
-(* not first-order expressions *)
-exception NotFO
-
-(* Renaming of Coq globals *)
-
-let global_names = Hashtbl.create 97
-let used_names = Hashtbl.create 97
-
-let rename_global r =
-  try 
-    Hashtbl.find global_names r
-  with Not_found ->
-    let rec loop id = 
-      if Hashtbl.mem used_names id then 
-	loop (lift_ident id)
-      else begin 
-	Hashtbl.add used_names id ();
-	let s = string_of_id id in
-	Hashtbl.add global_names r s; 
-	s
-      end
-    in
-    loop (Nametab.id_of_global r)
-
-let foralls =
-  List.fold_right 
-    (fun (x,t) p -> Forall (x, t, p))
-
-let fresh_var = function
-  | Anonymous -> rename_global (VarRef (id_of_string "x"))
-  | Name x -> rename_global (VarRef x)
-
-(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of 
-   env names, and returns the new variables together with the new 
-   environment *)
-let coq_rename_vars env vars =
-  let avoid = ref (ids_of_named_context (Environ.named_context env)) in
-  List.fold_right
-    (fun (na,t) (newvars, newenv) -> 
-       let id = next_name_away na !avoid in
-       avoid := id :: !avoid;
-       id :: newvars, Environ.push_named (id, None, t) newenv)
-    vars ([],env)
-
-(* extract the prenex type quantifications i.e.
-   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 || is_Type a -> 
-	loop ((n,a) :: vars) t
-    | _ -> 
-	let vars, env = coq_rename_vars env vars in
-	let t = substl (List.map mkVar vars) t in
-	List.rev vars, env, t
-  in
-  loop [] 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 || is_Type a -> 
-	loop ((n,a) :: vars) t
-    | _ -> 
-	let vars, env = coq_rename_vars env vars in
-	let t = substl (List.map mkVar vars) t in
-	List.rev vars, env, t
-  in
-  loop [] t
-
-let decompose_arrows = 
-  let rec arrows_rec l c = match kind_of_term c with
-    | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c
-    | Cast (c,_,_) -> arrows_rec l c
-    | _ -> List.rev l, c
-  in 
-  arrows_rec []
-
-let rec eta_expanse t vars env i =
-  assert (i >= 0);
-  if i = 0 then
-    t, vars, env
-  else
-    match kind_of_term (Typing.type_of env Evd.empty t) with
-      | Prod (n, a, b) when not (dependent (mkRel 1) b) ->
-	  let avoid = ids_of_named_context (Environ.named_context env) in
-	  let id = next_name_away n avoid in
-	  let env' = Environ.push_named (id, None, a) env in
-	  let t' = mkApp (t, [| mkVar id |]) in
-	  eta_expanse t' (id :: vars) env' (pred i)
-      | _ -> 
-	  assert false
-
-let rec skip_k_args k cl = match k, cl with
-  | 0, _ -> cl
-  | _, _ :: cl -> skip_k_args (k-1) cl
-  | _, [] -> raise NotFO
-
-(* Coq global references *)
-
-type global = Gnot_fo | Gfo of Fol.decl
-
-let globals = ref Refmap.empty
-let globals_stack = ref []
-
-(* synchronization *)
-let () =
-  Summary.declare_summary "Dp globals"
-    { Summary.freeze_function = (fun () -> !globals, !globals_stack);
-      Summary.unfreeze_function = 
-	(fun (g,s) -> globals := g; globals_stack := s);
-      Summary.init_function = (fun () -> ());
-      Summary.survive_module = false;
-      Summary.survive_section = false }
-
-let add_global r d = globals := Refmap.add r d !globals
-let mem_global r = Refmap.mem r !globals
-let lookup_global r = match Refmap.find r !globals with
-  | Gnot_fo -> raise NotFO
-  | Gfo d -> d
-
-let locals = Hashtbl.create 97
-
-let lookup_local r =  match Hashtbl.find locals r with
-  | Gnot_fo -> raise NotFO
-  | Gfo d -> d
-
-let iter_all_constructors i f =  
-  let _, oib = Global.lookup_inductive i in
-  Array.iteri
-    (fun j tj -> f j (mkConstruct (i, j+1)))
-    oib.mind_nf_lc
-
-
-(* injection c [t1,...,tn] adds the injection axiom
-     forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. 
-       c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
-
-let injection c l =
-  let i = ref 0 in
-  let var s = incr i; id_of_string (s ^ string_of_int !i) in
-  let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
-  i := 0;
-  let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
-  let f = 
-    List.fold_right2 
-      (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
-      xl yl True
-  in
-  let vars = List.map (fun (x,_) -> App(x,[])) in
-  let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in
-  let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in
-  let f = foralls xl (foralls yl f) in
-  let ax = Axiom ("injection_" ^ c, f) in
-  globals_stack := ax :: !globals_stack
-
-(* rec_names_for c [|n1;...;nk|] builds the list of constant names for 
-   identifiers n1...nk with the same path as c, if they exist; otherwise
-   raises Not_found *)
-let rec_names_for c =
-  let mp,dp,_ = Names.repr_con c in
-  array_map_to_list
-    (function 
-       | Name id -> 
-	   let c' = Names.make_con mp dp (label_of_id id) in
-	   ignore (Global.lookup_constant c');
-	   msgnl (Printer.pr_constr (mkConst c'));
-	   c'
-       | Anonymous ->
-	   raise Not_found)
-
-(* abstraction tables *)
-
-let term_abstractions = Hashtbl.create 97
-
-let new_abstraction = 
-  let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
-
-(* Arithmetic constants *)
-
-exception NotArithConstant
-
-(* 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 ->
-      Cst 1
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
-      Plus (Mult (Cst 2, tr_positive a), Cst 1)
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
-      Mult (Cst 2, tr_positive a)
-  | Term.Cast (p, _, _) ->
-      tr_positive p
-  | _ ->
-      raise NotArithConstant
-
-(* translates a closed Coq term t:Z into a FOL term of type int *)
-let rec tr_arith_constant t = match kind_of_term t with
-  | Term.Construct _ when t = Lazy.force coq_Z0 ->
-      Cst 0
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
-      tr_positive a
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
-      Moins (Cst 0, tr_positive a)
-  | Term.Cast (t, _, _) ->
-      tr_arith_constant t
-  | _ -> 
-      raise NotArithConstant
-
-(* translate a Coq term t:Set into a FOL type expression;
-   tv = list of type variables *)
-and tr_type tv env t =
-  let t = Reductionops.nf_betadeltaiota env Evd.empty t in
-  if t = Lazy.force coq_Z then 
-    Tid ("int", [])
-  else match kind_of_term t with
-    | Var x when List.mem x tv ->
-	Tvar (string_of_id x)
-    | _ ->
-	let f, cl = decompose_app t in
-	begin try
-	  let r = global_of_constr f in
-	  match tr_global env r with
-	    | DeclType (id, k) -> 
-		assert (k = List.length cl); (* since t:Set *)
-		Tid (id, List.map (tr_type tv env) cl)
-	    | _ -> 
-		raise NotFO
-	with 
-	  | Not_found ->
-	      raise NotFO
-	  | NotFO -> 
-	      (* we need to abstract some part of (f cl) *)
-	      (*TODO*)
-	      raise NotFO
-	end
-
-and make_term_abstraction tv env c =
-  let ty = Typing.type_of env Evd.empty c in
-  let id = new_abstraction () in
-  match tr_decl env id ty with
-    | DeclFun (id,_,_,_) as d ->
-	begin try
-	  Hashtbl.find term_abstractions c
-	with Not_found ->
-	  Hashtbl.add term_abstractions c id;
-	  globals_stack := d :: !globals_stack;
-	  id
-	end
-    | _ ->
-	raise NotFO
-
-(* translate a Coq declaration id:ty in a FOL declaration, that is either
-   - a type declaration : DeclType (id, n) where n:int is the type arity
-   - a function declaration : DeclFun (id, tl, t) ; that includes constants
-   - a predicate declaration : DeclPred (id, tl)
-   - an axiom : Axiom (id, p)
- *)
-and tr_decl env id ty =
-  let tv, env, t = decomp_type_quantifiers env ty in
-  if is_Set t || is_Type t then
-    DeclType (id, List.length tv)
-  else if is_Prop t then
-    DeclPred (id, List.length tv, [])
-  else 
-    let s = Typing.type_of env Evd.empty t in
-    if is_Prop s then
-      Axiom (id, tr_formula tv [] env t)
-    else
-      let l, t = decompose_arrows t in
-      let l = List.map (tr_type tv env) l in
-      if is_Prop t then
-	DeclPred(id, List.length tv, l)
-      else 
-	let s = Typing.type_of env Evd.empty t in
-	if is_Set s || is_Type s then 
-	  DeclFun (id, List.length tv, l, tr_type tv env t)
-	else 
-	  raise NotFO
-
-(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
-and tr_global env r = match r with
-  | VarRef id ->
-      lookup_local id
-  | r ->
-      try
-	lookup_global r
-      with Not_found ->
-	try
-	  let ty = Global.type_of_global r in
-	  let id = rename_global r in
-	  let d = tr_decl env id ty in
-	  (* r can be already declared if it is a constructor *)
-	  if not (mem_global r) then begin 
-	    add_global r (Gfo d);
-	    globals_stack := d :: !globals_stack
-	  end;
-	  begin try axiomatize_body env r id d with NotFO -> () end;
-	  d
-	with NotFO ->
-	  add_global r Gnot_fo;
-	  raise NotFO
-
-and axiomatize_body env r id d = match r with
-  | VarRef _ -> 
-      assert false
-  | ConstRef c ->
-      begin match (Global.lookup_constant c).const_body with
-	| Some b ->
-	    let b = force 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;*)
-		     let b = match kind_of_term b with
-		       (* a single recursive function *)
-		       | Fix (_, (_,_,[|b|])) -> 
-			   subst1 (mkConst c) b
-                       (* mutually recursive functions *)
-		       | Fix ((_,i), (names,_,bodies)) ->
-                           (* we only deal with named functions *)
-			   begin try
-			     let l = rec_names_for c names in
-			     substl (List.rev_map mkConst l) bodies.(i)
-			   with Not_found ->
-			     b
-			   end
-		       | _ -> 
-			   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
-		     assert (k <= n);
-		     let vars, env = coq_rename_vars env vars in
-		     let t = substl (List.map mkVar vars) t in
-		     let t, vars, env = eta_expanse t vars env (n-k) in
-		     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_vars = List.map fol_var vars in
-		     let vars = List.combine vars l in
-		     begin match d with
-		       | 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 t = tr_term tv bv env t in
-				 let ax = 
-				   add_proof (Fun_def (id, vars, ty, t))
-				 in
-				 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
-			   let p = Iff (Fatom (Pred (id, fol_vars)), value) in
-			   [id, foralls vars p]
-		       | _ ->
-			   assert false
-		     end
-		 | DeclType _ ->
-		     raise NotFO
-		 | Axiom _ -> assert false)
-	    in
-	    let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
-	    globals_stack := axioms @ !globals_stack
-	| None -> 
-	    () (* Coq axiom *)
-      end
-  | IndRef i ->
-      iter_all_constructors i
-	(fun _ c ->
-	   let rc = global_of_constr c in
-	   try
-	     begin match tr_global env rc with
-	       | DeclFun (_, _, [], _) -> ()
-	       | DeclFun (idc, _, al, _) -> injection idc al
-	       | _ -> ()
-	     end
-	   with NotFO ->
-	     ())
-  | _ -> ()
-
-and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
-  | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars ->
-      let eqs = ref [] in
-      iter_all_constructors ci.ci_ind
-	(fun j cj ->
-	   try
-	     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 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_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
-		   let fol_vars = List.map fst vars in
-		   let fol_vars = List.map fol_var fol_vars in
-		   let fol_vars = List.map (fun y -> match y with
-					      | App (id, _) ->
-						  if id = string_of_id x
-						  then fol_rec_term
-						  else y
-					      | _ -> y)
-				    fol_vars in
-		   let vars = vars @ rec_vars in
-		   let rec remove l e = match l with
-		     | [] -> []
-		     | (y, t)::l' -> if y = string_of_id e then l'
-		       else (y, t)::(remove l' e) in
-		   let vars = remove vars x in
-		   let p = 
-		     Fatom (Eq (App (id, fol_vars), 
-				tr_term tv bv env b))
-		   in
-		   eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
-	       | _ -> 
-		   assert false end
-	   with NotFO ->
-	     ());
-      !eqs
-  | _ ->
-      raise NotFO
-
-(* assumption: t:T:Set *)
-and tr_term tv bv env t = match kind_of_term t with
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> 
-      Plus (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> 
-      Moins (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> 
-      Mult (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> 
-      Div (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.Var id when List.mem id bv ->
-      App (string_of_id id, [])
-  | _ ->
-      try
-	tr_arith_constant t
-      with NotArithConstant ->
-	let f, cl = decompose_app t in
-	begin try
-	  let r = global_of_constr f in
-	  match tr_global env r with
-	    | DeclFun (s, k, _, _) -> 
-		let cl = skip_k_args k cl in
-		Fol.App (s, List.map (tr_term tv bv env) cl)
-	    | _ -> 
-		raise NotFO
-	with 
-	  | Not_found ->
-	      raise NotFO
-	  | NotFO -> (* we need to abstract some part of (f cl) *)
-	      let rec abstract app = function
-		| [] ->
-		    Fol.App (make_term_abstraction tv env app, [])
-		| x :: l as args ->
-		    begin try
-		      let s = make_term_abstraction tv env app in
-		      Fol.App (s, List.map (tr_term tv bv env) args)
-		    with NotFO ->
-		      abstract (applist (app, [x])) l
-		    end
-	      in
-	      let app,l = match cl with 
-		| x :: l -> applist (f, [x]), l | [] -> raise NotFO
-	      in
-	      abstract app l
-	end
-
-and quantifiers n a b tv bv env =
-  let vars, env = coq_rename_vars env [n,a] in
-  let id = match vars with [x] -> x | _ -> assert false in
-  let b = subst1 (mkVar id) b in
-  let t = tr_type tv env a in
-  let bv = id :: bv in
-  id, t, bv, env, b
-
-(* assumption: f is of type Prop *)
-and tr_formula tv bv env f =
-  let c, args = decompose_app f in
-  match kind_of_term c, args with
-    | Var id, [] -> 
-	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 || 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 
-	  raise NotFO
-    | _, [a;b] when c = Lazy.force coq_Zle ->
-	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zlt ->
-	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zge ->
-	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zgt ->
-	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [] when c = build_coq_False () ->
-	False
-    | _, [] when c = build_coq_True () ->
-	True
-    | _, [a] when c = build_coq_not () ->
-	Not (tr_formula tv bv env a)
-    | _, [a;b] when c = build_coq_and () ->
-	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)
-	else
-	  let id, t, bv, env, b = quantifiers n a b tv bv env in
-	  Forall (string_of_id id, t, tr_formula tv bv env b)
-    | _, [_; a] when c = build_coq_ex () ->
-	begin match kind_of_term a with
-	  | Lambda(n, a, b) ->
-	      let id, t, bv, env, b = quantifiers n a b tv bv env in
-	      Exists (string_of_id id, t, tr_formula tv bv env b)
-	  | _ -> 
-	      (* unusual case of the shape (ex p) *)
-	      raise NotFO (* TODO: we could eta-expanse *)
-	end
-    | _ ->
-	begin try
-	  let r = global_of_constr c in
-	  match tr_global env r with
-	    | DeclPred (s, k, _) -> 
-		let args = skip_k_args k args in
-		Fatom (Pred (s, List.map (tr_term tv bv env) args))
-	    | _ -> 
-		raise NotFO
-	with Not_found ->
-	  raise NotFO
-	end
-
-
-let tr_goal gl =
-  Hashtbl.clear locals;
-  let tr_one_hyp (id, ty) = 
-    try
-      let s = rename_global (VarRef id) in
-      let d = tr_decl (pf_env gl) s ty in
-      Hashtbl.add locals id (Gfo d);
-      d
-    with NotFO ->
-      Hashtbl.add locals id Gnot_fo;
-      raise NotFO
-  in
-  let hyps =
-    List.fold_right 
-      (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
-      (pf_hyps_types gl) []
-  in
-  let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in
-  let hyps = List.rev_append !globals_stack (List.rev hyps) in
-  hyps, c
-
-
-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 "why-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" (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 "why-cpulimit %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 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 --alt-ergo %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" (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 %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 -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 "why-cpulimit %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 None else if out = 1 then Invalid else Timeout 
-  in
-  if not !debug then remove_files [fwhy; fsmt];
-  r
-
-let call_cvcl fwhy =
-  let cmd = 
-    sprintf "why --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 %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 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 --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
-  if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
-  let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
-  let outf = Filename.temp_file "rv" ".out" in
-  let out = 
-    Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" 
-		   !timeout f outf) 
-  in
-  let r =
-    if out <> 0 then 
-      Timeout
-    else
-      let cmd = 
-	sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
-      in
-      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 %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;
-  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 (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
-  let one_hint (qid,r) = 
-    if not (mem_global r) then begin
-      let ty = Global.type_of_global r in
-      let s = Typing.type_of env Evd.empty ty in
-      if is_Prop s then
-	try
-	  let id = rename_global r 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 ->
-	  add_global r Gnot_fo;
-	  msg_warning
-	    (pr_reference qid ++ 
-	     str " ignored (not a first order proposition)")
-	else begin
-	  add_global r Gnot_fo;
-	  msg_warning
-	    (pr_reference qid ++ str " ignored (not a proposition)")
-	end
-    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
deleted file mode 100644
index 6dbc05e1..00000000
--- a/contrib/dp/dp.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-
-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_gappa.ml b/contrib/dp/dp_gappa.ml
deleted file mode 100644
index 9c035aa8..00000000
--- a/contrib/dp/dp_gappa.ml
+++ /dev/null
@@ -1,445 +0,0 @@
-
-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 = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ 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 999999. Print %s.proof." 
-    (Filename.chop_suffix gappa_out2 ".v") gappa2;
-  close_out c;
-  let lambda = temp_file "gappa_lambda" in
-  let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ 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_why.ml b/contrib/dp/dp_why.ml
deleted file mode 100644
index e24049ad..00000000
--- a/contrib/dp/dp_why.ml
+++ /dev/null
@@ -1,151 +0,0 @@
-
-(* Pretty-print PFOL (see fol.mli) in Why syntax *)
-
-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
-  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-let space fmt () = fprintf fmt "@ "
-let comma fmt () = fprintf fmt ",@ "
-
-let is_why_keyword = 
-  let h = Hashtbl.create 17 in
-  List.iter 
-    (fun s -> Hashtbl.add h s ())
-    ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
-     "bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
-     "external"; "false"; "for"; "forall"; "fun"; "function"; "goal";
-     "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
-     "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
-     "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
-     "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; 
-  Hashtbl.mem h
-
-let ident fmt s =
-  if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s
-
-let rec print_typ fmt = function
-  | Tvar x -> fprintf fmt "'%a" ident x
-  | Tid ("int", []) -> fprintf fmt "int"
-  | Tid (x, []) -> fprintf fmt "%a" ident x
-  | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
-  | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
-
-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 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 "%a" ident id
-  | Fatom (Pred (id, tl)) -> 
-      fprintf fmt "@[%a(%a)@]" ident id print_terms tl
-  | Imp (a, b) ->
-      fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
-  | Iff (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 %a:%a.@ %a)@]" ident id print_typ t pp p
-  | Exists (id, t, p) -> 
-      fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
-
-let print_query fmt (decls,concl) =
-  let print_dtype = function
-    | DeclType (id, 0) ->
-	fprintf fmt "@[type %a@]@\n@\n" ident id
-    | DeclType (id, 1) ->
-	fprintf fmt "@[type 'a %a@]@\n@\n" ident id
-    | DeclType (id, n) ->
-	fprintf fmt "@[type (";
-	for i = 1 to n do 
-	  fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
-	done;
-	fprintf fmt ") %a@]@\n@\n" ident id
-    | DeclFun _ | DeclPred _ | Axiom _ ->
-	()
-  in
-  let print_dvar_dpred = function
-    | DeclFun (id, _, [], t) ->
-	fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
-    | DeclFun (id, _, l, t) ->
-	fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" 
-	  ident id (print_list comma print_typ) l print_typ t
-    | DeclPred (id, _, []) ->
-	fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
-    | DeclPred (id, _, l) -> 
-	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" 
-	  ident id (print_list comma print_typ) l
-    | DeclType _ | Axiom _ ->
-	()
-  in
-  let print_assert = function
-    | Axiom (id, f)  -> 
-	fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
-    | DeclType _ | DeclFun _ | DeclPred _ ->
-	()
-  in
-  List.iter print_dtype decls;
-  List.iter print_dvar_dpred decls;
-  List.iter print_assert decls;
-  fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl
-
-let output_file f q =
-  let c = open_out f in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[%a@]@." print_query q;
-  close_out c
-
-
diff --git a/contrib/dp/dp_why.mli b/contrib/dp/dp_why.mli
deleted file mode 100644
index b38a3d37..00000000
--- a/contrib/dp/dp_why.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-
-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.mli b/contrib/dp/dp_zenon.mli
deleted file mode 100644
index 0a727d1f..00000000
--- a/contrib/dp/dp_zenon.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-
-open Fol
-
-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
deleted file mode 100644
index e15e280d..00000000
--- a/contrib/dp/dp_zenon.mll
+++ /dev/null
@@ -1,181 +0,0 @@
-
-{
-
-  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 (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 (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
deleted file mode 100644
index b94bd3e3..00000000
--- a/contrib/dp/fol.mli
+++ /dev/null
@@ -1,55 +0,0 @@
-
-(* Polymorphic First-Order Logic (that is Why's input logic) *)
-
-type typ = 
-  | Tvar of string
-  | Tid of string * typ list
-
-type term =   
-  | Cst of int
-  | Plus of term * term
-  | Moins of term * term
-  | Mult of term * term
-  | Div of term * term
-  | App of string * term list
-
-and atom =   
-  | Eq of term * term
-  | Le of term * term
-  | Lt of term * term
-  | Ge of term * term
-  | Gt of term * term
-  | Pred of string * term list
-
-and form = 
-  | Fatom of atom
-  | Imp of form * form
-  | Iff of form * form
-  | And of form * form
-  | Or of form * form
-  | Not of form
-  | Forall of string * typ * form
-  | Exists of string * typ * form
-  | True
-  | False
-
-(* the integer indicates the number of type variables *)
-type decl =
-  | DeclType of string * int
-  | DeclFun of string * int * typ list * typ
-  | DeclPred of string * int * typ list
-  | Axiom of string * form
-
-type query = decl list * form
-
-
-(* prover result *)
-
-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
deleted file mode 100644
index 99bcf477..00000000
--- a/contrib/dp/g_dp.ml4
+++ /dev/null
@@ -1,79 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *)
-
-open Dp
-
-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
-
-TACTIC EXTEND Harvey
-  [ "harvey" ] -> [ harvey ]
-END
-
-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 ]
-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
deleted file mode 100644
index 3e4c0f6d..00000000
--- a/contrib/dp/test2.v
+++ /dev/null
@@ -1,80 +0,0 @@
-Require Import ZArith.
-Require Import Classical.
-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
-  | Zneg p => Zpos p
-  end.
-
-Goal forall z, neg (neg z) = z.
-  Admitted.
-
-Open Scope nat_scope.
-Print plus.
-
-Goal forall x, x+0=x.
-  induction x; ergo.
-  (* simplify resoud le premier, pas le second *)
-  Admitted.
-
-Goal 1::2::3::nil = 1::2::(1+2)::nil.
-  zenon.
-  Admitted.
-
-Definition T := nat.
-Parameter fct : T -> nat.
-Goal fct O = O.
- Admitted.
-
-Fixpoint even (n:nat) : Prop :=
-  match n with 
-  O => True
-  | S O => False
-  | S (S p) => even p
-  end.
-
-Goal even 4%nat.
-  try zenon.
-  Admitted.
-
-Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.
-
-Definition head :=
-fun (A : Set) (l : list A) =>
-match l with
-| nil => None (A:=A)
-| x :: _ => Some x
-end.
-
-Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
-
-Admitted.
-
-(*
-BUG avec head prédéfini : manque eta-expansion sur A:Set
-
-Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
-
-Print value. 
-Print Some.
- 
-zenon.
-*)
-
-Inductive IN (A:Set) : A -> list A -> Prop :=
-  | IN1 : forall x l, IN A x (x::l)
-  | IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
-Implicit Arguments IN [A].
-
-Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
-  zenon.
-Print In.
diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v
deleted file mode 100644
index eb65a59d..00000000
--- a/contrib/dp/test_gappa.v
+++ /dev/null
@@ -1,91 +0,0 @@
-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
deleted file mode 100644
index a6d4f2e1..00000000
--- a/contrib/dp/tests.v
+++ /dev/null
@@ -1,288 +0,0 @@
-
-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.
-simplify.
-Qed.
-
-(* Examples in the Propositional Calculus
-   and theory of equality *)
-
-Parameter A C : Prop.
-
-Goal A -> A.
-simplify.
-Qed.
-
-
-Goal A -> (A \/ C).
-
-simplify.
-Qed.
-
-
-Parameter x y z : Z.
-
-Goal x = y -> y = z -> x = z.
-ergo.
-Qed.
-
-
-Goal ((((A -> C) -> A) -> A) -> C) -> C.
-
-ergo.
-Qed.
-
-(* Arithmetic *)
-Open Scope Z_scope.
-
-Goal 1 + 1 = 2.
-yices.
-Qed.
-
-
-Goal 2*x + 10 = 18 -> x = 4.
-
-simplify.
-Qed.
-
-
-(* Universal quantifier *)
-
-Goal (forall (x y : Z), x = y) -> 0=1.
-try zenon.
-ergo.
-Qed.
-
-Goal forall (x: nat), (x + 0 = x)%nat.
-
-induction x0; ergo.
-Qed.
-
-
-(* No decision procedure can solve this problem 
-  Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
-*)
-
-
-(* Functions definitions *) 
-
-Definition fst (x y : Z) : Z := x.
-
-Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.
-
-simplify.
-Qed.
-
-
-(* Eta-expansion example *)
-
-Definition snd_of_3 (x y z : Z) : Z := y.
-
-Definition f : Z -> Z -> Z := snd_of_3 0.
-
-Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.
-
-simplify.
-Qed.
-
-
-(* Inductive types definitions - call to incontrib/dp/jection function *)
-
-Inductive even : Z -> Prop :=
-| even_0 : even 0
-| even_plus2 : forall z : Z, even z -> even (z + 2).
-
-
-(* Simplify and Zenon can't prove this goal before the timeout
-   unlike CVC Lite *)
-
-Goal even 4.
-ergo.
-Qed.
-
-
-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.
-yices.
-Qed.
-
-
-(* Axioms definitions and dp_hint *)
-
-Parameter add : nat -> nat -> nat.
-Axiom add_0 : forall (n : nat), add 0%nat n = n.
-Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
-
-Dp_hint add_0.
-Dp_hint add_S.
-
-(* Simplify can't prove this goal before the timeout 
-   unlike zenon *)
-
-Goal forall n : nat, add n 0 = n.
-induction n ; yices.
-Qed.
-
-
-Definition pred (n : nat) : nat := match n with
-  | 0%nat => 0%nat
-  | S n' => n'
-end.
-
-Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
-yices.
-(*zenon.*)
-Qed.
-
-
-Fixpoint plus (n m : nat) {struct n} : nat :=
-  match n with
-  | 0%nat => m
-  | S n' => S (plus n' m)
-end.
-
-Goal forall n : nat, plus n 0%nat = n.
-
-induction n; ergo.
-Qed.
-
-
-(* Mutually recursive functions *)
-
-Fixpoint even_b (n : nat) : bool := match n with
-  | O => true
-  | S m => odd_b m
-end
-with odd_b (n : nat) : bool := match n with
-  | O => false
-  | S m => even_b m
-end.
-
-Goal even_b (S (S O)) = true.
-ergo.
-(*
-simplify.
-zenon.
-*)
-Qed.
-
-
-(* sorts issues *)
-
-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.
-yices.
-(*zenon.*)
-Qed.
-
-
-
-(* abstractions *)
-
-Parameter poly_f : forall A:Set, A->A.
-
-Goal forall x:nat, poly_f nat x = poly_f nat x.
-ergo.
-(*zenon.*)
-Qed.
-
-
-
-(* Anonymous mutually recursive functions : no equations are produced
-
-Definition mrf :=
-  fix even2 (n : nat) : bool := match n with
-    | O => true
-    | S m => odd2 m
-  end
-  with odd2 (n : nat) : bool := match n with
-    | O => false
-    | S m => even2 m
-  end for even.
-
-   Thus this goal is unsolvable
-
-Goal mrf (S (S O)) = true.
-
-zenon.
-
-*)
diff --git a/contrib/dp/zenon.v b/contrib/dp/zenon.v
deleted file mode 100644
index 4ad00a11..00000000
--- a/contrib/dp/zenon.v
+++ /dev/null
@@ -1,94 +0,0 @@
-(*  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/BUGS b/contrib/extraction/BUGS
deleted file mode 100644
index 7f3f59c1..00000000
--- a/contrib/extraction/BUGS
+++ /dev/null
@@ -1,2 +0,0 @@
-It's not a bug, it's a lack of feature !!
-Cf TODO.
diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES
deleted file mode 100644
index acd1dbda..00000000
--- a/contrib/extraction/CHANGES
+++ /dev/null
@@ -1,409 +0,0 @@
-7.4 -> 8.0
-
-No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, 
-but also a few steps toward a more user-friendly extraction:
-
-* syntax of extraction: 
-- The old   (Recursive) Extraction Module M.
-  is now    (Recursive) Extraction Library M.
-  The old name was misleading since this command only works with M being a 
-  library M.v, and not a module produced by interactive command Module M. 
-- The other commands 
-    Extraction foo.
-    Recursive Extraction foo bar.
-    Extraction "myfile.ml" foo bar. 
-  now accept that foo can be a module name instead of just a constant name. 
-
-* Support of type scheme axioms (i.e. axiom whose type is an arity 
-  (x1:X1)...(xn:Xn)s with s a sort). For example: 
-
-   Axiom myprod : Set -> Set -> Set.
-   Extract Constant myprod "'a" "'b" => "'a * 'b". 
-   Recursive Extraction myprod. 
-   -------> type ('a,'b) myprod = 'a * 'b		
-
-* More flexible support of axioms. When an axiom isn't realized via Extract 
-  Constant before extraction, a warning is produced (instead of an error), 
-  and the extracted code must be completed later by hand. To find what
-  needs to be completed, search for the following string: AXIOM TO BE REALIZED
-
-* Cosmetics: When extraction produces a file, it tells it. 
-
-* (Experimental) It is allowed to extract under a opened interactive module
-  (but still outside sections). Feature to be used with caution. 
-
-* A problem has been identified concerning .v files used as normal interactive 
-  modules, like in 
-    
-    <file A.v>
-    Definition foo :=O.
-    <End file A.v>
-
-    <at toplevel>
-    Require A.
-    Module M:=A
-    Extraction M.
-
-  I might try to support that in the future. In the meanwhile, the
-  current behaviour of extraction is to forbid this.
-
-* bug fixes: 
-- many concerning Records. 
-- a Stack Overflow with mutual inductive (PR#320)
-- some optimizations have been removed since they were not type-safe:
-  For example if e has type:  type 'x a = A
-  Then:       match e with A -> A     -----X---->    e
-  To be investigated further.
-
-
-7.3 -> 7.4
-
-* The two main new features: 
-  - Automatic generation of Obj.magic when the extracted code 
-  in Ocaml is not directly typable.
-  - An experimental extraction of Coq's new modules to Ocaml modules. 
-
-* Concerning those Obj.magic: 
-  - The extraction now computes the expected type of any terms. Then 
-  it compares it with the actual type of the produced code. And when 
-  a mismatch is found, a Obj.magic is inserted. 
-  
-  - As a rule, any extracted development that was compiling out of the box 
-  should not contain any Obj.magic. At the other hand, generation of 
-  Obj.magic is not optimized yet: there might be several of them at a place 
-  were one would have been enough. 
-  
-  - Examples of code needing those Obj.magic: 
-     * contrib/extraction/test_extraction.v in the Coq source
-     * in the users' contributions: 
-	Lannion
-	Lyon/CIRCUITS
-        Rocq/HIGMAN
- 
-  - As a side-effect of this Obj.magic feature, we now print the types 
-  of the extracted terms, both in .ml files as commented documentation 
-  and in interfaces .mli files
-
-  - This feature hasn't been ported yet to Haskell. We are aware of 
-  some unsafe casting functions like "unsafeCoerce" on some Haskell implems.
-  So it will eventually be done.
-
-* Concerning the extraction of Coq's new modules: 
-  - Taking in account the new Coq's modules system has implied a *huge*
-  rewrite of most of the extraction code.
-
-  - The extraction core (translation from Coq to an abstract mini-ML) 
-  is now complete and fairly stable, and supports modules, modules type 
-  and functors and all that stuff.
-
-  - The ocaml pretty-print part, especially the renaming issue, is 
-  clearly weaker, and certainly still contains bugs. 
-
-  - Nothing done for translating these Coq Modules to Haskell.
-
-  - A temporary drawback of this module extraction implementation is that 
-  efficiency (especially extraction speed) has been somehow neglected.
-  To improve ...
-
-  - As an interesting side-effect, definitions are now printed according to 
-  the user's original order. No more of this "dependency-correct but weird"
-  order. In particular realized axioms via Extract Constant are now at their 
-  right place, and not at the beginning. 
-
-* Other news: 
-  
-  - Records are now printed using the Ocaml record syntax
- 
-  - Syntax output toward Scheme. Quite funny, but quite experimental and 
-  not documented. I recommend using the bigloo compiler since it contains 
-  natively some pattern matching.
-
-  - the dummy constant "__" have changed. see README
-
-  - a few bug-fixes (#191 and others)
-
-7.2 -> 7.3
-
-* Improved documentation in the Reference Manual.
-
-* Theoretical bad news: 
-- a naughty example (see the end of test_extraction.v)
-forced me to stop eliminating lambdas and arguments corresponding to 
-so-called "arity" in the general case. 
-
-- The dummy constant used in extraction ( let prop = () in ocaml ) 
-may in some cases be applied to arguments. This problem is dealt by 
-generating sufficient abstraction before the (). 
-
-
-* Theoretical good news: 
-- there is now a mechanism that remove useless prop/arity lambdas at the 
-top of function declarations. If your function had signature 
-nat -> prop -> nat in the previous extraction, it will now be nat -> nat. 
-So the extractions of common terms should look very much like the old 
-V6.2 one, except in some particular cases (functions as parameters, partial 
-applications, etc). In particular the bad news above have nearly no 
-impact...
-
-
-* By the way there is no more "let prop = ()" in ocaml. Those () are
-directly inlined. And in Haskell the dummy constant is now __ (two
-underscore) and is defined by 
-__ = Prelude.error "Logical or arity value used"
-This dummy constant should never be evaluated when computing an
-informative value, thanks to the lazy strategy. Hence the error message. 
-
-
-* Syntax changes, see Documentation for details: 
-
-Extraction Language Ocaml.
-Extraction Language Haskell. 
-Extraction Language Toplevel.
-
-That fixes the target language of extraction. Default is Ocaml, even in the 
-coq toplevel: you can now do copy-paste from the coq toplevel without 
-renaming problems. Toplevel language is the ocaml pseudo-language used 
-previously used inside the coq toplevel: coq names are printed with the coq 
-way, i.e. with no renaming. 
-
-So there is no more particular commands for Haskell, like 
-Haskell Extraction "file" id. Just set your favourite language and go... 
-
-
-* Haskell extraction has been tested at last (and corrected...). 
-See specificities in Documentation. 
-
-
-* Extraction of CoInductive in Ocaml language is now correct: it uses the 
-Lazy.force and lazy features of Ocaml. 
-
-
-* Modular extraction in Ocaml is now far more readable: 
-instead of qualifying everywhere (A.foo), there are now some "open" at the 
-beginning of files. Possible clashes are dealt with. 
-
-
-* By default, any recursive function associated with an inductive type 
-(foo_rec and foo_rect when foo is inductive type) will now be inlined 
-in extracted code. 
-
-
-* A few constants are explicitely declared to be inlined in extracted code. 
-For the moment there are: 
-	Wf.Acc_rec
-	Wf.Acc_rect
-	Wf.well_founded_induction
-	Wf.well_founded_induction_type
-Those constants does not match the auto-inlining criterion based on strictness.
-Of course, you can still overide this behaviour via some Extraction NoInline. 
-
-* There is now a web page showing the extraction of all standard theories: 
-http://www.lri.fr/~letouzey/extraction
-
-
-7.1 -> 7.2 :
-
-* Syntax changes, see Documentation for more details: 
-
-Set/Unset Extraction Optimize. 
-
-Default is Set. This control all optimizations made on the ML terms 
-(mostly reduction of dummy beta/iota redexes, but also simplications on 
-Cases, etc). Put this option to Unset if you what a ML term as close as 
-possible to the Coq term.
-
-Set/Unset Extraction AutoInline. 
-
-Default in Set, so by default, the extraction mechanism feels free to 
-inline the bodies of some defined constants, according to some heuristics 
-like size of bodies, useness of some arguments, etc. Those heuristics are 
-not always perfect, you may want to disable this feature, do it by Unset. 
-
-Extraction Inline toto foo. 
-Extraction NoInline titi faa bor. 
-
-In addition to the automatic inline feature, you can now tell precisely to 
-inline some more constants by the Extraction Inline command. Conversely, 
-you can forbid the inlining of some specific constants by automatic inlining. 
-Those two commands enable a precise control of what is inlined and what is not. 
-
-Print Extraction Inline. 
-
-Sum up the current state of the table recording the custom inlings 
-(Extraction (No)Inline). 
-
-Reset Extraction Inline. 
-
-Put the table recording the custom inlings back to empty. 
-
-As a consequence, there is no more need for options inside the commands of 
-extraction: 
-
-Extraction foo. 
-Recursive Extraction foo bar. 
-Extraction "file" foo bar. 
-Extraction Module Mymodule. 
-Recursive Extraction Module Mymodule. 
-
-New: The last syntax extracts the module Mymodule and all the modules 
-it depends on. 
-
-You can also try the Haskell versions (not tested yet): 
-
-Haskell Extraction foo.
-Haskell Recursive Extraction foo bar.
-Haskell Extraction "file" foo bar.
-Haskell Extraction Module Mymodule.
-Haskell Recursive Extraction Module Mymodule.
-
-And there's still the realization syntax: 
-
-Extract Constant coq_bla => "caml_bla".
-Extract Inlined Constant coq_bla => "caml_bla".
-Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ].
-
-Note that now, the Extract Inlined Constant command is sugar for an Extract 
-Constant followed by a Extraction Inline. So be careful with 
-Reset Extraction Inline. 
-
- 
-
-* Lot of works around optimization of produced code. Should make code more 
-readable. 
-
-- fixpoint definitions : there should be no more stupid printings like 
-
-let foo x = 
-  let rec f x = 
-    .... (f y) ....
-  in f x
-
-but rather 
-
-let rec foo x = 
-  .... (foo y) .... 
-
-- generalized iota (in particular iota and permutation cases/cases):
-
-A generalized iota redex is a "Cases e of ...." where e is ok. 
-And the recursive predicate "ok" is given by:  
-e is ok if e is a Constructor or a Cases where all branches are ok.
-In the case of generalized iota redex, it might be good idea to reduce it, 
-so we do it. 
-Example: 
-
-match (match t with 
-         O -> Left
-       | S n -> match n with 
-                  O -> Right 
-                | S m -> Left) with 
- Left -> blabla 
-| Right -> bloblo
-
-After simplification, that gives: 
-
-match t with 
-  O -> blabla
-| S n -> match n with 
-          O -> bloblo
-        | S n -> blabla
-
-As shown on the example, code duplication can occur. In practice 
-it seems not to happen frequently. 
-
-- "constant" case:
-In V7.1 we used to simplify cases where all branches are the same. 
-In V7.2 we can simplify in addition terms like 
-	cases e of 
-	  C1 x y -> f (C x y)
-	| C2 z -> f (C2 z) 
-If x y z don't occur in f, we can produce (f e). 
-
-- permutation cases/fun: 
-extracted code has frequenty functions in branches of cases: 
-
-let foo x = match x with 
-   O -> fun _ -> .... 
- | S y -> fun _ -> .... 
-
-the optimization consist in lifting the common "fun _ ->", and that gives
- 
-let foo x _ = match x with 
-   O -> .....
- | S y -> ....
- 
-
-* Some bug corrections (many thanks in particular to Michel Levy). 
-
-* Testing in coq contributions: 
-If you are interested in extraction, you can look at the extraction tests 
-I'have put in the following coq contributions 
-
-Bordeaux/Additions			computation of fibonacci(2000)
-Bordeaux/EXCEPTIONS			multiplication using exception.
-Bordeaux/SearchTrees			list -> binary tree. maximum.
-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-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. 
-Sophia-Antipolis/Stalmarck		boolean tautology checker.
-Suresnes/BDD				boolean tautology checker.
-
-Just do "make" in those contributions, the extraction test is integrated. 
-More tests will follow on more contributions.
-
-
-
-7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with.
-
-* The semantics of Extract Constant changed: If you provide a extraction 
-for p by Extract Constant p => "0", your generated ML file will begin by 
-a let p = 0. The old semantics, which was to replace p everywhere by the
-provided terms, is still available via the Extract Inlined Constant p => 
-"0" syntax.
-
-
-* There are more optimizations applied to the generated code: 
-- identity cases: match e with P x y -> P x y | Q z -> Q z | ...
-is simplified into e. Especially interesting with the sumbool terms: 
-there will be no more match ... with Left -> Left | Right -> Right
-
-- constant cases: match e with P x y -> c | Q z -> c | ...
-is simplified into c as soon as x, y, z do not occur in c.
-So no more match ... with Left -> Left | Right -> Left.
-  
-
-* the extraction at Toplevel (Extraction foo and Recursive Extraction foo),
-which was only a development tool at the beginning, is now closer to 
-the real extraction to a file. In particular optimizations are done, 
-and constants like recursors ( ..._rec ) are expanded. 
-
-
-* the singleton optimization is now protected against circular type.
-( Remind : this optimization is the one that simplify 
-type 'a sig = Exists of 'a  into type 'a sig = 'a and 
-match e with (Exists c) -> d into let c = e in d ) 
-
-
-* Fixed one bug concerning casted code
-
-
-* The inductives generated should now have always correct type-var list 
-('a,'b,'c...)
-
-
-* Code cleanup until three days before release. Messing-up code 
-in the last three days before release.
-
-
-
-
-
-
-
-6.x -> 7.0 : Everything changed. See README
diff --git a/contrib/extraction/README b/contrib/extraction/README
deleted file mode 100644
index 7350365e..00000000
--- a/contrib/extraction/README
+++ /dev/null
@@ -1,139 +0,0 @@
-
-Status of Extraction in Coq version 7.x
-======================================
-
-(* 22 jan 2003 : Updated for version 7.4 *)
-
-
-J.C. Filliâtre
-P. Letouzey
-
-
-
-Extraction code has been completely rewritten since version V6.3. 
-This work is still not finished, but most parts of it are already usable. 
-In consequence it is included in the Coq V7.0 final release. 
-But don't be mistaken: 
-
-	THIS WORK IS STILL EXPERIMENTAL !
-
-1) Principles 
-
-The main goal of the new extraction is to handle any Coq term, even 
-those upon sort Type, and to produce code that always compiles. 
-Thus it will never answer something like "Not an ML type", but rather
-a dummy term like the ML unit. 
-
-Translation between Coq and ML is based upon the following principles: 
-
-- Terms of sort Prop don't have any computational meaning, so they are
-merged into one ML term "__". This part is done according to P. Letouzey's 
-works (*) and (**).
-
-This dummy constant "__" used to be implemented by the unit (), but 
-we recently found that this constant might be applied in some cases. 
-So "__" is now in Ocaml a fixpoint that forgets its arguments: 
-
-           let __ = let rec f _ = Obj.repr f in Obj.repr f
-
-
-- Terms that are type schemes (i.e. something of type ( : )( : )...s with 
-s a sort ) don't have any ML counterpart at the term level, since they 
-are types transformers. In fact they do not have any computational
-meaning either. So we also merge them into that dummy term "__".
-
-- A Coq term gives a ML term or a ML type depending of its type: 
-type schemes will (try to) give ML types, and all other terms give ML terms.
-
-And the rest of the translation is (almost) straightforward: an inductive
-gives an inductive, etc...
-
-This gives ML code that have no special reason to typecheck, due 
-to the incompatibilities between Coq and ML typing systems. In fact
-most of the time everything goes right. For example, it is sufficient 
-to extract and compile everything in the "theories" directory 
-(cf test subdirectory).
-
-We now verify during extraction that the produced code is typecheckable, 
-and if it is not we insert unsafe type casting at critical points in the 
-code. For the moment, it is an Ocaml-only feature, using the "Obj.magic"
-function, but the same kind of trick will be soon made in Haskell.
-
-
-2) Differences with previous extraction (V6.3 and before)
-
-2.a) The pros 
-
-The ability to extract every Coq term, as explain in the previous 
-paragraph. 
-
-The ability to extract from a file an ML module (cf Extraction Module in the 
-documentation)
-
-You can have a taste of extraction directly at the toplevel by 
-using the "Extraction <ident>" or the "Recursive Extraction <ident>".
-This toplevel extraction was already there in V6.3, but was printing 
-Fw terms. It now prints in the language of your choice: 
-Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. 
-
-The optimization done on extracted code has been ported between 
-V6.3 and V7 and enhanced, and in particular the mechanism of automatic
-expansion. 
-
-2.b) The cons 
-
-The presence of some parasite "__" as dummy arguments
-in functions. This denotes the rests of a proof part. The previous 
-extraction was able to remove them totally. The current implementation
-removes a good deal of them (more that in 7.0), but not all. 
-
-This problem is due to extraction upon Type.
-For example, let's take this pathological term: 
-	(if b then Set else Prop)  : Type
-The only way to know if this is an Set (to keep) or a Prop (to remove) 
-is to compute the boolean b, and we do not want to do that during 
-extraction. 
-
-There is no more "ML import" feature. You can compensate by using 
-Axioms, and then "Extract Constant ..." 
-
-3) Examples 
-
-The file "test-extraction.v" is made of some examples used while debugging.
-
-In the subdirectory "test", you can test extraction on the Coq theories.
-Go there.
-"make tree" to make a local copy of the "theories" tree
-"make" to extract & compile most of the theories file in Ocaml
-"make -f Makefile.haskell" to extract & compile in Haskell
-
-See also Reference Manual for explanation of extraction syntaxes
-and more examples. 
-
-
-(*):
-Exécution de termes de preuves: une nouvelle méthode d'extraction 
-pour le Calcul des Constructions Inductives, Pierre Letouzey,
-DEA thesis, 2000, 
-http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz
-
-(**) 
-A New Extraction for Coq, Pierre Letouzey, 
-Types 2002 Post-Workshop Proceedings, to appear, 
-draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz
-
-
-Any feedback is welcome: 
-Pierre.Letouzey@lri.fr
-Jean.Christophe.Filliatre@lri.fr
-
-
-
-
-
-
-
-
-
-
-
diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO
deleted file mode 100644
index 174be06e..00000000
--- a/contrib/extraction/TODO
+++ /dev/null
@@ -1,31 +0,0 @@
-
- 16. Haskell : 
-     - equivalent of Obj.magic (unsafeCoerce ?) 
-     - look again at the syntax (make it independant of layout ...)  
-     - producing .hi files
-     - modules/modules types/functors in Haskell ?
-
- 17. Scheme : 
-     - modular Scheme ? 
-
- 18. Improve speed (profiling)
-
- 19. Look again at those hugly renamings functions. 
-     Especially get rid of ML clashes like 
-   
-    let t = 0
-    module M = struct 
-       let t = 1 
-       let u = The.External.t (* ?? *)
-    end
-
- 20. Support the .v-as-internal-module, like in 
-    
-    <file A.v>
-    Definition foo :=O.
-    <End file A.v>
-
-    <at toplevel>
-    Require A.
-    Module M:=A
-    Extraction M.
\ No newline at end of file
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
deleted file mode 100644
index 73f44e68..00000000
--- a/contrib/extraction/common.ml
+++ /dev/null
@@ -1,444 +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        *)
-(************************************************************************)
-
-(*i $Id: common.ml 13200 2010-06-25 22:36:25Z letouzey $ i*)
-
-open Pp
-open Util
-open Names
-open Term
-open Declarations
-open Nameops
-open Libnames
-open Table
-open Miniml
-open Mlutil
-open Modutil
-open Mod_subst
-
-let string_of_id id = ascii_of_ident (Names.string_of_id id)
-
-(*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] -> s
-  | s::[""] -> s
-  | s::l -> (dottify l)^"."^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 =
-  let s = string_of_id id in
-  assert (s<>"");
-  if s.[0] = '_' then id_of_string ("Coq_"^s)
-  else id_of_string (String.capitalize s)
-
-type kind = Term | Type | Cons | Mod
-
-let upperkind = function
-  | Type -> lang () = Haskell
-  | Term -> false
-  | Cons | Mod -> true
-
-let kindcase_id k id =
-  if upperkind k then uppercase_id id else lowercase_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 register_cleanup, do_cleanup =
-  let funs = ref [] in
-  (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs)
-
-type phase = Pre | Impl | Intf
-
-let set_phase, get_phase =
-  let ph = ref Impl in ((:=) ph), (fun () -> !ph)
-
-let set_keywords, get_keywords =
-  let k = ref Idset.empty in
-  ((:=) k), (fun () -> !k)
-
-let add_global_ids, get_global_ids =
-  let ids = ref Idset.empty in
-  register_cleanup (fun () -> ids := get_keywords ());
-  let add s = ids := Idset.add s !ids
-  and get () = !ids
-  in (add,get)
-
-let empty_env () = [], get_global_ids ()
-
-let mktable autoclean =
-  let h = Hashtbl.create 97 in
-  if autoclean then register_cleanup (fun () -> Hashtbl.clear h);
-  (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h)
-
-(* A table recording objects in the first level of all MPfile *)
-
-let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content =
-  mktable false
-
-(*s The list of external modules that will be opened initially *)
-
-let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear =
-  let m = ref MPset.empty in
-  let add mp = m:=MPset.add mp !m
-  and mem mp = MPset.mem mp !m
-  and list () = MPset.elements !m
-  and clear () = m:=MPset.empty
-  in
-  register_cleanup clear;
-  (add,mem,list,clear)
-
-(*s table indicating the visible horizon at a precise moment,
-    i.e. the stack of structures we are inside.
-
-  - The sequence of [mp] parts should have the following form: 
-  [X.Y; X; A.B.C; A.B; A; ...], i.e. each addition should either 
-  be a [MPdot] over the last entry, or something new, mainly 
-  [MPself], or [MPfile] at the beginning.
-
-  - The [content] part is used to recoard all the names already
-  seen at this level.
-  
-  - The [subst] part is here mainly for printing signature
-  (in which names are still short, i.e. relative to a [msid]).
-*)
-
-type visible_layer = { mp : module_path;
-		       content : ((kind*string),unit) Hashtbl.t }
-
-let pop_visible, push_visible, get_visible, subst_mp =
-  let vis = ref [] and sub = ref [empty_subst] in
-  register_cleanup (fun () -> vis := []; sub := [empty_subst]);
-  let pop () =
-    let v = List.hd !vis in
-    (* we save the 1st-level-content of MPfile for later use *)
-    if get_phase () = Impl && modular () && is_modfile v.mp
-    then add_mpfiles_content v.mp v.content;
-    vis := List.tl !vis;
-    sub := List.tl !sub
-  and push mp o =
-    vis := { mp = mp; content = Hashtbl.create 97 } :: !vis;
-    let s = List.hd !sub in
-    let s = match o with None -> s | Some msid -> add_msid msid mp s in
-    sub := s :: !sub
-  and get () = !vis
-  and subst mp = subst_mp (List.hd !sub) mp
-  in (pop,push,get,subst)
-
-let get_visible_mps () = List.map (function v -> v.mp) (get_visible ())
-let top_visible () = match get_visible () with [] -> assert false | v::_ -> v
-let top_visible_mp () = (top_visible ()).mp
-let add_visible ks = Hashtbl.add (top_visible ()).content ks ()
-
-(* table of local module wrappers used to provide non-ambiguous names *)
-
-let add_duplicate, check_duplicate =
-  let index = ref 0 and dups = ref Gmap.empty in
-  register_cleanup (fun () -> index := 0; dups := Gmap.empty);
-  let add mp l =
-     incr index;
-     let ren = "Coq__" ^ string_of_int (!index) in
-     dups := Gmap.add (mp,l) ren !dups
-  and check mp l = Gmap.find (subst_mp mp, l) !dups
-  in (add,check)
-
-type reset_kind = AllButExternal | Everything
-
-let reset_renaming_tables flag =
-  do_cleanup ();
-  if flag = Everything then clear_mpfiles_content ()
-
-(*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 
-   with previous [Coq_id] variable, these prefixes are duplicated if already 
-   existing. *)
-
-let modular_rename k id =
-  let s = string_of_id id in
-  let prefix,is_ok =
-    if upperkind k then "Coq_",is_upper else "coq_",is_lower
-  in
-  if not (is_ok s) ||
-    (Idset.mem id (get_keywords ())) ||
-    (String.length s >= 4 && String.sub s 0 4 = prefix)
-  then prefix ^ s
-  else s
-
-(*s For monolithic extraction, first-level modules might have to be renamed 
-    with unique numbers *)
-
-let modfstlev_rename =
-  let add_prefixes,get_prefixes,_ = mktable true in
-  fun l ->
-    let coqid = id_of_string "Coq" in
-    let id = id_of_label l in
-    try
-      let coqset = get_prefixes id in
-      let nextcoq = next_ident_away coqid coqset in
-      add_prefixes 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_prefixes id [coqid]; "Coq_"^s)
-      else
-	(add_prefixes id []; s)
-
-(*s Creating renaming for a [module_path] : first, the real function ... *)
-
-let rec mp_renaming_fun mp = match mp with
-  | _ when not (modular ()) && at_toplevel mp -> [""]
-  | MPdot (mp,l) ->
-      let lmp = mp_renaming mp in
-      if lmp = [""] then (modfstlev_rename l)::lmp
-      else (modular_rename Mod (id_of_label l))::lmp
-  | MPself msid -> [modular_rename Mod (id_of_msid msid)]
-  | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)]
-  | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *)
-  | MPfile _ ->
-      assert (get_phase () = Pre);
-      let current_mpfile = (list_last (get_visible ())).mp in
-      if mp <> current_mpfile then mpfiles_add mp;
-      [string_of_modfile mp]
-
-(* ... and its version using a cache *)
-
-and mp_renaming =
-  let add,get,_ = mktable true in
-  fun x ->  try get x with Not_found -> let y = mp_renaming_fun x in add x y; y
-
-(*s Renamings creation for a [global_reference]: we build its fully-qualified
-    name in a [string list] form (head is the short name). *)
-
-let ref_renaming_fun (k,r) =
-  let mp = subst_mp (modpath_of_r r) in
-  let l = mp_renaming mp in
-  let s =
-    if l = [""] (* this happens only at toplevel of the monolithic case *)
-    then
-      let globs = Idset.elements (get_global_ids ()) in
-      let id = next_ident_away (kindcase_id k (safe_id_of_global r)) globs in
-      string_of_id id
-    else modular_rename k (safe_id_of_global r)
-  in
-  add_global_ids (id_of_string s);
-  s::l
-
-(* Cached version of the last function *)
-
-let ref_renaming =
-  let add,get,_ = mktable true in
-  fun x -> try get x with Not_found -> let y = ref_renaming_fun x in add x y; y
-
-(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k]
-   can be printed as [s] in the current context of visible
-   modules. More precisely, we check if there exists a 
-   visible [mp] that contains [s]. 
-   The verification stops if we encounter [mp=mp0]. *)
-
-let rec clash mem mp0 ks = function
-  | [] -> false
-  | mp :: _ when mp = mp0 -> false
-  | mp :: _ when mem mp ks -> true
-  | _ :: mpl -> clash mem mp0 ks mpl
-
-let mpfiles_clash mp0 ks =
-  clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks
-    (List.rev (mpfiles_list ()))
-
-let visible_clash mp0 ks =
-  let rec clash = function
-    | [] -> false
-    | v :: _ when v.mp = mp0 -> false
-    | v :: _ when Hashtbl.mem v.content ks -> true
-    | _ :: vis -> clash vis
-  in clash (get_visible ())
-
-(* After the 1st pass, we can decide which modules will be opened initially *)
-
-let opened_libraries () =
-  if not (modular ()) then []
-  else
-    let used = mpfiles_list () in
-    let rec check_elsewhere avoid = function
-      | [] -> []
-      | mp :: mpl ->
-	  let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in
-	  if List.exists clash avoid
-	  then check_elsewhere avoid mpl
-	  else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl
-    in
-    let opened = check_elsewhere [] used in
-    mpfiles_clear ();
-    List.iter mpfiles_add opened;
-    opened
-
-(*s On-the-fly qualification issues for both monolithic or modular extraction. *)
-
-(* First, a function that factorize the printing of both [global_reference]
-   and module names for ocaml. When [k=Mod] then [olab=None], otherwise it 
-   contains the label of the reference to print. 
-   Invariant: [List.length ls >= 2], simpler situations are handled elsewhere. *)
-
-let pp_gen k mp ls olab =
-  try (* what is the largest prefix of [mp] that belongs to [visible]? *)
-    let prefix = common_prefix_from_list mp (get_visible_mps ()) in
-    let delta = mp_length mp - mp_length prefix in
-    assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
-    let ls = list_firstn (delta + if k = Mod then 0 else 1) ls in
-    let s,ls' = list_sep_last ls in
-    (* Reference r / module path mp is of the form [<prefix>.s.<List.rev ls'>].
-       Difficulty: in ocaml the prefix part cannot be used for
-       qualification (we are inside it) and the rest of the long
-       name may be hidden. 
-       Solution: we duplicate the _definition_ of r / mp in a Coq__XXX module *)
-    let k' = if ls' = [] then k else Mod in
-    if visible_clash prefix (k',s) then
-      let front = if ls' = [] && k <> Mod then [s] else ls' in
-      let lab = (* label associated with s *)
-	if delta = 0 && k <> Mod then Option.get olab
-	else get_nth_label_mp delta mp
-      in
-      try dottify (front @ [check_duplicate prefix lab])
-      with Not_found ->
-	assert (get_phase () = Pre); (* otherwise it's too late *)
-	add_duplicate prefix lab; 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
-    (* [List.rev ls] is [base_s :: s :: List.rev ls2] *)
-    let k' = if ls2 = [] then k else Mod in
-    if modular () && (mpfiles_mem base) &&
-      (not (mpfiles_clash base (k',s))) &&
-      (not (visible_clash base (k',s)))
-    then (* Standard situation of an object in another file: *)
-      (* Thanks to the "open" of this file we remove its name *)
-      dottify ls1
-    else if visible_clash base (Mod,base_s) then
-      error_module_clash base_s
-    else dottify ls
-
-let pp_global k r =
-  let ls = ref_renaming (k,r) in
-  assert (List.length ls > 1);
-  let s = List.hd ls in
-  let mp = subst_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_visible (k,s); unquote s)
-  else match lang () with
-    | Scheme -> unquote s (* no modular Scheme extraction... *)
-    | Haskell -> if modular () then dottify ls else s
-	(* for the moment we always qualify in modular Haskell... *)
-    | Ocaml -> pp_gen k mp ls (Some (label_of_r r))
-
-(* The next function is used only in Ocaml extraction...*)
-let pp_module mp =
-  let mp = subst_mp mp in
-  let ls = mp_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_visible (Mod,s); s
-    | _ -> pp_gen Mod mp ls None
-
-
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
deleted file mode 100644
index b7e70414..00000000
--- a/contrib/extraction/common.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        *)
-(************************************************************************)
-
-(*i $Id: common.mli 11559 2008-11-07 22:03:34Z letouzey $ i*)
-
-open Names
-open Libnames
-open Miniml
-open Mlutil
-open Pp
-
-val fnl2 : unit -> std_ppcmds
-val space_if : bool -> std_ppcmds
-val sec_space_if : bool -> std_ppcmds
-
-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
-
-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
-
-type phase = Pre | Impl | Intf
-
-val set_phase : phase -> unit
-val get_phase : unit -> phase
-
-val opened_libraries : unit -> 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 -> mod_self_id option -> unit
-val pop_visible : unit -> unit
-
-val check_duplicate : module_path -> label -> string
-
-type reset_kind = 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
deleted file mode 100644
index 057a7b29..00000000
--- a/contrib/extraction/extract_env.ml
+++ /dev/null
@@ -1,529 +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        *)
-(************************************************************************)
-
-(*i $Id: extract_env.ml 13201 2010-06-25 22:36:27Z letouzey $ i*)
-
-open Term
-open Declarations
-open Names
-open Libnames
-open Pp
-open Util
-open Miniml
-open Table
-open Extraction
-open Modutil
-open Common
-open Mod_subst
-
-(***************************************)
-(*S Part I: computing Coq environment. *)
-(***************************************)
-
-let toplevel_env () = 
-  let seg = Lib.contents_after None in 
-  let get_reference = function 
-    | (_,kn), Lib.Leaf o ->
-	let mp,_,l = repr_kn kn in 
-	let seb = match Libobject.object_tag o with
-	  | "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 -> SEBstruct (msid, List.rev (map_succeed get_reference seg))
-    | _ -> assert false
-
-let environment_until dir_opt = 
-  let rec parse = function 
-    | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
-    | [] -> [] 
-    | d :: l -> 
-	match (Global.lookup_module (MPfile d)).mod_expr with 
-	  | Some meb -> 
-	      if dir_opt = Some d then [MPfile d, meb]
-	      else (MPfile d, meb) :: (parse l)
-	  | _ -> assert false
-  in parse (Library.loaded_libraries ())
-
-
-(*s Visit: 
-  a structure recording the needed dependencies for the current extraction *)
-
-module type VISIT = sig 
-  (* Reset the dependencies by emptying the visit lists *)
-  val reset : unit -> unit
-    
-  (* Add the module_path and all its prefixes to the mp visit list *)  
-  val add_mp : module_path -> unit
-    
-  (* Add kernel_name / constant / reference / ... in the visit lists. 
-     These functions silently add the mp of their arg in the mp list *)
-  val add_kn : kernel_name -> unit
-  val add_con : constant -> unit
-  val add_ref : global_reference -> unit
-  val add_decl_deps : ml_decl -> unit
-  val add_spec_deps : ml_spec -> unit
-
-  (* Test functions: 
-     is a particular object a needed dependency for the current extraction ? *)
-  val needed_kn : kernel_name -> bool 
-  val needed_con : constant -> bool
-  val needed_mp : module_path -> bool
-end
-  
-module Visit : VISIT = struct 
-  (* What used to be in a single KNset should now be split into a KNset
-     (for inductives and modules names) and a Cset for constants
-     (and still the remaining MPset) *)
-  type must_visit = 
-      { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t }
-  (* the imperative internal visit lists *)
-  let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } 
-  (* the accessor functions *)
-  let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
-  let needed_kn kn = KNset.mem kn v.kn
-  let needed_con c = Cset.mem c v.con
-  let needed_mp mp = MPset.mem mp v.mp
-  let add_mp mp = 
-    check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp
-  let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn)
-  let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c)
-  let add_ref = function 
-    | ConstRef c -> add_con c
-    | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn
-    | VarRef _ -> assert false
-  let add_decl_deps = decl_iter_references add_ref add_ref add_ref 
-  let add_spec_deps = spec_iter_references add_ref add_ref add_ref
-end
-
-exception Impossible
-
-let check_arity env cb = 
-  let t = Typeops.type_of_constant_type env cb.const_type in
-  if Reduction.is_arity env t then raise Impossible
-
-let check_fix env cb i = 
-  match cb.const_body with 
-    | None -> raise Impossible
-    | Some lbody -> 
-	match kind_of_term (Declarations.force lbody) with 
-	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
-	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
-	  | _ -> raise Impossible
-
-let factor_fix env l cb msb = 
-  let _,recd as check = check_fix env cb 0 in 
-  let n = Array.length (let fi,_,_ = recd in fi) in
-  if n = 1 then [|l|], recd, msb
-  else begin 
-    if List.length msb < n-1 then raise Impossible; 
-    let msb', msb'' = list_chop (n-1) msb in 
-    let labels = Array.make n l in 
-    list_iter_i 
-      (fun j -> 
-	 function 
-	   | (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 build_mb expr typ_opt =
-  { mod_expr = Some expr;
-    mod_type = typ_opt;
-    mod_constraints = Univ.Constraint.empty;
-    mod_alias = Mod_subst.empty_subst;
-    mod_retroknowledge = [] }
-
-let my_type_of_mb env mb =
-  match mb.mod_type with
-    | Some mtb -> mtb
-    | None -> Modops.eval_struct env (Option.get mb.mod_expr)
-
-(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
-    To check with Elie. *)
-
-let env_for_mtb_with env mtb idl =
-  let msid,sig_b = match Modops.eval_struct env mtb with
-    | SEBstruct(msid,sig_b) -> msid,sig_b
-    | _ -> assert false
-  in
-  let l = label_of_id (List.hd idl) in
-  let before = fst (list_split_at (fun (l',_) -> l=l') sig_b) in
-  Modops.add_signature (MPself msid) before env
-
-(* From a [structure_body] (i.e. a list of [structure_field_body])
-   to specifications. *)
-
-let rec extract_sfb_spec env mp = function 
-  | [] -> [] 
-  | (l,SFBconst cb) :: msig -> 
-      let kn = make_con mp empty_dirpath l in 
-      let s = extract_constant_spec env kn cb in 
-      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 _) :: msig -> 
-      let kn = make_kn mp empty_dirpath l in 
-      let s = Sind (kn, extract_inductive env kn) in 
-      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 spec = extract_seb_spec env (my_type_of_mb env mb) in
-      (l,Smodule spec) :: specs
-  | (l,SFBmodtype mtb) :: msig -> 
-      let specs = extract_sfb_spec env mp msig in
-      (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs
-  | (l,SFBalias(mp1,typ_opt,_))::msig -> 
-      let mb = build_mb (SEBident mp1) typ_opt in
-      extract_sfb_spec env mp ((l,SFBmodule mb) :: msig)
-
-(* From [struct_expr_body] to specifications *)
-
-(* Invariant: the [seb] given to [extract_seb_spec] should either come:
-   - from a [mod_type] or [type_expr] field
-   - from the output of [Modops.eval_struct].
-   This way, any encountered [SEBident] should be a true module type.
-   For instance, [my_type_of_mb] ensures this invariant.
-*)
-
-and extract_seb_spec env = function
-  | SEBident mp -> Visit.add_mp mp; MTident mp
-  | SEBwith(mtb',With_definition_body(idl,cb))->
-      let env' = env_for_mtb_with env mtb' idl in
-      let mtb''= extract_seb_spec env 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 mtb',
-	     ML_With_module(idl,mp))
-(* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre:
-   | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) 
-     when mbid = mbid2 -> extract_seb_spec env m 
-   (* faudrait alors ajouter un test de non-apparition de mbid dans mb *)
-*)
-  | 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_seb_spec env mtb.typ_expr,
-		extract_seb_spec env' mtb')
-  | SEBstruct (msid, msig) -> 
-      let mp = MPself msid in 
-      let env' = Modops.add_signature mp msig env in 
-	MTsig (msid, extract_sfb_spec env' mp msig) 
-  | SEBapply _ as mtb ->
-      extract_seb_spec env (Modops.eval_struct env mtb)
-
-
-(* From a [structure_body] (i.e. a list of [structure_field_body])
-   to implementations. 
-
-   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,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_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
-	   if (not b) && (logical_decl d) then ms 
-	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
-	 else ms
-       with Impossible ->
-	 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 
-	   let d = extract_constant env c cb in
-	   if (not b) && (logical_decl d) then ms 
-	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
-	 else ms)
-  | (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 
-	let d = Dind (kn, extract_inductive env kn) in 
-	if (not b) && (logical_decl d) then ms 
-	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
-      else ms
-  | (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,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 mtb.typ_expr)) :: ms
-      else ms
-  | (l,SFBalias (mp1,typ_opt,_)) :: msb ->
-      let mb = build_mb (SEBident mp1) typ_opt in
-      extract_sfb env mp all ((l,SFBmodule mb) :: msb)
-
-(* 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_seb_spec env 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, Modops.subst_structure (map_msid msid mp) msb
-      in 
-      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]. *)
-  { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr);
-    ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) }
-
-
-let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
-
-let mono_environment refs mpl = 
-  Visit.reset ();
-  List.iter Visit.add_ref refs; 
-  List.iter Visit.add_mp mpl; 
-  let env = Global.env () in 
-  let l = List.rev (environment_until None) in 
-  List.rev_map 
-    (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 fc =
-  let d = descr () in
-  let fn = if d.capital_file then fc else String.uncapitalize fc
-  in
-  Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, id_of_string fc
-
-(*s Extraction of one decl to stdout. *)
-
-let print_one_decl struc mp decl =
-  let d = descr () in
-  reset_renaming_tables AllButExternal;
-  set_phase Pre;
-  ignore (d.pp_struct struc);
-  set_phase Impl;
-  push_visible mp None;
-  msgnl (d.pp_decl decl);
-  pop_visible ()
-
-(*s Extraction of a ml struct to a file. *)
-
-let formatter dry file =
-  if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ())
-  else match file with
-    | None -> !Pp_control.std_ft
-    | Some cout ->
-	let ft = Pp_control.with_output_to cout in
-	Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ());
-	ft
-
-let print_structure_to_file (fn,si,mo) dry struc =
-  let d = descr () in
-  reset_renaming_tables AllButExternal;
-  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
-  (* First, a dry run, for computing objects to rename or duplicate *)
-  set_phase Pre;
-  let devnull = formatter true None in
-  msg_with devnull (d.pp_struct struc);
-  let opened = opened_libraries () in
-  (* Print the implementation *)
-  let cout = if dry then None else Option.map open_out fn in
-  let ft = formatter dry cout in
-  begin try
-    (* The real printing of the implementation *)
-    set_phase Impl;
-    msg_with ft (d.preamble mo opened unsafe_needs);
-    msg_with ft (d.pp_struct struc);
-    Option.iter close_out cout; 
-  with e -> 
-    Option.iter close_out cout; raise e
-  end;
-  if not dry then Option.iter info_file fn;
-  (* Now, let's print the signature *)
-  Option.iter
-    (fun si ->
-       let cout = open_out si in
-       let ft = formatter false (Some cout) in
-       begin try
-	 set_phase Intf;
-	 msg_with ft (d.sig_preamble mo opened unsafe_needs);
-	 msg_with ft (d.pp_sig (signature_of_structure struc));
-	 close_out cout;
-       with e -> 
-	 close_out cout; raise e 
-       end; 
-       info_file si)
-    (if dry then None else 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 ()
-
-(* From a list of [reference], let's retrieve whether they correspond
-   to modules or [global_reference]. Warn the user if both is possible. *)
-
-let rec locate_ref = function
-  | [] -> [],[]
-  | r::l ->
-      let q = snd (qualid_of_reference r) in
-      let mpo = try Some (Nametab.locate_module q) with Not_found -> None
-      and ro = try Some (Nametab.locate q) with Not_found -> None in
-      match mpo, ro with
-	| None, None -> Nametab.error_global_not_found q
-	| None, Some r -> let refs,mps = locate_ref l in r::refs,mps
-	| Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps
-	| Some mp, Some r ->
-	    warning_both_mod_and_cst q mp r;
-	    let refs,mps = locate_ref l in refs,mp::mps
-
-(*s Recursive extraction in the Coq toplevel. The vernacular command is
-    \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when 
-    extracting to a file with the command: 
-    \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
-
-let full_extr f (refs,mps) =
-  init false;
-  List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps;
-  let struc = optimize_struct refs (mono_environment refs mps) in
-  warning_axioms ();
-  print_structure_to_file (mono_filename f) false struc;
-  reset ()
-
-let full_extraction f lr = full_extr f (locate_ref lr)
-
-
-(*s Simple extraction in the Coq toplevel. The vernacular command 
-    is \verb!Extraction! [qualid]. *)
-
-let simple_extraction r = match locate_ref [r] with
-  | ([], [mp]) as p -> full_extr None p
-  | [r],[] ->
-      init false;
-      let struc = optimize_struct [r] (mono_environment [r] []) in
-      let d = get_decl_in_structure r struc in
-      warning_axioms ();
-      if is_custom r then msgnl (str "(** User defined extraction *)");
-      print_one_decl struc (modpath_of_r r) d;
-      reset ()
-  | _ -> assert false
-
-
-(*s (Recursive) Extraction of a library. The vernacular command is 
-  \verb!(Recursive) Extraction Library! [M]. *) 
-
-let extraction_library is_rec m =
-  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_seb env (Some mp) true meb)) :: l 
-    else l
-  in
-  let struc = List.fold_left select [] l in
-  let struc = optimize_struct [] struc in
-  warning_axioms ();
-  let print = function
-    | (MPfile dir as mp, sel) as e ->
-	let dry = not is_rec && dir <> dir_m in
-	let s = string_of_modfile mp in
-	print_structure_to_file (module_filename s) dry [e]
-    | _ -> assert false
-  in
-  List.iter print struc;
-  reset ()
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
deleted file mode 100644
index 8d906985..00000000
--- a/contrib/extraction/extract_env.mli
+++ /dev/null
@@ -1,23 +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        *)
-(************************************************************************)
-
-(*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 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
deleted file mode 100644
index 2cf457c6..00000000
--- a/contrib/extraction/extraction.ml
+++ /dev/null
@@ -1,917 +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        *)
-(************************************************************************)
-
-(*i $Id: extraction.ml 11897 2009-02-09 19:28:02Z barras $ i*)
-
-(*i*)
-open Util
-open Names
-open Term
-open Declarations
-open Environ
-open Reduction
-open Reductionops
-open Inductive
-open Termops
-open Inductiveops
-open Recordops
-open Nameops
-open Summary
-open Libnames
-open Nametab
-open Miniml
-open Table
-open Mlutil
-(*i*)
-
-exception I of inductive_info
-
-(* A set of all fixpoint functions currently being extracted *)
-let current_fixpoints = ref ([] : constant list)
-
-let none = Evd.empty
-
-let type_of env c = Retyping.get_type_of env none (strip_outer_cast c)
-
-let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c)
-
-let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
-
-(*S Generation of flags and signatures. *)
-
-(* The type [flag] gives us information about any Coq term: 
-   \begin{itemize}
-   \item [TypeScheme] denotes a type scheme, that is 
-     something that will become a type after enough applications. 
-     More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with 
-     [s = Set], [Prop] or [Type] 
-   \item [Default] denotes the other cases. It may be inexact after 
-     instanciation. For example [(X:Type)X] is [Default] and may give [Set]
-     after instanciation, which is rather [TypeScheme]
-   \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
-   \item [Info] is the opposite. The same example [(X:Type)X] shows 
-     that an [Info] term might in fact be [Logic] later on. 
-   \end{itemize} *)
-
-type info = Logic | Info
-
-type scheme = TypeScheme | Default
-
-type flag = info * scheme
-
-(*s [flag_of_type] transforms a type [t] into a [flag]. 
-  Really important function. *)
-
-let rec flag_of_type env t = 
-  let t = whd_betadeltaiota env none t in 
-  match kind_of_term t with
-    | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
-    | Sort (Prop Null) -> (Logic,TypeScheme)
-    | Sort _ -> (Info,TypeScheme)
-    | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
-
-(*s Two particular cases of [flag_of_type]. *)
-
-let is_default env t = (flag_of_type env t = (Info, Default))
-
-exception NotDefault of kill_reason
-
-let check_default env t = 
-  match flag_of_type env t with 
-    | _,TypeScheme -> raise (NotDefault Ktype)
-    | Logic,_ -> raise (NotDefault Kother)
-    | _ -> ()
-
-let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
-
-(*s [type_sign] gernerates a signature aimed at treating a type application. *)
-
-let rec type_sign env c = 
-  match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
-	(if is_info_scheme env t then Keep else Kill Kother)
-	:: (type_sign (push_rel_assum (n,t) env) d)
-    | _ -> []
-
-let rec type_scheme_nb_args env c = 
-  match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
-	let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in 
-	if is_info_scheme env t then n+1 else n
-    | _ -> 0
-
-let _ = register_type_scheme_nb_args type_scheme_nb_args
-
-(*s [type_sign_vl] does the same, plus a type var list. *)
-
-let rec type_sign_vl env c = 
-  match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) -> 
-	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in 
-	if not (is_info_scheme env t) then Kill Kother::s, vl
-	else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
-    | _ -> [],[]
-
-let rec nb_default_params env c = 
-  match kind_of_term (whd_betadeltaiota env none c) with
-    | Prod (n,t,d) ->
-	let n = nb_default_params (push_rel_assum (n,t) env) d in 
-	if is_default env t then n+1 else n
-    | _ -> 0
-
-(*S Management of type variable contexts. *)
-
-(* A De Bruijn variable context (db) is a context for translating Coq [Rel]  
-   into ML type [Tvar]. *)
-
-(*s From a type signature toward a type variable context (db). *)
-
-let db_from_sign s = 
-  let rec make i acc = function 
-    | [] -> acc  
-    | Keep :: l -> make (i+1) (i::acc) l
-    | Kill _ :: l -> make i (0::acc) l
-  in make 1 [] s
-
-(*s Create a type variable context from indications taken from 
-  an inductive type (see just below). *) 
-
-let rec db_from_ind dbmap i = 
-  if i = 0 then []
-  else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
-
-(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument 
-  of a constructor corresponds to the j-th type var of the ML inductive. *)
-
-(* \begin{itemize}
-   \item [si] : signature of the inductive
-   \item [i] :  counter of Coq args for [(I args)] 
-   \item [j] : counter of ML type vars 
-   \item [relmax] : total args number of the constructor 
-   \end{itemize} *)
-
-let parse_ind_args si args relmax = 
-  let rec parse i j = function 
-    | [] -> Intmap.empty
-    | Kill _ :: s -> parse (i+1) j s
-    | Keep :: s -> 
-      (match kind_of_term args.(i-1) with 
-	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
-	 | _ -> parse (i+1) (j+1) s)
-  in parse 1 1 si 
-
-(*S Extraction of a type. *)
-
-(* [extract_type env db c args] is used to produce an ML type from the 
-   coq term [(c args)], which is supposed to be a Coq type. *)
-
-(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
-
-(* [j] stands for the next ML type var. [j=0] means we do not 
-   generate ML type var anymore (in subterms for example). *) 
-
-
-let rec extract_type env db j c args = 
-  match kind_of_term (whd_betaiotazeta Evd.empty c) with
-    | App (d, args') ->
-	(* We just accumulate the arguments. *)
-	extract_type env db j d (Array.to_list args' @ args)
-    | Lambda (_,_,d) -> 
-	(match args with 
-	   | [] -> assert false (* otherwise the lambda would be reductible. *)
-	   | a :: args -> extract_type env db j (subst1 a d) args)
-    | Prod (n,t,d) ->
-	assert (args = []); 
-	let env' = push_rel_assum (n,t) env in 
-	(match flag_of_type env t with 
-	   | (Info, Default) -> 
-	       (* Standard case: two [extract_type] ... *)
-	       let mld = extract_type env' (0::db) j d [] in 
-	       (match expand env mld with 
-		  | Tdummy d -> Tdummy d
-		  | _ -> Tarr (extract_type env db 0 t [], mld))
-	   | (Info, TypeScheme) when j > 0 -> 
-	       (* A new type var. *)
-	       let mld = extract_type env' (j::db) (j+1) d [] in 
-	       (match expand env mld with 
-		  | Tdummy d -> Tdummy d
-		  | _ -> Tarr (Tdummy Ktype, mld))
-	   | _,lvl -> 
-	       let mld = extract_type env' (0::db) j d [] in 
-	       (match expand env mld with 
-		  | Tdummy d -> Tdummy d
-		  | _ -> 
-		      let reason = if lvl=TypeScheme then Ktype else Kother in
-		      Tarr (Tdummy reason, mld)))
-    | Sort _ -> Tdummy Ktype (* The two logical cases. *)
-    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
-    | Rel n -> 
-	(match lookup_rel n env with
-           | (_,Some t,_) -> extract_type env db j (lift n t) args
-	   | _ -> 
-	       (* Asks [db] a translation for [n]. *)
-	       if n > List.length db then Tunknown 
-	       else let n' = List.nth db (n-1) in 
-	       if n' = 0 then Tunknown else Tvar n')
-    | Const kn -> 
-	let r = ConstRef kn in 
-	let cb = lookup_constant kn env in 
-	let typ = Typeops.type_of_constant_type env cb.const_type in 
-	(match flag_of_type env typ with 
-	   | (Info, TypeScheme) -> 
-	       let mlt = extract_type_app env db (r, type_sign env typ) args in 
-	       (match cb.const_body with 
-		  | None -> mlt
-		  | Some _ when is_custom r -> mlt 
-		  | Some lbody -> 
-		      let newc = applist (Declarations.force lbody, args) in 
-		      let mlt' = extract_type env db j newc [] in 
-		      (* ML type abbreviations interact badly with Coq *)
-		      (* reduction, so [mlt] and [mlt'] might be different: *)
-		      (* The more precise is [mlt'], extracted after reduction *)
-		      (* The shortest is [mlt], which use abbreviations *)
-		      (* If possible, we take [mlt], otherwise [mlt']. *)
-		      if expand env mlt = expand env mlt' then mlt else mlt')
-	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
-	       (match cb.const_body with 
-		  | None -> Tunknown (* Brutal approximation ... *)
-		  | Some lbody -> 
-		      (* We try to reduce. *)
-		      let newc = applist (Declarations.force lbody, args) in 
-		      extract_type env db j newc []))
-    | Ind (kn,i) ->
-	let s = (extract_ind env kn).ind_packets.(i).ip_sign in  
-	extract_type_app env db (IndRef (kn,i),s) args
-    | Case _ | Fix _ | CoFix _ -> Tunknown
-    | _ -> assert false
-
-(* [extract_maybe_type] calls [extract_type] when used on a Coq type, 
-   and otherwise returns [Tdummy] or [Tunknown] *)
-
-and extract_maybe_type env db c = 
-  let t = whd_betadeltaiota env none (type_of env c) in 
-  if isSort t then extract_type env db 0 c [] 
-  else if sort_of env t = InProp then Tdummy Kother else Tunknown
-
-(*s Auxiliary function dealing with type application. 
-  Precondition: [r] is a type scheme represented by the signature [s], 
-  and is completely applied: [List.length args = List.length s]. *)
-		  
-and extract_type_app env db (r,s) args =
-  let ml_args = 
-    List.fold_right 
-      (fun (b,c) a -> if b=Keep then 
-	 let p = List.length (fst (splay_prod env none (type_of env c))) in
-         let db = iterate (fun l -> 0 :: l) p db in
-         (extract_type_scheme env db c p) :: a
-       else a)
-      (List.combine s args) []
-  in Tglob (r,  ml_args)
-
-(*S Extraction of a type scheme. *)
-
-(* [extract_type_scheme env db c p] works on a Coq term [c] which is
-  an informative type scheme. It means that [c] is not a Coq type, but will 
-  be when applied to sufficiently many arguments ([p] in fact).  
-  This function decomposes p lambdas, with eta-expansion if needed. *)
-
-(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
-
-and extract_type_scheme env db c p = 
-  if p=0 then extract_type env db 0 c [] 
-  else 
-    let c = whd_betaiotazeta Evd.empty c in 
-    match kind_of_term c with 
-      | Lambda (n,t,d) -> 
-          extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
-      | _ ->  
-          let rels = fst (splay_prod env none (type_of env c)) in
-          let env = push_rels_assum rels env in  
-          let eta_args = List.rev_map mkRel (interval 1 p) in 
-          extract_type env db 0 (lift p c) eta_args
-
-
-(*S Extraction of an inductive type. *)
-
-and extract_ind env kn = (* kn is supposed to be in long form *)
-  let mib = Environ.lookup_mind kn env in
-  try
-    (* For a same kn, we can get various bodies due to module substitutions.
-       We hence check that the mib has not changed from recording 
-       time to retrieving time. Ideally we should also check the env. *)
-    let (mib0,ml_ind) = lookup_ind kn in 
-    if not (mib = mib0) then raise Not_found; 
-    ml_ind
-  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; 
-    (* Everything concerning parameters. *)
-    (* We do that first, since they are common to all the [mib]. *)
-    let mip0 = mib.mind_packets.(0) in 
-    let npar = mib.mind_nparams in
-    let epar = push_rel_context mib.mind_params_ctxt env in
-    (* First pass: we store inductive signatures together with *)
-    (* their type var list. *)
-    let packets = 
-      Array.map 
-	(fun mip ->
-	   let b = snd (mind_arity mip) <> InProp in
-	   let ar = Inductive.type_of_inductive env (mib,mip) in
-	   let s,v = if b then type_sign_vl env ar else [],[] in
-	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
-	   { ip_typename = mip.mind_typename;
-	     ip_consnames = mip.mind_consnames;
-	     ip_logical = (not b); 
-	     ip_sign = s; 
-	     ip_vars = v; 
-	     ip_types = t }) 
-	mib.mind_packets 
-    in 
-    add_ind kn mib
-      {ind_info = Standard; 
-       ind_nparams = npar; 
-       ind_packets = packets; 
-       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 
-      if not p.ip_logical then
-	let types = arities_of_constructors env (kn,i) in 
-	for j = 0 to Array.length types - 1 do 
-	  let t = snd (decompose_prod_n npar types.(j)) in
-	  let prods,head = dest_prod epar t in 
-	  let nprods = List.length prods in 
-          let args = match kind_of_term head with
-            | App (f,args) -> args (* [kind_of_term f = Ind ip] *)
-            | _ -> [||]
-          in
-	  let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in 
-	  let db = db_from_ind dbmap npar in 
-	  p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
-	done
-    done;
-    (* Third pass: we determine special cases. *)
-    let ind_info = 
-      try 
-	if not mib.mind_finite then raise (I Coinductive); 
-	if mib.mind_ntypes <> 1 then raise (I Standard); 
-	let p = packets.(0) in 
-	if p.ip_logical then raise (I Standard);
-	if Array.length p.ip_types <> 1 then raise (I Standard);
-	let typ = p.ip_types.(0) in 
-	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in 
-	if List.length l = 1 && not (type_mem_kn kn (List.hd l)) 
-	then raise (I Singleton); 
-	if l = [] then raise (I Standard);
-	if not mib.mind_record then raise (I Standard);
-	let ip = (kn, 0) in 
-	let r = IndRef ip in 
-	if is_custom r then raise (I Standard); 
-	(* Now we're sure it's a record. *)
-	(* First, we find its field names. *)
-	let rec names_prod t = match kind_of_term t with 
-	  | Prod(n,_,t) -> n::(names_prod t)
-	  | LetIn(_,_,_,t) -> names_prod t
-	  | Cast(t,_,_) -> names_prod t
-	  | _ -> []
-	in 
-	let field_names = 
-	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in 
-	assert (List.length field_names = List.length typ);
-	let projs = ref Cset.empty in 
-	let mp,d,_ = repr_kn kn in 
-	let rec select_fields l typs = match l,typs with 
-	  | [],[] -> []
-	  | (Name id)::l, typ::typs -> 
-	      if isDummy (expand env typ) then select_fields l typs 
-	      else  
-		let knp = make_con mp d (label_of_id id) in 
-		if not (List.exists isKill (type2signature env typ))
-		then 
-		  projs := Cset.add knp !projs; 
-		(ConstRef knp) :: (select_fields l typs)
-	  | Anonymous::l, typ::typs -> 
-	      if isDummy (expand env typ) then select_fields l typs
-	      else error_record r
-	  | _ -> assert false 
-	in 
-	let field_glob = select_fields field_names typ
-	in
-	(* Is this record officially declared with its projections ? *)
-	(* If so, we use this information. *)
-	begin try 
-	  let n = nb_default_params env
-            (Inductive.type_of_inductive env (mib,mip0))
-	  in
-	  List.iter 
-	    (Option.iter 
-	       (fun kn -> if Cset.mem kn !projs then add_projection n kn))
-	    (lookup_projections ip)
-	with Not_found -> ()
-	end; 
-	Record field_glob
-      with (I info) -> info
-    in
-    let i = {ind_info = ind_info; 
-	     ind_nparams = npar; 
-	     ind_packets = packets; 
-	     ind_equiv = match mib.mind_equiv with 
-	       | None -> NoEquiv
-	       | Some kn -> Equiv kn }
-    in
-    add_ind kn mib i; 
-    i
-
-(*s [extract_type_cons] extracts the type of an inductive 
-  constructor toward the corresponding list of ML types. *)
-
-(* \begin{itemize}
-   \item [db] is a context for translating Coq [Rel] into ML type [Tvar] 
-   \item [dbmap] is a translation map (produced by a call to [parse_in_args])
-   \item [i] is the rank of the current product (initially [params_nb+1]) 
-   \end{itemize} *)
-
-and extract_type_cons env db dbmap c i =
-  match kind_of_term (whd_betadeltaiota env none c) with 
-    | Prod (n,t,d) -> 
-	let env' = push_rel_assum (n,t) env in
-	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
-	let l = extract_type_cons env' db' dbmap d (i+1) in 
-	(extract_type env db 0 t []) :: l 
-    | _ -> [] 
-
-(*s Recording the ML type abbreviation of a Coq type scheme constant. *)
-
-and mlt_env env r = match r with 
-  | ConstRef kn -> 
-      (try 
-	 if not (visible_con kn) then raise Not_found; 
-	 match lookup_term kn with 
-	   | Dtype (_,vl,mlt) -> Some mlt
-	   | _ -> None
-       with Not_found -> 
-	 let cb = Environ.lookup_constant kn env in
-	 let typ = Typeops.type_of_constant_type env cb.const_type in 
-	 match cb.const_body with
-	   | None -> None
-	   | Some l_body -> 
-	       (match flag_of_type env typ with 
-		  | Info,TypeScheme -> 
-		      let body = Declarations.force l_body in
-		      let s,vl = type_sign_vl env typ in 
-		      let db = db_from_sign s in 
-		      let t = extract_type_scheme env db body (List.length s) 
-		      in add_term kn (Dtype (r, vl, t)); Some t
-		  | _ -> None))
-  | _ -> None
-
-and expand env = type_expand (mlt_env env)
-and type2signature env = type_to_signature (mlt_env env)
-let type2sign env = type_to_sign (mlt_env env)
-let type_expunge env = type_expunge (mlt_env env)
-
-(*s Extraction of the type of a constant. *)
-
-let record_constant_type env kn opt_typ = 
-  try 
-    if not (visible_con kn) then raise Not_found; 
-    lookup_type kn 
-  with Not_found ->
-    let typ = match opt_typ with 
-      | None -> Typeops.type_of_constant env kn
-      | Some typ -> typ 
-    in let mlt = extract_type env [] 1 typ [] 
-    in let schema = (type_maxvar mlt, mlt)
-    in add_type kn schema; schema
-
-(*S Extraction of a term. *)
-
-(* Precondition: [(c args)] is not a type scheme, and is informative. *)
-
-(* [mle] is a ML environment [Mlenv.t]. *)
-(* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
-
-let rec extract_term env mle mlt c args = 
-  match kind_of_term c with
-    | App (f,a) ->
-	extract_term env mle mlt f (Array.to_list a @ args)
-    | Lambda (n, t, d) ->
-	let id = id_of_name n in 
-	(match args with 
-	   | a :: l -> 
-	       (* We make as many [LetIn] as possible. *)
- 	       let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
-	       in extract_term env mle mlt d' []
-	   | [] -> 
-	       let env' = push_rel_assum (Name id, t) env in 
-	       let id, a = try check_default env t; id, new_meta()
-	       with NotDefault d -> dummy_name, Tdummy d
-	       in 
-	       let b = new_meta () in 
-	       (* If [mlt] cannot be unified with an arrow type, then magic! *)
-	       let magic = needs_magic (mlt, Tarr (a, b)) in 
-	       let d' = extract_term env' (Mlenv.push_type mle a) b d [] in 
-	       put_magic_if magic (MLlam (id, d')))
-    | LetIn (n, c1, t1, c2) ->
-	let id = id_of_name n in 
-	let env' = push_rel (Name id, Some c1, t1) env in 
-	let args' = List.map (lift 1) args in 
-	(try 
-	  check_default env t1; 
-	  let a = new_meta () in 
-	  let c1' = extract_term env mle a c1 [] in
-	  (* The type of [c1'] is generalized and stored in [mle]. *)
-	  let mle' = Mlenv.push_gen mle a in 
-	  MLletin (id, c1', extract_term env' mle' mlt c2 args') 
-	with NotDefault d -> 
-	  let mle' = Mlenv.push_std_type mle (Tdummy d) in 
-	  ast_pop (extract_term env' mle' mlt c2 args'))
-    | Const kn ->
-	extract_cst_app env mle mlt kn args
-    | Construct cp ->
-	extract_cons_app env mle mlt cp args
-    | Rel n ->
-	(* As soon as the expected [mlt] for the head is known, *)
-	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
-	let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
-	in extract_app env mle mlt extract_rel args 
-    | Case ({ci_ind=ip},_,c0,br) ->
- 	extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
-    | Fix ((_,i),recd) ->
- 	extract_app env mle mlt (extract_fix env mle i recd) args 
-    | CoFix (i,recd) ->
- 	extract_app env mle mlt (extract_fix env mle i recd) args
-    | Cast (c,_,_) -> extract_term env mle mlt c args
-    | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false 
-
-(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) 
-
-and extract_maybe_term env mle mlt c =
-  try check_default env (type_of env c); 
-    extract_term env mle mlt c [] 
-  with NotDefault d -> 
-    put_magic (mlt, Tdummy d) MLdummy
-
-(*s Generic way to deal with an application. *)
-
-(* We first type all arguments starting with unknown meta types. 
-   This gives us the expected type of the head. Then we use the 
-   [mk_head] to produce the ML head from this type. *)
-
-and extract_app env mle mlt mk_head args = 
-  let metas = List.map new_meta args in 
-  let type_head = type_recomp (metas, mlt) in 
-  let mlargs = List.map2 (extract_maybe_term env mle) metas args in 
-  if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs)
-
-(*s Auxiliary function used to extract arguments of constant or constructor. *)
-
-and make_mlargs env e s args typs = 
-  let l = ref s in 
-  let keep () = match !l with [] -> true | b :: s -> l:=s; b=Keep in
-  let rec f = function  
-    | [], [] -> [] 
-    | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt))
-    | _::la, _::lt -> f (la,lt)
-    | _ -> assert false 
-  in f (args,typs)
-
-(*s Extraction of a constant applied to arguments. *)
-
-and extract_cst_app env mle mlt kn args = 
-  (* First, the [ml_schema] of the constant, in expanded version. *) 
-  let nb,t = record_constant_type env kn None in 
-  let schema = nb, expand env t in 
-  (* Can we instantiate types variables for this constant ? *)
-  (* In Ocaml, inside the definition of this constant, the answer is no. *)
-  let instantiated = 
-    if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
-    else instantiation schema
-  in 
-  (* Then the expected type of this constant. *)
-  let a = new_meta () in 
-  (* We compare stored and expected types in two steps. *)
-  (* First, can [kn] be applied to all args ? *)
-  let metas = List.map new_meta args in 
-  let magic1 = needs_magic (type_recomp (metas, a), instantiated) in 
-  (* Second, is the resulting type compatible with the expected type [mlt] ? *)
-  let magic2 = needs_magic (a, mlt) in 
-  (* The internal head receives a magic if [magic1] *)
-  let head = put_magic_if magic1 (MLglob (ConstRef kn)) in 
-  (* Now, the extraction of the arguments. *)
-  let s = type2signature env (snd schema) in 
-  let ls = List.length s in 
-  let la = List.length args in
-  let mla = make_mlargs env mle s args metas in 
-  let mla =
-    if not magic1 then 
-      try 
-	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in 
-	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
-	else mla
-      with _ -> mla
-    else mla
-  in 			    
-  (* Different situations depending of the number of arguments: *)
-  if ls = 0 then put_magic_if magic2 head
-  else if List.mem Keep s then 
-    if la >= ls || not (List.exists isKill s) 
-    then 
-      put_magic_if (magic2 && not magic1) (MLapp (head, mla))
-    else 
-      (* Not enough arguments. We complete via eta-expansion. *)
-      let ls' = ls-la in
-      let s' = list_lastn ls' s in
-      let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
-      put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s')
-  else if List.mem (Kill Kother) s then 
-    (* In the special case of always false signature, one dummy lam is left. *)
-    (* So a [MLdummy] is left accordingly. *) 
-    if la >= ls 
-    then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla))
-    else put_magic_if magic2 (dummy_lams head (ls-la-1))
-  else (* s is made only of [Kill Ktype] *)
-    if la >= ls 
-    then put_magic_if (magic2 && not magic1) (MLapp (head, mla))
-    else put_magic_if magic2 (dummy_lams head (ls-la))
-
-
-(*s Extraction of an inductive constructor applied to arguments. *)
-
-(* \begin{itemize}
-   \item In ML, contructor arguments are uncurryfied. 
-   \item We managed to suppress logical parts inside inductive definitions,
-   but they must appears outside (for partial applications for instance)
-   \item We also suppressed all Coq parameters to the inductives, since
-   they are fixed, and thus are not used for the computation.
-   \end{itemize} *)
-
-and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
-  (* First, we build the type of the constructor, stored in small pieces. *)
-  let mi = extract_ind env kn in 
-  let params_nb = mi.ind_nparams in 
-  let oi = mi.ind_packets.(i) in 
-  let nb_tvars = List.length oi.ip_vars
-  and types = List.map (expand env) oi.ip_types.(j-1) in
-  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in 
-  let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
-  let type_cons = instantiation (nb_tvars, type_cons) in 
-  (* Then, the usual variables [s], [ls], [la], ... *)
-  let s = List.map (type2sign env) types in
-  let ls = List.length s in 
-  let la = List.length args in 
-  assert (la <= ls + params_nb);
-  let la' = max 0 (la - params_nb) in 
-  let args' = list_lastn la' args in 
-  (* Now, we build the expected type of the constructor *)
-  let metas = List.map new_meta args' in 
-  (* If stored and expected types differ, then magic! *)
-  let a = new_meta () in 
-  let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
-  let magic2 = needs_magic (a, mlt) in 
-  let head mla = 
-    if mi.ind_info = Singleton then 
-      put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
-    else put_magic_if magic1 (MLcons (mi.ind_info, ConstructRef cp, mla))
-  in 
-  (* Different situations depending of the number of arguments: *)
-  if la < params_nb then 
-    let head' = head (eta_args_sign ls s) in 
-    put_magic_if magic2 
-      (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
-  else 
-    let mla = make_mlargs env mle s args' metas in 
-    if la = ls + params_nb 
-    then put_magic_if (magic2 && not magic1) (head mla)
-    else (* [ params_nb <= la <= ls + params_nb ] *) 
-      let ls' = params_nb + ls - la in 
-      let s' = list_lastn ls' s in 
-      let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
-      put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
-
-(*S Extraction of a case. *)
-
-and extract_case env mle ((kn,i) as ip,c,br) mlt = 
-  (* [br]: bodies of each branch (in functional form) *)
-  (* [ni]: number of arguments without parameters in each branch *)
-  let ni = mis_constr_nargs_env env ip in
-  let br_size = Array.length br in 
-  assert (Array.length ni = br_size); 
-  if br_size = 0 then begin
-    add_recursors env kn; (* May have passed unseen if logical ... *)
-    MLexn "absurd case"
-  end else 
-    (* [c] has an inductive type, and is not a type scheme type. *)
-    let t = type_of env c in 
-    (* The only non-informative case: [c] is of sort [Prop] *)
-    if (sort_of env t) = InProp then 
-      begin 
-	add_recursors env kn; (* May have passed unseen if logical ... *)
-	(* Logical singleton case: *)
-	(* [match c with C i j k -> t] becomes [t'] *)
-	assert (br_size = 1);
-	let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
-	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in 
-	let e = extract_maybe_term env mle mlt br.(0) in 
-	snd (case_expunge s e)
-      end 
-    else 
-      let mi = extract_ind env kn in 
-      let oi = mi.ind_packets.(i) in 
-      let metas = Array.init (List.length oi.ip_vars) new_meta in 
-      (* The extraction of the head. *)
-      let type_head = Tglob (IndRef ip, Array.to_list metas) in
-      let a = extract_term env mle type_head c [] in 
-      (* The extraction of each branch. *)
-      let extract_branch i = 
-	(* The types of the arguments of the corresponding constructor. *)
-	let f t = type_subst_vect metas (expand env t) in 
-	let l = List.map f oi.ip_types.(i) in
-	(* the corresponding signature *)
-	let s = List.map (type2sign env) oi.ip_types.(i) in
-	(* Extraction of the branch (in functional form). *)
-	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in 
-	(* We suppress dummy arguments according to signature. *)
-	let ids,e = case_expunge s e in
-	(ConstructRef (ip,i+1), List.rev ids, e)
-      in
-      if mi.ind_info = Singleton then 
-	begin 
-	  (* Informative singleton case: *)
-	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
-	  assert (br_size = 1);
-	  let (_,ids,e') = extract_branch 0 in
-	  assert (List.length ids = 1);
-	  MLletin (List.hd ids,a,e')
-	end 
-      else 
-	(* Standard case: we apply [extract_branch]. *)
-	MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch)
-  
-(*s Extraction of a (co)-fixpoint. *)
-
-and extract_fix env mle i (fi,ti,ci as recd) mlt = 
-  let env = push_rec_types recd env in 
-  let metas = Array.map new_meta fi in
-  metas.(i) <- mlt; 
-  let mle = Array.fold_left Mlenv.push_type mle metas in 
-  let ei = array_map2 (extract_maybe_term env mle) metas ci in 
-  MLfix (i, Array.map id_of_name fi, ei)
-
-(*S ML declarations. *)
-
-(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], 
-   and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
-
-let rec decomp_lams_eta_n n env c t = 
-  let rels = fst (decomp_n_prod env none n t) in 
-  let rels = List.map (fun (id,_,c) -> (id,c)) rels in 
-  let m = nb_lam c in 
-  if m >= n then decompose_lam_n n c 
-  else
-    let rels',c = decompose_lam c in 
-    let d = n - m in 
-    (* we'd better keep rels' as long as possible. *)
-    let rels = (list_firstn d rels) @ rels' in
-    let eta_args = List.rev_map mkRel (interval 1 d) in 
-    rels, applist (lift d c,eta_args)
-
-(*s From a constant to a ML declaration. *)
-
-let extract_std_constant env kn body typ = 
-  reset_meta_count (); 
-  (* The short type [t] (i.e. possibly with abbreviations). *)
-  let t = snd (record_constant_type env kn (Some typ)) in 
-  (* The real type [t']: without head lambdas, expanded, *)
-  (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
-  let l,t' = type_decomp (expand env (var2var' t)) in 
-  let s = List.map (type2sign env) l in 
-  (* The initial ML environment. *)
-  let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in 
-  (* Decomposing the top level lambdas of [body]. *)
-  let rels,c = decomp_lams_eta_n (List.length s) env body typ in
-  (* The lambdas names. *)
-  let ids = List.map (fun (n,_) -> id_of_name n) rels in 
-  (* The according Coq environment. *)
-  let env = push_rels_assum rels env in
-  (* The real extraction: *)
-  let e = extract_term env mle t' c [] in
-  (* Expunging term and type from dummy lambdas. *) 
-  term_expunge s (ids,e), type_expunge env t
-
-let extract_fixpoint env vkn (fi,ti,ci) = 
-  let n = Array.length vkn in 
-  let types = Array.make n (Tdummy Kother)
-  and terms = Array.make n MLdummy in 
-  let kns = Array.to_list vkn in 
-  current_fixpoints := kns; 
-  (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
-  let sub = List.rev_map mkConst kns in 
-  for i = 0 to n-1 do 
-    if sort_of env ti.(i) <> InProp then begin 
-      let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
-      terms.(i) <- e; 
-      types.(i) <- t;
-    end 
-  done; 
-  current_fixpoints := [];
-  Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) 
-		 
-let extract_constant env kn cb = 
-  let r = ConstRef kn in 
-  let typ = Typeops.type_of_constant_type env cb.const_type in 
-  match cb.const_body with
-    | None -> (* A logical axiom is risky, an informative one is fatal. *) 
-        (match flag_of_type env typ with
-	   | (Info,TypeScheme) -> 
-	       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 add_info_axiom r; 
-	       let t = snd (record_constant_type env kn (Some typ)) in 
-	       Dterm (r, MLaxiom, type_expunge env t) 
-           | (Logic,TypeScheme) -> 
-	       add_log_axiom r; Dtype (r, [], Tdummy Ktype)
-	   | (Logic,Default) -> 
-	       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)
-	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype)
-	   | (Info, Default) -> 
-	       let e,t = extract_std_constant env kn (force body) typ in 
-	       Dterm (r,e,t)
-	   | (Info, TypeScheme) -> 
-	       let s,vl = type_sign_vl env typ in 
-               let db = db_from_sign s in 
-               let t = extract_type_scheme env db (force body) (List.length s) 
-	       in Dtype (r, vl, t))
-
-let extract_constant_spec env kn cb = 
-  let r = ConstRef kn in 
-  let typ = Typeops.type_of_constant_type env cb.const_type in 
-  match flag_of_type env typ with 
-    | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
-    | (Logic, Default) -> Sval (r, Tdummy Kother) 
-    | (Info, TypeScheme) -> 
-	let s,vl = type_sign_vl env typ in 
-	(match cb.const_body with 
-	  | None -> Stype (r, vl, None)
-	  | Some body -> 
-	      let db = db_from_sign s in 
-	      let t = extract_type_scheme env db (force body) (List.length s)
-	      in Stype (r, vl, Some t)) 
-    | (Info, Default) -> 
-	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
-    | (Info, TypeScheme) ->
-	let s,vl = type_sign_vl env typ in
-	let body = Option.get cb.const_body in
-	let db = db_from_sign s in
-	let t = extract_type_scheme env db (force body) (List.length s) in
-	Some (vl, t)
-    | _ -> None
-
-		   
-let extract_inductive env kn = 
-  let ind = extract_ind env kn in 
-  add_recursors env kn; 
-  let f l = List.filter (fun t -> not (isDummy (expand env t))) l in 
-  let packets = 
-    Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) 
-      ind.ind_packets
-  in { ind with ind_packets = packets }
-
-(*s Is a [ml_decl] logical ? *) 
-
-let logical_decl = function 
-  | Dterm (_,MLdummy,Tdummy _) -> true
-  | Dtype (_,[],Tdummy _) -> true 
-  | Dfix (_,av,tv) -> 
-      (array_for_all ((=) MLdummy) av) && 
-      (array_for_all isDummy tv)
-  | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
-  | _ -> false
-
-(*s Is a [ml_spec] logical ? *)
-
-let logical_spec = function 
-  | Stype (_, [], Some (Tdummy _)) -> true
-  | 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
deleted file mode 100644
index 6d41b630..00000000
--- a/contrib/extraction/extraction.mli
+++ /dev/null
@@ -1,34 +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        *)
-(************************************************************************)
-
-(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
-
-(*s Extraction from Coq terms to Miniml. *)
-
-open Names
-open Term
-open Declarations
-open Environ
-open Libnames
-open Miniml
-
-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 Is a [ml_decl] or a [ml_spec] logical ? *) 
-
-val logical_decl : ml_decl -> bool
-val logical_spec : ml_spec -> bool
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
deleted file mode 100644
index 345cb307..00000000
--- a/contrib/extraction/g_extraction.ml4
+++ /dev/null
@@ -1,123 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* ML names *)
-
-open Vernacexpr
-open Pcoq
-open Genarg
-open Pp
-
-let pr_mlname _ _ _ s = spc () ++ qs s
-
-ARGUMENT EXTEND mlname
-  TYPED AS string
-  PRINTED BY pr_mlname
-| [ preident(id) ] -> [ id ]
-| [ string(s) ] -> [ s ]
-END
-
-open Table
-open Extract_env
-
-let pr_language = function
-  | Ocaml -> str "Ocaml" 
-  | Haskell -> str "Haskell"
-  | Scheme -> str "Scheme"
-
-VERNAC ARGUMENT EXTEND language
-PRINTED BY pr_language
-| [ "Ocaml" ] -> [ Ocaml ]
-| [ "Haskell" ] -> [ Haskell ]
-| [ "Scheme" ] -> [ Scheme ]
-END
-
-(* Extraction commands *)
-
-VERNAC COMMAND EXTEND Extraction
-(* Extraction in the Coq toplevel *)
-| [ "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) ] 
-  -> [ full_extraction (Some f) l ]
-END
-
-(* Modular extraction (one Coq library = one ML module) *)
-VERNAC COMMAND EXTEND ExtractionLibrary
-| [ "Extraction" "Library" ident(m) ]
-  -> [ extraction_library false m ]
-END
-
-VERNAC COMMAND EXTEND RecursiveExtractionLibrary
-| [ "Recursive" "Extraction" "Library" ident(m) ]
-  -> [ extraction_library true m ]
-END
-
-(* Target Language *)
-VERNAC COMMAND EXTEND ExtractionLanguage
-| [ "Extraction" "Language" language(l) ] 
-  -> [ extraction_language l ]
-END
-
-VERNAC COMMAND EXTEND ExtractionInline
-(* Custom inlining directives *)
-| [ "Extraction" "Inline" ne_global_list(l) ] 
-  -> [ extraction_inline true l ]
-END
-
-VERNAC COMMAND EXTEND ExtractionNoInline
-| [ "Extraction" "NoInline" ne_global_list(l) ] 
-  -> [ extraction_inline false l ]
-END
-
-VERNAC COMMAND EXTEND PrintExtractionInline
-| [ "Print" "Extraction" "Inline" ]
-  -> [ print_extraction_inline () ]
-END
-
-VERNAC COMMAND EXTEND ResetExtractionInline
-| [ "Reset" "Extraction" "Inline" ]
-  -> [ reset_extraction_inline () ]
-END
-
-VERNAC COMMAND EXTEND ExtractionBlacklist
-(* Force Extraction to not use some filenames *)
-| [ "Extraction" "Blacklist" ne_ident_list(l) ]
-  -> [ extraction_blacklist l ]
-END
-
-VERNAC COMMAND EXTEND PrintExtractionBlacklist
-| [ "Print" "Extraction" "Blacklist" ]
-  -> [ print_extraction_blacklist () ]
-END
-
-VERNAC COMMAND EXTEND ResetExtractionBlacklist
-| [ "Reset" "Extraction" "Blacklist" ]
-  -> [ reset_extraction_blacklist () ]
-END
-
-
-(* Overriding of a Coq object by an ML one *)
-VERNAC COMMAND EXTEND ExtractionConstant
-| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
-  -> [ extract_constant_inline false x idl y ]
-END
-
-VERNAC COMMAND EXTEND ExtractionInlinedConstant
-| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
-  -> [ extract_constant_inline true x [] y ]
-END
-
-VERNAC COMMAND EXTEND ExtractionInductive
-| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ]
-  -> [ extract_inductive x (id,idl) ]
-END
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
deleted file mode 100644
index 3f0366e6..00000000
--- a/contrib/extraction/haskell.ml
+++ /dev/null
@@ -1,334 +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        *)
-(************************************************************************)
-
-(*i $Id: haskell.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
-
-(*s Production of Haskell syntax. *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Libnames
-open Table
-open Miniml
-open Mlutil
-open Common
-
-(*s Haskell renaming issues. *)
-
-let pr_lower_id id = str (String.uncapitalize (string_of_id id))
-let pr_upper_id id = str (String.capitalize (string_of_id id))
-
-let keywords =     
-  List.fold_right (fun s -> Idset.add (id_of_string s))
-  [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
-    "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; 
-    "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
-    "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
-  Idset.empty
-
-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 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
-unsafeCoerce = GHC.Base.unsafeCoerce#
-#else
--- HUGS
-import qualified IOExts
-unsafeCoerce = IOExts.unsafeCoerce
-#endif" ++ fnl2 ())
-  ++
-  (if not usf.mldummy then mt () 
-   else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ())
-
-let pp_abst = function
-  | [] -> (mt ())
-  | l  -> (str "\\" ++
-             prlist_with_sep (fun () -> (str " ")) pr_id l ++
-             str " ->" ++ spc ())
-
-(*s The pretty-printer for haskell syntax *)
-
-let pp_global k r = 
-  if is_inline_custom r then str (find_custom r) 
-  else str (Common.pp_global k r)
-
-(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
-    are needed or not. *)
-
-let kn_sig = 
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in 
-  make_kn specif empty_dirpath (mk_label "sig")
-
-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 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 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)
-    | Tdummy _ -> str "()"
-    | Tunknown -> str "()"
-    | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
- in 
-  hov 0 (pp_rec par t)
-
-(*s Pretty-printing of expressions. [par] indicates whether
-    parentheses are needed or not. [env] is the list of names for the
-    de Bruijn variables. [args] is the list of collected arguments
-    (already pretty-printed). *)
-
-let expr_needs_par = function
-  | MLlam _  -> true
-  | MLcase _ -> true
-  | _        -> false 
-
-
-let rec pp_expr par env args =
-  let par' = args <> [] || par
-  and apply st = pp_apply st par args in 
-  function
-    | MLrel n -> 
-	let id = get_db_name n env in apply (pr_id id)
-    | MLapp (f,args') ->
-	let stl = List.map (pp_expr true env []) args' in
-        pp_expr par env (stl @ args) f
-    | MLlam _ as a -> 
-      	let fl,a' = collect_lams a in
-	let fl,env' = push_vars fl env in
-	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
-	apply (pp_par par' st)
-    | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
-	let pp_id = pr_id (List.hd i)
-	and pp_a1 = pp_expr false env [] a1
-	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in
-	hv 0 
-	  (apply 
-	     (pp_par par' 
-		(hv 0 
-		   (hov 5 
-		      (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ 
-		    spc () ++ str "in") ++
-		 spc () ++ hov 0 pp_a2)))
-    | MLglob r -> 
-	apply (pp_global Term r)
-    | MLcons (_,r,[]) ->
-	assert (args=[]); pp_global Cons r
-    | MLcons (_,r,[a]) ->
-	assert (args=[]);
-	pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a)
-    | MLcons (_,r,args') ->
-	assert (args=[]);
-	pp_par par (pp_global Cons r ++ spc () ++ 
-		    prlist_with_sep spc (pp_expr true env []) args')
-    | MLcase ((_,factors),t, pv) ->
-      	apply (pp_par par' 
-		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
-		       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
-    | MLexn s -> 
-	(* An [MLexn] may be applied, but I don't really care. *)
-	pp_par par (str "Prelude.error" ++ spc () ++ qs s)
-    | MLdummy ->
-	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
-    | MLmagic a ->  
-	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 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 Cons name ++
-	   (match ids with 
-	      | [] -> mt ()
-	      | _  -> (str " " ++ 
-		       prlist_with_sep 
-			 (fun () -> (spc ())) pr_id (List.rev ids))) ++
-	   str " ->" ++ spc () ++ pp_expr par env' [] t)
-  in 
-  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. *)
-
-and pp_fix par env i (ids,bl) args =
-  pp_par par
-    (v 0  
-       (v 2 (str "let" ++ fnl () ++
-	     prvect_with_sep fnl 
-	       (fun (fi,ti) -> pp_function env (pr_id fi) ti) 
-	       (array_map2 (fun a b -> a,b) ids bl)) ++ 
-	fnl () ++ 
-	hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
-
-and pp_function env f t =
-  let bl,t' = collect_lams t in
-  let bl,env' = push_vars bl env in
-  (f ++ pr_binding (List.rev bl) ++
-     str " =" ++ fnl () ++ str "  " ++
-     hov 2 (pp_expr false env' [] t'))
-
-(*s Pretty-printing of inductive types declaration. *)
-
-let pp_comment s = str "-- " ++ s ++ fnl ()
-
-let pp_logical_ind packet = 
-  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
-  pp_comment (str "with constructors : " ++ 
-	      prvect_with_sep spc pr_id packet.ip_consnames)
-
-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 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 () ++
-	 pp_comment (str "singleton inductive, whose constructor was " ++ 
-		     pr_id packet.ip_consnames.(0)))
-
-let pp_one_ind ip pl cv =
-  let pl = rename_tvars keywords pl in
-  let pp_constructor (r,l) =
-    (pp_global Cons r ++
-     match l with
-       | [] -> (mt ()) 
-       | _  -> (str " " ++
-      	       	prlist_with_sep 
-		  (fun () -> (str " ")) (pp_type true pl) l))
-  in
-  str (if Array.length cv = 0 then "type " else "data ") ++ 
-  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"
-  else 
-    (v 0 (str "= " ++
-	  prvect_with_sep (fun () -> fnl () ++ str "  | ") pp_constructor 
-	    (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv)))
-  
-let rec pp_ind first kn i ind =
-  if i >= Array.length ind.ind_packets then 
-    if first then mt () else fnl () 
-  else 
-    let ip = (kn,i) in 
-    let p = ind.ind_packets.(i) in 
-    if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind 
-    else 
-      if p.ip_logical then  
-	pp_logical_ind p ++ pp_ind first kn (i+1) ind
-      else 
-	pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ 
-	pp_ind false kn (i+1) ind
-	  
-
-(*s Pretty-printing of a declaration. *)
-
-let pp_string_parameters ids = prlist (fun id -> str id ++ str " ")
-
-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)
-  | Dtype (r, l, t) ->
-      if is_inline_custom r then mt () 
-      else 
-	let l = rename_tvars keywords l in 
-	let st = 
-	  try 
-	    let ids,s = find_type_custom r in 
-	    prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s
-	  with not_found -> 
-	    prlist (fun id -> pr_id id ++ str " ") l ++
-	    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 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 Term rv.(i) in 
-	  e ++ str " :: " ++ pp_type false [] typs.(i) ++ 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 Term r in 
-	e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
-	  if is_custom r then 	
-	    hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
-	  else 
-	    hov 0 (pp_function (empty_env ()) e a ++ fnl2 ())
-
-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 = 
-  let pp_sel (mp,sel) = 
-    push_visible mp None; 
-    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
deleted file mode 100644
index 1af9c231..00000000
--- a/contrib/extraction/haskell.mli
+++ /dev/null
@@ -1,12 +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        *)
-(************************************************************************)
-
-(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
-
-val haskell_descr : Miniml.language_descr
-
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
deleted file mode 100644
index dfe4eb48..00000000
--- a/contrib/extraction/miniml.mli
+++ /dev/null
@@ -1,188 +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        *)
-(************************************************************************)
-
-(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
-
-(*s Target language for extraction: a core ML called MiniML. *)
-
-open Pp
-open Util
-open Names
-open Libnames
-
-(* The [signature] type is used to know how many arguments a CIC
-   object expects, and what these arguments will become in the ML
-   object. *)
-
-(* We eliminate from terms:  1) types 2) logical parts.
-   [Kother] stands both for logical or unknown reason. *)
-
-type kill_reason = Ktype | Kother
-
-type sign = Keep | Kill of kill_reason
-
-   
-(* Convention: outmost lambda/product gives the head of the list. *)
-
-type signature = sign list
-
-(*s ML type expressions. *)
-
-type ml_type = 
-  | Tarr    of ml_type * ml_type
-  | Tglob   of global_reference * ml_type list 
-  | Tvar    of int
-  | Tvar'   of int (* same as Tvar, used to avoid clash *)
-  | Tmeta   of ml_meta (* used during ML type reconstruction *)
-  | Tdummy  of kill_reason
-  | Tunknown
-  | Taxiom
-
-and ml_meta = { id : int; mutable contents : ml_type option }
-
-(* ML type schema. 
-   The integer is the number of variable in the schema. *)
-
-type ml_schema = int * ml_type 
-
-(*s ML inductive types. *)
-
-type inductive_info = 
-  | Singleton 
-  | Coinductive 
-  | 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, 
-   [ip_sign] is a signature concerning the arguments of the inductive, 
-   [ip_vars] contains the names of the type variables surviving in ML, 
-   [ip_types] contains the ML types of all constructors.    
-*)
-
-type ml_ind_packet = { 
-  ip_typename : identifier; 
-  ip_consnames : identifier array; 
-  ip_logical : bool;
-  ip_sign : signature; 
-  ip_vars : identifier list; 
-  ip_types : (ml_type list) array }  
-
-(* [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 : equiv
-}
-
-(*s ML terms. *)
-
-type ml_ast = 
-  | MLrel    of int
-  | MLapp    of ml_ast * ml_ast list
-  | MLlam    of identifier * 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*case_info) * ml_ast * 
-      (global_reference * identifier list * ml_ast) array
-  | MLfix    of int * identifier array * ml_ast array
-  | MLexn    of string
-  | MLdummy
-  | MLaxiom
-  | MLmagic  of ml_ast
-
-(*s ML declarations. *)
-
-type ml_decl = 
-  | Dind  of kernel_name * ml_ind
-  | Dtype of global_reference * identifier list * ml_type
-  | Dterm of global_reference * ml_ast * ml_type
-  | Dfix  of global_reference array * ml_ast array * ml_type array
-
-type ml_spec = 
-  | Sind  of kernel_name * ml_ind
-  | Stype of global_reference * identifier list * ml_type option 
-  | Sval  of global_reference * ml_type
-
-type ml_specif = 
-  | Spec of ml_spec 
-  | Smodule of ml_module_type
-  | Smodtype of ml_module_type
-
-and ml_module_type = 
-  | 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
-
-type ml_structure_elem = 
-  | SEdecl of ml_decl
-  | SEmodule of ml_module
-  | SEmodtype of ml_module_type
-
-and ml_module_expr =
-  | MEident of module_path
-  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr 
-  | MEstruct of mod_self_id * ml_module_structure
-  | MEapply of ml_module_expr * ml_module_expr
-
-and ml_module_structure = (label * ml_structure_elem) list
-
-and ml_module = 
-    { ml_mod_expr : ml_module_expr; 
-      ml_mod_type : ml_module_type }
-
-(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] 
-   implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *)
-
-type ml_structure = (module_path * ml_module_structure) list
-
-type ml_signature = (module_path * ml_module_sig) 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
deleted file mode 100644
index 4e2904ba..00000000
--- a/contrib/extraction/mlutil.ml
+++ /dev/null
@@ -1,1167 +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        *)
-(************************************************************************)
-
-(*i $Id: mlutil.ml 13202 2010-06-25 22:36:30Z letouzey $ i*)
-
-(*i*)
-open Pp
-open Util
-open Names
-open Libnames
-open Nametab
-open Table
-open Miniml
-(*i*)
-
-(*s Exceptions. *)
-
-exception Found
-exception Impossible
-
-(*S Names operations. *)
-
-let anonymous = id_of_string "x"
-let dummy_name = id_of_string "_"
-
-let id_of_name = function
-  | Anonymous -> anonymous
-  | Name id when id = dummy_name -> anonymous
-  | Name id -> id 
-
-(*S Operations upon ML types (with meta). *)
-
-let meta_count = ref 0 
-		     
-let reset_meta_count () = meta_count := 0
-			      
-let new_meta _ = 
-  incr meta_count; 
-  Tmeta {id = !meta_count; contents = None}
-
-(*s Sustitution of [Tvar i] by [t] in a ML type. *)
-
-let type_subst i t0 t = 
-  let rec subst t = match t with
-    | Tvar j when i = j -> t0
-    | Tmeta {contents=None} -> t 
-    | Tmeta {contents=Some u} -> subst u
-    | Tarr (a,b) -> Tarr (subst a, subst b)
-    | Tglob (r, l) -> Tglob (r, List.map subst l)
-    | a -> a 
-  in subst t
-       
-(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
-
-let type_subst_list l t = 
-  let rec subst t = match t with 
-    | Tvar j -> List.nth l (j-1)
-    | Tmeta {contents=None} -> t
-    | Tmeta {contents=Some u} -> subst u
-    | Tarr (a,b) -> Tarr (subst a, subst b)
-    | Tglob (r, l) -> Tglob (r, List.map subst l)
-    | a -> a
-  in subst t
-
-(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *)
-
-let type_subst_vect v t = 
-  let rec subst t = match t with 
-    | Tvar j -> v.(j-1)
-    | Tmeta {contents=None} -> t
-    | Tmeta {contents=Some u} -> subst u
-    | Tarr (a,b) -> Tarr (subst a, subst b)
-    | Tglob (r, l) -> Tglob (r, List.map subst l)
-    | a -> a
-  in subst t
-
-(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *)
-
-let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
-
-(*s Occur-check of a free meta in a type *)
-
-let rec type_occurs alpha t =
-  match t with
-  | Tmeta {id=beta; contents=None} -> alpha = beta
-  | Tmeta {contents=Some u} -> type_occurs alpha u
-  | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
-  | Tglob (r,l) -> List.exists (type_occurs alpha) l  
-  | _ -> false
-
-(*s Most General Unificator *)
-
-let rec mgu = function
-  | Tmeta m, Tmeta m' when m.id = m'.id -> ()
-  | Tmeta m, t when m.contents=None -> 
-      if type_occurs m.id t then raise Impossible
-      else m.contents <- Some t
-  | t, Tmeta m when m.contents=None -> 
-      if type_occurs m.id t then raise Impossible
-      else m.contents <- Some t
-  | Tmeta {contents=Some u}, t -> mgu (u, t)
-  | t, Tmeta {contents=Some u} -> mgu (t, u)
-  | Tarr(a, b), Tarr(a', b') ->
-      mgu (a, a'); mgu (b, b')
-  | Tglob (r,l), Tglob (r',l') when r = r' ->
-       List.iter mgu (List.combine l l')
-  | Tvar i, Tvar j when i = j -> ()
-  | Tvar' i, Tvar' j when i = j -> ()
-  | Tdummy _, Tdummy _ -> ()
-  | Tunknown, Tunknown -> ()
-  | _ -> raise Impossible
-
-let needs_magic p = try mgu p; false with Impossible -> true
-
-let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a
-
-let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a
-
-
-(*S ML type env. *)
-
-module Mlenv = struct 
-  
-  let meta_cmp m m' = compare m.id m'.id 
-  module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end)
-
-  (* Main MLenv type. [env] is the real environment, whereas [free] 
-     (tries to) record the free meta variables occurring in [env]. *)
-
-  type t = { env : ml_schema list; mutable free : Metaset.t}
-
-  (* Empty environment. *)
-
-  let empty = { env = []; free = Metaset.empty }
-
-  (* [get] returns a instantiated copy of the n-th most recently added 
-     type in the environment. *)
-
-  let get mle n = 
-    assert (List.length mle.env >= n); 
-    instantiation (List.nth mle.env (n-1))
-
-  (* [find_free] finds the free meta in a type. *) 
-
-  let rec find_free set = function 
-    | Tmeta m when m.contents = None -> Metaset.add m set
-    | Tmeta {contents = Some t} -> find_free set t
-    | Tarr (a,b) -> find_free (find_free set a) b
-    | Tglob (_,l) -> List.fold_left find_free set l
-    | _ -> set
-
-  (* The [free] set of an environment can be outdate after 
-     some unifications. [clean_free] takes care of that. *) 
-			
-  let clean_free mle = 
-    let rem = ref Metaset.empty 
-    and add = ref Metaset.empty in 
-    let clean m = match m.contents with 
-      | None -> () 
-      | Some u -> rem := Metaset.add m !rem; add := find_free !add u
-    in 
-    Metaset.iter clean mle.free; 
-    mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add
-
-  (* From a type to a type schema. If a [Tmeta] is still uninstantiated
-     and does appears in the [mle], then it becomes a [Tvar]. *)
-
-  let generalization mle t = 
-    let c = ref 0 in 
-    let map = ref (Intmap.empty : int Intmap.t) in 
-    let add_new i = incr c; map := Intmap.add i !c !map; !c in 
-    let rec meta2var t = match t with 
-      | Tmeta {contents=Some u} -> meta2var u 
-      | Tmeta ({id=i} as m) -> 
-	  (try Tvar (Intmap.find i !map) 
-	   with Not_found ->  
-	     if Metaset.mem m mle.free then t 
-	     else Tvar (add_new i))
-      | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2)
-      | Tglob (r,l) -> Tglob (r, List.map meta2var l) 
-      | t -> t 
-    in !c, meta2var t
-	
-  (* Adding a type in an environment, after generalizing. *)
-
-  let push_gen mle t = 
-    clean_free mle; 
-    { env = generalization mle t :: mle.env; free = mle.free }
-
-  (* Adding a type with no [Tvar], hence no generalization needed. *)
-
-  let push_type {env=e;free=f} t = 
-    { env = (0,t) :: e; free = find_free f t} 
-    
-  (* Adding a type with no [Tvar] nor [Tmeta]. *)
-
-  let push_std_type {env=e;free=f} t = 
-    { env = (0,t) :: e; free = f}
-
-end
-
-(*S Operations upon ML types (without meta). *)
-
-(*s Does a section path occur in a ML type ? *)
-
-let rec type_mem_kn kn = function 
-  | Tmeta {contents = Some t} -> type_mem_kn kn t
-  | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l
-  | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
-  | _ -> false
-
-(*s Greatest variable occurring in [t]. *)
-
-let type_maxvar t = 
-  let rec parse n = function 
-    | Tmeta {contents = Some t} -> parse n t
-    | Tvar i -> max i n 
-    | Tarr (a,b) -> parse (parse n a) b
-    | Tglob (_,l) -> List.fold_left parse n l 
-    | _ -> n 
-  in parse 0 t
-
-(*s From [a -> b -> c] to [[a;b],c]. *) 
-
-let rec type_decomp = function 
-  | Tmeta {contents = Some t} -> type_decomp t 
-  | Tarr (a,b) -> let l,h = type_decomp b in a::l, h 
-  | a -> [],a
-
-(*s The converse: From [[a;b],c] to [a -> b -> c]. *)
-
-let rec type_recomp (l,t) = match l with 
-  | [] -> t 
-  | a::l -> Tarr (a, type_recomp (l,t))
-
-(*s Translating [Tvar] to [Tvar'] to avoid clash. *)
-
-let rec var2var' = function 
-  | Tmeta {contents = Some t} -> var2var' t
-  | Tvar i -> Tvar' i
-  | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
-  | Tglob (r,l) -> Tglob (r, List.map var2var' l)
-  | a -> a
-
-type abbrev_map = global_reference -> ml_type option
-
-(*s Delta-reduction of type constants everywhere in a ML type [t].
-   [env] is a function of type [ml_type_env]. *)
-
-let type_expand env t = 
-  let rec expand = function
-    | Tmeta {contents = Some t} -> expand t
-    | Tglob (r,l) ->    
-	(match env r with 
-	   | Some mlt -> expand (type_subst_list l mlt) 
-	   | None -> Tglob (r, List.map expand l))
-    | Tarr (a,b) -> Tarr (expand a, expand b)
-    | a -> a
-  in if Table.type_expand () then expand t else t
-
-(*s Idem, but only at the top level of implications. *)
-
-let is_arrow = function Tarr _ -> true | _ -> false
-
-let type_weak_expand env t = 
-  let rec expand = function
-    | Tmeta {contents = Some t} -> expand t
-    | Tglob (r,l) as t ->    
-	(match env r with 
-	   | Some mlt -> 
-	       let u = expand (type_subst_list l mlt) in 
-	       if is_arrow u then u else t
-	   | None -> t)
-    | Tarr (a,b) -> Tarr (a, expand b)
-    | a -> a
-  in expand t
-
-(*s Generating a signature from a ML type. *)
-
-let type_to_sign env t = match type_expand env t with 
-  | Tdummy d -> Kill d 
-  | _ -> Keep
-
-let type_to_signature env t = 
-  let rec f = function 
-    | Tmeta {contents = Some t} -> f t 
-    | Tarr (Tdummy d, b) -> Kill d :: f b
-    | Tarr (_, b) -> Keep :: f b
-    | _ -> [] 
-  in f (type_expand env t)
-
-let isKill = function Kill _ -> true | _ -> false
-
-let isDummy = function Tdummy _ -> true | _ -> false
-
-let sign_of_id i = if i = dummy_name then Kill Kother else Keep
-
-(*s Removing [Tdummy] from the top level of a ML type. *)
-
-let type_expunge env t = 
-  let s = type_to_signature env t in 
-  if s = [] then t 
-  else if List.mem Keep s then 
-    let rec f t s = 
-      if List.exists isKill s then 
-	match t with 
-	  | Tmeta {contents = Some t} -> f t s
-	  | Tarr (a,b) -> 
-	      let t = f b (List.tl s) in 
-	      if List.hd s = Keep then Tarr (a, t) else t  
-	  | Tglob (r,l) ->
-	      (match env r with 
-		 | Some mlt -> f (type_subst_list l mlt) s
-		 | None -> assert false)
-	  | _ -> assert false
-      else t 
-    in f t s 
-  else if List.mem (Kill Kother) s then 
-    Tarr (Tdummy Kother, snd (type_decomp (type_weak_expand env t))) 
-  else snd (type_decomp (type_weak_expand env t))
-
-(*S Generic functions over ML ast terms. *)
-
-(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care 
-   of the number of bingings crossed before reaching the [MLrel]. *)
-
-let ast_iter_rel f = 
-  let rec iter n = function
-    | MLrel i -> f (i-n)
-    | MLlam (_,a) -> iter (n+1) a
-    | MLletin (_,a,b) -> iter n a; iter (n+1) b
-    | MLcase (_,a,v) ->
-	iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
-    | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
-    | MLapp (a,l) -> iter n a; List.iter (iter n) l
-    | MLcons (_,_,l) ->  List.iter (iter n) l
-    | MLmagic a -> iter n a
-    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
-  in iter 0 
-
-(*s Map over asts. *)
-
-let ast_map_case f (c,ids,a) = (c,ids,f a)
-
-let ast_map f = function
-  | MLlam (i,a) -> MLlam (i, f a)
-  | MLletin (i,a,b) -> MLletin (i, f a, f b)
-  | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v)
-  | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
-  | MLapp (a,l) -> MLapp (f a, List.map f l)
-  | MLcons (i,c,l) -> MLcons (i,c, List.map f l)
-  | MLmagic a -> MLmagic (f a)
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
-
-(*s Map over asts, with binding depth as parameter. *)
-
-let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
-
-let ast_map_lift f n = function 
-  | MLlam (i,a) -> MLlam (i, f (n+1) a)
-  | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
-  | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v)
-  | MLfix (i,ids,v) -> 
-      let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
-  | MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
-  | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l)
-  | MLmagic a -> MLmagic (f n a)
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a	
-
-(*s Iter over asts. *) 
-
-let ast_iter_case f (c,ids,a) = f a
-
-let ast_iter f = function
-  | MLlam (i,a) -> f a
-  | MLletin (i,a,b) -> f a; f b
-  | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v
-  | MLfix (i,ids,v) -> Array.iter f v
-  | MLapp (a,l) -> f a; List.iter f l
-  | MLcons (_,c,l) -> List.iter f l
-  | MLmagic a -> f a
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom  -> ()
-
-(*S Operations concerning De Bruijn indices. *)
-
-(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *)
-
-let ast_occurs k t = 
-  try 
-    ast_iter_rel (fun i -> if i = k then raise Found) t; false 
-  with Found -> true
-
-(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] 
-   in [t] with [k<=i<=k'] *)
-
-let ast_occurs_itvl k k' t = 
-  try 
-    ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false 
-  with Found -> true
-
-(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *)
-
-let nb_occur_k k t =
-  let cpt = ref 0 in 
-  ast_iter_rel (fun i -> if i = k then incr cpt) t;
-  !cpt
-
-let nb_occur t = nb_occur_k 1 t
-
-(* Number of occurences of [Rel 1] in [t], with special treatment of match:
-   occurences in different branches aren't added, but we rather use max. *)
-
-let nb_occur_match = 
-  let rec nb k = function 
-    | MLrel i -> if i = k then 1 else 0
-    | MLcase(_,a,v) -> 
-        (nb k a) +
-	Array.fold_left 
-	  (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
-    | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) 
-    | MLfix (_,ids,v) -> let k = k+(Array.length ids) in 
-      Array.fold_left (fun r a -> r+(nb k a)) 0 v
-    | MLlam (_,a) -> nb (k+1) a
-    | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
-    | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l 
-    | MLmagic a -> nb k a
-    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
-  in nb 1
-
-(*s Lifting on terms.
-    [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *)
-
-let ast_lift k t = 
-  let rec liftrec n = function
-    | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
-    | a -> ast_map_lift liftrec n a
-  in if k = 0 then t else liftrec 0 t
-
-let ast_pop t = ast_lift (-1) t
-
-(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... 
-  Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *)
-
-let permut_rels k k' = 
-  let rec permut n = function
-    | MLrel i as a ->
-	let i' = i-n in
-	if i'<1 || i'>k+k' then a 
-	else if i'<=k then MLrel (i+k')
-	else MLrel (i-k)
-    | a -> ast_map_lift permut n a
-  in permut 0  
-
-(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. 
-    Lifting (of one binder) is done at the same time. *)
-
-let ast_subst e =
-  let rec subst n = function
-    | MLrel i as a ->
-	let i' = i-n in 
-	if i'=1 then ast_lift n e
-	else if i'<1 then a 
-	else MLrel (i-1)
-    | a -> ast_map_lift subst n a
-  in subst 0
-
-(*s Generalized substitution. 
-   [gen_subst v d t] applies to [t] the substitution coded in the 
-   [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies 
-   to [Rel] greater than [Array.length v]. *)
-
-let gen_subst v d t = 
-  let rec subst n = function
-    | MLrel i as a -> 
-	let i'= i-n in 
-	if i' < 1 then a 
-	else if i' <= Array.length v then 
-	  ast_lift n v.(i'-1) 
-	else MLrel (i+d) 
-    | a -> ast_map_lift subst n a
-  in subst 0 t
-
-(*S Operations concerning lambdas. *)
-
-(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
-    [[idn;...;id1]] and the term [t]. *)
-
-let collect_lams = 
-  let rec collect acc = function
-    | MLlam(id,t) -> collect (id::acc) t
-    | x           -> acc,x
-  in collect []
-
-(*s [collect_n_lams] does the same for a precise number of [MLlam]. *)
-
-let collect_n_lams = 
-  let rec collect acc n t = 
-    if n = 0 then acc,t 
-    else match t with 
-      | MLlam(id,t) -> collect (id::acc) (n-1) t
-      | _ -> assert false
-  in collect [] 
-
-(*s [remove_n_lams] just removes some [MLlam]. *)
-
-let rec remove_n_lams n t = 
-  if n = 0 then t  
-  else match t with 
-      | MLlam(_,t) -> remove_n_lams (n-1) t
-      | _ -> assert false
-
-(*s [nb_lams] gives the number of head [MLlam]. *)
-
-let rec nb_lams = function 
-  | MLlam(_,t) -> succ (nb_lams t)
-  | _ -> 0 
-
-(*s [named_lams] does the converse of [collect_lams]. *)
-
-let rec named_lams ids a = match ids with 
-  | [] -> a 
-  | id :: ids -> named_lams ids (MLlam (id,a))
-
-(*s The same in anonymous version. *)
-
-let rec anonym_lams a = function 
-  | 0 -> a 
-  | n -> anonym_lams (MLlam (anonymous,a)) (pred n)
-
-(*s Idem for [dummy_name]. *)
-
-let rec dummy_lams a = function 
-  | 0 -> a 
-  | n -> dummy_lams (MLlam (dummy_name,a)) (pred n)
-
-(*s mixed according to a signature. *)
-
-let rec anonym_or_dummy_lams a = function 
-  | [] -> a 
-  | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
-  | Kill _ :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s)
-
-(*S Operations concerning eta. *)
-
-(*s The following function creates [MLrel n;...;MLrel 1] *)
-
-let rec eta_args n = 
-  if n = 0 then [] else (MLrel n)::(eta_args (pred n))
-
-(*s Same, but filtered by a signature. *)
-
-let rec eta_args_sign n = function 
-  | [] -> [] 
-  | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) 
-  | Kill _ :: s -> eta_args_sign (n-1) s
-
-(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
-
-let rec test_eta_args_lift k n = function 
-  | [] -> n=0
-  | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
-
-(*s Computes an eta-reduction. *)
-
-let eta_red e = 
-  let ids,t = collect_lams e in 
-  let n = List.length ids in
-  if n = 0 then e 
-  else match t with 
-    | MLapp (f,a) -> 
-	let m = List.length a in 
-	let ids,body,args = 
-	  if m = n then 
-	    [], f, a
-	  else if m < n then 
-	    list_skipn 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)].
-  Non-linear head beta-redex become let-in. *)
-
-let rec linear_beta_red a t = match a,t with  
-  | [], _ -> t 
-  | a0::a, MLlam (id,t) ->
-      (match nb_occur_match t with
-	 | 0 -> linear_beta_red a (ast_pop t)
-	 | 1 -> linear_beta_red a (ast_subst a0 t)
-	 | _ -> 
-	     let a = List.map (ast_lift 1) a in 
-	     MLletin (id, a0, linear_beta_red a t))
-  | _ -> MLapp (t, a)
-
-(*s Applies a substitution [s] of constants by their body, plus 
-  linear beta reductions at modified positions. *)  
-
-let rec ast_glob_subst s t = match t with 
-  | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> 
-      let a = List.map (ast_glob_subst s) a in 
-      (try linear_beta_red a (Refmap.find refe s) 
-       with Not_found -> MLapp (f, a))
-  | MLglob ((ConstRef kn) as refe) ->
-      (try Refmap.find refe s with Not_found -> t)
-  | _ -> ast_map (ast_glob_subst s) t
-
-
-(*S Auxiliary functions used in simplification of ML cases. *)
-
-(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1]
-  and raises [Impossible] if any variable in [l] occurs outside such a 
-  [MLcons] *)
-
-let check_and_generalize (r0,l,c) = 
-  let nargs = List.length l in 
-  let rec genrec n = function 
-    | MLrel i as c -> 
-	let i' = i-n in 
-	if i'<1 then c 
-	else if i'>nargs then MLrel (i-nargs+1) 
-	else raise Impossible
-    | MLcons(_,r,args) when r=r0 && (test_eta_args_lift n nargs args) -> 
-	MLrel (n+1) 
-    | a -> ast_map_lift genrec n a
-  in genrec 0 c  
-
-(*s [check_generalizable_case] checks if all branches can be seen as the 
-  same function [f] applied to the term matched. It is a generalized version 
-  of the identity case optimization. *)
-
-(* CAVEAT: this optimization breaks typing in some special case. example: 
-   [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a],
-   which is incompatible with the type of [let f x = x].
-   By default, we brutally disable this optim except for some known types: 
-   [bool], [sumbool], [sumor] *)
-
-let generalizable_list = 
-  let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes")
-  and specif = MPfile (dirpath_of_string "Coq.Init.Specif")
-  in 
-  [ make_kn datatypes empty_dirpath (mk_label "bool"); 
-    make_kn specif empty_dirpath (mk_label "sumbool");
-    make_kn specif empty_dirpath (mk_label "sumor") ]
-
-let check_generalizable_case unsafe br = 
-  if not unsafe then 
-    (match br.(0) with 
-     | ConstructRef ((kn,_),_), _, _ ->
-	 if not (List.mem kn generalizable_list) then raise Impossible
-     | _ -> assert false); 
-  let f = check_and_generalize br.(0) in 
-  for i = 1 to Array.length br - 1 do 
-    if check_and_generalize br.(i) <> f then raise Impossible 
-  done; f
-
-(*s Detecting similar branches of a match *)
-
-(* 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. *)
-
-let rec merge_ids ids ids' = match ids,ids' with 
-  | [],l -> l 
-  | l,[] -> l
-  | i::ids, i'::ids' -> 
-      (if i = dummy_name then i' else i) :: (merge_ids ids ids')
-
-let is_exn = function MLexn _ -> true | _ -> false
-
-let rec permut_case_fun br acc = 
-  let nb = ref max_int in 
-  Array.iter (fun (_,_,t) -> 
-		let ids, c = collect_lams t in 
-		let n = List.length ids in 
-		if (n < !nb) && (not (is_exn c)) then nb := n) br; 
-  if !nb = max_int || !nb = 0 then ([],br) 
-  else begin
-    let br = Array.copy br in 
-    let ids = ref [] in  
-    for i = 0 to Array.length br - 1 do 
-      let (r,l,t) = br.(i) in 
-      let local_nb = nb_lams t in 
-      if local_nb < !nb then (* t = MLexn ... *)
-	br.(i) <- (r,l,remove_n_lams local_nb t)
-      else begin
-	let local_ids,t = collect_n_lams !nb t in 
-	ids := merge_ids !ids local_ids; 
-	br.(i) <- (r,l,permut_rels !nb (List.length l) t)
-      end
-    done; 
-    (!ids,br)
-  end
-  
-(*S Generalized iota-reduction. *)
-
-(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] 
-   with [(is_iota_gen e)=true]. Any generalized iota-redex is 
-   transformed into beta-redexes. *)
-
-let rec is_iota_gen = function 
-  | MLcons _ -> true
-  | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
-  | _ -> false
-
-let constructor_index = function
-  | ConstructRef (_,j) -> pred j
-  | _ -> assert false
-
-let iota_gen br = 
-  let rec iota k = function 
-    | MLcons (i,r,a) ->
-	let (_,ids,c) = br.(constructor_index r) in
-	let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in
-	let c = ast_lift k c in 
-	MLapp (c,a)
-    | MLcase(i,e,br') -> 
-	let new_br = 
-	  Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br'
-	in MLcase(i,e, new_br)
-    | _ -> assert false
-  in iota 0 
-
-let is_atomic = function 
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
-  | _ -> false
-
-(*S The main simplification function. *)
-
-(* Some beta-iota reductions + simplifications. *)
-
-let rec simpl o = function
-  | MLapp (f, []) ->
-      simpl o f
-  | MLapp (f, a) -> 
-      simpl_app o (List.map (simpl o) a) (simpl o f)
-  | MLcase (i,e,br) ->
-      let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in 
-      simpl_case o i br (simpl o e) 
-  | MLletin(id,c,e) -> 
-      let e = (simpl o e) in 
-      if 
-	(id = dummy_name) || (is_atomic c) || (is_atomic e) ||
-	(let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let))
-      then 
-	simpl o (ast_subst c e)
-      else 
-	MLletin(id, simpl o c, e)
-  | MLfix(i,ids,c) -> 
-      let n = Array.length ids in 
-      if ast_occurs_itvl 1 n c.(i) then 
-	MLfix (i, ids, Array.map (simpl o) c)
-      else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *)
-  | a -> ast_map (simpl o) a 
-
-and simpl_app o a = function  
-  | MLapp (f',a') -> simpl_app o (a'@a) f'
-  | MLlam (id,t) when id = dummy_name -> 
-      simpl o (MLapp (ast_pop t, List.tl a))
-  | MLlam (id,t) -> (* Beta redex *)
-      (match nb_occur_match t with
-	 | 0 -> simpl o (MLapp (ast_pop t, List.tl a))
-	 | 1 when o.opt_lin_beta -> 
-	     simpl o (MLapp (ast_subst (List.hd a) t, List.tl a))
-	 | _ -> 
-	     let a' = List.map (ast_lift 1) (List.tl a) in
-	     simpl o (MLletin (id, List.hd a, MLapp (t, a'))))
-  | MLletin (id,e1,e2) when o.opt_let_app -> 
-      (* Application of a letin: we push arguments inside *)
-      MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a)))
-  | MLcase (i,e,br) when o.opt_case_app -> 
-      (* Application of a case: we push arguments inside *)
-      let br' = 
-	Array.map 
-      	  (fun (n,l,t) -> 
-	     let k = List.length l in
-	     let a' = List.map (ast_lift k) a in
-      	     (n, l, simpl o (MLapp (t,a')))) br 
-      in simpl o (MLcase (i,e,br')) 
-  | (MLdummy | MLexn _) as e -> e 
-	(* We just discard arguments in those cases. *)
-  | f -> MLapp (f,a)
-
-and simpl_case o i br e = 
-  if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *)
-    simpl o (iota_gen br e)
-  else 
-    try (* Does a term [f] exist such that each branch is [(f e)] ? *)
-      if not o.opt_case_idr then raise Impossible;
-      let f = check_generalizable_case o.opt_case_idg br in 
-      simpl o (MLapp (MLlam (anonymous,f),[e]))
-    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 (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)) -> 
-      post_simpl (ast_subst (eta_red c) e)
-  | a -> ast_map post_simpl a 
-
-(*S Local prop elimination. *) 
-(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
-
-(*s In a list, it selects only the elements corresponding to a [Keep] 
-   in the boolean list [l]. *)
-
-let rec select_via_bl l args = match l,args with 
-  | [],_ -> args
-  | Keep::l,a::args -> a :: (select_via_bl l args)
-  | Kill _::l,a::args -> select_via_bl l args
-  | _ -> assert false 
-
-(*s [kill_some_lams] removes some head lambdas according to the signature [bl].
-   This list is build on the identifier list model: outermost lambda
-   is on the right. 
-   [Rels] corresponding to removed lambdas are supposed not to occur, and 
-   the other [Rels] are made correct via a [gen_subst].
-   Output is not directly a [ml_ast], compose with [named_lams] if needed. *)
-
-let kill_some_lams bl (ids,c) =
-  let n = List.length bl in
-  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in 
-  if n = n' then ids,c
-  else if n' = 0 then [],ast_lift (-n) c 
-  else begin
-    let v = Array.make n MLdummy in 
-    let rec parse_ids i j = function 
-      | [] -> ()
-      | Keep :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l
-      | Kill _ :: l -> parse_ids (i+1) j l
-    in parse_ids 0 1 bl ; 
-    select_via_bl bl ids, gen_subst v (n'-n) c
-  end
-
-(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding 
-  to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or 
-  if there is no lambda left at all. *)
-
-let kill_dummy_lams c = 
-  let ids,c = collect_lams c in 
-  let bl = List.map sign_of_id ids in
-  if (List.mem Keep bl) && (List.exists isKill bl) then 
-    let ids',c = kill_some_lams bl (ids,c) in 
-    ids, named_lams ids' c
-  else raise Impossible
-
-(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] 
-   and a signature [s] and builds a eta-long version. *)
-
-(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is :
-   [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)]  with [c' = lift 4 c] *)
-
-let eta_expansion_sign s (ids,c) =
-  let rec abs ids rels i = function
-    | [] -> 
-	let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels
-	in ids, MLapp (ast_lift (i-1) c, a) 
-    | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l 
-    | Kill _ :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l
-  in abs ids [] 1 s
-
-(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] 
-  in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas 
-  corresponding to [Del] in [s]. *)
-
-let case_expunge s e = 
-  let m = List.length s in 
-  let n = nb_lams e in 
-  let p = if m <= n then collect_n_lams m e 
-  else eta_expansion_sign (list_skipn n s) (collect_lams e) in 
-  kill_some_lams (List.rev s) p
-
-(*s [term_expunge] takes a function [fun idn ... id1 -> c] 
-  and a signature [s] and remove dummy lams. The difference 
-  with [case_expunge] is that we here leave one dummy lambda 
-  if all lambdas are logical dummy. *)
-
-let term_expunge s (ids,c) =
-  if s = [] then c 
-  else 
-    let ids,c = kill_some_lams (List.rev s) (ids,c) in 
-    if ids = [] && List.mem (Kill Kother) s then 
-      MLlam (dummy_name, ast_lift 1 c)
-    else named_lams ids c
-
-(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and 
-  purge the args of [t0] corresponding to a [dummy_name]. 
-  It makes eta-expansion if needed. *) 
-
-let kill_dummy_args ids t0 t =
-  let m = List.length ids in 
-  let bl = List.rev_map sign_of_id ids in
-  let rec killrec n = function 
-    | MLapp(e, a) when e = ast_lift n t0 -> 
-	let k = max 0 (m - (List.length a)) in 
-	let a = List.map (killrec n) a in  
-	let a = List.map (ast_lift k) a in 
-	let a = select_via_bl bl (a @ (eta_args k)) in 
-	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) 
-    | e when e = ast_lift n t0 -> 
-	let a = select_via_bl bl (eta_args m) in 
-	named_lams ids (MLapp (ast_lift m e, a))
-    | e -> ast_map_lift killrec n e 
-  in killrec 0 t 
-
-(*s The main function for local [dummy] elimination. *)
-
-let rec kill_dummy = function 
-  | MLfix(i,fi,c) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in 
-	 ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1))
-       with Impossible -> MLfix (i,fi,Array.map kill_dummy c))
-  | MLapp (MLfix (i,fi,c),a) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in 
-	 let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in 
-	 let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in
-	 ast_subst (MLfix (i,fi,c)) e  
-       with Impossible -> 
-	 MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a))
-  | MLletin(id, MLfix (i,fi,c),e) -> 
-      (try 
-	 let ids,c = kill_dummy_fix i fi c in
-	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in 
-	 MLletin(id, MLfix(i,fi,c),e)
-      with Impossible -> 
-	MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e))
-  | MLletin(id,c,e) -> 
-      (try 
-	 let ids,c = kill_dummy_lams c in 
-	 let e = kill_dummy_args ids (MLrel 1) e in 
-	 MLletin (id, kill_dummy c,kill_dummy e) 
-       with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
-  | a -> ast_map kill_dummy a
-
-and kill_dummy_fix i fi c = 
-  let n = Array.length fi in 
-  let ids,ci = kill_dummy_lams c.(i) in 
-  let c = Array.copy c in c.(i) <- ci; 
-  for j = 0 to (n-1) do 
-    c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) 
-  done;
-  ids,c
-
-(*s Putting things together. *)
-
-let normalize a = 
-  let o = optims () in 
-  let a = simpl o a in 
-  if o.opt_kill_dum then post_simpl (kill_dummy a) else a
-
-(*S Special treatment of fixpoint for pretty-printing purpose. *)
-
-let general_optimize_fix f ids n args m c = 
-  let v = Array.make n 0 in 
-  for i=0 to (n-1) do v.(i)<-i done;
-  let aux i = function 
-    | MLrel j when v.(j-1)>=0 -> 
-	if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
-    | _ -> raise Impossible
-  in list_iter_i aux args; 
-  let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
-  let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in  
-  let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
-  MLfix(0,[|f|],[|new_c|])
-
-let optimize_fix a = 
-  if not (optims()).opt_fix_fun then a 
-  else
-    let ids,a' = collect_lams a in 
-    let n = List.length ids in 
-    if n = 0 then a 
-    else match a' with 
-      | MLfix(_,[|f|],[|c|]) ->
-	  let new_f = MLapp (MLrel (n+1),eta_args n) in 
-	  let new_c = named_lams ids (normalize (ast_subst new_f c))
-	  in MLfix(0,[|f|],[|new_c|])
-      | MLapp(a',args) ->
-	  let m = List.length args in 
-	  (match a' with 
-	     | MLfix(_,_,_) when 
-		 (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') 
-		 -> a'
-	     | MLfix(_,[|f|],[|c|]) -> 
-		 (try general_optimize_fix f ids n args m c
-		  with Impossible -> a)
-	     | _ -> a)
-      | _ -> a
-
-(*S Inlining. *)
-
-(* Utility functions used in the decision of inlining. *)
-
-let rec ml_size = function
-  | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l
-  | MLlam(_,t) -> 1 + ml_size t
-  | MLcons(_,_,l) -> ml_size_list l
-  | MLcase(_,t,pv) -> 
-      1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
-  | MLfix(_,_,f) -> ml_size_array f
-  | MLletin (_,_,t) -> ml_size t
-  | MLmagic t -> ml_size t
-  | _ -> 0
-
-and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l
-
-and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l
-
-let is_fix = function MLfix _ -> true | _ -> false
-
-let rec is_constr = function
-  | MLcons _   -> true
-  | MLlam(_,t) -> is_constr t
-  | _          -> false
-
-(*s Strictness *)
-
-(* A variable is strict if the evaluation of the whole term implies
-   the evaluation of this variable. Non-strict variables can be found 
-   behind Match, for example. Expanding a term [t] is a good idea when 
-   it begins by at least one non-strict lambda, since the corresponding 
-   argument to [t] might be unevaluated in the expanded code. *)
-
-exception Toplevel
-
-let lift n l = List.map ((+) n) l
-
-let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l 
-
-(* This function returns a list of de Bruijn indices of non-strict variables,
-   or raises [Toplevel] if it has an internal non-strict variable. 
-   In fact, not all variables are checked for strictness, only the ones which 
-   de Bruijn index is in the candidates list [cand]. The flag [add] controls 
-   the behaviour when going through a lambda: should we add the corresponding 
-   variable to the candidates?  We use this flag to check only the external 
-   lambdas, those that will correspond to arguments. *)
-
-let rec non_stricts add cand = function 
-  | MLlam (id,t) -> 
-      let cand = lift 1 cand in
-      let cand = if add then 1::cand else cand in
-      pop 1 (non_stricts add cand t)
-  | MLrel n -> 
-      List.filter ((<>) n) cand  
-  | MLapp (MLrel n, _) -> 
-      List.filter ((<>) n) cand
-	(* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *)
-	(* gain something if x is replaced by a function like a projection *)
-  | MLapp (t,l)-> 
-      let cand = non_stricts false cand t in 
-      List.fold_left (non_stricts false) cand l 
-  | MLcons (_,_,l) -> 
-      List.fold_left (non_stricts false) cand l
-  | MLletin (_,t1,t2) -> 
-      let cand = non_stricts false cand t1 in 
-      pop 1 (non_stricts add (lift 1 cand) t2)
-  | MLfix (_,i,f)-> 
-      let n = Array.length i in
-      let cand = lift n cand in 
-      let cand = Array.fold_left (non_stricts false) cand f in 
-      pop n cand
-  | MLcase (_,t,v) -> 
-      (* The only interesting case: for a variable to be non-strict, *)
-      (* it is sufficient that it appears non-strict in at least one branch, *)
-      (* so we make an union (in fact a merge). *)
-      let cand = non_stricts false cand t in 
-      Array.fold_left 
-	(fun c (_,i,t)-> 
-	   let n = List.length i in 
-	   let cand = lift n cand in 
-	   let cand = pop n (non_stricts add cand t) in
-	   Sort.merge (<=) cand c) [] v
-	(* [merge] may duplicates some indices, but I don't mind. *)
-  | MLmagic t -> 
-      non_stricts add cand t
-  | _ -> 
-      cand
-
-(* The real test: we are looking for internal non-strict variables, so we start
-   with no candidates, and the only positive answer is via the [Toplevel] 
-   exception. *)
-
-let is_not_strict t = 
-  try let _ = non_stricts true [] t in false
-  with Toplevel -> true
-
-(*s Inlining decision *)
-
-(* [inline_test] answers the following question: 
-   If we could inline [t] (the user said nothing special), 
-   should we inline ? 
-   
-   We expand small terms with at least one non-strict 
-   variable (i.e. a variable that may not be evaluated).
-   
-   Futhermore we don't expand fixpoints. *)
-
-let inline_test 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" ; "Fix" ]
-
-let manual_inline = function 
-  | ConstRef c -> List.mem c manual_inline_list
-  | _ -> false 
-
-(* If the user doesn't say he wants to keep [t], we inline in two cases:
-   \begin{itemize}
-   \item the user explicitly requests it 
-   \item [expansion_test] answers that the inlining is a good idea, and 
-   we are free to act (AutoInline is set)
-   \end{itemize} *)
-
-let inline r t = 
-  not (to_keep r) (* The user DOES want to keep it *)
-  && not (is_inline_custom r) 
-  && (to_inline r (* The user DOES want to inline it *) 
-     || (auto_inline () && lang () <> Haskell && not (is_projection r)
-         && (is_recursor r || manual_inline r || inline_test t)))
-
diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli
deleted file mode 100644
index a55caaf2..00000000
--- a/contrib/extraction/mlutil.mli
+++ /dev/null
@@ -1,113 +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        *)
-(************************************************************************)
-
-(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
-
-open Util
-open Names
-open Term
-open Libnames
-open Miniml
-
-(*s Utility functions over ML types with meta. *)
-
-val reset_meta_count : unit -> unit
-val new_meta : 'a -> ml_type
-
-val type_subst : int -> ml_type -> ml_type -> ml_type
-val type_subst_list : ml_type list -> ml_type -> ml_type
-val type_subst_vect : ml_type array -> ml_type -> ml_type
-
-val instantiation : ml_schema -> ml_type
-
-val needs_magic : ml_type * ml_type -> bool
-val put_magic_if : bool -> ml_ast -> ml_ast
-val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
-
-(*s ML type environment. *)
-
-module Mlenv : sig 
-  type t 
-  val empty : t
-    
-  (* get the n-th more recently entered schema and instantiate it. *) 
-  val get : t -> int -> ml_type
-
-  (* Adding a type in an environment, after generalizing free meta *)
-  val push_gen : t -> ml_type -> t
-
-  (* Adding a type with no [Tvar] *)
-  val push_type : t -> ml_type -> t
-     
-  (* Adding a type with no [Tvar] nor [Tmeta] *)
-  val push_std_type : t -> ml_type -> t
-end
-
-(*s Utility functions over ML types without meta *)
-
-val type_mem_kn : kernel_name -> ml_type -> bool
-
-val type_maxvar : ml_type -> int
-
-val type_decomp : ml_type -> ml_type list * ml_type
-val type_recomp : ml_type list * ml_type -> ml_type
-
-val var2var' : ml_type -> ml_type 
-
-type abbrev_map = global_reference -> ml_type option
-
-val type_expand : abbrev_map -> ml_type -> ml_type 
-val type_to_sign : abbrev_map -> ml_type -> sign
-val type_to_signature : abbrev_map -> ml_type -> signature
-val type_expunge : abbrev_map -> ml_type -> ml_type
-
-val isDummy : ml_type -> bool
-val isKill : sign -> bool
-
-val case_expunge : signature -> ml_ast -> identifier list * ml_ast
-val term_expunge : signature -> identifier list * ml_ast -> ml_ast
-
-
-(*s Special identifiers. [dummy_name] is to be used for dead code
-    and will be printed as [_] in concrete (Caml) code. *)
-
-val anonymous : identifier
-val dummy_name : identifier
-val id_of_name : name -> identifier
-
-(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
-    the list [idn;...;id1] and the term [t]. *)
-
-val collect_lams : ml_ast -> identifier list * ml_ast
-val collect_n_lams : int -> ml_ast -> identifier list * ml_ast
-val nb_lams : ml_ast -> int
-
-val dummy_lams : ml_ast -> int -> ml_ast
-val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast
-
-val eta_args_sign : int -> signature -> ml_ast list 
-
-(*s Utility functions over ML terms. *)
-
-val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast
-val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast
-val ast_iter : (ml_ast -> unit) -> ml_ast -> unit
-val ast_occurs : int -> ml_ast -> bool
-val ast_occurs_itvl : int -> int -> ml_ast -> bool
-val ast_lift : int -> ml_ast -> ml_ast
-val ast_pop : ml_ast -> ml_ast
-val ast_subst : ml_ast -> ml_ast -> ml_ast
-
-val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast
-
-val normalize : ml_ast -> ml_ast 
-val optimize_fix : ml_ast -> ml_ast
-val inline : global_reference -> ml_ast -> bool
-
-
-
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
deleted file mode 100644
index 68adeb81..00000000
--- a/contrib/extraction/modutil.ml
+++ /dev/null
@@ -1,365 +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        *)
-(************************************************************************)
-
-(*i $Id: modutil.ml 11602 2008-11-18 00:08:33Z letouzey $ i*)
-
-open Names
-open Declarations
-open Environ
-open Libnames
-open Util
-open Miniml
-open Table
-open Mlutil
-open Mod_subst
-
-(*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"
-
-(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a 
-   [ml_structure]. *) 
-
-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 l',idl' = list_sep_last idl in
-	let mp_w =
-	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
-	in
-	let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in
-	mt_iter mt; do_decl (Dtype(r,l,t))
-    | MTwith (mt,_)->mt_iter mt
-    | MTsig (_, sign) -> List.iter spec_iter sign
-  and spec_iter = function 
-    | (_,Spec s) -> do_spec s
-    | (_,Smodule mt) -> mt_iter mt
-    | (_,Smodtype mt) -> mt_iter mt
-  in
-  let rec se_iter = function 
-    | (_,SEdecl d) -> do_decl d
-    | (_,SEmodule m) -> 
-	me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
-    | (_,SEmodtype m) -> mt_iter m
-  and me_iter = function 
-    | MEident _ -> () 
-    | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
-    | MEapply (me,me') -> me_iter me; me_iter me'
-    | MEstruct (msid, sel) -> List.iter se_iter sel
-  in 
-  List.iter (function (_,sel) -> List.iter se_iter sel) s
-
-(*s Apply some fonctions upon all references in [ml_type], [ml_ast], 
-  [ml_decl], [ml_spec] and [ml_structure]. *)
-
-type do_ref = global_reference -> unit
-
-let record_iter_references do_term = function 
-  | Record l -> List.iter do_term l 
-  | _ -> ()
-
-let type_iter_references do_type t = 
-  let rec iter = function 
-    | Tglob (r,l) -> do_type r; List.iter iter l 
-    | Tarr (a,b) -> iter a; iter b 
-    | _ -> () 
-  in iter t
-
-let ast_iter_references do_term do_cons do_type a = 
-  let rec iter a = 
-    ast_iter iter a;
-    match a with 
-      | MLglob r -> do_term r
-      | MLcons (i,r,_) -> 
-	  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 (fst i); 
-	  Array.iter (fun (r,_,_) -> do_cons r) v
-      | _ -> ()
-  in iter a
-
-let ind_iter_references do_term do_cons do_type kn ind = 
-  let type_iter = type_iter_references do_type in
-  let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in 
-  let packet_iter ip p = 
-    do_type (IndRef ip); 
-    if lang () = Ocaml then 
-      (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; 
-  Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
-  
-let decl_iter_references do_term do_cons do_type = 
-  let type_iter = type_iter_references do_type 
-  and ast_iter = ast_iter_references do_term do_cons do_type in
-  function 
-    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind 
-    | Dtype (r,_,t) -> do_type r; type_iter t 
-    | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t
-    | Dfix(rv,c,t) -> 	
-	Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t
-
-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
-  | Sval (r,t) -> do_term r; type_iter_references do_type t
-
-(*s Searching occurrences of a particular term (no lifting done). *)
-
-exception Found
-
-let rec ast_search f a = 
-  if f a then raise Found else ast_iter (ast_search f) a
-
-let decl_ast_search f = function 
-  | Dterm (_,a,_) -> ast_search f a
-  | Dfix (_,c,_) -> Array.iter (ast_search f) c
-  | _ -> () 
-
-let struct_ast_search f s = 
-  try struct_iter (decl_ast_search f) (fun _ -> ()) s; false
-  with Found -> true
-
-let rec type_search f = function  
-  | Tarr (a,b) -> type_search f a; type_search f b 
-  | Tglob (r,l) -> List.iter (type_search f) l
-  | u -> if f u then raise Found
-
-let decl_type_search f = function 
-  | Dind (_,{ind_packets=p})  -> 
-      Array.iter 
-	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
-  | Dterm (_,_,u) -> type_search f u
-  | Dfix (_,_,v) -> Array.iter (type_search f) v
-  | Dtype (_,_,u) -> type_search f u
-
-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
-  | Sval (_,u) -> type_search f u
-
-let struct_type_search f s = 
-  try struct_iter (decl_type_search f) (spec_type_search f) s; false
-  with Found -> true
-
-
-(*s Generating the signature. *)
-
-let rec msig_of_ms = function 
-  | [] -> [] 
-  | (l,SEdecl (Dind (kn,i))) :: ms -> 
-      (l,Spec (Sind (kn,i))) :: (msig_of_ms ms)
-  | (l,SEdecl (Dterm (r,_,t))) :: ms -> 
-      (l,Spec (Sval (r,t))) :: (msig_of_ms ms)
-  | (l,SEdecl (Dtype (r,v,t))) :: ms -> 
-      (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) 
-  | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> 
-      let msig = ref (msig_of_ms ms) in 
-      for i = Array.length rv - 1 downto 0 do 
-	msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig
-      done; 
-      !msig
-  | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms)
-  | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms)
-
-let signature_of_structure s = 
-  List.map (fun (mp,ms) -> mp,msig_of_ms ms) s 
-
-
-(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
-
-let get_decl_in_structure r struc = 
-  try 
-    let base_mp,ll = labels_of_ref r in 
-    if not (at_toplevel base_mp) then error_not_visible r;
-    let sel = List.assoc base_mp struc in
-    let rec go ll sel = match ll with 
-      | [] -> assert false
-      | l :: ll -> 
-	  match List.assoc l sel with 
-	    | SEdecl d -> d 
-	    | SEmodtype m -> assert false
-	    | SEmodule m ->
-		match m.ml_mod_expr with 
-		  | MEstruct (_,sel) -> go ll sel 
-		  | _ -> error_not_visible r 
-    in go ll sel
-  with Not_found -> assert false
-
-
-(*s Optimization of a [ml_structure]. *)
-
-(* Some transformations of ML terms. [optimize_struct] simplify
-   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. *)
-
-let dfix_to_mlfix rv av i = 
-  let rec make_subst n s = 
-    if n < 0 then s 
-    else make_subst (n-1) (Refmap.add rv.(n) (n+1) s)
-  in 
-  let s = make_subst (Array.length rv - 1) Refmap.empty 
-  in 
-  let rec subst n t = match t with 
-    | MLglob ((ConstRef kn) as refe) -> 
-	(try MLrel (n + (Refmap.find refe s)) with Not_found -> t)
-    | _ -> ast_map_lift subst n t 
-  in 
-  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in 
-  let c = Array.map (subst 0) av 
-  in MLfix(i, ids, c)
-
-let rec optim to_appear s = function
-  | [] -> []
-  | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: 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 || 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 to_appear s l)
-      else optim to_appear s l
-  | d :: l -> d :: (optim to_appear s l)
-
-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 (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 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 
-      (* This fake body ensures that no fixpoint will be auto-inlined. *)
-      let fake_body = MLfix (0,[||],[||]) in 
-      for i = 0 to Array.length rv - 1 do 
-	if inline rv.(i) fake_body
-	then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
-	else all := false
-      done; 
-      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 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 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 to_appear s me, optim_me to_appear s me')
-  | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me)
-
-(* After these optimisations, some dependencies may not be needed anymore. 
-   For monolithic extraction, we recompute a minimal set of dependencies. *)
-
-exception NoDepCheck
-
-let base_r = function
-  | ConstRef c as r -> r
-  | IndRef (kn,_) -> IndRef (kn,0)
-  | ConstructRef ((kn,_),_) -> IndRef (kn,0)
-  | _ -> assert false
-
-let reset_needed, add_needed, found_needed, is_needed =
-  let needed = ref Refset.empty in
-  ((fun l -> needed := Refset.empty),
-   (fun r -> needed := Refset.add (base_r r) !needed),
-   (fun r -> needed := Refset.remove (base_r r) !needed),
-   (fun r -> Refset.mem (base_r r) !needed))
-
-let declared_refs = function
-  | Dind (kn,_) -> [|IndRef (kn,0)|]
-  | Dtype (r,_,_) -> [|r|]
-  | Dterm (r,_,_) -> [|r|]
-  | Dfix (rv,_,_) -> rv
-
-(* Computes the dependencies of a declaration, except in case 
-   of custom extraction. *)
-
-let compute_deps_decl = function
-  | Dind (kn,ind) ->
-      (* Todo Later : avoid dependencies when Extract Inductive *)
-      ind_iter_references add_needed add_needed add_needed kn ind
-  | Dtype (r,ids,t) ->
-      if not (is_custom r) then type_iter_references add_needed t
-  | Dterm (r,u,t) ->
-      type_iter_references add_needed t;
-      if not (is_custom r) then
-	ast_iter_references add_needed add_needed add_needed u
-  | Dfix _ as d ->
-      (* Todo Later : avoid dependencies when Extract Constant *)
-      decl_iter_references add_needed add_needed add_needed d
-
-let rec depcheck_se = function
-  | [] -> []
-  | ((l,SEdecl d) as t)::se ->
-      let se' = depcheck_se se in
-      let rv = declared_refs d in
-      if not (array_exists is_needed rv) then
-	(Array.iter remove_info_axiom rv; se')
-      else
-	(Array.iter found_needed rv; compute_deps_decl d; t::se')
-  | _ -> raise NoDepCheck
-
-let rec depcheck_struct = function
-  | [] -> []
-  | (mp,lse)::struc ->
-      let struc' = depcheck_struct struc in
-      let lse' = depcheck_se lse in
-      (mp,lse')::struc'
-
-let optimize_struct to_appear struc =
-  let subst = ref (Refmap.empty : ml_ast Refmap.t) in
-  let opt_struc =
-    List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc
-  in
-  let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in
-  try
-    if modular () then raise NoDepCheck;
-    reset_needed ();
-    List.iter add_needed to_appear;
-    depcheck_struct opt_struc
-  with NoDepCheck -> opt_struc
diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli
deleted file mode 100644
index e279261d..00000000
--- a/contrib/extraction/modutil.mli
+++ /dev/null
@@ -1,41 +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        *)
-(************************************************************************)
-
-(*i $Id: modutil.mli 11602 2008-11-18 00:08:33Z letouzey $ i*)
-
-open Names
-open Declarations
-open Environ
-open Libnames
-open Miniml
-open Mod_subst
-
-(*s Functions upon ML modules. *)
-
-val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool
-val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
-
-type do_ref = global_reference -> unit 
-
-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 signature_of_structure : ml_structure -> ml_signature
-
-val msid_of_mt : ml_module_type -> module_path
-
-val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
-
-(* Some transformations of ML terms. [optimize_struct] simplify
-   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. The first argument is the list of objects we want to appear.
-*)
-
-val optimize_struct : global_reference list -> ml_structure -> ml_structure
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
deleted file mode 100644
index 0166d854..00000000
--- a/contrib/extraction/ocaml.ml
+++ /dev/null
@@ -1,731 +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        *)
-(************************************************************************)
-
-(*i $Id: ocaml.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
-
-(*s Production of Ocaml syntax. *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Libnames
-open Table
-open Miniml
-open Mlutil
-open Modutil
-open Common
-open Declarations
-
-
-(*s Some utility functions. *)
-
-let pp_tvar id = 
-  let s = string_of_id id in 
-  if String.length s < 2 || s.[1]<>'\'' 
-  then str ("'"^s)
-  else str ("' "^s)
-
-let pp_tuple_light f = function
-  | [] -> mt ()
-  | [x] -> f true x
-  | l -> 
-      pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
-
-let pp_tuple f = function
-  | [] -> mt ()
-  | [x] -> f x
-  | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
-
-let pp_boxed_tuple f = function
-  | [] -> mt ()
-  | [x] -> f x
-  | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
-
-let pp_abst = function
-  | [] -> mt ()
-  | l  -> 
-      str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ 
-      str " ->" ++ spc ()
-
-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 Ocaml renaming issues. *)
-
-let keywords =     
-  List.fold_right (fun s -> Idset.add (id_of_string s))
-  [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
-    "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
-    "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
-    "inherit"; "initializer"; "lazy"; "let"; "match"; "method";
-    "module"; "mutable"; "new"; "object"; "of"; "open"; "or";
-    "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
-    "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
-    "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] 
-  Idset.empty
-
-let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
-
-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 ())
-
-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())
-
-(*s The pretty-printer for Ocaml syntax*)
-
-(* Beware of the side-effects of [pp_global] and [pp_modname].
-   They are used to update table of content for modules. Many [let] 
-   below should not be altered since they force evaluation order. 
-*)
-
-let pp_global k r =
-  if is_inline_custom r then str (find_custom r)
-  else str (Common.pp_global k r)
-
-let pp_modname mp = str (Common.pp_module mp)
-
-
-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
-
-let find_projections = function Record l -> l | _ -> raise NoRecord
-
-(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
-    are needed or not. *)
-
-let kn_sig = 
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in 
-  make_kn specif empty_dirpath (mk_label "sig")
-
-let rec pp_type par vl t =
-  let rec pp_rec par = function
-    | Tmeta _ | Tvar' _ | Taxiom -> assert false
-    | Tvar i -> (try pp_tvar (List.nth vl (pred i)) 
-		 with _ -> (str "'a" ++ int i))
-    | 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 Type r
-    | Tarr (t1,t2) ->
-	pp_par par 
-	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
-    | Tdummy _ -> str "__"
-    | Tunknown -> str "__"
-  in 
-  hov 0 (pp_rec par t)
-
-(*s Pretty-printing of expressions. [par] indicates whether
-    parentheses are needed or not. [env] is the list of names for the
-    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 (_,_,pv) -> not (is_ifthenelse pv)
-  | _        -> false 
-
-
-let rec pp_expr par env args = 
-  let par' = args <> [] || par
-  and apply st = pp_apply st par args in 
-  function
-    | MLrel n -> 
-	let id = get_db_name n env in apply (pr_id id)
-    | MLapp (f,args') ->
-	let stl = List.map (pp_expr true env []) args' in
-        pp_expr par env (stl @ args) f
-    | MLlam _ as a -> 
-      	let fl,a' = collect_lams a in
-	let fl,env' = push_vars fl env in
-	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
-	apply (pp_par par' st)
-    | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
-	let pp_id = pr_id (List.hd i)
-	and pp_a1 = pp_expr false env [] a1
-	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in 
-	hv 0 
-	  (apply 
-	     (pp_par par' 
-		(hv 0 
-		   (hov 2 
-		      (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ 
-		    spc () ++ str "in") ++ 
-		 spc () ++ hov 0 pp_a2)))
-    | MLglob r -> 
-	(try 
-	   let args = list_skipn (projection_arity r) args in 
-	   let record = List.hd args in 
-	   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 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 Cons r ++ spc() ++ tuple ++str ")")
-    | MLcons (_,r,[]) -> 
-	assert (args=[]);
-	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 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 
-	  (pp_expr false env [] t) 
-	in 
-	(try 
-	   let projs = find_projections i in 
-	   let (_, ids, c) = pv.(0) in 
-	   let n = List.length ids in 
-	   match c with 
-	     | MLrel i when i <= n -> 
-		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++ 
-				     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
-		 else
-		   let ids,env' = push_vars (List.rev ids) env in
-		   (pp_apply 
-		      (pp_expr true env [] t ++ str "." ++ 
-		       pp_global Term (List.nth projs (n-i)))
-		      par ((List.map (pp_expr true env' []) a) @ args))
-	     | _ -> raise NoRecord
-	 with NoRecord -> 
-	   if Array.length pv = 1 then 
-	     let s1,s2 = pp_one_pat env i pv.(0) in 
-	     apply 
-	       (hv 0 
-		  (pp_par par' 
-		     (hv 0 
-			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) 
-			 ++ spc () ++ str "in") ++ 
-		      spc () ++ hov 0 s2)))
-	   else 
- 	     apply
-      	       (pp_par par' 
-		  (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
-    | MLexn s -> 
-	(* An [MLexn] may be applied, but I don't really care. *)
-	pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
-    | MLdummy ->
-	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
-    | MLmagic a ->
-	pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
-    | MLaxiom -> 
-	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
-
-	  
-and pp_record_pat (projs, args) =
-   str "{ " ++
-   prlist_with_sep (fun () -> str ";" ++ spc ()) 
-     (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 
-  try 
-    let projs = find_projections i in 
-    pp_record_pat (projs, List.rev_map pr_id ids), expr
-  with NoRecord -> 
-    (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 (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 fst i=Standard -> 
-	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then 
-	  pr_binding (List.rev (List.tl bl)) ++
-       	  str " = function" ++ fnl () ++
-	  v 0 (str "  | " ++ pp_pat env' i pv)
-	else
-          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. *)
-
-and pp_fix par env i (ids,bl) args =
-  pp_par par 
-    (v 0 (str "let rec " ++
-	  prvect_with_sep
-      	    (fun () -> fnl () ++ str "and ")
-	    (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 = 
-  hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ 
-  str " **)")  ++ fnl2 ()
-
-(*s Pretty-printing of [Dfix] *)
-
-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 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 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_equiv pl name cnames ctyps =
-  let pl = rename_tvars keywords pl in
-  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 ++ 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 ()
-
-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 ++ 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 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 ++ name ++ 
-  pp_equiv pl name ip_equiv ++ str " = { "++
-  hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
-	   (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) 
-  ++ str " }"
-
-let pp_coind pl name = 
-  let pl = rename_tvars keywords pl in
-  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 = ind.ind_equiv, i in 
-      let p = ind.ind_packets.(i) in 
-      if is_custom (IndRef ip) then pp (i+1)
-      else begin 
-	some := true; 
-	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
-	else 
-	  let s = !init in 
-	  begin 
-	    init := (fnl () ++ str "and "); 
-	    s ++
-	    (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
-  in 
-  let st = pp 0 in if !some then st else failwith "empty phrase"
-	     
-
-(*s Pretty-printing of a declaration. *)
-
-let pp_mind kn i = 
-  match i.ind_info with 
-    | Singleton -> pp_singleton kn i.ind_packets.(0)
-    | Coinductive -> pp_ind true kn i
-    | Record projs -> 
-	pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0)
-    | Standard -> pp_ind false kn i
-
-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) -> 
-        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 -> 
-	    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 " ++ ids ++ name ++ spc () ++ def)
-    | Dterm (r, a, t) -> 
-	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 (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) -> 
-      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) -> 
-      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 -> 
-      pp_modname kn
-  | MTfunsig (mbid, mt, mt') -> 
-      let typ = pp_module_type None mt in 
-      let name = pp_modname (MPbound mbid) in 
-      let def = pp_module_type None mt' in 
-      str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
-  | MTsig (msid, sign) ->
-      let tvm = top_visible_mp () in
-      let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
-      (* References in [sign] are in short form (relative to [msid]).
-	 In push_visible, [msid-->mp] is added to the current subst. *)
-      push_visible mp (Some msid);
-      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"
-  | MTwith(mt,ML_With_type(idl,vl,typ)) ->
-      let ids = pp_parameters (rename_tvars keywords vl) in
-      let mp_mt = msid_of_mt mt in
-      let l,idl' = list_sep_last idl in
-      let mp_w =
-	List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
-      in
-      let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l))
-      in
-      push_visible mp_mt None;
-      let s =
-	pp_module_type None mt ++ str " with type " ++
-	  pp_global Type r ++ 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
-      let mp_w =
-	List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl
-      in
-      push_visible mp_mt None;
-      let s =
-	pp_module_type None mt ++ str " with module " ++ pp_modname mp_w
-      in
-      pop_visible ();
-      s ++ str " = " ++ pp_modname mp
-
-let is_short = function MEident _ | MEapply _ -> true | _ -> false
-  
-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 typ =
-        (* virtual printing of the type, in order to have a correct mli later*)
-	if Common.get_phase () = Pre then
-	  str ": " ++ pp_module_type (Some l) m.ml_mod_type
-	else mt ()
-      in
-      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 " ++ name ++ typ ++ 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) -> 
-      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) -> 
-      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 None me ++ str "(" ++ pp_module_expr None me' ++ str ")"
-  | MEstruct (msid, sel) -> 
-      let tvm = top_visible_mp () in 
-      let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
-      (* No need to update the subst with [Some msid] below : names are
-	 already in long form (see [subst_structure] in [Extract_env]). *)
-      push_visible mp None; 
-      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 do_struct f s =
-  let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt ()
-  in
-  let ppl (mp,sel) =
-    push_visible mp None;
-    let p = prlist_strict pp sel in
-    (* for monolithic extraction, we try to simulate the unavailability
-       of [MPfile] in names by artificially nesting these [MPfile] *)
-    (if modular () then pop_visible ()); p
-  in
-  let p = prlist_strict ppl s in
-  (if not (modular ()) then repeat (List.length s) pop_visible ());
-  p
-
-let pp_struct s = do_struct pp_structure_elem s
-
-let pp_signature s = do_struct pp_specif 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
deleted file mode 100644
index 3d90e74c..00000000
--- a/contrib/extraction/ocaml.mli
+++ /dev/null
@@ -1,12 +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        *)
-(************************************************************************)
-
-(*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
deleted file mode 100644
index f4941a9c..00000000
--- a/contrib/extraction/scheme.ml
+++ /dev/null
@@ -1,202 +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        *)
-(************************************************************************)
-
-(*i $Id: scheme.ml 11559 2008-11-07 22:03:34Z letouzey $ i*)
-
-(*s Production of Scheme syntax. *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Libnames
-open Miniml
-open Mlutil
-open Table
-open Common
-
-(*s Scheme renaming issues. *)
-
-let keywords =     
-  List.fold_right (fun s -> Idset.add (id_of_string s))
-    [ "define"; "let"; "lambda"; "lambdas"; "match"; 
-      "apply"; "car"; "cdr"; 
-      "error"; "delay"; "force"; "_"; "__"] 
-    Idset.empty
-
-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
-  for i = 0 to String.length s - 1 do 
-    if s.[i] = '\'' then s.[i] <- '~'
-  done; 
-  str s
-
-let paren = pp_par true
-
-let pp_abst st = function 
-  | [] -> assert false
-  | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st)
-  | l -> paren 
-	(str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st)
-
-let pp_apply st _ = function 
-  | [] -> st 
-  | [a] -> hov 2 (paren (st ++ spc () ++ a))
-  | args -> hov 2 (paren (str "@ " ++ st ++ 
-			  (prlist_strict (fun x -> spc () ++ x) args)))
-
-(*s The pretty-printer for Scheme syntax *)
-
-let pp_global k r = str (Common.pp_global k r)
-
-(*s Pretty-printing of expressions.  *)
-
-let rec pp_expr env args = 
-  let apply st = pp_apply st true args in 
-  function
-    | MLrel n -> 
-	let id = get_db_name n env in apply (pr_id id)
-    | MLapp (f,args') ->
-	let stl = List.map (pp_expr env []) args' in
-        pp_expr env (stl @ args) f
-    | MLlam _ as a -> 
-      	let fl,a' = collect_lams a in
-	let fl,env' = push_vars fl env in
-	apply (pp_abst (pp_expr env' [] a') (List.rev fl))
-    | MLletin (id,a1,a2) ->
-	let i,env' = push_vars [id] env in
-	apply 
-	  (hv 0 
-	     (hov 2 
-		(paren 
-		   (str "let " ++ 
-		    paren 
-		      (paren 
-			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) 
-		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
-    | MLglob r -> 
-	apply (pp_global Term r)
-    | MLcons (i,r,args') ->
-	assert (args=[]);
-	let st = 
-	  str "`" ++ 
-	  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) ->
-	let e = 
-	  if i <> Coinductive then pp_expr env [] t 	
-	  else paren (str "force" ++ spc () ++ pp_expr env [] t)
-	in 
-	apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv)))
-    | MLfix (i,ids,defs) ->
-	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
-      	pp_fix env' i (Array.of_list (List.rev ids'),defs) args
-    | MLexn s -> 
-	(* An [MLexn] may be applied, but I don't really care. *)
-	paren (str "error" ++ spc () ++ qs s)
-    | MLdummy ->
-	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
-    | MLmagic a ->
-	pp_expr env args a
-    | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"")
-
-and pp_cons_args env = function 
-  | MLcons (i,r,args) when i<>Coinductive -> 
-      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
-	
-
-and pp_one_pat env (r,ids,t) = 
-  let ids,env' = push_vars (List.rev ids) env in
-  let args = 
-    if ids = [] then mt () 
-    else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
-  in 
-  (pp_global Cons r ++ args), (pp_expr env' [] t)
-  
-and pp_pat env pv = 
-  prvect_with_sep fnl  
-    (fun x -> let s1,s2 = pp_one_pat env x in 
-     hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv
-
-(*s names of the functions ([ids]) are already pushed in [env],
-    and passed here just for convenience. *)
-
-and pp_fix env j (ids,bl) args =
-    paren 
-      (str "letrec " ++
-       (v 0 (paren 
-	       (prvect_with_sep fnl
-		  (fun (fi,ti) -> 
-		     paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti)))
-		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
-	     fnl () ++
-      	     hov 2 (pp_apply (pr_id (ids.(j))) true args))))
-
-(*s Pretty-printing of a declaration. *)
-
-let pp_decl = function
-  | Dind _ -> mt ()
-  | Dtype _ -> mt () 
-  | Dfix (rv, defs,_) ->
-      let ppv = Array.map (pp_global Term) rv in 
-      prvect_with_sep fnl 
-	(fun (pi,ti) -> 
-	   hov 2 
-	     (paren (str "define " ++ pi ++ spc () ++ 
-		     (pp_expr (empty_env ()) [] ti)) 
-	      ++ fnl ()))
-	(array_map2 (fun p b -> (p,b)) ppv defs) ++
-      fnl ()
-  | Dterm (r, a, _) ->
-      if is_inline_custom r then mt () 
-      else 
-	if is_custom r then 
-	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ 
-			  str (find_custom r))) ++ fnl () ++ fnl () 
-	else 
-	  hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
-			  pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl ()
-
-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 = 
-  let pp_sel (mp,sel) = 
-    push_visible mp None; 
-    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
deleted file mode 100644
index a88bb6db..00000000
--- a/contrib/extraction/scheme.mli
+++ /dev/null
@@ -1,11 +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        *)
-(************************************************************************)
-
-(*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
deleted file mode 100644
index c675a744..00000000
--- a/contrib/extraction/table.ml
+++ /dev/null
@@ -1,653 +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        *)
-(************************************************************************)
-
-(*i $Id: table.ml 11844 2009-01-22 16:45:06Z letouzey $ i*)
-
-open Names
-open Term
-open Declarations
-open Nameops
-open Summary
-open Libobject
-open Goptions
-open Libnames
-open Util
-open Pp
-open Miniml
-
-(*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
-
-let occur_kn_in_ref kn = function
-  | IndRef (kn',_)
-  | ConstructRef ((kn',_),_) -> kn = kn'
-  | ConstRef _ -> false
-  | VarRef _ -> assert false
-      
-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 raw_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 ()
-
-let at_toplevel mp = 
-  is_modfile mp || is_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 = function
-  | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
-  | _ -> failwith "get_nth_label: not enough MPdot"
-
-let common_prefix_from_list mp0 mpl = 
-  let prefixes = prefixes_mp mp0 in 
-  let rec f = function 
-    | [] -> raise Not_found
-    | mp :: l -> if MPset.mem mp prefixes then mp else 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)
-let init_terms () = terms := Cmap.empty
-let add_term kn d = terms := Cmap.add kn d !terms
-let lookup_term kn = Cmap.find kn !terms
-
-let types = ref (Cmap.empty : ml_schema Cmap.t)
-let init_types () = types := Cmap.empty
-let add_type kn s = types := Cmap.add kn s !types
-let lookup_type kn = Cmap.find kn !types 
-
-(*s Inductives table. *)
-
-let inductives = ref (KNmap.empty : (mutual_inductive_body * ml_ind) KNmap.t)
-let init_inductives () = inductives := KNmap.empty
-let add_ind kn mib ml_ind = inductives := KNmap.add kn (mib,ml_ind) !inductives
-let lookup_ind kn = KNmap.find kn !inductives
-
-(*s Recursors table. *)
-
-let recursors = ref Cset.empty
-let init_recursors () = recursors := Cset.empty
-
-let add_recursors env kn = 
-  let make_kn id = make_con (modpath kn) empty_dirpath (label_of_id id) in 
-  let mib = Environ.lookup_mind kn env in 
-  Array.iter 
-    (fun mip -> 
-       let id = mip.mind_typename in 
-       let kn_rec = make_kn (Nameops.add_suffix id "_rec")
-       and kn_rect = make_kn (Nameops.add_suffix id "_rect") in 
-       recursors := Cset.add kn_rec (Cset.add kn_rect !recursors))
-    mib.mind_packets
-
-let is_recursor = function 
-  | ConstRef kn -> Cset.mem kn !recursors
-  | _ -> false
-
-(*s Record tables. *)
-
-let projs = ref (Refmap.empty : int Refmap.t)
-let init_projs () = projs := Refmap.empty
-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 remove_info_axiom r = info_axioms := Refset.remove 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 Printing. *)
-
-(* The following functions work even on objects not in [Global.env ()].
-   WARNING: for inductive objects, an extract_inductive must have been 
-   done before. *)
-
-let safe_id_of_global = function 
-  | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l
-  | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename
-  | ConstructRef ((kn,i),j) -> 
-      (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1)
-  | _ -> assert false
-
-let safe_pr_global r =
- try Printer.pr_global r
- with _ -> pr_id (safe_id_of_global r)
-
-(* idem, but with qualification, and only for constants. *)
-
-let safe_pr_long_global r =
-  try Printer.pr_global r
-  with _ -> match r with
-    | ConstRef kn ->
-	let mp,_,l = repr_con kn in
-	str ((string_of_mp mp)^"."^(string_of_label l))
-    | _ -> assert false
-
-let pr_long_mp mp =
-  let lid = repr_dirpath (Nametab.dir_of_mp mp) in
-  str (String.concat "." (List.map string_of_id (List.rev lid)))
-
-let pr_long_global ref = pr_sp (Nametab.sp_of_global ref)
-
-(*S Warning and Error messages. *)
-
-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 safe_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 safe_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 warning_both_mod_and_cst q mp r =
- msg_warning
-   (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++
-    str "do you mean module " ++
-    pr_long_mp mp ++
-    str " or object " ++
-    pr_long_global r ++ str " ?" ++ fnl () ++
-    str "First choice is assumed, for the second one please use " ++
-    str "fully qualified name." ++ fnl ())
-
-let error_axiom_scheme r i = 
-  err (str "The type scheme axiom " ++ spc () ++
-       safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ 
-       str " type variable(s).") 
-
-let check_inside_module () = 
-  if Lib.is_modtype () then 
-    err (str "You can't do that within a Module Type." ++ fnl () ++
-	 str "Close it and try again.") 
-  else if Lib.is_module () then 
-    msg_warning
-      (str "Extraction inside an opened module is experimental.\n" ++
-       str "In case of problem, close it first.\n")
-
-let check_inside_section () = 
-  if Lib.sections_are_opened () then 
-    err (str "You can't do that within a section." ++ fnl () ++
-	 str "Close it and try again.")
-
-let error_constant r = 
-  err (safe_pr_global r ++ str " is not a constant.") 
-
-let error_inductive r = 
-  err (safe_pr_global r ++ spc () ++ str "is not an inductive type.")
-
-let error_nb_cons () = 
-  err (str "Not the right number of constructors.")
-
-let error_module_clash s = 
-  err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ 
-       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_scheme () = 
-  err (str "No Scheme modular extraction available yet.")
-
-let error_not_visible r = 
-  err (safe_pr_global r ++ str " is not directly visible.\n" ++
-       str "For example, it may be inside an applied functor." ++
-       str "Use Recursive Extraction to get the whole environment.")
-
-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 "^(raw_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 " ++ safe_pr_global r ++ str " has an anonymous field." ++
-       fnl () ++ str "To help extraction, please use an explicit name.")
-
-let check_loaded_modfile mp = match base_mp mp with 
-  | MPfile dp -> if not (Library.library_is_loaded dp) then 
-      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
-
-let auto_inline () = !auto_inline_ref
-
-let _ = declare_bool_option 
-	  {optsync = true;
-	   optname = "Extraction AutoInline";
-	   optkey = SecondaryTable ("Extraction", "AutoInline");
-	   optread = auto_inline; 
-	   optwrite = (:=) auto_inline_ref}
-
-(*s Extraction TypeExpand *)
-
-let type_expand_ref = ref true
-
-let type_expand () = !type_expand_ref
-
-let _ = declare_bool_option 
-	  {optsync = true;
-	   optname = "Extraction TypeExpand";
-	   optkey = SecondaryTable ("Extraction", "TypeExpand");
-	   optread = type_expand; 
-	   optwrite = (:=) type_expand_ref}
-
-(*s Extraction Optimize *)
-
-type opt_flag = 
-    { opt_kill_dum : bool; (* 1 *) 
-      opt_fix_fun : bool;   (* 2 *)
-      opt_case_iot : bool;  (* 4 *)
-      opt_case_idr : bool;  (* 8 *)
-      opt_case_idg : bool;  (* 16 *)
-      opt_case_cst : bool;  (* 32 *)
-      opt_case_fun : bool;  (* 64 *)
-      opt_case_app : bool;  (* 128 *)
-      opt_let_app : bool;   (* 256 *)
-      opt_lin_let : bool;   (* 512 *)
-      opt_lin_beta : bool } (* 1024 *)
-
-let kth_digit n k = (n land (1 lsl k) <> 0)
-
-let flag_of_int n = 
-    { opt_kill_dum = kth_digit n 0;
-      opt_fix_fun = kth_digit n 1;
-      opt_case_iot = kth_digit n 2;
-      opt_case_idr = kth_digit n 3;
-      opt_case_idg = kth_digit n 4; 
-      opt_case_cst = kth_digit n 5;
-      opt_case_fun = kth_digit n 6;
-      opt_case_app = kth_digit n 7;
-      opt_let_app = kth_digit n 8;
-      opt_lin_let = kth_digit n 9;
-      opt_lin_beta = kth_digit n 10 }
-
-(* For the moment, we allow by default everything except the type-unsafe 
-   optimization [opt_case_idg]. *)
-
-let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024
-
-let int_flag_ref = ref int_flag_init
-let opt_flag_ref = ref (flag_of_int int_flag_init)
-
-let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n
-
-let optims () = !opt_flag_ref
-
-let _ = declare_bool_option 
-	  {optsync = true; 
-	   optname = "Extraction Optimize";
-	   optkey = SecondaryTable ("Extraction", "Optimize");
-	   optread = (fun () -> !int_flag_ref <> 0); 
-	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
-
-let _ = declare_int_option
-          { optsync = true;
-            optname = "Extraction Flag";
-            optkey = SecondaryTable("Extraction","Flag"); 
-            optread = (fun _ -> Some !int_flag_ref); 
-            optwrite = (function 
-                          | None -> chg_flag 0
-                          | Some i -> chg_flag (max i 0))}
-
-
-(*s Extraction Lang *)
-
-type lang = Ocaml | Haskell | Scheme
-
-let lang_ref = ref Ocaml
-
-let lang () = !lang_ref
-
-let (extr_lang,_) = 
-  declare_object 
-    {(default_object "Extraction Lang") with  
-       cache_function = (fun (_,l) -> lang_ref := l);
-       load_function = (fun _ (_,l) -> lang_ref := l);
-       export_function = (fun x -> Some x)}
-
-let _ = declare_summary "Extraction Lang" 
-	  { freeze_function = (fun () -> !lang_ref);
-	    unfreeze_function = ((:=) lang_ref);
-	    init_function = (fun () -> lang_ref := Ocaml);
-	    survive_module = true;
-	    survive_section = true }  
-	  
-let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
-
-(*s Extraction Inline/NoInline *)
-
-let empty_inline_table = (Refset.empty,Refset.empty)
-
-let inline_table = ref empty_inline_table
-
-let to_inline r = Refset.mem r (fst !inline_table)
-
-let to_keep r = Refset.mem r (snd !inline_table)
-
-let add_inline_entries b l = 
-  let f b = if b then Refset.add else Refset.remove in 
-  let i,k = !inline_table in 
-  inline_table := 
-  (List.fold_right (f b) l i), 
-  (List.fold_right (f (not b)) l k)
-
-(* Registration of operations for rollback. *)
-
-let (inline_extraction,_) =
-  declare_object 
-    {(default_object "Extraction Inline") with 
-       cache_function = (fun (_,(b,l)) -> add_inline_entries b l);
-       load_function = (fun _ (_,(b,l)) -> add_inline_entries b l);
-       export_function = (fun x -> Some x); 
-       classify_function = (fun (_,o) -> Substitute o); 
-       subst_function =
-        (fun (_,s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
-    }
-
-let _ = declare_summary "Extraction Inline"
-	  { freeze_function = (fun () -> !inline_table);
-	    unfreeze_function = ((:=) inline_table);
-	    init_function = (fun () -> inline_table := empty_inline_table);
-	    survive_module = true;
-	    survive_section = true }
-
-(* Grammar entries. *)
-
-let extraction_inline b l =
-  check_inside_section (); 
-  let refs = List.map Nametab.global l in 
-  List.iter 
-    (fun r -> match r with 
-       | ConstRef _ -> ()
-       | _ -> error_constant r) refs; 
-  Lib.add_anonymous_leaf (inline_extraction (b,refs))
-
-(* Printing part *)
-
-let print_extraction_inline () = 
-  let (i,n)= !inline_table in 
-  let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in 
-  msg 
-    (str "Extraction Inline:" ++ fnl () ++ 
-     Refset.fold
-       (fun r p -> 
-	  (p ++ str "  " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++
-     str "Extraction NoInline:" ++ fnl () ++ 
-     Refset.fold
-       (fun r p -> 
-	  (p ++ str "  " ++ safe_pr_long_global r ++ fnl ())) n (mt ()))
-
-(* Reset part *)
-
-let (reset_inline,_) = 
-  declare_object
-    {(default_object "Reset Extraction Inline") with  
-       cache_function = (fun (_,_)-> inline_table :=  empty_inline_table);
-       load_function = (fun _ (_,_)-> inline_table :=  empty_inline_table); 
-       export_function = (fun x -> Some x)}
-
-let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
-
-(*s Extraction Blacklist of filenames not to use while extracting *)
-
-let blacklist_table = ref Idset.empty
-
-let modfile_ids = ref []
-let modfile_mps = ref MPmap.empty
-
-let reset_modfile () =
-  modfile_ids := Idset.elements !blacklist_table;
-  modfile_mps := MPmap.empty
-
-let string_of_modfile mp =
-  try MPmap.find mp !modfile_mps
-  with Not_found ->
-    let id = id_of_string (raw_string_of_modfile mp) in
-    let id' = next_ident_away id !modfile_ids in
-    let s' = string_of_id id' in
-    modfile_ids := id' :: !modfile_ids;
-    modfile_mps := MPmap.add mp s' !modfile_mps;
-    s'
-
-let add_blacklist_entries l =
-  blacklist_table :=
-    List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s)))
-      l !blacklist_table
-
-(* Registration of operations for rollback. *)
-
-let (blacklist_extraction,_) =
-  declare_object
-    {(default_object "Extraction Blacklist") with
-       cache_function = (fun (_,l) -> add_blacklist_entries l);
-       load_function = (fun _ (_,l) -> add_blacklist_entries l);
-       export_function = (fun x -> Some x);
-       classify_function = (fun (_,o) -> Libobject.Keep o);
-       subst_function = (fun (_,_,x) -> x)
-    }
-
-let _ = declare_summary "Extraction Blacklist"
-	  { freeze_function = (fun () -> !blacklist_table);
-	    unfreeze_function = ((:=) blacklist_table);
-	    init_function = (fun () -> blacklist_table := Idset.empty);
-	    survive_module = true;
-	    survive_section = true }
-
-(* Grammar entries. *)
-
-let extraction_blacklist l =
-  let l = List.rev_map string_of_id l in
-  Lib.add_anonymous_leaf (blacklist_extraction l)
-
-(* Printing part *)
-
-let print_extraction_blacklist () =
-  msgnl
-    (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table))
-
-(* Reset part *)
-
-let (reset_blacklist,_) =
-  declare_object
-    {(default_object "Reset Extraction Blacklist") with
-       cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
-       load_function = (fun _ (_,_)-> blacklist_table := Idset.empty);
-       export_function = (fun x -> Some x)}
-
-let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ())
-
-(*s Extract Constant/Inductive. *)
-
-(* UGLY HACK: to be defined in [extraction.ml] *)
-let use_type_scheme_nb_args, register_type_scheme_nb_args = 
-  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r 
-
-let customs = ref Refmap.empty
-
-let add_custom r ids s = customs := Refmap.add r (ids,s) !customs
-
-let is_custom r = Refmap.mem r !customs
-
-let is_inline_custom r = (is_custom r) && (to_inline r) 
-
-let find_custom r = snd (Refmap.find r !customs)
-
-let find_type_custom r = Refmap.find r !customs
-
-(* Registration of operations for rollback. *)
-
-let (in_customs,_) = 
-  declare_object 
-    {(default_object "ML extractions") with 
-       cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
-       load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s);
-       export_function = (fun x -> Some x); 
-       classify_function = (fun (_,o) -> Substitute o); 
-       subst_function =
-        (fun (_,s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
-    }
-
-let _ = declare_summary "ML extractions"
-	  { freeze_function = (fun () -> !customs);
-	    unfreeze_function = ((:=) customs);
-	    init_function = (fun () -> customs := Refmap.empty);
-	    survive_module = true;
-	    survive_section = true }
-
-(* Grammar entries. *)
-
-let extract_constant_inline inline r ids s =
-  check_inside_section ();
-  let g = Nametab.global r in 
-  match g with 
-    | ConstRef kn -> 
-	let env = Global.env () in 
-	let typ = Typeops.type_of_constant env kn in 
-	let typ = Reduction.whd_betadeltaiota env typ in
-	if Reduction.is_arity env typ 
-	  then begin 
-	    let nargs = use_type_scheme_nb_args env typ in 
-	    if List.length ids <> nargs then error_axiom_scheme g nargs
-	  end; 
-	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
-	Lib.add_anonymous_leaf (in_customs (g,ids,s))
-    | _ -> error_constant g
-
-
-let extract_inductive r (s,l) =
-  check_inside_section ();
-  let g = Nametab.global r in 
-  match g with
-    | IndRef ((kn,i) as ip) ->
-	let mib = Global.lookup_mind kn in
-	let n = Array.length mib.mind_packets.(i).mind_consnames in
-	if n <> List.length l then error_nb_cons (); 
-	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
-	Lib.add_anonymous_leaf (in_customs (g,[],s));
-	list_iter_i
-	  (fun j s -> 
-	     let g = ConstructRef (ip,succ j) in 
-	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
-	     Lib.add_anonymous_leaf (in_customs (g,[],s))) l
-    | _ -> error_inductive g 
-
-
-
-(*s Tables synchronization. *)
-
-let reset_tables () =
-  init_terms (); init_types (); init_inductives (); init_recursors ();
-  init_projs (); init_axioms (); reset_modfile ()
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
deleted file mode 100644
index 5ef7139e..00000000
--- a/contrib/extraction/table.mli
+++ /dev/null
@@ -1,151 +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        *)
-(************************************************************************)
-
-(*i $Id: table.mli 11844 2009-01-22 16:45:06Z letouzey $ i*)
-
-open Names
-open Libnames
-open Miniml
-open Declarations
-
-val safe_id_of_global : global_reference -> identifier
-
-(*s Warning and Error messages. *)
-
-val warning_axioms : unit -> unit
-val warning_both_mod_and_cst :
- qualid -> module_path -> global_reference -> unit
-val error_axiom_scheme : global_reference -> int -> 'a
-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_scheme : unit -> 'a
-val error_not_visible : global_reference -> '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
-
-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 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 labels_of_ref : global_reference -> module_path * label list
-
-(*s Some table-related operations *)
-
-val add_term : constant -> ml_decl -> unit
-val lookup_term : constant -> ml_decl
-
-val add_type : constant -> ml_schema -> unit
-val lookup_type : constant -> ml_schema
-
-val add_ind : kernel_name -> mutual_inductive_body -> ml_ind -> unit
-val lookup_ind : kernel_name -> mutual_inductive_body * ml_ind
-
-val add_recursors : Environ.env -> kernel_name -> unit
-val is_recursor : global_reference -> bool 
-
-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 remove_info_axiom : global_reference -> unit
-val add_log_axiom : global_reference -> unit
-
-val reset_tables : unit -> unit
-
-(*s AutoInline parameter *) 
-
-val auto_inline : unit -> bool
-
-(*s TypeExpand parameter *) 
-
-val type_expand : unit -> bool
-
-(*s Optimize parameter *) 
-
-type opt_flag = 
-    { opt_kill_dum : bool; (* 1 *) 
-      opt_fix_fun : bool;   (* 2 *)
-      opt_case_iot : bool;  (* 4 *)
-      opt_case_idr : bool;  (* 8 *)
-      opt_case_idg : bool;  (* 16 *)
-      opt_case_cst : bool;  (* 32 *)
-      opt_case_fun : bool;  (* 64 *)
-      opt_case_app : bool;  (* 128 *)
-      opt_let_app : bool;   (* 256 *)
-      opt_lin_let : bool;   (* 512 *)
-      opt_lin_beta : bool } (* 1024 *)
-
-val optims :  unit -> opt_flag
-
-(*s Target language. *)
-
-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
-val to_keep : global_reference -> bool
-
-(*s Table for user-given custom ML extractions. *)
-
-(* UGLY HACK: registration of a function defined in [extraction.ml] *)
-val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
-
-val is_custom : global_reference -> bool
-val is_inline_custom : global_reference -> bool
-val find_custom : global_reference -> string
-val find_type_custom : global_reference -> string list * string
-
-(*s Extraction commands. *)
-
-val extraction_language : lang -> unit
-val extraction_inline : bool -> reference list -> unit
-val print_extraction_inline : unit -> unit
-val reset_extraction_inline : unit -> unit
-val extract_constant_inline : 
-  bool -> reference -> string list -> string -> unit
-val extract_inductive : reference -> string * string list -> unit
-
-(*s Table of blacklisted filenames *)
-
-val extraction_blacklist : identifier list -> unit
-val reset_extraction_blacklist : unit -> unit
-val print_extraction_blacklist : unit -> unit
-
-
-
diff --git a/contrib/field/LegacyField.v b/contrib/field/LegacyField.v
deleted file mode 100644
index 08397d02..00000000
--- a/contrib/field/LegacyField.v
+++ /dev/null
@@ -1,15 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *)
-
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-Require Export LegacyField_Tactic.
-
-(* Command declarations are moved to the ML side *)
diff --git a/contrib/field/LegacyField_Compl.v b/contrib/field/LegacyField_Compl.v
deleted file mode 100644
index b37281e9..00000000
--- a/contrib/field/LegacyField_Compl.v
+++ /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        *)
-(************************************************************************)
-
-(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *)
-
-Require Import List.
-
-Definition assoc_2nd :=
-  (fix assoc_2nd_rec (A:Type) (B:Set)
-                     (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
-                     (lst:list (prod A B)) {struct lst} : 
-   B -> A -> A :=
-     fun (key:B) (default:A) =>
-       match lst with
-       | nil => default
-       | (v,e) :: l =>
-           match eq_dec e key with
-           | left _ => v
-           | right _ => assoc_2nd_rec A B eq_dec l key default
-           end
-       end).
-
-Definition mem :=
-  (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) 
-           (a:A) (l:list A) {struct l} : bool :=
-     match l with
-     | nil => false
-     | a1 :: l1 =>
-         match eq_dec a a1 with
-         | left _ => true
-         | right _ => mem A eq_dec a l1
-         end
-     end).
diff --git a/contrib/field/LegacyField_Tactic.v b/contrib/field/LegacyField_Tactic.v
deleted file mode 100644
index 2b6ff5b4..00000000
--- a/contrib/field/LegacyField_Tactic.v
+++ /dev/null
@@ -1,433 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *)
-
-Require Import List.
-Require Import LegacyRing.
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-
-(**** Interpretation A --> ExprA ****)
-
-Ltac get_component a s := eval cbv beta iota delta [a] in (a s).
-
-Ltac body_of s := eval cbv beta iota delta [s] in s.
-
-Ltac mem_assoc var lvar :=
-  match constr:lvar with
-  | nil => constr:false
-  | ?X1 :: ?X2 =>
-      match constr:(X1 = var) with
-      | (?X1 = ?X1) => constr:true
-      | _ => mem_assoc var X2
-      end
-  end.
-
-Ltac number lvar := 
-  let rec number_aux lvar cpt :=
-    match constr:lvar with
-    | (@nil ?X1) => constr:(@nil (prod X1 nat))
-    | ?X2 :: ?X3 =>
-        let l2 := number_aux X3 (S cpt) in
-        constr:((X2,cpt) :: l2) 
-    end
-  in number_aux lvar 0.
-
-Ltac build_varlist FT trm := 
-  let rec seek_var lvar trm :=
-    let AT := get_component A FT
-    with AzeroT := get_component Azero FT
-    with AoneT := get_component Aone FT
-    with AplusT := get_component Aplus FT
-    with AmultT := get_component Amult FT
-    with AoppT := get_component Aopp FT
-    with AinvT := get_component Ainv FT in
-    match constr:trm with
-    | AzeroT => lvar
-    | AoneT => lvar
-    | (AplusT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AmultT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AoppT ?X1) => seek_var lvar X1
-    | (AinvT ?X1) => seek_var lvar X1
-    | ?X1 =>
-        let res := mem_assoc X1 lvar in
-        match constr:res with
-        | true => lvar
-        | false => constr:(X1 :: lvar)
-        end
-    end in
-  let AT := get_component A FT in
-  let lvar := seek_var (@nil AT) trm in
-  number lvar.
-
-Ltac assoc elt lst :=
-  match constr:lst with
-  | nil => fail
-  | (?X1,?X2) :: ?X3 =>
-      match constr:(elt = X1) with
-      | (?X1 = ?X1) => constr:X2
-      | _ => assoc elt X3
-      end
-  end.
-
-Ltac interp_A FT lvar trm :=
-  let AT := get_component A FT
-  with AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | AzeroT => constr:EAzero
-  | AoneT => constr:EAone
-  | (AplusT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAplus e1 e2)
-  | (AmultT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAmult e1 e2)
-  | (AoppT ?X1) =>
-      let e := interp_A FT lvar X1 in
-      constr:(EAopp e)
-  | (AinvT ?X1) => let e := interp_A FT lvar X1 in
-                   constr:(EAinv e)
-  | ?X1 => let idx := assoc X1 lvar in
-           constr:(EAvar idx)
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Generation of the multiplier ****)
-
-Ltac remove e l :=
-  match constr:l with
-  | nil => l
-  | e :: ?X2 => constr:X2
-  | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
-  end.
-
-Ltac union l1 l2 :=
-  match constr:l1 with
-  | nil => l2
-  | ?X2 :: ?X3 =>
-      let nl2 := remove X2 l2 in
-      let nl := union X3 nl2 in
-      constr:(X2 :: nl)
-  end.
-
-Ltac raw_give_mult trm :=
-  match constr:trm with
-  | (EAinv ?X1) => constr:(X1 :: nil)
-  | (EAopp ?X1) => raw_give_mult X1
-  | (EAplus ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      union l1 l2
-  | (EAmult ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      eval compute in (app l1 l2)
-  | _ => constr:(@nil ExprA)
-  end.
-
-Ltac give_mult trm :=
-  let ltrm := raw_give_mult trm in
-  constr:(mult_of_list ltrm).
-
-(**** Associativity ****)
-
-Ltac apply_assoc FT lvar trm :=
-  let t := eval compute in (assoc trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- *
-  end.
-
-(**** Distribution *****)
-
-Ltac apply_distrib FT lvar trm :=
-  let t := eval compute in (distrib trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (distrib_correct FT trm);
-       change (distrib trm) with t in |- *
-  end.
-
-(**** Multiplication by the inverse product ****)
-
-Ltac grep_mult := match goal with
-                  | id:(interp_ExprA _ _ _ <> _) |- _ => id
-                  end.
-
-Ltac weak_reduce :=
-  match goal with
-  |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
-      cbv beta iota zeta
-       delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
-             Aone Aplus Amult Aopp Ainv] in |- *
-  end.
-
-Ltac multiply mul :=
-  match goal with
-  |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
-      let AzeroT := get_component Azero FT in
-      cut (interp_ExprA FT X2 mul <> AzeroT);
-       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
-       | weak_reduce;
-          (let AoneT := get_component Aone ltac:(body_of FT)
-           with AmultT := get_component Amult ltac:(body_of FT) in
-           try
-             match goal with
-             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
-             end; clear FT X2) ]
-  end.
-
-Ltac apply_multiply FT lvar trm :=
-  let t := eval compute in (multiply trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (multiply_correct FT trm);
-       change (multiply trm) with t in |- *
-  end.
-
-(**** Permutations and simplification ****)
-
-Ltac apply_inverse mul FT lvar trm :=
-  let t := eval compute in (inverse_simplif mul trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (inverse_correct FT trm mul);
-       [ change (inverse_simplif mul trm) with t in |- * | assumption ]
-  end.
-(**** Inverse test ****)
-
-Ltac strong_fail tac := first [ tac | fail 2 ].
-
-Ltac inverse_test_aux FT trm :=
-  let AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | (AinvT _) => fail 1
-  | (AoppT ?X1) =>
-      strong_fail ltac:(inverse_test_aux FT X1; idtac)
-  | (AplusT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | (AmultT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | _ => idtac
-  end.
-
-Ltac inverse_test FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
-  end.
-
-(**** Field itself ****)
-
-Ltac apply_simplif sfun :=
-  match goal with
-  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => 
-  sfun X1 X2 X3
-  end;
-   match goal with
-   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => 
-   sfun X1 X2 X3
-   end.
-
-Ltac unfolds FT :=
-  match get_component Aminus FT with
-  | Some ?X1 => unfold X1 in |- *
-  | _ => idtac
-  end;
-  match get_component Adiv FT with
-  | Some ?X1 => unfold X1 in |- *
-  | _ => idtac
-  end.
-
-Ltac reduce FT :=
-  let AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * ||
-     compute in |- *).
-
-Ltac field_gen_aux FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      let lvar := build_varlist FT (AplusT X1 X2) in
-      let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
-      let mul := give_mult (EAplus trm1 trm2) in
-      cut
-        (let ft := FT in
-         let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
-        [ compute in |- *; auto
-        | intros ft vm; apply_simplif apply_distrib;
-           apply_simplif apply_assoc; multiply mul;
-           [ apply_simplif apply_multiply;
-              apply_simplif ltac:(apply_inverse mul);
-              (let id := grep_mult in
-               clear id; weak_reduce; clear ft vm; first
-              [ inverse_test FT; legacy ring | field_gen_aux FT ])
-           | idtac ] ]
-  end.
-
-Ltac field_gen FT :=
-  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
-
-(*****************************)
-(*    Term Simplification    *)
-(*****************************)
-
-(**** Minus and division expansions ****)
-
-Ltac init_exp FT trm :=
-  let e :=
-   (match get_component Aminus FT with
-    | Some ?X1 => eval cbv beta delta [X1] in trm
-    | _ => trm
-    end) in
-  match get_component Adiv FT with
-  | Some ?X1 => eval cbv beta delta [X1] in e
-  | _ => e
-  end.
-
-(**** Inverses simplification ****)
-
-Ltac simpl_inv trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAplus e1 e2)
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAmult e1 e2)
-  | (EAopp ?X1) => let e := simpl_inv X1 in
-                   constr:(EAopp e)
-  | (EAinv ?X1) => SimplInvAux X1
-  | ?X1 => constr:X1
-  end
- with SimplInvAux trm :=
-  match constr:trm with
-  | (EAinv ?X1) => simpl_inv X1
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
-      constr:(EAmult e1 e2)
-  | ?X1 => let e := simpl_inv X1 in
-           constr:(EAinv e)
-  end.
-
-(**** Monom simplification ****)
-
-Ltac map_tactic fcn lst :=
-  match constr:lst with
-  | nil => lst
-  | ?X2 :: ?X3 =>
-      let r := fcn X2 with t := map_tactic fcn X3 in
-      constr:(r :: t)
-  end.
-
-Ltac build_monom_aux lst trm :=
-  match constr:lst with
-  | nil => eval compute in (assoc trm)
-  | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
-  end.
-
-Ltac build_monom lnum lden :=
-  let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
-  let ltot := eval compute in (app lnum ildn) in
-  let trm := build_monom_aux ltot EAone in
-  match constr:trm with
-  | (EAmult _ ?X1) => constr:X1
-  | ?X1 => constr:X1
-  end.
-
-Ltac simpl_monom_aux lnum lden trm :=
-  match constr:trm with
-  | (EAmult (EAinv ?X1) ?X2) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          simpl_monom_aux newlnum lden X2
-      | false => simpl_monom_aux lnum (X1 :: lden) X2
-      end
-  | (EAmult ?X1 ?X2) =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          simpl_monom_aux lnum newlden X2
-      | false => simpl_monom_aux (X1 :: lnum) lden X2
-      end
-  | (EAinv ?X1) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          build_monom newlnum lden
-      | false => build_monom lnum (X1 :: lden)
-      end
-  | ?X1 =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          build_monom lnum newlden
-      | false => build_monom (X1 :: lnum) lden
-      end
-  end.
-
-Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.
-
-Ltac simpl_all_monomials trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
-      constr:(EAplus e1 e2)
-  | ?X1 => simpl_monom X1
-  end.
-
-(**** Associativity and distribution ****)
-
-Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).
-
-(**** The tactic Field_Term ****)
-
-Ltac eval_weak_reduce trm :=
-  eval
-   cbv beta iota zeta
-    delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
-          Amult Aopp Ainv] in trm.
-
-Ltac field_term FT exp :=
-  let newexp := init_exp FT exp in
-  let lvar := build_varlist FT newexp in
-  let trm := interp_A FT lvar newexp in
-  let tma := eval compute in (assoc trm) in
-  let tsmp :=
-   simpl_all_monomials
-    ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
-  let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
-  (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/contrib/field/LegacyField_Theory.v b/contrib/field/LegacyField_Theory.v
deleted file mode 100644
index 9c3a12fb..00000000
--- a/contrib/field/LegacyField_Theory.v
+++ /dev/null
@@ -1,650 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *)
-
-Require Import List.
-Require Import Peano_dec.
-Require Import LegacyRing.
-Require Import LegacyField_Compl.
-
-Record Field_Theory : Type := 
-  {A : Type;
-   Aplus : A -> A -> A;
-   Amult : A -> A -> A;
-   Aone : A;
-   Azero : A;
-   Aopp : A -> A;
-   Aeq : A -> A -> bool;
-   Ainv : A -> A;
-   Aminus : option (A -> A -> A);
-   Adiv : option (A -> A -> A);
-   RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
-   Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.
-
-(* The reflexion structure *)
-Inductive ExprA : Set :=
-  | EAzero : ExprA
-  | EAone : ExprA
-  | EAplus : ExprA -> ExprA -> ExprA
-  | EAmult : ExprA -> ExprA -> ExprA
-  | EAopp : ExprA -> ExprA
-  | EAinv : ExprA -> ExprA
-  | EAvar : nat -> ExprA.
-
-(**** Decidability of equality ****)
-
-Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
-Proof.
-  double induction e1 e2; try intros;
-   try (left; reflexivity) || (try (right; discriminate)).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red in |- *; intro; inversion H3; auto).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red in |- *; intro; inversion H3; auto).
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red in |- *; intro; inversion H1; auto.
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red in |- *; intro; inversion H1; auto.
-  elim (eq_nat_dec n n0); intro y.
-  left; rewrite y; auto.
-  right; red in |- *; intro; inversion H; auto. 
-Defined.
-
-Definition eq_nat_dec := Eval compute in eq_nat_dec.
-Definition eqExprA := Eval compute in eqExprA_O.
-
-(**** Generation of the multiplier ****)
-
-Fixpoint mult_of_list (e:list ExprA) : ExprA :=
-  match e with
-  | nil => EAone
-  | e1 :: l1 => EAmult e1 (mult_of_list l1)
-  end.
-
-Section Theory_of_fields.
-
-Variable T : Field_Theory.
-
-Let AT := A T.
-Let AplusT := Aplus T.
-Let AmultT := Amult T.
-Let AoneT := Aone T.
-Let AzeroT := Azero T.
-Let AoppT := Aopp T.
-Let AeqT := Aeq T.
-Let AinvT := Ainv T.
-Let RTT := RT T.
-Let Th_inv_defT := Th_inv_def T.
-
-Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
- Azero T) (Aopp T) (Aeq T) (RT T).
-
-Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
-
-(***************************)
-(*    Lemmas to be used    *)
-(***************************)
-
-Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_assoc :
- forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_assoc :
- forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_AplusT_distr :
- forall r1 r2 r3:AT,
-   AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
-Proof.
-  intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
-  legacy ring.
-  transitivity (AplusT (AplusT (AoppT r) r) r2).
-  repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
-  legacy ring.
-Qed.
- 
-Lemma r_AmultT_mult :
- forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
-Proof.
-  intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
-  rewrite Th_inv_defT; [ symmetry  in |- *; apply AmultT_1l; auto | auto ].
-  transitivity (AmultT (AmultT (AinvT r) r) r2).
-  repeat rewrite AmultT_assoc; rewrite H; trivial.
-  rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
-Qed.
-
-Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
- 
-Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
- 
-Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
-Proof.
-  intro; legacy ring.
-Qed.
- 
-Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
-Proof.
-  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
-Qed.
- 
-Lemma Rmult_neq_0_reg :
- forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
-Proof.
-  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
-Qed.
-
-(************************)
-(*    Interpretation    *)
-(************************)
-
-(**** ExprA --> A ****)
-
-Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
- AT :=
-  match e with
-  | EAzero => AzeroT
-  | EAone => AoneT
-  | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAopp e => Aopp T (interp_ExprA lvar e)
-  | EAinv e => Ainv T (interp_ExprA lvar e)
-  | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Associativity ****)
-
-Definition merge_mult :=
-  (fix merge_mult (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAmult t1 t2 =>
-           match t2 with
-           | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2))
-           | _ => EAmult t1 (EAmult t2 e2)
-           end
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint assoc_mult (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e3 =>
-      match e1 with
-      | EAmult e1 e2 =>
-          merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
-            (assoc_mult e3)
-      | _ => EAmult e1 (assoc_mult e3)
-      end
-  | _ => e
-  end.
-
-Definition merge_plus :=
-  (fix merge_plus (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           match t2 with
-           | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2))
-           | _ => EAplus t1 (EAplus t2 e2)
-           end
-       | _ => EAplus e1 e2
-       end).
-
-Fixpoint assoc (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e3 =>
-      match e1 with
-      | EAplus e1 e2 =>
-          merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3)
-      | _ => EAplus (assoc_mult e1) (assoc e3)
-      end
-  | _ => assoc_mult e
-  end.
-
-Lemma merge_mult_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
-   interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
- unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
- fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
- fold interp_ExprA in |- *; auto.
-Qed.
-
-Lemma merge_mult_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try (intros; simpl in |- *; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AmultT (interp_ExprA lvar e2)
-     (AmultT (interp_ExprA lvar e4)
-        (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AmultT
-     (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl in |- *; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_mult_correct1 :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AmultT (interp_ExprA lvar (assoc_mult e1))
-     (interp_ExprA lvar (assoc_mult e2)) =
-   interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
- simpl in |- *; rewrite merge_mult_correct; simpl in |- *; 
- auto.
-Qed.
-
-Lemma assoc_mult_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-intros; simpl in |- *; legacy ring.
-simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
- rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
- rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc;
- rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
- rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
- fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
- rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; 
- legacy ring.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-Qed.
-
-Lemma merge_plus_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
-   interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
- unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
- fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
- fold interp_ExprA in |- *; auto.
-Qed.
-
-Lemma merge_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try intros; try (simpl in |- *; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AplusT (interp_ExprA lvar e2)
-     (AplusT (interp_ExprA lvar e4)
-        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AplusT
-     (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl in |- *; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
-   interp_ExprA lvar (assoc (EAplus e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
- simpl in |- *; rewrite merge_plus_correct; simpl in |- *; 
- auto.
-Qed.
-
-Lemma assoc_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
- rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc;
- rewrite assoc_plus_correct; rewrite H2; simpl in |- *;
- apply
-  (r_AplusT_plus (interp_ExprA lvar (assoc e1))
-     (AplusT (interp_ExprA lvar (assoc e2))
-        (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
-     (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
-        (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
- rewrite
-  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
-  ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; 
- rewrite (H0 lvar);
- rewrite <-
-  (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
-     (interp_ExprA lvar e3) (interp_ExprA lvar e1))
-  ;
- rewrite
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
-     (interp_ExprA lvar e3));
- rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
- rewrite <-
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-     (interp_ExprA lvar e1)); apply AplusT_comm.
-unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
- rewrite (H0 lvar); simpl in |- *; auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
- simpl in |- *; auto.
-Qed.
-
-(**** Distribution *****)
-
-Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e)
-  | e => e
-  end.
-
-Definition distrib_mult_right :=
-  (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
-  match e1 with
-  | EAplus t1 t2 =>
-      EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2)
-  | _ => distrib_mult_right e2 e1
-  end.
-
-Fixpoint distrib_main (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2)
-  | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2)
-  | EAopp e => EAopp (distrib_main e)
-  | _ => e
-  end.
-
-Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).
-
-Lemma distrib_mult_right_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_right e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl in |- *; auto.
-rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
- rewrite (H0 e2 lvar); legacy ring.
-Qed.
-
-Lemma distrib_mult_left_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_left e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl in |- *.
-rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
- apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. 
-rewrite AmultT_comm;
- rewrite
-  (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
-     (interp_ExprA lvar e0));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
- rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-Qed.
-
-Lemma distrib_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib in |- *; simpl in |- *; auto.
-simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
-simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
- unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
- simpl in |- *; fold AoppT in |- *; legacy ring.
-Qed.
-
-(**** Multiplication by the inverse product ****)
-
-Lemma mult_eq :
- forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
-   interp_ExprA lvar e1 = interp_ExprA lvar e2.
-Proof.
-  simpl in |- *; intros;
-   apply
-    (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
-       (interp_ExprA lvar e2)); assumption.
-Qed.
-
-Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
-  | _ => EAmult a e
-  end.
-
-Definition multiply (e:ExprA) : ExprA :=
-  match e with
-  | EAmult a e1 => multiply_aux a e1
-  | _ => e
-  end.
-
-Lemma multiply_aux_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply_aux a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
- auto.
-  simpl in |- *; rewrite (H0 lvar); legacy ring.
-Qed.
-
-Lemma multiply_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
-Proof.
-  simple induction e; simpl in |- *; auto.
-  intros; apply multiply_aux_correct.
-Qed.
-
-(**** Permutations and simplification ****)
-
-Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
-  match m with
-  | EAmult m0 m1 =>
-      match eqExprA m0 (EAinv a) with
-      | left _ => m1
-      | right _ => EAmult m0 (monom_remove a m1)
-      end
-  | _ =>
-      match eqExprA m (EAinv a) with
-      | left _ => EAone
-      | right _ => EAmult a m
-      end
-  end.
-
-Definition monom_simplif_rem :=
-  (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
-     fun m:ExprA =>
-       match a with
-       | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
-       | _ => monom_remove a m
-       end).
-
-Definition monom_simplif (a m:ExprA) : ExprA :=
-  match m with
-  | EAmult a' m' =>
-      match eqExprA a a' with
-      | left _ => monom_simplif_rem a m'
-      | right _ => m
-      end
-  | _ => m
-  end.
-
-Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
-  | _ => monom_simplif a e
-  end.
-
-Lemma monom_remove_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_remove a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; intros.
-simpl in |- *; case (eqExprA EAzero (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA EAone (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
- [ inversion e2 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
-rewrite e2; simpl in |- *; fold AinvT in |- *.
-rewrite <-
- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
-simpl in |- *; rewrite H0; auto; legacy ring.
-simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
- intros; [ inversion e1 | simpl in |- *; trivial ].
-unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
-case (eqExprA e0 a); intros.
-rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
-inversion e1; simpl in |- *; elimtype False; auto.
-simpl in |- *; trivial.
-unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
-Qed.
-
-Lemma monom_simplif_rem_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif_rem a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
- auto.
-elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
- intros.
-rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
-legacy ring.
-Qed.
-
-Lemma monom_simplif_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl in |- *; case (eqExprA a e0); intros.
-rewrite <- e2; apply monom_simplif_rem_correct; auto. 
-simpl in |- *; trivial.
-Qed.
-
-Lemma inverse_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
-unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
-Qed.
-
-End Theory_of_fields.
-
-(* Compatibility *)
-Notation AplusT_sym := AplusT_comm (only parsing).
-Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
deleted file mode 100644
index dea79773..00000000
--- a/contrib/field/field.ml4
+++ /dev/null
@@ -1,193 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *)
-
-open Names
-open Pp
-open Proof_type
-open Tacinterp
-open Tacmach
-open Term
-open Typing
-open Util
-open Vernacinterp
-open Vernacexpr
-open Tacexpr
-open Mod_subst
-open Coqlib
-
-(* Interpretation of constr's *)
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-(* Construction of constants *)
-let constant dir s = gen_constant "Field" ("field"::dir) s
-let init_constant s = gen_constant_in_modules "Field" init_modules s
-
-(* To deal with the optional arguments *)
-let constr_of_opt a opt =
-  let ac = constr_of a in
-  let ac3 = mkArrow ac (mkArrow ac ac) in
-  match opt with
-  | None -> mkApp (init_constant "None",[|ac3|])
-  | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
-
-(* Table of theories *)
-let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
-
-let lookup env typ =
-  try Gmap.find typ !th_tab
-  with Not_found -> 
-    errorlabstrm "field"
-      (str "No field is declared for type" ++ spc() ++
-      Printer.pr_lconstr_env env typ)
-
-let _ = 
-  let init () = th_tab := Gmap.empty in
-  let freeze () = !th_tab in
-  let unfreeze fs = th_tab := fs in
-  Summary.declare_summary "field"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init;
-      Summary.survive_module = false;
-      Summary.survive_section   = false }
-
-let load_addfield _ = ()
-let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
-let subst_addfield (_,subst,(typ,th as obj)) =
-  let typ' = subst_mps subst typ in
-  let th' = subst_mps subst th in
-    if typ' == typ && th' == th then obj else
-      (typ',th')
-let export_addfield x = Some x
-
-(* Declaration of the Add Field library object *)
-let (in_addfield,out_addfield)=
-  Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
-       Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
-       Libobject.cache_function = cache_addfield;
-       Libobject.subst_function = subst_addfield;
-       Libobject.classify_function = (fun (_,a) -> Libobject.Substitute a);
-       Libobject.export_function = export_addfield }
-
-(* Adds a theory to the table *)
-let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
-  ainv_l =
-  begin
-    (try
-      Ring.add_theory true true false a None None None aplus amult aone azero
-        (Some aopp) aeq rth Quote.ConstrSet.empty
-     with | UserError("Add Semi Ring",_) -> ());
-    let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
-      [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
-    begin
-      let _ = type_of (Global.env ()) Evd.empty th in ();
-      Lib.add_anonymous_leaf (in_addfield (a,th))
-    end
-  end
-
-(* Vernac command declaration *)
-open Extend
-open Pcoq
-open Genarg
-
-VERNAC ARGUMENT EXTEND divarg
-| [ "div" ":=" constr(adiv) ] -> [ adiv ]
-END
-
-VERNAC ARGUMENT EXTEND minusarg
-| [ "minus" ":=" constr(aminus) ] -> [ aminus ]
-END
-
-(*
-(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*)
-VERNAC ARGUMENT EXTEND minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-*)
-
-(* For the translator, otherwise the code above is OK *)
-open Ppconstr
-let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = 
-  if omin=None && odiv=None then mt() else
-    spc() ++ str "with" ++
-    pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
-    pr_opt (fun c -> str "div := " ++ _prc c) odiv
-(*
-let () =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_minus_div_arg,pp_minus_div_arg)
-    (globwit_minus_div_arg,pp_minus_div_arg)
-    (wit_minus_div_arg,pp_minus_div_arg)
-*)
-ARGUMENT EXTEND minus_div_arg 
-  TYPED AS constr_opt * constr_opt
-  PRINTED BY pp_minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-
-VERNAC COMMAND EXTEND Field
-  [ "Add" "Legacy" "Field" 
-      constr(a) constr(aplus) constr(amult) constr(aone)
-      constr(azero) constr(aopp) constr(aeq)
-      constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
-    -> [ let (aminus_o, adiv_o) = md in
-         add_field
-           (constr_of a) (constr_of aplus) (constr_of amult)
-           (constr_of aone) (constr_of azero) (constr_of aopp)
-           (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o)
-           (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ]
-END
-
-(* Guesses the type and calls field_gen with the right theory *)
-let field g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let typ = 
-    match Hipattern.match_with_equation (pf_concl g) with
-      | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
-      | _ -> 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 ())
-    <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
-
-(* Verifies that all the terms have the same type and gives the right theory *)
-let guess_theory env evc = function
-  | c::tl ->
-    let t = type_of env evc c in
-    if List.exists (fun c1 ->
-      not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then
-      errorlabstrm "Field:" (str" All the terms must have the same type")
-    else
-      lookup env t
-  | [] -> anomaly "Field: must have a non-empty constr list here"
-
-(* Guesses the type and calls Field_Term with the right theory *)
-let field_term l g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let env = (pf_env g)
-  and evc = (project g) in
-  let th = valueIn (VConstr (guess_theory env evc l))
-  and nl = List.map (fun x -> valueIn (VConstr x)) (Quote.sort_subterm g l) in
-  (List.fold_right
-    (fun c a ->
-     let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
-     Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g
-
-(* Declaration of Field *)
-
-TACTIC EXTEND legacy_field
-| [ "legacy" "field" ] -> [ field ]
-| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
-END
diff --git a/contrib/firstorder/formula.ml b/contrib/firstorder/formula.ml
deleted file mode 100644
index 3e49cd9c..00000000
--- a/contrib/firstorder/formula.ml
+++ /dev/null
@@ -1,270 +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        *)
-(************************************************************************)
-
-(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
-
-open Hipattern
-open Names
-open Term
-open Termops
-open Reductionops
-open Tacmach
-open Util
-open Declarations
-open Libnames
-open Inductiveops
-
-let qflag=ref true
-
-let red_flags=ref Closure.betaiotazeta
-
-let (=?) f g i1 i2 j1 j2=
-  let c=f i1 i2 in
-    if c=0 then g j1 j2 else c
-
-let (==?) fg h i1 i2 j1 j2 k1 k2=
-  let c=fg i1 i2 j1 j2 in
-    if c=0 then h k1 k2 else c
-
-type ('a,'b) sum = Left of 'a | Right of 'b
-
-type counter = bool -> metavariable
-
-exception Is_atom of constr
-
-let meta_succ m = m+1
-
-let rec nb_prod_after n c=
-  match kind_of_term c with
-    | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 
-	1+(nb_prod_after 0 b)
-    | _ -> 0
-
-let construct_nhyps ind gls =
-  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
-  let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in 
-  let hyp = nb_prod_after nparams in	
-    Array.map hyp constr_types
-
-(* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
-let ind_hyps nevar ind largs gls= 
-  let types= Inductiveops.arities_of_constructors (pf_env gls) ind in 
-  let lp=Array.length types in     
-  let myhyps i=
-    let t1=Term.prod_applist types.(i) largs in
-    let t2=snd (Sign.decompose_prod_n_assum nevar t1) in
-      fst (Sign.decompose_prod_assum t2) in
-    Array.init lp myhyps
-
-let special_nf gl=
-  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
-
-let special_whd gl=
-  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
-
-type kind_of_formula=
-    Arrow of constr*constr
-  | False of inductive*constr list
-  | And of inductive*constr list*bool
-  | Or of inductive*constr list*bool
-  | Exists of inductive*constr list
-  | Forall of constr*constr
-  | Atom of constr
-      
-let rec kind_of_formula gl term =
-  let normalize=special_nf gl in
-  let cciterm=special_whd gl term in
-    match match_with_imp_term cciterm with
-	Some (a,b)-> Arrow(a,(pop b))
-      |_->
-	 match match_with_forall_term cciterm with
-	     Some (_,a,b)-> Forall(a,b)
-	   |_-> 
-	      match match_with_nodep_ind cciterm with
-		  Some (i,l,n)->
-		    let ind=destInd i in
-		    let (mib,mip) = Global.lookup_inductive ind in
-		    let nconstr=Array.length mip.mind_consnames in
-		      if nconstr=0 then 
-			False(ind,l)
-		      else
-			let has_realargs=(n>0) in
-			let is_trivial=
-			  let is_constant c =
-			    nb_prod c = mib.mind_nparams in  
-			    array_exists is_constant mip.mind_nf_lc in 
-			  if Inductiveops.mis_is_recursive (ind,mib,mip) ||
-			    (has_realargs && not is_trivial)
-			  then
-			    Atom cciterm 
-			  else
-			    if nconstr=1 then
-			      And(ind,l,is_trivial)
-			    else 
-			      Or(ind,l,is_trivial) 
-		| _ ->  
-		    match match_with_sigma_type cciterm with
-			Some (i,l)-> Exists((destInd i),l)
-		      |_-> Atom (normalize cciterm)
-  
-type atoms = {positive:constr list;negative:constr list}
-
-type side = Hyp | Concl | Hint
-
-let no_atoms = (false,{positive=[];negative=[]})
-
-let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
-
-let build_atoms gl metagen side cciterm =
-  let trivial =ref false
-  and positive=ref []
-  and negative=ref [] in
-  let normalize=special_nf gl in 
-  let rec build_rec env polarity cciterm=
-    match kind_of_formula gl cciterm with
-	False(_,_)->if not polarity then trivial:=true
-      | Arrow (a,b)->
-	  build_rec env (not polarity) a;
-	  build_rec env polarity b
-      | And(i,l,b) | Or(i,l,b)->
-	  if b then 
-	    begin
-	      let unsigned=normalize (substnl env 0 cciterm) in
-		if polarity then 
-		  positive:= unsigned :: !positive 
-		else 
-		  negative:= unsigned :: !negative
-	    end;
-	  let v = ind_hyps 0 i l gl in
-	  let g i _ (_,_,t) =
-	    build_rec env polarity (lift i t) in
-	  let f l =
-	    list_fold_left_i g (1-(List.length l)) () l in
-	    if polarity && (* we have a constant constructor *)
-	      array_exists (function []->true|_->false) v 
-	    then trivial:=true;
-	    Array.iter f v 
-      | Exists(i,l)->
-	  let var=mkMeta (metagen true) in
-	  let v =(ind_hyps 1 i l gl).(0) in
-	  let g i _ (_,_,t) =
-	    build_rec (var::env) polarity (lift i t) in
-	    list_fold_left_i g (2-(List.length l)) () v
-      | Forall(_,b)->
-	  let var=mkMeta (metagen true) in
-	    build_rec (var::env) polarity b
-      | Atom t->
-	  let unsigned=substnl env 0 t in
-	    if not (isMeta unsigned) then (* discarding wildcard atoms *)
-	      if polarity then 
-		positive:= unsigned :: !positive 
-	      else 
-		negative:= unsigned :: !negative in
-    begin
-      match side with
-	  Concl    -> build_rec [] true cciterm
-	| Hyp      -> build_rec [] false cciterm
-	| Hint     -> 
-	    let rels,head=decompose_prod cciterm in
-	    let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
-	      build_rec env false head;trivial:=false (* special for hints *)
-    end;
-    (!trivial,
-     {positive= !positive;
-      negative= !negative})
-    
-type right_pattern =
-    Rarrow
-  | Rand
-  | Ror 
-  | Rfalse
-  | Rforall
-  | Rexists of metavariable*constr*bool
-   
-type left_arrow_pattern=
-    LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
-  | LLforall of constr
-  | LLexists of inductive*constr list
-  | LLarrow of constr*constr*constr
-
-type left_pattern=
-    Lfalse    
-  | Land of inductive
-  | Lor of inductive 
-  | Lforall of metavariable*constr*bool
-  | Lexists of inductive
-  | LA of constr*left_arrow_pattern
-
-type t={id:global_reference;
-	constr:constr;
-	pat:(left_pattern,right_pattern) sum;
-	atoms:atoms}
-    
-let build_formula side nam typ gl metagen=
-  let normalize = special_nf gl in
-    try 
-      let m=meta_succ(metagen false) in
-      let trivial,atoms=
-	if !qflag then 
-	  build_atoms gl metagen side typ 
-	else no_atoms in
-      let pattern=
-	match side with
-	    Concl ->
-	      let pat=
-		match kind_of_formula gl typ with
-		    False(_,_)        -> Rfalse
-		  | Atom a       -> raise (Is_atom a)
-		  | And(_,_,_)        -> Rand
-		  | Or(_,_,_)         -> Ror
-		  | Exists (i,l) -> 
-		      let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
-			Rexists(m,d,trivial)
-		  | Forall (_,a) -> Rforall 
-		  | Arrow (a,b) -> Rarrow in
-		Right pat
-	  | _ ->
-	      let pat=
-		match kind_of_formula gl typ with
-		    False(i,_)        ->  Lfalse
-		  | Atom a       ->  raise (Is_atom a)
-		  | And(i,_,b)         ->  
-		      if b then
-			let nftyp=normalize typ in raise (Is_atom nftyp)
-		      else Land i
-		  | Or(i,_,b)          ->
-		      if b then
-			let nftyp=normalize typ in raise (Is_atom nftyp)
-		      else Lor i
-		  | Exists (ind,_) ->  Lexists ind 
-		  | Forall (d,_) -> 
-		      Lforall(m,d,trivial)
-		  | Arrow (a,b) ->
-		      let nfa=normalize a in
-			LA (nfa, 
-			    match kind_of_formula gl a with
-				False(i,l)-> LLfalse(i,l)
-			      | Atom t->     LLatom
-			      | And(i,l,_)-> LLand(i,l)
-			      | Or(i,l,_)->  LLor(i,l)
-			      | Arrow(a,c)-> LLarrow(a,c,b)
-			      | Exists(i,l)->LLexists(i,l)
-			      | Forall(_,_)->LLforall a) in
-		Left pat
-      in
-	Left {id=nam;
-	      constr=normalize typ;
-	      pat=pattern;
-	      atoms=atoms}
-    with Is_atom a-> Right a (* already in nf *)
-
diff --git a/contrib/firstorder/formula.mli b/contrib/firstorder/formula.mli
deleted file mode 100644
index 8703045c..00000000
--- a/contrib/firstorder/formula.mli
+++ /dev/null
@@ -1,77 +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        *)
-(************************************************************************)
-
-(* $Id: formula.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Names
-open Libnames
-
-val qflag : bool ref
-
-val red_flags: Closure.RedFlags.reds ref
-
-val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 
-  'a -> 'a -> 'b -> 'b -> int
-  
-val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 
-  'a -> 'a -> 'b -> 'b -> 'c ->'c -> int
-
-type ('a,'b) sum = Left of 'a | Right of 'b
-
-type counter = bool -> metavariable
-
-val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
-
-val ind_hyps : int -> inductive -> constr list -> 
-  Proof_type.goal Tacmach.sigma -> Sign.rel_context array
-
-type atoms = {positive:constr list;negative:constr list}
-
-type side = Hyp | Concl | Hint
-
-val dummy_id: global_reference
-			
-val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> 
-  side -> constr -> bool * atoms
-
-type right_pattern =
-    Rarrow
-  | Rand
-  | Ror 
-  | Rfalse
-  | Rforall
-  | Rexists of metavariable*constr*bool
-    
-type left_arrow_pattern=
-    LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
-  | LLforall of constr
-  | LLexists of inductive*constr list
-  | LLarrow of constr*constr*constr
-
-type left_pattern=
-    Lfalse    
-  | Land of inductive
-  | Lor of inductive 
-  | Lforall of metavariable*constr*bool
-  | Lexists of inductive
-  | LA of constr*left_arrow_pattern
-      
-type t={id: global_reference;
-	constr: constr;
-	pat: (left_pattern,right_pattern) sum;
-	atoms: atoms}
-    
-(*exception Is_atom of constr*)
-
-val build_formula : side -> global_reference -> types -> 
-  Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum
-
diff --git a/contrib/firstorder/g_ground.ml4 b/contrib/firstorder/g_ground.ml4
deleted file mode 100644
index f7b0a546..00000000
--- a/contrib/firstorder/g_ground.ml4
+++ /dev/null
@@ -1,128 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma"  i*)
-
-(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *)
-
-open Formula
-open Sequent
-open Ground
-open Goptions
-open Tactics
-open Tacticals
-open Tacinterp
-open Term
-open Names
-open Util
-open Libnames
-
-(* declaring search depth as a global option *)
-
-let ground_depth=ref 3
-
-let _=
-  let gdopt=
-    { optsync=true;
-      optname="Firstorder Depth";
-      optkey=SecondaryTable("Firstorder","Depth"); 
-      optread=(fun ()->Some !ground_depth); 
-      optwrite=
-   (function 
-	None->ground_depth:=3
-      |	Some i->ground_depth:=(max i 0))}
-  in
-    declare_int_option gdopt
-
-let congruence_depth=ref 100
-
-let _=
-  let gdopt=
-    { optsync=true;
-      optname="Congruence Depth";
-      optkey=SecondaryTable("Congruence","Depth"); 
-      optread=(fun ()->Some !congruence_depth); 
-      optwrite=
-   (function 
-	None->congruence_depth:=0
-      |	Some i->congruence_depth:=(max i 0))}
-  in
-    declare_int_option gdopt
-
-let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
-
-let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
-		      
-type external_env=
-    Ids of global_reference list
-  | Bases of Auto.hint_db_name list
-  | Void
-
-let gen_ground_tac flag taco ext gl=
-  let backup= !qflag in
-    try
-      qflag:=flag;
-      let solver= 
-	match taco with 
-	    Some tac-> tac
-	  | None-> default_solver in
-      let startseq=
-	match ext with
-	    Void -> (fun gl -> empty_seq !ground_depth)
-	  | Ids l-> create_with_ref_list l !ground_depth
-	  | Bases l-> create_with_auto_hints l !ground_depth in
-      let result=ground_tac solver startseq gl in 
-	qflag:=backup;result
-    with e ->qflag:=backup;raise e
-      
-(* special for compatibility with Intuition 
-
-let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
-
-let defined_connectives=lazy
-  [[],EvalConstRef (destConst (constant "not"));
-   [],EvalConstRef (destConst (constant "iff"))]
-
-let normalize_evaluables=
-  onAllClauses
-    (function 
-	 None->unfold_in_concl (Lazy.force defined_connectives)
-       | Some id-> 
-	   unfold_in_hyp (Lazy.force defined_connectives) 
-	   (Tacexpr.InHypType id)) *)
-
-TACTIC EXTEND firstorder
-    [ "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 ]
-END
-
-TACTIC EXTEND gintuition
-  [ "gintuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (Option.map eval_tactic t) Void ]
-END
-
-
-let default_declarative_automation gls = 
-  tclORELSE
-    (tclORELSE (Auto.h_trivial [] None) 
-    (Cctac.congruence_tac !congruence_depth []))
-    (gen_ground_tac true 
-       (Some (tclTHEN
-		default_solver
-		(Cctac.congruence_tac !congruence_depth [])))
-       Void) gls
-
-
-
-let () = 
-  Decl_proof_instr.register_automation_tac default_declarative_automation
-
diff --git a/contrib/firstorder/ground.ml b/contrib/firstorder/ground.ml
deleted file mode 100644
index f4661869..00000000
--- a/contrib/firstorder/ground.ml
+++ /dev/null
@@ -1,152 +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        *)
-(************************************************************************)
-
-(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *)
-
-open Formula
-open Sequent
-open Rules
-open Instances
-open Term
-open Tacmach
-open Tactics
-open Tacticals
-open Libnames
-
-(*
-let old_search=ref !Auto.searchtable 
-
-(* I use this solution as a means to know whether hints have changed, 
-but this prevents the GC from collecting the previous table, 
-resulting in some limited space wasting*)
-
-let update_flags ()=
-  if not ( !Auto.searchtable == !old_search ) then
-    begin
-      old_search:=!Auto.searchtable;
-      let predref=ref Names.KNpred.empty in
-      let f p_a_t = 
-	match p_a_t.Auto.code with
-	    Auto.Unfold_nth (ConstRef kn)->
-	      predref:=Names.KNpred.add kn !predref
-	  | _ ->() in
-      let g _ l=List.iter f l in
-      let h _ hdb=Auto.Hint_db.iter g hdb in
-	Util.Stringmap.iter h !Auto.searchtable;
-	red_flags:=
-	Closure.RedFlags.red_add_transparent 
-	  Closure.betaiotazeta (Names.Idpred.full,!predref)
-    end
-*)
-
-let update_flags ()=
-  let predref=ref Names.Cpred.empty in
-  let f coe=
-    try
-      let kn=destConst (Classops.get_coercion_value coe) in
-	predref:=Names.Cpred.add kn !predref
-    with Invalid_argument "destConst"-> () in
-    List.iter f (Classops.coercions ());
-    red_flags:=
-    Closure.RedFlags.red_add_transparent 
-      Closure.betaiotazeta 
-      (Names.Idpred.full,Names.Cpred.complement !predref)
-
-let ground_tac solver startseq gl=
-  update_flags ();
-  let rec toptac skipped seq gl=
-    if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
-    then Pp.msgnl (Printer.pr_goal (sig_it gl));
-    tclORELSE (axiom_tac seq.gl seq)
-      begin
-	try      
-	  let (hd,seq1)=take_formula seq  
-	  and re_add s=re_add_formula_list skipped s in
-	  let continue=toptac [] 
-	  and backtrack gl=toptac (hd::skipped) seq1 gl in
-	    match hd.pat with
-		Right rpat->
-		  begin
-		    match rpat with
-			Rand->
-			  and_tac backtrack continue (re_add seq1)
-		      | Rforall->
-			  let backtrack1=
-			    if !qflag then 
-			      tclFAIL 0 (Pp.str "reversible in 1st order mode")
-			    else
-			      backtrack in
-			    forall_tac backtrack1 continue (re_add seq1)
-		      | Rarrow->
-			  arrow_tac backtrack continue (re_add seq1)
-		      | Ror->
-			  or_tac  backtrack continue (re_add seq1)
-		      | Rfalse->backtrack 
-		      | Rexists(i,dom,triv)->
-			  let (lfp,seq2)=collect_quantified seq in
-			  let backtrack2=toptac (lfp@skipped) seq2 in
-			    if  !qflag && seq.depth>0 then 
-			      quantified_tac lfp backtrack2 
-				continue (re_add seq)
-			    else
-			      backtrack2 (* need special backtracking *)
-		  end
-	      | Left lpat->
-		  begin
-		    match lpat with
-			Lfalse->
-			  left_false_tac hd.id
-		      | Land ind->
-			  left_and_tac ind backtrack 
-			  hd.id continue (re_add seq1)
-		      | Lor ind->
-			  left_or_tac ind backtrack 
-			  hd.id continue (re_add seq1)
-		      | Lforall (_,_,_)->
-			  let (lfp,seq2)=collect_quantified seq in
-			  let backtrack2=toptac (lfp@skipped) seq2 in
-			    if  !qflag && seq.depth>0 then 
-			      quantified_tac lfp backtrack2 
-				continue (re_add seq)
-			    else
-			      backtrack2 (* need special backtracking *)
-  		      | Lexists ind ->
-			  if !qflag then 
-			    left_exists_tac ind backtrack hd.id
-			      continue (re_add seq1)
-			  else backtrack
-		      | LA (typ,lap)->
-			  let la_tac=
-			    begin
-			      match lap with
-				  LLatom -> backtrack 
-				| LLand (ind,largs) | LLor(ind,largs) 
-				| LLfalse (ind,largs)->
-				    (ll_ind_tac ind largs backtrack 
-				       hd.id continue (re_add seq1)) 
-				| LLforall p ->	      
-				    if seq.depth>0 && !qflag then 
-				      (ll_forall_tac p backtrack 
-					 hd.id continue (re_add seq1))
-				    else backtrack
-				| LLexists (ind,l) ->
-				    if !qflag then
-				      ll_ind_tac ind l backtrack
-					hd.id continue (re_add seq1)
-				    else
-				      backtrack
-				| LLarrow (a,b,c) ->	      
-				    (ll_arrow_tac a b c backtrack
-				       hd.id continue (re_add seq1))
-			    end in			 
-			    ll_atom_tac typ la_tac hd.id continue (re_add seq1)
-		  end
-	    with Heap.EmptyHeap->solver
-      end gl in
-    wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
-      
diff --git a/contrib/firstorder/ground.mli b/contrib/firstorder/ground.mli
deleted file mode 100644
index 621f99db..00000000
--- a/contrib/firstorder/ground.mli
+++ /dev/null
@@ -1,13 +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        *)
-(************************************************************************)
-
-(* $Id: ground.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-val ground_tac:     Tacmach.tactic ->
-  (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
-
diff --git a/contrib/firstorder/instances.ml b/contrib/firstorder/instances.ml
deleted file mode 100644
index 1432207d..00000000
--- a/contrib/firstorder/instances.ml
+++ /dev/null
@@ -1,206 +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        *)
-(************************************************************************)
-
-(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*)
-
-open Formula
-open Sequent
-open Unify
-open Rules
-open Util
-open Term
-open Rawterm
-open Tacmach
-open Tactics
-open Tacticals
-open Termops
-open Reductionops
-open Declarations
-open Formula
-open Sequent
-open Names
-open Libnames
-
-let compare_instance inst1 inst2=
-	match inst1,inst2 with
-	    Phantom(d1),Phantom(d2)->
-	      (OrderedConstr.compare d1 d2)
-	  | Real((m1,c1),n1),Real((m2,c2),n2)->
-	      ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2
-	  | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
-	  | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
-
-let compare_gr id1 id2=
-  if id1==id2 then 0 else
-    if id1==dummy_id then 1 
-    else if id2==dummy_id then -1 
-    else Pervasives.compare id1 id2
-
-module OrderedInstance=
-struct
-  type t=instance * Libnames.global_reference
-  let compare (inst1,id1) (inst2,id2)=
-    (compare_instance =? compare_gr) inst2 inst1 id2 id1
-    (* we want a __decreasing__ total order *)
-end
-  
-module IS=Set.Make(OrderedInstance)
-
-let make_simple_atoms seq=
-  let ratoms=
-    match seq.glatom with
-	Some t->[t]
-      | None->[]
-  in {negative=seq.latoms;positive=ratoms}
-
-let do_sequent setref triv id seq i dom atoms=
-  let flag=ref true in
-  let phref=ref triv in
-  let do_atoms a1 a2 =
-    let do_pair t1 t2 = 
-      match unif_atoms i dom t1 t2 with
-	  None->()
-	| Some (Phantom _) ->phref:=true
-	| Some c ->flag:=false;setref:=IS.add (c,id) !setref in
-      List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive;
-      List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in
-    HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes;
-    do_atoms atoms (make_simple_atoms seq);
-    !flag && !phref 
- 
-let match_one_quantified_hyp setref seq lf=
-  match lf.pat with 
-      Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
-	if do_sequent setref triv lf.id seq i dom lf.atoms then
-	  setref:=IS.add ((Phantom dom),lf.id) !setref 
-    | _ ->anomaly "can't happen" 
-
-let give_instances lf seq=
-  let setref=ref IS.empty in
-    List.iter (match_one_quantified_hyp setref seq) lf;
-    IS.elements !setref
-	  	  
-(* collector for the engine *)
-
-let rec collect_quantified seq=
-  try
-    let hd,seq1=take_formula seq in
-      (match hd.pat with 
-	   Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> 
-	     let (q,seq2)=collect_quantified seq1 in
-	       ((hd::q),seq2)
-	 | _->[],seq)
-  with Heap.EmptyHeap -> [],seq
-
-(* open instances processor *)
-
-let dummy_constr=mkMeta (-1)
-
-let dummy_bvid=id_of_string "x"
-
-let mk_open_instance id gl m t=
-  let env=pf_env gl in
-  let evmap=Refiner.project gl in
-  let var_id=
-    if id==dummy_id then dummy_bvid else
-      let typ=pf_type_of gl (constr_of_global id) in
-	(* since we know we will get a product, 
-	   reduction is not too expensive *)
-      let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
-	match nam with 
-	    Name id -> id
-	  | Anonymous ->  dummy_bvid in
-  let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
-  let rec aux n avoid=
-    if n=0 then [] else
-      let nid=(fresh_id avoid var_id gl) in
-	(Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in
-  let nt=it_mkLambda_or_LetIn revt (aux m []) in
-  let rawt=Detyping.detype false [] [] nt in
-  let rec raux n t=
-    if n=0 then t else 
-      match t with
-	  RLambda(loc,name,k,_,t0)->
-	    let t1=raux (n-1) t0 in
-	      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)
-  with _ -> 
-    error "Untypable instance, maybe higher-order non-prenex quantification" in
-    Sign.decompose_lam_n_assum m ntt
-
-(* tactics   *)
-
-let left_instance_tac (inst,id) continue seq=
-  match inst with
-      Phantom dom->
-	if lookup (id,None) seq then 
-	  tclFAIL 0 (Pp.str "already done")
-	else
-	  tclTHENS (cut dom) 
-	    [tclTHENLIST
-	       [introf;
-		(fun gls->generalize 
-		   [mkApp(constr_of_global id,
-			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
-		introf;
-		tclSOLVE [wrap 1 false continue 
-			    (deepen (record (id,None) seq))]];
-	    tclTRY assumption]
-    | Real((m,t) as c,_)->
-	if lookup (id,Some c) seq then 
-	  tclFAIL 0 (Pp.str "already done")
-	else 
-	  let special_generalize=
-	    if m>0 then 
-	      fun gl-> 
-		let (rc,ot)= mk_open_instance id gl m t in
-		let gt= 
-		  it_mkLambda_or_LetIn 
-		    (mkApp(constr_of_global id,[|ot|])) rc in
-		  generalize [gt] gl
-	    else
-	      generalize [mkApp(constr_of_global id,[|t|])]
-	  in
-	    tclTHENLIST 
-	      [special_generalize;
-	       introf; 
-	       tclSOLVE 
-		 [wrap 1 false continue (deepen (record (id,Some c) seq))]]
-	      
-let right_instance_tac inst continue seq=
-  match inst with
-      Phantom dom ->
-	tclTHENS (cut dom) 
-	[tclTHENLIST
-	   [introf;
-	    (fun gls->
-	       split (Rawterm.ImplicitBindings 
-			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
-	    tclSOLVE [wrap 0 true continue (deepen seq)]];
-	 tclTRY assumption] 
-    | Real ((0,t),_) ->
-	(tclTHEN (split (Rawterm.ImplicitBindings [t]))
-	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
-    | Real ((m,t),_) ->
-	tclFAIL 0 (Pp.str "not implemented ... yet")
-
-let instance_tac inst=
-  if (snd inst)==dummy_id then 
-    right_instance_tac (fst inst)
-  else
-    left_instance_tac inst
-
-let quantified_tac lf backtrack continue seq gl=
-  let insts=give_instances lf seq in
-    tclORELSE
-      (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts))
-      backtrack gl
-
- 
diff --git a/contrib/firstorder/instances.mli b/contrib/firstorder/instances.mli
deleted file mode 100644
index 7667c89f..00000000
--- a/contrib/firstorder/instances.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        *)
-(************************************************************************)
-
-(*i $Id: instances.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-open Term
-open Tacmach
-open Names
-open Libnames
-open Rules
-  
-val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
-
-val give_instances : Formula.t list -> Sequent.t -> 
-  (Unify.instance * global_reference) list
-
-val quantified_tac : Formula.t list -> seqtac with_backtracking
-
-
-
-
diff --git a/contrib/firstorder/rules.ml b/contrib/firstorder/rules.ml
deleted file mode 100644
index cc7b19e0..00000000
--- a/contrib/firstorder/rules.ml
+++ /dev/null
@@ -1,216 +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        *)
-(************************************************************************)
-
-(* $Id: rules.ml 11512 2008-10-27 12:28:36Z herbelin $ *)
-
-open Util
-open Names
-open Term
-open Tacmach
-open Tactics
-open Tacticals
-open Termops
-open Declarations
-open Formula
-open Sequent
-open Libnames
-
-type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
-
-type lseqtac= global_reference -> seqtac
-
-type 'a with_backtracking = tactic -> 'a
-
-let wrap n b continue seq gls=
-  check_for_interrupt ();
-  let nc=pf_hyps gls in
-  let env=pf_env gls in
-  let rec aux i nc ctx=
-    if i<=0 then seq else 
-      match nc with
-	  []->anomaly "Not the expected number of hyps"
-	| ((id,_,typ) as nd)::q->  
-	    if occur_var env id (pf_concl gls) || 
-	      List.exists (occur_var_in_decl env id) ctx then
-		(aux (i-1) q (nd::ctx))
-	    else
-	      add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in
-  let seq1=aux n nc [] in
-  let seq2=if b then 
-    add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
-    continue seq2 gls
-
-let id_of_global=function
-    VarRef id->id
-  | _->assert false
-
-let clear_global=function
-    VarRef id->clear [id]
-  | _->tclIDTAC
-      
-
-(* connection rules *)
-
-let axiom_tac t seq=
-  try exact_no_check (constr_of_global (find_left t seq)) 
-  with Not_found->tclFAIL 0 (Pp.str "No axiom link")
-
-let ll_atom_tac a backtrack id continue seq= 
-  tclIFTHENELSE
-    (try 
-      tclTHENLIST
-	[generalize [mkApp(constr_of_global id,
-			   [|constr_of_global (find_left a seq)|])];
-	 clear_global id;
-	 intro]
-    with Not_found->tclFAIL 0 (Pp.str "No link"))
-    (wrap 1 false continue seq) backtrack 
-
-(* right connectives rules *)
-
-let and_tac backtrack continue seq=
-  tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
-
-let or_tac backtrack continue seq=
-  tclORELSE 
-    (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
-    backtrack
-
-let arrow_tac backtrack continue seq=
-  tclIFTHENELSE intro (wrap 1 true continue seq)
-    (tclORELSE
-       (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq)))
-       backtrack)
-(* left connectives rules *)
-
-let left_and_tac ind backtrack id continue seq gls=
- let n=(construct_nhyps ind gls).(0) in  
-   tclIFTHENELSE
-     (tclTHENLIST 
-      [simplest_elim (constr_of_global id);
-       clear_global id; 
-       tclDO n intro])
-     (wrap n false continue seq)
-     backtrack gls
-
-let left_or_tac ind backtrack id continue seq gls=
-  let v=construct_nhyps ind gls in  
-  let f n=
-    tclTHENLIST
-      [clear_global id;
-       tclDO n intro;
-       wrap n false continue seq] in
-    tclIFTHENSVELSE
-      (simplest_elim (constr_of_global id))
-      (Array.map f v)
-      backtrack gls
-
-let left_false_tac id=
-  simplest_elim (constr_of_global id)
-
-(* left arrow connective rules *)
-
-(* We use this function for false, and, or, exists *)
-
-let ll_ind_tac ind largs backtrack id continue seq gl= 
-     let rcs=ind_hyps 0 ind largs gl in
-     let vargs=Array.of_list largs in
-	     (* construire le terme  H->B, le generaliser etc *)   
-     let myterm i=
-       let rc=rcs.(i) in
-       let p=List.length rc in
-       let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in
-       let vars=Array.init p (fun j->mkRel (p-j)) in
-       let capply=mkApp ((lift p cstr),vars) in
-       let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
-	 Sign.it_mkLambda_or_LetIn head rc in
-       let lp=Array.length rcs in
-       let newhyps=list_tabulate myterm lp in
-	 tclIFTHENELSE
-	   (tclTHENLIST 
-	      [generalize newhyps;
-	       clear_global id;
-	       tclDO lp intro])
-	   (wrap lp false continue seq) backtrack gl
-
-let ll_arrow_tac a b c backtrack id continue seq=
-  let cc=mkProd(Anonymous,a,(lift 1 b)) in
-  let d=mkLambda (Anonymous,b,
-		  mkApp ((constr_of_global id),
-			 [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
-    tclORELSE
-      (tclTHENS (cut c)
-	 [tclTHENLIST
-	    [introf;
-	     clear_global id;
-	     wrap 1 false continue seq];
-	  tclTHENS (cut cc) 
-            [exact_no_check (constr_of_global id); 
-	     tclTHENLIST 
-	       [generalize [d];
-		clear_global id;
-		introf;
-		introf;
-		tclCOMPLETE (wrap 2 true continue seq)]]])
-      backtrack
-
-(* quantifier rules (easy side) *)
-
-let forall_tac backtrack continue seq=
-  tclORELSE
-    (tclIFTHENELSE intro (wrap 0 true continue seq)
-       (tclORELSE
-	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
-	  backtrack))
-    (if !qflag then 
-       tclFAIL 0 (Pp.str "reversible in 1st order mode")
-     else
-       backtrack)
-
-let left_exists_tac ind backtrack id continue seq gls=
-  let n=(construct_nhyps ind gls).(0) in  
-    tclIFTHENELSE
-      (simplest_elim (constr_of_global id))
-      (tclTHENLIST [clear_global id;
-                    tclDO n intro;
-                    (wrap (n-1) false continue seq)]) 
-      backtrack 
-      gls
-	
-let ll_forall_tac prod backtrack id continue seq=
-  tclORELSE
-    (tclTHENS (cut prod)
-       [tclTHENLIST
-	  [intro;
-	   (fun gls->
-	      let id0=pf_nth_hyp_id gls 1 in
-	      let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
-		tclTHEN (generalize [term]) (clear [id0]) gls);  
-	   clear_global id;
-	   intro;
-	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
-	tclCOMPLETE (wrap 0 true continue (deepen seq))])
-    backtrack
-
-(* rules for instantiation with unification moved to instances.ml *)
-
-(* special for compatibility with old Intuition *)
-
-let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
-
-let defined_connectives=lazy
-  [all_occurrences,EvalConstRef (destConst (constant "not"));
-   all_occurrences,EvalConstRef (destConst (constant "iff"))]
-
-let normalize_evaluables=
-  onAllClauses
-    (function 
-	 None->unfold_in_concl (Lazy.force defined_connectives)
-       | Some ((_,id),_)-> 
-	   unfold_in_hyp (Lazy.force defined_connectives) 
-	   ((Rawterm.all_occurrences_expr,id),InHypTypeOnly))
diff --git a/contrib/firstorder/rules.mli b/contrib/firstorder/rules.mli
deleted file mode 100644
index 3798d8d4..00000000
--- a/contrib/firstorder/rules.mli
+++ /dev/null
@@ -1,54 +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        *)
-(************************************************************************)
-
-(* $Id: rules.mli 6141 2004-09-27 14:55:34Z corbinea $ *)
-
-open Term
-open Tacmach
-open Names
-open Libnames
-
-type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
-
-type lseqtac= global_reference -> seqtac
-
-type 'a with_backtracking = tactic -> 'a
-
-val wrap : int -> bool -> seqtac
-
-val id_of_global: global_reference -> identifier
-
-val clear_global: global_reference -> tactic
-
-val axiom_tac : constr -> Sequent.t -> tactic
-
-val ll_atom_tac : constr -> lseqtac with_backtracking
-
-val and_tac : seqtac with_backtracking
-
-val or_tac : seqtac with_backtracking
-
-val arrow_tac : seqtac with_backtracking
-
-val left_and_tac : inductive -> lseqtac with_backtracking
-
-val left_or_tac : inductive -> lseqtac with_backtracking
-
-val left_false_tac : global_reference -> tactic
-
-val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking
-
-val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
-
-val forall_tac : seqtac with_backtracking
-
-val left_exists_tac : inductive -> lseqtac with_backtracking
-
-val ll_forall_tac : types -> lseqtac with_backtracking 
-
-val normalize_evaluables : tactic
diff --git a/contrib/firstorder/sequent.ml b/contrib/firstorder/sequent.ml
deleted file mode 100644
index e931f8fd..00000000
--- a/contrib/firstorder/sequent.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        *)
-(************************************************************************)
-
-(* $Id: sequent.ml 11282 2008-07-28 11:51:53Z msozeau $ *)
-
-open Term
-open Util
-open Formula
-open Unify
-open Tacmach
-open Names
-open Libnames
-open Pp
-
-let newcnt ()=
-  let cnt=ref (-1) in
-    fun b->if b then incr cnt;!cnt
-
-let priority = (* pure heuristics, <=0 for non reversible *)
-  function
-      Right rf->
-	begin
-	  match rf with
-	      Rarrow               -> 100
-	    | Rand                 ->  40 
-	    | Ror                  -> -15
-	    | Rfalse               -> -50
-	    | Rforall              -> 100
-	    | Rexists (_,_,_)      -> -29
-	end
-    | Left lf ->
-	match lf with
-	    Lfalse                 -> 999
-	  | Land _                 ->  90
-	  | Lor _                  ->  40
-	  | Lforall (_,_,_)        -> -30 
-	  | Lexists _              ->  60
-	  | LA(_,lap) ->
-	      match lap with
-		  LLatom           ->   0
-		| LLfalse (_,_)    -> 100
-		| LLand (_,_)      ->  80
-		| LLor (_,_)       ->  70
-		| LLforall _       -> -20
-		| LLexists (_,_)   ->  50
-		| LLarrow  (_,_,_) -> -10 
-
-let left_reversible lpat=(priority lpat)>0
-
-module OrderedFormula=
-struct
-  type t=Formula.t
-  let compare e1 e2=
-	(priority e1.pat) - (priority e2.pat)
-end
-
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's,
-   application associativity, binders name and Cases annotations are
-   not taken into account *)
-
-let rec compare_list f l1 l2=
-  match l1,l2 with
-      [],[]-> 0
-    | [],_ -> -1
-    | _,[] -> 1
-    | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
-
-let compare_array f v1 v2=  
-  let l=Array.length v1 in
-  let c=l - Array.length v2 in
-    if c=0 then
-      let rec comp_aux i=
-	if i<0 then 0 
-	else
-	  let ci=f v1.(i) v2.(i) in
-	    if ci=0 then 
-	      comp_aux (i-1)
-	    else ci
-      in comp_aux (l-1)
-    else c
-
-let compare_constr_int f t1 t2 =
-  match kind_of_term t1, kind_of_term t2 with
-    | Rel n1, Rel n2 -> n1 - n2
-    | Meta m1, Meta m2 -> m1 - m2
-    | Var id1, Var id2 -> Pervasives.compare id1 id2
-    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
-    | Cast (c1,_,_), _ -> f c1 t2
-    | _, Cast (c2,_,_) -> f t1 c2
-    | Prod (_,t1,c1), Prod (_,t2,c2) 
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	(f =? f) t1 t2 c1 c2 
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
-	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
-    | App (_,_), App (_,_) ->
-	let c1,l1=decompose_app t1 
-	and c2,l2=decompose_app t2 in
-	  (f =? (compare_list f)) c1 c2 l1 l2
-    | Evar (e1,l1), Evar (e2,l2) -> 
-	((-) =? (compare_array f)) e1 e2 l1 l2
-    | Const c1, Const c2 -> Pervasives.compare c1 c2
-    | Ind c1, Ind c2 -> Pervasives.compare c1 c2
-    | Construct c1, Construct c2 -> Pervasives.compare c1 c2
-    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | _ -> Pervasives.compare t1 t2
-
-let rec compare_constr m n=
-  compare_constr_int compare_constr m n
-    
-module OrderedConstr=
-struct
-  type t=constr
-  let compare=compare_constr
-end
-
-type h_item = global_reference * (int*constr) option
-
-module Hitem=
-struct 
-  type t = h_item
-  let compare (id1,co1) (id2,co2)=
-    (Pervasives.compare 
-     =? (fun oc1 oc2 ->
-	   match oc1,oc2 with 
-	       Some (m1,c1),Some (m2,c2) -> 
-		 ((-) =? OrderedConstr.compare) m1 m2 c1 c2
-	     | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
-end
-
-module CM=Map.Make(OrderedConstr)
-
-module History=Set.Make(Hitem)
-
-let cm_add typ nam cm=
-  try 
-    let l=CM.find typ cm in CM.add typ (nam::l) cm
-  with
-      Not_found->CM.add typ [nam] cm
-	
-let cm_remove typ nam cm=
-  try
-    let l=CM.find typ cm in 
-    let l0=List.filter (fun id->id<>nam) l in
-      match l0 with 
-	  []->CM.remove typ cm
-	| _ ->CM.add typ l0 cm
-      with Not_found ->cm
-
-module HP=Heap.Functional(OrderedFormula)
-
-type t=
-    {redexes:HP.t;
-     context:(global_reference list) CM.t;
-     latoms:constr list;
-     gl:types;
-     glatom:constr option;
-     cnt:counter;
-     history:History.t;
-     depth:int}
-
-let deepen seq={seq with depth=seq.depth-1}
- 
-let record item seq={seq with history=History.add item seq.history}
-
-let lookup item seq=
-  History.mem item seq.history ||
-  match item with
-      (_,None)->false
-    | (id,Some ((m,t) as c))->
-	let p (id2,o)=
-	  match o with
-	      None -> false
-	    | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in
-	  History.exists p seq.history
-
-let rec add_formula side nam t seq gl=
-  match build_formula side nam t gl seq.cnt with
-      Left f->
-	begin
-	  match side with
-	      Concl ->
-		{seq with 
-		   redexes=HP.add f seq.redexes;
-		   gl=f.constr;
-		   glatom=None}
-	    | _ ->
-		{seq with 
-		   redexes=HP.add f seq.redexes;
-		   context=cm_add f.constr nam seq.context}
-	end
-    | Right t->
-	match side with
-	    Concl ->
-	      {seq with gl=t;glatom=Some t}
-	  | _ ->
-	      {seq with 
-		 context=cm_add t nam seq.context;
-		 latoms=t::seq.latoms}
-	      
-let re_add_formula_list lf seq=
-  let do_one f cm=
-    if f.id == dummy_id then cm
-    else cm_add f.constr f.id cm in
-  {seq with 
-     redexes=List.fold_right HP.add lf seq.redexes;
-     context=List.fold_right do_one lf seq.context}
-
-let find_left t seq=List.hd (CM.find t seq.context)
-
-(*let rev_left seq=
-  try
-    let lpat=(HP.maximum seq.redexes).pat in
-      left_reversible lpat
-  with Heap.EmptyHeap -> false
-*)
-let no_formula seq=
-  seq.redexes=HP.empty
-
-let rec take_formula seq=
-  let hd=HP.maximum seq.redexes
-  and hp=HP.remove seq.redexes in
-    if hd.id == dummy_id then
-      let nseq={seq with redexes=hp} in
-	if seq.gl==hd.constr then 
-	  hd,nseq
-	else
-	  take_formula nseq (* discarding deprecated goal *)
-    else
-      hd,{seq with 
-	    redexes=hp;
-	    context=cm_remove hd.constr hd.id seq.context}
-	
-let empty_seq depth=
-  {redexes=HP.empty;   
-   context=CM.empty;
-   latoms=[];
-   gl=(mkMeta 1);
-   glatom=None;
-   cnt=newcnt ();
-   history=History.empty;
-   depth=depth}
-
-let create_with_ref_list l depth gl=
-  let f gr seq=
-    let c=constr_of_global gr in    
-    let typ=(pf_type_of gl c) in
-      add_formula Hyp gr typ seq gl in
-    List.fold_right f l (empty_seq depth)
-
-open Auto
-
-let create_with_auto_hints l depth gl=
-  let seqref=ref (empty_seq depth) in
-  let f p_a_t =
-    match p_a_t.code with
-	Res_pf (c,_) | Give_exact c
-      | Res_pf_THEN_trivial_fail (c,_) ->
-	  (try 
-	     let gr=global_of_constr c in 
-	     let typ=(pf_type_of gl c) in
-	       seqref:=add_formula Hint gr typ !seqref gl
-	   with Not_found->())
-      | _-> () in
-  let g _ l=List.iter f l in
-  let h dbname=
-    let hdb=
-      try
-	searchtable_map dbname
-      with Not_found-> 
-	error ("Firstorder: "^dbname^" : No such Hint database") in
-      Hint_db.iter g hdb in
-    List.iter h l;
-    !seqref
-
-let print_cmap map=
-  let print_entry c l s=
-    let xc=Constrextern.extern_constr false (Global.env ()) c in
-      str "| " ++ 
-      Util.prlist Printer.pr_global l ++ 
-      str " : " ++
-      Ppconstr.pr_constr_expr xc ++ 
-      cut () ++ 
-      s in
-    msgnl (v 0 
-	     (str "-----" ++ 
-	      cut () ++
-	      CM.fold print_entry map (mt ()) ++
-	      str "-----"))
-
-	
diff --git a/contrib/firstorder/sequent.mli b/contrib/firstorder/sequent.mli
deleted file mode 100644
index 47fb74c7..00000000
--- a/contrib/firstorder/sequent.mli
+++ /dev/null
@@ -1,66 +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        *)
-(************************************************************************)
-
-(* $Id: sequent.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Util
-open Formula
-open Tacmach
-open Names
-open Libnames
-
-module OrderedConstr: Set.OrderedType with type t=constr
-
-module CM: Map.S with type key=constr
-
-type h_item = global_reference * (int*constr) option
-
-module History: Set.S with type elt = h_item
-
-val cm_add : constr -> global_reference -> global_reference list CM.t ->
-  global_reference list CM.t
-
-val cm_remove : constr -> global_reference -> global_reference list CM.t ->
-  global_reference list CM.t
-
-module HP: Heap.S with type elt=Formula.t
-
-type t = {redexes:HP.t;
-	  context: global_reference list CM.t;
-	  latoms:constr list;
-	  gl:types;
-	  glatom:constr option;
-	  cnt:counter;
-	  history:History.t;
-	  depth:int}
-
-val deepen: t -> t
-
-val record: h_item -> t -> t
-
-val lookup: h_item -> t -> bool
-
-val add_formula : side -> global_reference -> constr -> t -> 
-  Proof_type.goal sigma -> t
-
-val re_add_formula_list : Formula.t list -> t -> t
-
-val find_left : constr -> t -> global_reference
-
-val take_formula : t -> Formula.t * t
-
-val empty_seq : int -> t
-
-val create_with_ref_list : global_reference list ->
-  int -> Proof_type.goal sigma -> t
-
-val create_with_auto_hints : Auto.hint_db_name list -> 
-  int -> Proof_type.goal sigma -> t
-
-val print_cmap: global_reference list CM.t -> unit 
diff --git a/contrib/firstorder/unify.ml b/contrib/firstorder/unify.ml
deleted file mode 100644
index 27c06f54..00000000
--- a/contrib/firstorder/unify.ml
+++ /dev/null
@@ -1,143 +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        *)
-(************************************************************************)
-
-(*i $Id: unify.ml 11897 2009-02-09 19:28:02Z barras $ i*)
-
-open Util
-open Formula 
-open Tacmach
-open Term
-open Names
-open Termops
-open Reductionops
-
-exception UFAIL of constr*constr
-
-(* 
-   RIGID-only Martelli-Montanari style unification for CLOSED terms 
-   I repeat : t1 and t2 must NOT have ANY free deBruijn                        
-   sigma is kept normal with respect to itself but is lazily applied 
-   to the equation set. Raises UFAIL with a pair of  terms 
-*)
-
-let unif t1 t2= 
-  let bige=Queue.create () 
-  and sigma=ref [] in
-  let bind i t=
-    sigma:=(i,t)::
-      (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in
-  let rec head_reduce t= 
-    (* forbids non-sigma-normal meta in head position*)
-    match kind_of_term t with
-	Meta i->
-	  (try 
-	     head_reduce (List.assoc i !sigma) 
-	   with Not_found->t)
-      | _->t in 
-    Queue.add (t1,t2) bige;
-    try while true do
-      let t1,t2=Queue.take bige in
-      let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) 
-      and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in
-	match (kind_of_term nt1),(kind_of_term nt2) with
-	    Meta i,Meta j-> 
-	      if i<>j then 
-		if i<j then bind j nt1
-		else bind i nt2
-	  | Meta i,_ ->
-	      let t=subst_meta !sigma nt2 in
-		if Intset.is_empty (free_rels t) && 
-		  not (occur_term (mkMeta i) t) then
-		    bind i t else raise (UFAIL(nt1,nt2))
-	  | _,Meta i -> 
-	      let t=subst_meta !sigma nt1 in
-		if Intset.is_empty (free_rels t) && 
-		  not (occur_term (mkMeta i) t) then
-		    bind i t else raise (UFAIL(nt1,nt2))
-	  | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
- 	  | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige 
-	  | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))->
-	      Queue.add (a,c) bige;Queue.add (pop b,pop d) bige
-	  | Case (_,pa,ca,va),Case (_,pb,cb,vb)->
-	      Queue.add (pa,pb) bige;
-	      Queue.add (ca,cb) bige;
-	      let l=Array.length va in
-		if l<>(Array.length vb) then 
-		  raise (UFAIL (nt1,nt2))
-		else 
-		  for i=0 to l-1 do
-		    Queue.add (va.(i),vb.(i)) bige
-		  done	  
-	  | App(ha,va),App(hb,vb)->
-	      Queue.add (ha,hb) bige;
-	      let l=Array.length va in
-		if l<>(Array.length vb) then 
-		  raise (UFAIL (nt1,nt2))
-		else 
-		  for i=0 to l-1 do
-		    Queue.add (va.(i),vb.(i)) bige
-		  done
-	  | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
-    done;
-      assert false 
-	(* this place is unreachable but needed for the sake of typing *)
-    with Queue.Empty-> !sigma
-
-let value i t=
-  let add x y=
-    if x<0 then y else if y<0 then x else x+y in
-  let tref=mkMeta i in
-  let rec vaux term=
-    if term=tref then 0 else 
-      let f v t=add v (vaux t) in
-      let vr=fold_constr f (-1) term in
-	if vr<0 then -1 else vr+1 in
-    vaux t
-	  
-type instance=
-    Real of (int*constr)*int 
-  | Phantom of constr 
-
-let mk_rel_inst t=
-  let new_rel=ref 1 in
-  let rel_env=ref [] in
-  let rec renum_rec d t=
-    match kind_of_term t with 
-	Meta n->
-	  (try 
-	     mkRel (d+(List.assoc n !rel_env))
-	   with Not_found->
-	     let m= !new_rel in
-	       incr new_rel;
-	       rel_env:=(n,m) :: !rel_env;
-	       mkRel (m+d))
-      | _ -> map_constr_with_binders succ renum_rec d t
-  in 
-  let nt=renum_rec 0 t in (!new_rel - 1,nt)
-
-let unif_atoms i dom t1 t2=
-  try 
-    let t=List.assoc i (unif t1 t2) in 
-      if isMeta t then Some (Phantom dom)
-      else Some (Real(mk_rel_inst t,value i t1))
-  with
-      UFAIL(_,_) ->None
-    | Not_found ->Some (Phantom dom)
-	   	  
-let renum_metas_from k n t= (* requires n = max (free_rels t) *)
-  let l=list_tabulate (fun i->mkMeta (k+i)) n in
-    substl l t
-
-let more_general (m1,t1) (m2,t2)=
-  let mt1=renum_metas_from 0 m1 t1
-  and mt2=renum_metas_from m1 m2 t2 in
-    try 
-      let sigma=unif mt1 mt2 in
-      let p (n,t)= n<m1 || isMeta t in
-	List.for_all p sigma
-    with UFAIL(_,_)->false
diff --git a/contrib/firstorder/unify.mli b/contrib/firstorder/unify.mli
deleted file mode 100644
index 9fbe3dda..00000000
--- a/contrib/firstorder/unify.mli
+++ /dev/null
@@ -1,23 +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        *)
-(************************************************************************)
-
-(* $Id: unify.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-
-exception UFAIL of constr*constr
-
-val unif : constr -> constr -> (int*constr) list
-
-type instance=
-    Real of (int*constr)*int (* nb trous*terme*valeur heuristique *)
-  | Phantom of constr        (* domaine de quantification *)
-
-val unif_atoms : metavariable -> constr -> constr -> constr -> instance option
-
-val more_general : (int*constr) -> (int*constr) -> bool
diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v
deleted file mode 100644
index 024aa1c3..00000000
--- a/contrib/fourier/Fourier.v
+++ /dev/null
@@ -1,19 +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        *)
-(************************************************************************)
-
-(* $Id: Fourier.v 11672 2008-12-12 14:45:09Z herbelin $ *)
-
-(* "Fourier's method to solve linear inequations/equations systems.".*)
-
-Require Export Fourier_util.
-Require Export LegacyField.
-Require Export DiscrR.
-
-Ltac fourier := abstract (fourierz; field; discrR).
-
-Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v
deleted file mode 100644
index 6a9ab051..00000000
--- a/contrib/fourier/Fourier_util.v
+++ /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        *)
-(************************************************************************)
-
-(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *)
-
-Require Export Rbase.
-Comments "Lemmas used by the tactic Fourier".
-
-Open Scope R_scope.
- 
-Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
-intros; apply Rmult_lt_compat_l; assumption.
-Qed.
- 
-Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
-red in |- *.
-intros.
-case H; auto with real.
-Qed.
- 
-Lemma Rfourier_lt_lt :
- forall x1 y1 x2 y2 a:R,
-   x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
-intros x1 y1 x2 y2 a H H0 H1; try assumption.
-apply Rplus_lt_compat.
-try exact H.
-apply Rfourier_lt.
-try exact H0.
-try exact H1.
-Qed.
- 
-Lemma Rfourier_lt_le :
- forall x1 y1 x2 y2 a:R,
-   x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
-intros x1 y1 x2 y2 a H H0 H1; try assumption.
-case H0; intros.
-apply Rplus_lt_compat.
-try exact H.
-apply Rfourier_lt; auto with real.
-rewrite H2.
-rewrite (Rplus_comm y1 (a * y2)).
-rewrite (Rplus_comm x1 (a * y2)).
-apply Rplus_lt_compat_l.
-try exact H.
-Qed.
- 
-Lemma Rfourier_le_lt :
- forall x1 y1 x2 y2 a:R,
-   x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
-intros x1 y1 x2 y2 a H H0 H1; try assumption.
-case H; intros.
-apply Rfourier_lt_le; auto with real.
-rewrite H2.
-apply Rplus_lt_compat_l.
-apply Rfourier_lt; auto with real.
-Qed.
- 
-Lemma Rfourier_le_le :
- forall x1 y1 x2 y2 a:R,
-   x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
-intros x1 y1 x2 y2 a H H0 H1; try assumption.
-case H0; intros.
-red in |- *.
-left; try assumption.
-apply Rfourier_le_lt; auto with real.
-rewrite H2.
-case H; intros.
-red in |- *.
-left; try assumption.
-rewrite (Rplus_comm x1 (a * y2)).
-rewrite (Rplus_comm y1 (a * y2)).
-apply Rplus_lt_compat_l.
-try exact H3.
-rewrite H3.
-red in |- *.
-right; try assumption.
-auto with real.
-Qed.
- 
-Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
-intros x H; try assumption.
-rewrite Rplus_comm.
-apply Rle_lt_0_plus_1.
-red in |- *; auto with real.
-Qed.
- 
-Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
-intros x y H H0; try assumption.
-replace 0 with (x * 0).
-apply Rmult_lt_compat_l; auto with real.
-ring.
-Qed.
- 
-Lemma Rlt_zero_1 : 0 < 1.
-exact Rlt_0_1.
-Qed.
- 
-Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
-intros x H; try assumption.
-case H; intros.
-red in |- *.
-left; try assumption.
-apply Rlt_zero_pos_plus1; auto with real.
-rewrite <- H0.
-replace (1 + 0) with 1.
-red in |- *; left.
-exact Rlt_zero_1.
-ring.
-Qed.
- 
-Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
-intros x y H H0; try assumption.
-case H; intros.
-red in |- *; left.
-apply Rlt_mult_inv_pos; auto with real.
-rewrite <- H1.
-red in |- *; right; ring.
-Qed.
- 
-Lemma Rle_zero_1 : 0 <= 1.
-red in |- *; left.
-exact Rlt_zero_1.
-Qed.
- 
-Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
-intros n d H; red in |- *; intros H0; try exact H0.
-generalize (Rgt_not_le 0 (n * / d)).
-intros H1; elim H1; try assumption.
-replace (n * / d) with (- - (n * / d)).
-replace 0 with (- -0).
-replace (- (n * / d)) with (- n * / d).
-replace (-0) with 0.
-red in |- *.
-apply Ropp_gt_lt_contravar.
-red in |- *.
-exact H0.
-ring.
-ring.
-ring.
-ring.
-Qed.
- 
-Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
-intros x; try assumption.
-replace (0 * x) with 0.
-apply Rlt_irrefl.
-ring.
-Qed.
- 
-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).
-replace (- n * / d) with (- (n * / d)).
-apply Ropp_lt_gt_contravar.
-try exact H.
-ring.
-ring.
-Qed.
- 
-Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
-unfold not in |- *; intros.
-apply H.
-apply Rplus_lt_reg_r with x.
-replace (x + 0) with x.
-replace (x + (y - x)) with y.
-try exact H0.
-ring.
-ring.
-Qed.
- 
-Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
-unfold not in |- *; intros.
-apply H.
-case H0; intros.
-left.
-apply Rplus_lt_reg_r with x.
-replace (x + 0) with x.
-replace (x + (y - x)) with y.
-try exact H1.
-ring.
-ring.
-right.
-rewrite H1; ring.
-Qed.
- 
-Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
-unfold Rgt in |- *; intros; assumption.
-Qed.
- 
-Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
-intros x y; exact (Rge_le y x).
-Qed.
- 
-Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
-exact Req_le.
-Qed.
- 
-Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
-exact Req_le_sym.
-Qed.
- 
-Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
-exact Rnot_ge_lt.
-Qed.
- 
-Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
-exact Rnot_gt_le.
-Qed.
- 
-Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
-exact Rnot_le_lt.
-Qed.
- 
-Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
-exact Rnot_lt_ge.
-Qed.
diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml
deleted file mode 100644
index 195d8605..00000000
--- a/contrib/fourier/fourier.ml
+++ /dev/null
@@ -1,205 +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        *)
-(************************************************************************)
-
-(* $Id: fourier.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
-
-(* Méthode d'élimination de Fourier *)
-(* Référence:
-Auteur(s) : Fourier, Jean-Baptiste-Joseph
- 
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
- 
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
- 
-Pages: 326-327
-
-http://gallica.bnf.fr/
-*)
-
-(* Un peu de calcul sur les rationnels... 
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
-*)
-type rational = {num:int;
-                 den:int}
-;;
-let print_rational x =
-        print_int x.num;
-        print_string "/";
-        print_int x.den
-;;
-
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
-
-
-let r0 = {num=0;den=1};;
-let r1 = {num=1;den=1};;
-
-let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
-              if x.num=0 then r0
-              else (let d=pgcd x.num x.den in
-		    let d= (if d<0 then -d else d) in
-                    {num=(x.num)/d;den=(x.den)/d});;
- 
-let rop x = rnorm {num=(-x.num);den=x.den};;
-
-let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
-
-let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
-
-let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
-
-let rinv x = rnorm {num=x.den;den=x.num};;
-
-let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
-
-let rinf x y = x.num*y.den < y.num*x.den;;
-let rinfeq x y = x.num*y.den <= y.num*x.den;;
-
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
-c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
-*)
-
-type ineq = {coef:rational list;
-             hist:rational list;
-             strict:bool};;
-
-let pop x l = l:=x::(!l);;
-
-(* sépare la liste d'inéquations s selon que leur premier coefficient est 
-négatif, nul ou positif. *)
-let partitionne s =
-   let lpos=ref [] in
-   let lneg=ref [] in
-   let lnul=ref [] in
-   List.iter (fun ie -> match ie.coef with
-                        [] ->  raise (Failure "empty ineq")
-                       |(c::r) -> if rinf c r0
-           	                  then pop ie lneg
-                                  else if rinf r0 c then pop ie lpos
-                                              else pop ie lnul)
-             s;
-   [!lneg;!lnul;!lpos]
-;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
-=
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
- ...
- {équation n, [0;0;...;1], sn}]
-*)
-let add_hist le =
-   let n = List.length le in
-   let i=ref 0 in
-   List.map (fun (ie,s) -> 
-              let h =ref [] in
-              for k=1 to (n-(!i)-1) do pop r0 h; done;
-              pop r1 h;
-              for k=1 to !i do pop r0 h; done;
-              i:=!i+1;
-              {coef=ie;hist=(!h);strict=s})
-             le
-;;
-(* additionne deux inéquations *)      
-let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
-                      hist=List.map2 rplus ie1.hist ie2.hist;
-		      strict=ie1.strict || ie2.strict}
-;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
-let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
-                     hist=List.map (fun x -> rmult a x) ie.hist;
-		     strict= ie.strict}
-;;
-(* on enlève le premier coefficient *)
-let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
-;;
-(* le premier coefficient: "tête" de l'inéquation *)
-let hd_coef ie = List.hd ie.coef
-;;
-
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
-*)
-let deduce_add lneg lpos =
-   let res=ref [] in
-   List.iter (fun i1 ->
-		 List.iter (fun i2 ->
-				let a = rop (hd_coef i1) in
-				let b = hd_coef i2 in
-				pop (ie_tl (ie_add (ie_emult b i1)
-						   (ie_emult a i2))) res)
-		           lpos)
-             lneg;
-   !res
-;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
-*)
-let deduce1 s =
-    match (partitionne s) with 
-      [lneg;lnul;lpos] ->
-    let lnew = deduce_add lneg lpos in
-    (List.map ie_tl lnul)@lnew
-     |_->assert false
-;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
-*)
-let deduce lie =
-   let n = List.length (fst (List.hd lie)) in
-   let lie=ref (add_hist lie) in
-   for i=1 to n-1 do
-      lie:= deduce1 !lie;
-   done;
-   !lie
-;;
-
-(* donne [] si le système a des solutions,
-sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
-qui donne 0 < c si s=true
-       ou 0 <= c sinon
-cette inéquation étant absurde.
-*)
-let unsolvable lie =
-   let lr = deduce lie in
-   let res = ref [] in
-   (try (List.iter (fun e ->
-         match e with
-           {coef=[c];hist=lc;strict=s} ->
-		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s) 
-                  then (res := [c,s,lc];
-			raise (Failure "contradiction found"))
-          |_->assert false)
-			     lr)
-   with _ -> ());
-   !res
-;;
-
-(* Exemples:
-
-let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
-deduce test1;;
-unsolvable test1;;
-
-let test2=[
-[r1;r1;r0;r0;r0],false;
-[r0;r1;r1;r0;r0],false;
-[r0;r0;r1;r1;r0],false;
-[r0;r0;r0;r1;r1],false;
-[r1;r0;r0;r0;r1],false;
-[rop r1;rop r1;r0;r0;r0],false;
-[r0;rop r1;rop r1;r0;r0],false;
-[r0;r0;rop r1;rop r1;r0],false;
-[r0;r0;r0;rop r1;rop r1],false;
-[rop r1;r0;r0;r0;rop r1],false
-];;
-deduce test2;;
-unsolvable test2;;
-
-*)
diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml
deleted file mode 100644
index 114d5f9c..00000000
--- a/contrib/fourier/fourierR.ml
+++ /dev/null
@@ -1,629 +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        *)
-(************************************************************************)
-
-(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
-
-
-
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients 
-des inéquations et équations sont entiers. En attendant la tactique Field.
-*)
-
-open Term
-open Tactics
-open Clenv
-open Names
-open Libnames
-open Tacticals
-open Tacmach
-open Fourier
-open Contradiction
-
-(******************************************************************************
-Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash 
-qui donne le coefficient d'un terme du calcul des constructions, 
-qui est zéro si le terme n'y est pas. 
-*)
-
-type flin = {fhom:(constr , rational)Hashtbl.t;
-             fcste:rational};;
-
-let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
-
-let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
-
-let flin_add f x c = 
-    let cx = flin_coef f x in
-    Hashtbl.remove f.fhom x;
-    Hashtbl.add f.fhom x (rplus cx c);
-    f
-;;
-let flin_add_cste f c = 
-    {fhom=f.fhom;
-     fcste=rplus f.fcste c}
-;;
-
-let flin_one () = flin_add_cste (flin_zero()) r1;;
-
-let flin_plus f1 f2 = 
-    let f3 = flin_zero() in
-    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
-    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
-    flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
-;;
-
-let flin_minus f1 f2 = 
-    let f3 = flin_zero() in
-    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
-    Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
-    flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
-;;
-let flin_emult a f =
-    let f2 = flin_zero() in
-    Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
-    flin_add_cste f2 (rmult a f.fcste);
-;;
-    
-(*****************************************************************************)
-open Vernacexpr
-
-type ineq = Rlt | Rle | Rgt | Rge
-
-let string_of_R_constant kn = 
-  match Names.repr_con kn with
-    | MPfile dir, sec_dir, id when 
-	sec_dir = empty_dirpath && 
-	string_of_dirpath dir = "Coq.Reals.Rdefinitions" 
-	-> string_of_label id
-    | _ -> "constant_not_of_R"
-
-let rec string_of_R_constr c =
- match kind_of_term c with
-   Cast (c,_,_) -> string_of_R_constr c
-  |Const c -> string_of_R_constant c
-  | _ -> "not_of_constant"
-
-let rec rational_of_constr c =
-  match kind_of_term c with
-  | Cast (c,_,_) -> (rational_of_constr c)
-  | App (c,args) ->
-      (match (string_of_R_constr c) with
-	 | "Ropp" -> 
-	     rop (rational_of_constr args.(0))
-	 | "Rinv" -> 
-	     rinv (rational_of_constr args.(0))
-	 | "Rmult" -> 
-	     rmult (rational_of_constr args.(0))
-                   (rational_of_constr args.(1))
-	 | "Rdiv" -> 
-	     rdiv (rational_of_constr args.(0))
-                  (rational_of_constr args.(1))
-	 | "Rplus" -> 
-	     rplus (rational_of_constr args.(0))
-                   (rational_of_constr args.(1))
-	 | "Rminus" -> 
-	     rminus (rational_of_constr args.(0))
-                    (rational_of_constr args.(1))
-	 | _ -> failwith "not a rational")
-  | Const kn ->
-      (match (string_of_R_constant kn) with
-	       "R1" -> r1
-              |"R0" -> r0
-              |  _ -> failwith "not a rational")
-  |  _ -> failwith "not a rational"
-;;
-
-let rec flin_of_constr c =
-  try(
-    match kind_of_term c with
-  | Cast (c,_,_) -> (flin_of_constr c)
-  | App (c,args) ->
-      (match (string_of_R_constr c) with
-	   "Ropp" -> 
-             flin_emult (rop r1) (flin_of_constr args.(0))
-	 | "Rplus"-> 
-             flin_plus (flin_of_constr args.(0))
-	               (flin_of_constr args.(1))
-	 | "Rminus"->
-             flin_minus (flin_of_constr args.(0))
-	                (flin_of_constr args.(1))
-	 | "Rmult"->
-	     (try (let a=(rational_of_constr args.(0)) in
-                     try (let b = (rational_of_constr args.(1)) in
-			    (flin_add_cste (flin_zero()) (rmult a b)))
-		     with _-> (flin_add (flin_zero())
-				 args.(1) 
-				 a))
-	      with _-> (flin_add (flin_zero())
-			  args.(0) 
-			  (rational_of_constr args.(1))))
-	 | "Rinv"->
-	     let a=(rational_of_constr args.(0)) in
-	       flin_add_cste (flin_zero()) (rinv a)
-	 | "Rdiv"->
-	     (let b=(rational_of_constr args.(1)) in
-		try (let a = (rational_of_constr args.(0)) in
-		       (flin_add_cste (flin_zero()) (rdiv a b)))
-		with _-> (flin_add (flin_zero())
-		            args.(0) 
-                            (rinv b)))
-         |_->assert false)
-  | Const c ->
-        (match (string_of_R_constant c) with
-	       "R1" -> flin_one ()
-              |"R0" -> flin_zero ()
-              |_-> assert false)
-  |_-> assert false)
-  with _ -> flin_add (flin_zero())
-                     c
-	             r1
-;;
-
-let flin_to_alist f =
-    let res=ref [] in
-    Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
-    !res
-;;
-
-(* Représentation des hypothèses qui sont des inéquations ou des équations.
-*)
-type hineq={hname:constr; (* le nom de l'hypothèse *)
-            htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
-            hleft:constr;
-            hright:constr;
-            hflin:flin;
-            hstrict:bool}
-;;
-
-(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
-*)
-let ineq1_of_constr (h,t) =
-    match (kind_of_term t) with
-       App (f,args) ->
-         (match kind_of_term f with
-           Const c when Array.length args = 2 ->
-             let t1= args.(0) in
-             let t2= args.(1) in
-            (match (string_of_R_constant c) with
-		 "Rlt" -> [{hname=h;
-                           htype="Rlt";
-		           hleft=t1;
-			   hright=t2;
-			   hflin= flin_minus (flin_of_constr t1)
-                                             (flin_of_constr t2);
-			   hstrict=true}]
-		|"Rgt" -> [{hname=h;
-                           htype="Rgt";
-		           hleft=t2;
-			   hright=t1;
-			   hflin= flin_minus (flin_of_constr t2)
-                                             (flin_of_constr t1);
-			   hstrict=true}]
-		|"Rle" -> [{hname=h;
-                           htype="Rle";
-		           hleft=t1;
-			   hright=t2;
-			   hflin= flin_minus (flin_of_constr t1)
-                                             (flin_of_constr t2);
-			   hstrict=false}]
-		|"Rge" -> [{hname=h;
-                           htype="Rge";
-		           hleft=t2;
-			   hright=t1;
-			   hflin= flin_minus (flin_of_constr t2)
-                                             (flin_of_constr t1);
-			   hstrict=false}]
-                |_->assert false)
-          | Ind (kn,i) ->
-	      if IndRef(kn,i) = Coqlib.glob_eq then
-		           let t0= args.(0) in
-                           let t1= args.(1) in
-                           let t2= args.(2) in
-		    (match (kind_of_term t0) with
-                         Const c ->
-			   (match (string_of_R_constant c) with
-			      "R"->
-                         [{hname=h;
-                           htype="eqTLR";
-		           hleft=t1;
-			   hright=t2;
-			   hflin= flin_minus (flin_of_constr t1)
-                                             (flin_of_constr t2);
-			   hstrict=false};
-                          {hname=h;
-                           htype="eqTRL";
-		           hleft=t2;
-			   hright=t1;
-			   hflin= flin_minus (flin_of_constr t2)
-                                             (flin_of_constr t1);
-			   hstrict=false}]
-                           |_-> assert false)
-                         |_-> assert false)
-	      else
-		assert false
-          |_-> assert false)
-        |_-> assert false
-;;
-
-(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
-*)
-
-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 _ -> 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
-               Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) 
-                  h.hflin.fhom;
-               ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
-             lineq1 in
-   unsolvable sys
-;;
-
-(*********************************************************************)
-(* Defined constants *)
-
-let get = Lazy.force
-let constant = Coqlib.gen_constant "Fourier"
-
-(* Standard library *)
-open Coqlib
-let coq_sym_eqT = lazy (build_coq_sym_eq ())
-let coq_False = lazy (build_coq_False ())
-let coq_not = lazy (build_coq_not ())
-let coq_eq = lazy (build_coq_eq ())
-
-(* Rdefinitions *)
-let constant_real = constant ["Reals";"Rdefinitions"]
-
-let coq_Rlt = lazy (constant_real "Rlt")
-let coq_Rgt = lazy (constant_real "Rgt")
-let coq_Rle = lazy (constant_real "Rle")
-let coq_Rge = lazy (constant_real "Rge")
-let coq_R = lazy (constant_real "R")
-let coq_Rminus = lazy (constant_real "Rminus")
-let coq_Rmult = lazy (constant_real "Rmult")
-let coq_Rplus = lazy (constant_real "Rplus")
-let coq_Ropp = lazy (constant_real "Ropp")
-let coq_Rinv = lazy (constant_real "Rinv")
-let coq_R0 = lazy (constant_real "R0")
-let coq_R1 = lazy (constant_real "R1")
-
-(* RIneq *)
-let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1")
-
-(* Fourier_util *)
-let constant_fourier = constant ["fourier";"Fourier_util"]
-
-let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1")
-let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1")
-let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1")
-let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos")
-let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero")
-let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1")
-let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos")
-let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0")
-let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt")
-let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt")
-let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le")
-let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le")
-let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le")
-
-let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt")
-let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le")
-let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt")
-let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge")
-let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt")
-let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le")
-let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt")
-let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le")
-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_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,
-i.e. on obtient une contradiction.
-*)
-let is_int x = (x.den)=1
-;;
-
-(* fraction = couple (num,den) *)
-let rec rational_to_fraction x= (x.num,x.den)
-;;
-    
-(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
-*)
-let int_to_real n =
-   let nn=abs n in
-   if nn=0
-   then get coq_R0
-   else
-     (let s=ref (get coq_R1) in
-      for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
-      if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s)
-;;
-(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
-*)
-let rational_to_real x =
-   let (n,d)=rational_to_fraction x in
-   mkApp (get coq_Rmult,
-     [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|])
-;;
-
-(* preuve que 0<n*1/d
-*)
-let tac_zero_inf_pos gl (n,d) =
-   let tacn=ref (apply (get coq_Rlt_zero_1)) in
-   let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do 
-       tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
-;;
-
-(* preuve que 0<=n*1/d
-*)
-let tac_zero_infeq_pos gl (n,d)=
-   let tacn=ref (if n=0 
-                 then (apply (get coq_Rle_zero_zero))
-                 else (apply (get coq_Rle_zero_1))) in
-   let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do 
-       tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
-;;
-  
-(* preuve que 0<(-n)*(1/d) => False 
-*)
-let tac_zero_inf_false gl (n,d) =
-    if n=0 then (apply (get coq_Rnot_lt0))
-    else
-     (tclTHEN (apply (get coq_Rle_not_lt))
-	      (tac_zero_infeq_pos 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_frac_opp))
-	      (tac_zero_inf_pos gl (-n,d)))
-;;
-
-let create_meta () = mkMeta(Evarutil.new_meta());;
-   
-let my_cut c gl=
-     let concl = pf_concl gl in
-       apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl
-;;
-
-let exact = exact_check;;
-
-let tac_use h = match h.htype with
-               "Rlt" -> exact h.hname
-              |"Rle" -> exact h.hname
-              |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt))
-                                (exact h.hname))
-              |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le))
-                                (exact h.hname))
-              |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le))
-                                (exact h.hname))
-              |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le))
-                                (exact h.hname))
-              |_->assert false
-;;
-
-(*
-let is_ineq (h,t) =
-    match (kind_of_term t) with
-	App (f,args) ->
-	  (match (string_of_R_constr f) with
-	       "Rlt" -> true
-	     | "Rgt" -> true
-	     | "Rle" -> true
-	     | "Rge" -> true
-(* Wrong:not in Rdefinitions: *) | "eqT" ->
-                (match (string_of_R_constr args.(0)) with
-			     "R" -> true
-			   | _ -> false)
-             | _ ->false)
-      |_->false
-;;
-*)
-
-let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
-
-let mkAppL a =
-   let l = Array.to_list a in
-   mkApp(List.hd l, Array.of_list (List.tl l))
-;;
-
-(* Résolution d'inéquations linéaires dans R *)
-let rec fourier gl=
-    Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
-    let goal = strip_outer_cast (pf_concl gl) in
-    let fhyp=id_of_string "new_hyp_for_fourier" in
-    (* si le but est une inéquation, on introduit son contraire,
-       et le but à prouver devient False *)
-    try (let tac =
-     match (kind_of_term goal) with
-      App (f,args) ->
-      (match (string_of_R_constr f) with
-	     "Rlt" -> 
-	       (tclTHEN
-	         (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
-			  (intro_using  fhyp))
-		 fourier)
-	    |"Rle" -> 
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_gt_le))
-		       (intro_using  fhyp))
-			fourier)
-	    |"Rgt" -> 
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_le_gt))
-		       (intro_using  fhyp))
-	      fourier)
-	    |"Rge" -> 
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
-		       (intro_using  fhyp))
-	      fourier)
-	    |_->assert false)
-        |_->assert false
-      in tac gl)
-     with _ -> 
-    (* les hypothèses *)
-    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))
-		        with _ -> ())
-              hyps;
-    (* lineq = les inéquations découlant des hypothèses *)
-    if !lineq=[] then Util.error "No inequalities";
-    let res=fourier_lineq (!lineq) in
-    let tac=ref tclIDTAC in
-    if res=[]
-    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)]->
-    (* lc=coefficients multiplicateurs des inéquations
-       qui donnent 0<cres ou 0<=cres selon sres *)
-	(*print_string "Fourier's method can prove the goal...";flush stdout;*)
-          let lutil=ref [] in
-	  List.iter 
-            (fun (h,c) ->
-			  if c<>r0
-        		  then (lutil:=(h,c)::(!lutil)(*;
-				print_rational(c);print_string " "*)))
-                    (List.combine (!lineq) lc); 
-       (* on construit la combinaison linéaire des inéquation *)
-             (match (!lutil) with
-          (h1,c1)::lutil ->
-	  let s=ref (h1.hstrict) in
-	  let t1=ref (mkAppL [|get coq_Rmult;
-	                  rational_to_real c1;
-			  h1.hleft|]) in
-	  let t2=ref (mkAppL [|get coq_Rmult;
-	                  rational_to_real c1;
-			  h1.hright|]) in
-	  List.iter (fun (h,c) ->
-	       s:=(!s)||(h.hstrict);
-	       t1:=(mkAppL [|get coq_Rplus;
-	                     !t1;
-                             mkAppL [|get coq_Rmult;
-                                      rational_to_real c;
-			              h.hleft|] |]);
-	       t2:=(mkAppL [|get coq_Rplus;
-	                     !t2;
-                             mkAppL [|get coq_Rmult;
-                                      rational_to_real c;
-			              h.hright|] |]))
-               lutil;
-          let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle;
-			      !t1;
-			      !t2 |] in
-	   let tc=rational_to_real cres in
-       (* puis sa preuve *)
-           let tac1=ref (if h1.hstrict 
-                         then (tclTHENS (apply (get coq_Rfourier_lt))
-                                 [tac_use h1;
-                                  tac_zero_inf_pos  gl
-                                      (rational_to_fraction c1)])
-                         else (tclTHENS (apply (get coq_Rfourier_le))
-                                 [tac_use h1;
-				  tac_zero_inf_pos  gl
-                                      (rational_to_fraction c1)])) in
-           s:=h1.hstrict;
-           List.iter (fun (h,c)-> 
-             (if (!s)
-	      then (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
-			       [!tac1;tac_use h; 
-			        tac_zero_inf_pos  gl
-                                      (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
-			       [!tac1;tac_use h; 
-			        tac_zero_inf_pos  gl
-                                      (rational_to_fraction c)]))
-	      else (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
-			       [!tac1;tac_use h; 
-			        tac_zero_inf_pos  gl
-                                      (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
-			       [!tac1;tac_use h; 
-			        tac_zero_inf_pos  gl
-                                      (rational_to_fraction c)])));
-	     s:=(!s)||(h.hstrict))
-              lutil;
-           let tac2= if sres
-                      then tac_zero_inf_false gl (rational_to_fraction cres)
-                      else tac_zero_infeq_false gl (rational_to_fraction cres)
-           in
-           tac:=(tclTHENS (my_cut ineq) 
-                     [tclTHEN (change_in_concl None
-			       (mkAppL [| get coq_not; ineq|]
-				       ))
-		      (tclTHEN (apply (if sres then get coq_Rnot_lt_lt
-					       else get coq_Rnot_le_le))
-			    (tclTHENS (Equality.replace
-				       (mkAppL [|get coq_Rminus;!t2;!t1|]
-					       )
-				       tc)
-		 	       [tac2;
-                                (tclTHENS
-				  (Equality.replace
-				    (mkApp (get coq_Rinv, 
-				      [|get coq_R1|]))
-				    (get coq_R1))
-(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)	
-
-      			        [tclORELSE
-                                   (Ring.polynom [])
-                                   tclIDTAC;
-					  (tclTHEN (apply (get coq_sym_eqT))
-						(apply (get coq_Rinv_1)))]
-                               
-					 )
-				]));
-                       !tac1]);
-	   tac:=(tclTHENS (cut (get coq_False))
-				  [tclTHEN intro (contradiction None);
-				   !tac])
-      |_-> assert false) |_-> assert false
-	  );
-(*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
-      (!tac gl) 
-(*      ((tclABSTRACT None !tac) gl) *)
-
-;;
-
-(*
-let fourier_tac x gl =
-     fourier gl
-;;
-
-let v_fourier = add_tactic "Fourier" fourier_tac
-*)
-
diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4
deleted file mode 100644
index 3a6be850..00000000
--- a/contrib/fourier/g_fourier.ml4
+++ /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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_fourier.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
-
-open FourierR
-
-TACTIC EXTEND fourier
-  [ "fourierz" ] -> [ fourier ]
-END
diff --git a/contrib/funind/Recdef.v b/contrib/funind/Recdef.v
deleted file mode 100644
index 2d206220..00000000
--- a/contrib/funind/Recdef.v
+++ /dev/null
@@ -1,48 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-Require Compare_dec.
-Require Wf_nat.
-
-Section Iter.
-Variable A : Type.
-
-Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
-  fun (fl : A -> A) (def : A) =>
-  match n with
-  | O => def
-  | S m => fl (iter m fl def)
-  end.
-End Iter.
-
-Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
-  intro p; intro p'; change (S p <= S (S (p + p'))); 
-    apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); 
-    apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
-Qed.
- 
-
-Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
-  intro p; intro p'; change (S p' <= S (p + p')); 
-    apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
-       apply Plus.le_plus_r.
-Qed.
-
-Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
-intro x; intro y; intro H; change (S x <= S (S y)); 
-    apply le_S; apply Gt.gt_le_S; change (x < S y); 
-    apply Lt.le_lt_n_Sm; exact H.
-Qed.
-
-Inductive max_type (m n:nat) : Set :=
-  cmt : forall v, m <= v -> n <= v -> max_type m n.
-
-Definition max : forall m n:nat, max_type m n.
-intros m n; case (Compare_dec.le_gt_dec m n).
-intros h; exists n; [exact h | apply le_n].
-intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h].
-Defined.
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
deleted file mode 100644
index b13bea9d..00000000
--- a/contrib/funind/functional_principles_proofs.ml
+++ /dev/null
@@ -1,1658 +0,0 @@
-open Printer
-open Util
-open Term
-open Termops 
-open Names 
-open Declarations
-open Pp
-open Entries
-open Hiddentac
-open Evd
-open Tacmach
-open Proof_type
-open Tacticals
-open Tactics
-open Indfun_common
-open Libnames
-
-let msgnl = Pp.msgnl
-  
-
-let observe strm =
-  if do_observe ()
-  then Pp.msgnl strm
-  else ()
-
-let observennl strm =
-  if do_observe ()
-  then begin Pp.msg strm;Pp.pp_flush () end
-  else ()
-
-
-
-
-let do_observe_tac s tac g =
- try let v = tac g in (* msgnl (goal ++ fnl () ++ (str 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 observe_tac_stream s tac g = 
-  if do_observe ()
-  then do_observe_tac  s tac g
-  else tac g
-
-let observe_tac s tac g = observe_tac_stream (str s) tac g
-
-(* let tclTRYD tac =  *)
-(*   if  !Flags.debug  || do_observe () *)
-(*   then (fun g -> try (\* do_observe_tac ""  *\)tac g with _ -> tclIDTAC g) *)
-(*   else tac *)
-
-
-let list_chop ?(msg="") n l = 
-  try 
-    list_chop n l 
-  with Failure (msg') -> 
-    failwith (msg ^ msg')
-  
-
-let make_refl_eq type_of_t t  =
-  let refl_equal_term = Lazy.force refl_equal in
-  mkApp(refl_equal_term,[|type_of_t;t|])
-
-
-type pte_info = 
-    { 
-      proving_tac : (identifier list ->  Tacmach.tactic);
-      is_valid : constr -> bool
-    }
-
-type ptes_info = pte_info Idmap.t
-
-type 'a dynamic_info = 
-    { 
-      nb_rec_hyps : int;
-      rec_hyps : identifier list ; 
-      eq_hyps : identifier list;
-      info : 'a
-    }
-
-type body_info = constr dynamic_info 
-      
-
-let finish_proof dynamic_infos g = 
-  observe_tac "finish" 
-    ( h_assumption)
-    g
-	  
-
-let refine c = 
-  Tacmach.refine_no_check c
-
-let thin l = 
-  Tacmach.thin_no_check l
-  
-
-let cut_replacing id t tac :tactic= 
-  tclTHENS (cut t)
-    [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
-      tac 
-    ]
-
-let intro_erasing id = tclTHEN (thin [id]) (introduction id)
-
-
-
-let rec_hyp_id = id_of_string "rec_hyp"
-
-let is_trivial_eq t = 
-  match kind_of_term t with 
-    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
-	eq_constr t1 t2
-    | _ -> false 
-
-
-let rec incompatible_constructor_terms t1 t2 = 
-  let c1,arg1 = decompose_app t1 
-  and c2,arg2 = decompose_app t2 
-  in 
-  (not (eq_constr t1 t2)) &&
-    isConstruct c1 && isConstruct c2 && 
-    (
-      not (eq_constr c1 c2) || 
-	List.exists2 incompatible_constructor_terms arg1 arg2
-    )
-
-let is_incompatible_eq t = 
-  match kind_of_term t with 
-    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
-	incompatible_constructor_terms t1 t2
-    | _ -> false 
-
-let change_hyp_with_using msg hyp_id t tac : tactic = 
-  fun g -> 
-    let prov_id = pf_get_new_id hyp_id g in 
-    tclTHENS
-      ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
-      [tclTHENLIST 
-      [	
-	(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
-	(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
-      ]] g
-
-exception TOREMOVE
-
-
-let prove_trivial_eq h_id context (type_of_term,term) = 
-  let nb_intros = List.length context in 
-  tclTHENLIST
-    [
-      tclDO nb_intros intro; (* introducing context *)
-      (fun g -> 
-	 let context_hyps =  
-	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) 
-	 in
-	 let context_hyps' = 
-	   (mkApp(Lazy.force refl_equal,[|type_of_term;term|]))::
-	     (List.map mkVar context_hyps)
-	 in
-	 let to_refine = applist(mkVar h_id,List.rev context_hyps') in 
-	 refine to_refine g
-      )
-    ]
-
-
-let isAppConstruct t = 
-  if isApp t 
-  then isConstruct (fst (destApp t))
-  else false 
-
-let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
-  let clos_norm_flags flgs env sigma t =
-    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
-    
-
-let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  = 
-  let nochange msg  = 
-    begin 
-(*       observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t    ); *)
-      failwith "NoChange"; 
-    end
-  in    
-  let eq_constr = Reductionops.is_conv env sigma in 
-  if not (noccurn 1 end_of_type)
-  then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
-    if not (isApp t) then nochange "not an equality";
-    let f_eq,args = destApp t in
-    if not (eq_constr f_eq (Lazy.force eq)) then nochange "not an equality";
-    let t1 = args.(1) 
-    and t2 = args.(2) 
-    and t1_typ = args.(0)
-    in 
-    if not (closed0 t1) then nochange "not a closed lhs";    
-    let rec compute_substitution sub t1 t2 = 
-(*       observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *)
-      if isRel t2 
-      then 
-	let t2 = destRel t2  in 
-	begin 
-	  try 
-	    let t1' = Intmap.find t2 sub in 
-	    if not (eq_constr t1 t1') then nochange "twice bound variable";
-	    sub
-	  with Not_found -> 
-	    assert (closed0 t1);
-	    Intmap.add t2 t1 sub
-	end
-      else if isAppConstruct t1 && isAppConstruct t2 
-      then 
-	begin
-	  let c1,args1 = destApp t1 
-	  and c2,args2 = destApp t2 
-	  in 
-	  if not (eq_constr c1 c2) then anomaly "deconstructing equation";
-	  array_fold_left2 compute_substitution sub args1 args2
-	end
-      else 
-	if (eq_constr t1 t2) then sub else nochange "cannot solve"
-    in
-    let sub = compute_substitution Intmap.empty t1 t2 in 
-    let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) 
-    let new_end_of_type = 
-      (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 
-	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
-      *)
-      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in 
-      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in 
-      List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
-	end_of_type_with_pop
-	sub''
-    in
-    let old_context_length = List.length context + 1 in
-    let witness_fun = 
-      mkLetIn(Anonymous,make_refl_eq t1_typ t1,t,
-	       mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i)))
-	      )
-    in
-    let new_type_of_hyp,ctxt_size,witness_fun = 
-      list_fold_left_i 
-	(fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> 
-	   try 
-	     let witness = Intmap.find i sub in 
-	     if b' <> None then anomaly "can not redefine a rel!";
-	     (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
-	   with Not_found  -> 
-	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
-	)
-	1 
-	(new_end_of_type,0,witness_fun)
-	context
-    in
-    let new_type_of_hyp =
-      Reductionops.nf_betaiota Evd.empty new_type_of_hyp in 
-    let new_ctxt,new_end_of_type = 
-      Sign.decompose_prod_n_assum ctxt_size new_type_of_hyp 
-    in 
-    let prove_new_hyp : tactic = 
-      tclTHEN
-	(tclDO ctxt_size intro)
-	(fun g ->
-	   let all_ids = pf_ids_of_hyps g in 
-	   let new_ids,_  = list_chop ctxt_size all_ids in 
-	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in 
-	   refine to_refine g
-	)
-    in
-    let simpl_eq_tac = 
-      change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp
-    in
-(*     observe (str "In " ++ Ppconstr.pr_id hyp_id ++  *)
-(* 	       str "removing an equation " ++ fnl ()++  *)
-(* 	       str "old_typ_of_hyp :=" ++ *)
-(* 	       Printer.pr_lconstr_env *)
-(* 	       env *)
-(* 	       (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *)
-(* 	     ++ fnl () ++ *)
-(* 	       str "new_typ_of_hyp := "++  *)
-(* 	       Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *)
-(* 	     ++ str "old context := " ++ pr_rel_context env context ++ fnl ()  *)
-(* 	     ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl ()  *)
-(* 	     ++ str "old type  := " ++ pr_lconstr end_of_type ++ fnl ()  *)
-(* 	     ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl ()  *)
-(* ); *)
-    new_ctxt,new_end_of_type,simpl_eq_tac
-
-
-let is_property ptes_info t_x full_type_of_hyp = 
-  if isApp t_x 
-  then 
-    let pte,args = destApp t_x in 
-    if isVar pte && array_for_all closed0 args 
-    then 
-      try 
-	let info = Idmap.find (destVar pte) ptes_info in 
-	info.is_valid full_type_of_hyp	  
-      with Not_found -> false 
-    else false 
-  else false 
-
-let isLetIn t = 
-  match kind_of_term t with 
-    | LetIn _ -> true 
-    | _ -> false 
-
-
-let h_reduce_with_zeta = 	 
-  h_reduce 
-    (Rawterm.Cbv
-       {Rawterm.all_flags 
-	with Rawterm.rDelta = false; 		 
-       })
-  
-
-
-let rewrite_until_var arg_num eq_ids : tactic =
-  (* tests if the declares recursive argument is neither a Constructor nor 
-     an applied Constructor since such a form for the recursive argument 
-     will break the Guard when trying to save the Lemma. 
-  *)
-  let test_var g = 
-    let _,args = destApp (pf_concl g) in 
-    not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
-  in
-  let rec do_rewrite eq_ids g  = 
-    if test_var g 
-    then tclIDTAC g
-    else
-      match eq_ids with 
-	| [] -> anomaly "Cannot find a way to prove recursive property";
-	| eq_id::eq_ids -> 
-	    tclTHEN 
-	      (tclTRY (Equality.rewriteRL (mkVar eq_id)))
-	      (do_rewrite eq_ids)
-	      g
-  in
-  do_rewrite eq_ids
-
-
-let rec_pte_id = id_of_string "Hrec" 
-let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = 
-  let coq_False = Coqlib.build_coq_False () in 
-  let coq_True = Coqlib.build_coq_True () in 
-  let coq_I = Coqlib.build_coq_I () in 
-  let rec scan_type  context type_of_hyp : tactic = 
-    if isLetIn type_of_hyp then 
-      let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in
-      let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in 
-      (* length of context didn't change ? *)
-      let new_context,new_typ_of_hyp = 
-	 Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp
-      in
-        tclTHENLIST 
-	[
-	  h_reduce_with_zeta
-	    (Tacticals.onHyp hyp_id)
-	  ;
-	  scan_type new_context new_typ_of_hyp 
-	  
-	]
-    else if isProd type_of_hyp 
-    then 
-      begin 
-	let (x,t_x,t') = destProd type_of_hyp in	
-	let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in 
-	if is_property ptes_infos t_x actual_real_type_of_hyp then
-	  begin
-	    let pte,pte_args =  (destApp t_x) in 
-	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in 
-	    let popped_t' = pop t' in 
-	    let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in 
-	    let prove_new_type_of_hyp = 
-	      let context_length = List.length context in 
-	      tclTHENLIST
-		[ 
-		  tclDO context_length intro; 
-		  (fun g ->  
-		     let context_hyps_ids = 
-		       fst (list_chop ~msg:"rec hyp : context_hyps"
-			      context_length (pf_ids_of_hyps g))
-		     in
-		     let rec_pte_id = pf_get_new_id rec_pte_id g in 
-		     let to_refine = 
-		       applist(mkVar hyp_id,
-			       List.rev_map mkVar (rec_pte_id::context_hyps_ids)
-			      )
-		     in
-(* 		     observe_tac "rec hyp " *)
-		       (tclTHENS
-		       (assert_tac (Name rec_pte_id) t_x)
-		       [
-			 (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps);
-(* 			observe_tac "prove rec hyp" *)
-			  (refine to_refine)
-		       ])
-		       g
-		  )
-		]
-	    in
-	    tclTHENLIST 
-	      [
-(* 		observe_tac "hyp rec"  *)
-		  (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp);
-		scan_type context popped_t'
-	      ]
-	  end
-	else if eq_constr t_x coq_False then 
-	  begin
-(* 	    observe (str "Removing : "++ Ppconstr.pr_id hyp_id++  *)
-(* 		       str " since it has False in its preconds " *)
-(* 		    ); *)
-	    raise TOREMOVE;  (* False -> .. useless *)
-	  end
-	else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *) 
-	else if eq_constr t_x coq_True  (* Trivial => we remove this precons *)
-	then 
-(* 	    observe (str "In "++Ppconstr.pr_id hyp_id++  *)
-(* 		       str " removing useless precond True" *)
-(* 		    );  *)
-	  let popped_t' = pop t' in
-	  let real_type_of_hyp = 
-	    it_mkProd_or_LetIn ~init:popped_t' context 
-	  in 
-	  let prove_trivial =  
-	    let nb_intro = List.length context in 
-	    tclTHENLIST [
-	      tclDO nb_intro intro;
-	      (fun g -> 
-		 let context_hyps = 
-		   fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
-		 in
-		 let to_refine = 
-		   applist (mkVar hyp_id,
-			    List.rev (coq_I::List.map mkVar context_hyps)
-			   )
-		 in
-		 refine to_refine g
-	      )
-	    ]
-	  in
-	  tclTHENLIST[
-	    change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp 
-	      ((* observe_tac "prove_trivial" *) prove_trivial);
-	    scan_type context popped_t'
-	  ]
-	else if is_trivial_eq t_x 
-	then (*  t_x :=  t = t   => we remove this precond *) 
-	  let popped_t' = pop t' in
-	  let real_type_of_hyp =
-	    it_mkProd_or_LetIn ~init:popped_t' context
-	  in
-	  let _,args = destApp t_x in
-	  tclTHENLIST
-	    [
-	      change_hyp_with_using
-		"prove_trivial_eq"
-		hyp_id
-		real_type_of_hyp
-		((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (args.(0),args.(1))));
-	      scan_type context popped_t'
-	    ] 
-	else 
-	  begin
-	    try 
-	      let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in 
-	      tclTHEN
-		tac 
-		(scan_type new_context new_t')
-	    with Failure "NoChange" -> 
-	      (* Last thing todo : push the rel in the context and continue *) 
-	      scan_type ((x,None,t_x)::context) t'
-	  end
-      end
-    else
-      tclIDTAC
-  in 
-  try 
-    scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id]
-  with TOREMOVE -> 
-    thin [hyp_id],[]
-
-
-let clean_goal_with_heq ptes_infos continue_tac dyn_infos  = 
-  fun g -> 
-    let env = pf_env g 
-    and sigma = project g 
-    in
-    let tac,new_hyps = 
-      List.fold_left ( 
-	fun (hyps_tac,new_hyps) hyp_id ->
-	  let hyp_tac,new_hyp = 
-	    clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma 
-	  in
-	  (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps
-      )
-	(tclIDTAC,[])
-	dyn_infos.rec_hyps
-    in
-    let new_infos = 
-      { dyn_infos with 
-	  rec_hyps = new_hyps; 
-	  nb_rec_hyps  = List.length new_hyps
-      }
-    in
-    tclTHENLIST 
-      [
-	tac ;
-	(* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos)
-      ]
-      g    
-
-let heq_id = id_of_string "Heq"
-
-let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = 
-  fun g -> 
-    let heq_id = pf_get_new_id heq_id g in 
-    let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in
-    tclTHENLIST
-      [ 
-	(* We first introduce the variables *) 
-	tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
-	(* Then the equation itself *)
-	introduction_no_check heq_id;
-	(* Then the new hypothesis *) 
-	tclMAP introduction_no_check dyn_infos.rec_hyps;
-	(* observe_tac "after_introduction"  *)(fun g' -> 
-	   (* We get infos on the equations introduced*)
-	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in 
-	   (* compute the new value of the body *)
-	   let new_term_value =
-	     match kind_of_term new_term_value_eq with
-	       | App(f,[| _;_;args2 |]) -> args2
-	       | _ ->
-		   observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
-			      pr_lconstr_env (pf_env g') new_term_value_eq
-			   );
-		   anomaly "cannot compute new term value"
-	   in
-	 let fun_body =
-	   mkLambda(Anonymous,
-		    pf_type_of g' term,
-		    replace_term term (mkRel 1) dyn_infos.info
-		   )
-	 in
-	 let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
-	 let new_infos = 
-	   {dyn_infos with 
-	      info = new_body;
-	      eq_hyps = heq_id::dyn_infos.eq_hyps
-	   }
-	 in 
-	 clean_goal_with_heq ptes_infos continue_tac new_infos  g'
-      )
-    ]
-      g
-
-
-let my_orelse tac1 tac2 g = 
-  try 
-    tac1 g 
-  with e -> 
-(*     observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
-    tac2 g 
-
-let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = 
-  let args = Array.of_list (List.map mkVar  args_id) in 
-  let instanciate_one_hyp hid = 
-    my_orelse
-      ( (* we instanciate the hyp if possible  *)
-	fun g -> 
-	  let prov_hid = pf_get_new_id hid g in
-	  tclTHENLIST[
-	    pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
-	    thin [hid];
-	    h_rename [prov_hid,hid]
-	  ] g
-      )
-      ( (*
-	  if not then we are in a mutual function block 
-	  and this hyp is a recursive hyp on an other function.
-	  
-	  We are not supposed to use it while proving this 
-	  principle so that we can trash it 
-	  
-	*)
-	(fun g -> 
-(* 	   observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *)
-	   thin [hid] g
-	)
-      )
-  in
-  if args_id = []  
-  then 
-    tclTHENLIST [
-      tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
-      do_prove hyps
-    ]
-  else
-    tclTHENLIST
-      [
-	tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
-	tclMAP instanciate_one_hyp hyps;
-	(fun g ->  
-	   let all_g_hyps_id = 
-	     List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
-	   in 
-	   let remaining_hyps = 
-	     List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
-	   in
-	   do_prove remaining_hyps g
-	  )
-      ]
-
-let build_proof 
-    (interactive_proof:bool)
-    (fnames:constant list)
-    ptes_infos
-    dyn_infos
-    : tactic =
-  let rec build_proof_aux do_finalize dyn_infos : tactic = 
-    fun g -> 
-(*      observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
-	match kind_of_term dyn_infos.info with 
-	  | Case(ci,ct,t,cb) -> 
-	      let do_finalize_t dyn_info' = 
-		fun g ->
-		  let t = dyn_info'.info in 
-		  let dyn_infos = {dyn_info' with info = 
-		      mkCase(ci,ct,t,cb)} in
-		  let g_nb_prod = nb_prod (pf_concl g) in
-		  let type_of_term = pf_type_of g t in
-		  let term_eq =
-		    make_refl_eq type_of_term t
-		  in
-		  tclTHENSEQ
-		    [
-		      h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
-		      thin dyn_infos.rec_hyps;
-		      pattern_option [(false,[1]),t] None;
-		      h_simplest_case t;
-		      (fun g' -> 
-			 let g'_nb_prod = nb_prod (pf_concl g') in 
-			 let nb_instanciate_partial = g'_nb_prod - g_nb_prod in 
-			 		     observe_tac "treat_new_case"
-			 (treat_new_case  
-			    ptes_infos
-			    nb_instanciate_partial 
-			    (build_proof do_finalize) 
-			    t 
-			    dyn_infos)
-			   g'
-		      )
-			
-		    ] g
-	      in
-	      build_proof do_finalize_t {dyn_infos with info = t} g
-	  | Lambda(n,t,b) ->
-	      begin
-		match kind_of_term( pf_concl g) with
-		  | Prod _ ->
-		      tclTHEN
-			intro
-			(fun g' ->
-			   let (id,_,_) = pf_last_hyp g' in
-			   let new_term = 
-			     pf_nf_betaiota g' 
-			       (mkApp(dyn_infos.info,[|mkVar id|])) 
-			   in
-			   let new_infos = {dyn_infos with info = new_term} in
-			   let do_prove new_hyps = 
-			     build_proof do_finalize 
-			       {new_infos with
-			       	  rec_hyps = new_hyps; 
-				  nb_rec_hyps  = List.length new_hyps
-			       }
-			   in 
-(* 			   observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g'
-			     (* 			   build_proof do_finalize new_infos g' *)
-			) g
-		  | _ ->
-		      do_finalize dyn_infos g 
-	      end
-	  | Cast(t,_,_) -> 
-	      build_proof do_finalize {dyn_infos with info = t} g
-	  | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
-	      do_finalize dyn_infos g
-	  | App(_,_) ->
-	      let f,args = decompose_app dyn_infos.info in
-	      begin
-		match kind_of_term f with
-		  | App _ -> assert false (* we have collected all the app in decompose_app *)
-		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
-		      let new_infos = 
-			{ dyn_infos with 
-			    info = (f,args)
-			}
-		      in
-		      build_proof_args do_finalize new_infos  g
-		  | Const c when not (List.mem c fnames) ->
-		      let new_infos = 
-			{ dyn_infos with 
-			    info = (f,args)
-			}
-		      in
-(* 		      Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *)
-		      build_proof_args do_finalize new_infos g
-		  | Const _ ->
-		      do_finalize dyn_infos  g
-		  | Lambda _ -> 
-		      let new_term =
-                        Reductionops.nf_beta Evd.empty dyn_infos.info in 
-		      build_proof do_finalize {dyn_infos with info = new_term} 
-			g
-		  | LetIn _ -> 
-		      let new_infos = 
-			{ dyn_infos with info = nf_betaiotazeta dyn_infos.info } 
-		      in 
-
-		      tclTHENLIST 
-			[tclMAP 
-			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
-			   dyn_infos.rec_hyps;
-			 h_reduce_with_zeta Tacticals.onConcl;
-			 build_proof do_finalize new_infos
-			] 
-			g
-		  | Cast(b,_,_) -> 
-		      build_proof do_finalize {dyn_infos with info = b } g
-		  | Case _ | Fix _ | CoFix _ ->
-		      let new_finalize dyn_infos = 
-			let new_infos = 
-			  { dyn_infos with 
-			      info = dyn_infos.info,args
-			  }
-			in 
-			build_proof_args do_finalize new_infos 
-		      in 
-		      build_proof new_finalize {dyn_infos  with info = f } g
-	      end
-	  | Fix _ | CoFix _ ->
-	      error ( "Anonymous local (co)fixpoints are not handled yet")
-
-	  | Prod _ -> error "Prod" 
-	  | LetIn _ -> 
-	      let new_infos = 
-		{ dyn_infos with 
-		    info = nf_betaiotazeta dyn_infos.info 
-		}
-	      in 
-
-	      tclTHENLIST 
-		[tclMAP 
-		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
-		   dyn_infos.rec_hyps;
-		 h_reduce_with_zeta Tacticals.onConcl;
-		 build_proof do_finalize new_infos
-		] g
-	  | Rel _ -> anomaly "Free var in goal conclusion !" 
-  and build_proof do_finalize dyn_infos g =
-(*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
-    observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
-  and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
-    fun g ->
-      let (f_args',args) = dyn_infos.info in 
-      let tac : tactic =
-	fun g -> 
-	match args with
-	  | []  ->
-	      do_finalize {dyn_infos with info = f_args'} g 
-	  | arg::args ->
-(* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
-(* 			fnl () ++  *)
-(* 			pr_goal (Tacmach.sig_it g) *)
-(* 			); *)
-	      let do_finalize dyn_infos =
-		let new_arg = dyn_infos.info in 
-		(* 		tclTRYD *)
-		(build_proof_args
-		   do_finalize
-		   {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args}
-		)
-	      in
-	      build_proof do_finalize 
-		{dyn_infos with info = arg }
-		g
-      in
-      (* observe_tac "build_proof_args" *) (tac ) g
-   in
-   let do_finish_proof dyn_infos = 
-     (* tclTRYD *) (clean_goal_with_heq 
-      ptes_infos
-      finish_proof dyn_infos)
-  in
-  (* observe_tac "build_proof" *)
-    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) 
-
-
-
-
-
-
-
-
-
-
-
-
-(* Proof of principles from structural functions *) 
-let is_pte_type t =
-  isSort (snd (decompose_prod t))
-    
-let is_pte (_,_,t) = is_pte_type t
-
-
-
-
-type static_fix_info = 
-    {
-      idx : int;
-      name : identifier;
-      types : types;
-      offset : int;
-      nb_realargs : int;
-      body_with_param : constr;
-      num_in_block : int 
-    }
-
-
-
-let prove_rec_hyp_for_struct fix_info = 
-      (fun  eq_hyps -> tclTHEN 
-	(rewrite_until_var (fix_info.idx) eq_hyps)
-	(fun g -> 
-	   let _,pte_args = destApp (pf_concl g) in 
-	   let rec_hyp_proof = 
-	     mkApp(mkVar fix_info.name,array_get_start pte_args) 
-	   in
-	   refine rec_hyp_proof g
-	))
-
-let prove_rec_hyp fix_info  =
-  { proving_tac = prove_rec_hyp_for_struct fix_info
-  ;
-    is_valid = fun _ -> true 
-  }
-
-
-exception Not_Rec
-    
-let generalize_non_dep hyp g = 
-(*   observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
-  let hyps = [hyp] in 
-  let env = Global.env () in 
-  let hyp_typ = pf_type_of g (mkVar hyp) in 
-  let to_revert,_ = 
-    Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
-      if List.mem hyp hyps
-	or List.exists (occur_var_in_decl env hyp) keep
-	or occur_var env hyp hyp_typ
-	or Termops.is_section_variable hyp (* should be dangerous *) 
-      then (clear,decl::keep)
-      else (hyp::clear,keep))
-      ~init:([],[]) (pf_env g)
-  in
-(*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
-  tclTHEN 
-    ((* observe_tac "h_generalize" *) (h_generalize  (List.map mkVar to_revert) ))
-    ((* observe_tac "thin" *) (thin to_revert))
-    g
-  
-let id_of_decl (na,_,_) =  (Nameops.out_name na)
-let var_of_decl decl = mkVar (id_of_decl decl)
-let revert idl = 
-  tclTHEN 
-    (generalize (List.map mkVar idl)) 
-    (thin idl)
-
-let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
-(*   observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
-(*   observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
-(*   observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
-  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 (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
-  let fnames_with_params =
-    let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in
-    let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in
-    fnames
-  in
-(*   observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *)
-(*   observe (str "body " ++ pr_lconstr bodies.(num)); *)
-  let f_body_with_params_and_other_fun  = substl fnames_with_params bodies.(num) in
-(*   observe (str "f_body_with_params_and_other_fun " ++  pr_lconstr f_body_with_params_and_other_fun); *)
-  let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
-(*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
-  let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) 
-    (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
-  let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
-  let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
-  let f_id = id_of_label (con_label (destConst f)) in
-  let prove_replacement =
-    tclTHENSEQ
-      [
-	tclDO (nb_params + rec_args_num + 1) intro;
-	(* observe_tac "" *) (fun g ->
-	   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 false (mkVar rec_id,Rawterm.NoBindings));
-	      intros_reflexivity] g
-	)
-      ]
-  in
-  Command.start_proof
-    (*i The next call to mk_equation_id is valid since we are constructing the lemma
-      Ensures by: obvious
-      i*) 
-    (mk_equation_id f_id)
-    (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-    lemma_type
-    (fun _ _ -> ());
-  Pfedit.by (prove_replacement);
-  Command.save_named false
-
-
-
-  
-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 (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
-	i*) 
-      let equation_lemma_id = (mk_equation_id f_id) in 
-      generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
-      let _ =
-	match e with 
-	  | Option.IsNone -> 
-	      let finfos = find_Function_infos (destConst f) in 
-	      update_Function 
-		{finfos with
-		   equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with
-					      ConstRef c -> c
-					    | _ -> Util.anomaly "Not a constant" 
-					 )
-		}
-	  | _ -> () 
-
-      in 
-      Tacinterp.constr_of_id (pf_env g) equation_lemma_id
-  in
-  let nb_intro_to_do = nb_prod (pf_concl g) in
-    tclTHEN
-      (tclDO nb_intro_to_do intro)
-      (
-	fun g' -> 
-	  let just_introduced = nLastHyps nb_intro_to_do g' in 
-	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in 
-	  tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
-      )
-      g
-
-let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
-  fun g -> 
-    let princ_type = pf_concl g in 
-    let princ_info = compute_elim_sig princ_type in 
-    let fresh_id = 
-      let avoid = ref (pf_ids_of_hyps g) in 
-      (fun na -> 
-	 let new_id = 
-	   match na with 
-	       Name id -> fresh_id !avoid (string_of_id id) 
-	     | Anonymous -> fresh_id !avoid "H"
-	 in
-	 avoid := new_id :: !avoid; 
-	 (Name new_id)
-      )
-    in
-    let fresh_decl = 
-      (fun (na,b,t) -> 
-	 (fresh_id na,b,t)
-      )
-    in
-    let princ_info : elim_scheme = 
-      { princ_info with 
-	  params = List.map fresh_decl princ_info.params;
-	  predicates = List.map fresh_decl princ_info.predicates; 
-	  branches = List.map fresh_decl princ_info.branches; 
-	  args = List.map fresh_decl princ_info.args
-      }
-    in
-    let get_body const =
-      match (Global.lookup_constant const ).const_body with
-	| Some b ->
-	     let body = force b in
-	     Tacred.cbv_norm_flags
-	       (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-	       (Global.env ())
-	       (Evd.empty)
-	       body
-	| None -> error ( "Cannot define a principle over an axiom ")
-    in
-    let fbody = get_body fnames.(fun_num) in
-    let f_ctxt,f_body = decompose_lam fbody in 
-    let f_ctxt_length = List.length f_ctxt in 
-    let diff_params = princ_info.nparams - f_ctxt_length in 
-    let full_params,princ_params,fbody_with_full_params = 
-      if diff_params > 0
-      then 
-	let princ_params,full_params = 
-	  list_chop  diff_params princ_info.params 
-	in 
-	(full_params, (* real params *)
-	 princ_params, (* the params of the principle which are not params of the function *)
-	 substl (* function instanciated with real params *)
-	   (List.map var_of_decl full_params)
-	   f_body
-	)
-      else
-	let f_ctxt_other,f_ctxt_params = 
-	  list_chop (- diff_params) f_ctxt in 
-	let f_body = compose_lam f_ctxt_other f_body in 
-	(princ_info.params, (* real params *)
-	 [],(* all params are full params *)
-	 substl (* function instanciated with real params *)
-	   (List.map var_of_decl princ_info.params)
-	   f_body
-	)
-    in
-(*     observe (str "full_params := " ++  *)
-(* 	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
-(* 	       full_params *)
-(* 	    );  *)
-(*     observe (str "princ_params := " ++  *)
-(* 	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
-(* 	       princ_params *)
-(* 	    );  *)
-(*     observe (str "fbody_with_full_params := " ++  *)
-(* 	       pr_lconstr fbody_with_full_params *)
-(* 	    );  *)
-    let all_funs_with_full_params = 
-      Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
-    in
-    let fix_offset = List.length princ_params in 
-    let ptes_to_fix,infos = 
-      match kind_of_term fbody_with_full_params with 
-	| Fix((idxs,i),(names,typess,bodies)) -> 
-	    let bodies_with_all_params = 
-	      Array.map 
-		(fun body -> 
-		   Reductionops.nf_betaiota Evd.empty
-		     (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
-			      List.rev_map var_of_decl princ_params))
-		)
-		bodies
-	    in
-	    let info_array = 
-	      Array.mapi 
-		(fun i types -> 
-		   let types = prod_applist types (List.rev_map var_of_decl princ_params) in
-		   { idx = idxs.(i)  - fix_offset;
-		     name = Nameops.out_name (fresh_id names.(i));
-		     types = types; 
-		     offset = fix_offset;
-		     nb_realargs = 
-		       List.length 
-			 (fst (decompose_lam bodies.(i))) - fix_offset;
-		     body_with_param = bodies_with_all_params.(i);
-		     num_in_block = i
-		   }
-		)
-		typess
-	    in
-	    let pte_to_fix,rev_info = 
-	      list_fold_left_i 
-		(fun i (acc_map,acc_info) (pte,_,_) -> 
-		   let infos = info_array.(i) in 
-		   let type_args,_ = decompose_prod infos.types in 
-		   let nargs = List.length type_args in 
-		   let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
-		   let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
-		   let app_f = mkApp(f,first_args) in
-		   let pte_args = (Array.to_list first_args)@[app_f] in 
-		   let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in 
-		   let body_with_param,num = 
-		     let body = get_body fnames.(i) in 
-		     let body_with_full_params = 
-		       Reductionops.nf_betaiota Evd.empty (
-			 applist(body,List.rev_map var_of_decl full_params))
-		     in
-		     match kind_of_term body_with_full_params with 
-		       | Fix((_,num),(_,_,bs)) -> 
-			       Reductionops.nf_betaiota Evd.empty
-				 (
-				   (applist
-				      (substl 
-					 (List.rev 
-					    (Array.to_list all_funs_with_full_params)) 
-					 bs.(num),
-				       List.rev_map var_of_decl princ_params))
-				 ),num
-			 | _ -> error "Not a mutual block"
-		   in
-		   let info = 
-		     {infos with 
-			types = compose_prod type_args app_pte;
-			 body_with_param = body_with_param;
-			 num_in_block = num
-		     }
-		   in 
-(* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
-(* 			      str " to " ++ Ppconstr.pr_id info.name); *)
-		   (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
-		   )
-		0 
-		(Idmap.empty,[]) 
-		(List.rev princ_info.predicates)
-	    in
-	    pte_to_fix,List.rev rev_info
-	| _ -> Idmap.empty,[]
-    in
-    let mk_fixes : tactic = 
-      let pre_info,infos = list_chop fun_num infos in 
-      match pre_info,infos with 
-	| [],[] -> tclIDTAC
-	| _, this_fix_info::others_infos -> 
-	    let other_fix_infos =
-	      List.map
-		(fun fi -> fi.name,fi.idx + 1 ,fi.types) 
-		(pre_info@others_infos)
-	    in 
-	    if other_fix_infos = [] 
-	    then
-	      (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
-	    else
-	      h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
-		other_fix_infos
-	| _ -> anomaly "Not a valid information"
-    in
-    let first_tac : tactic = (* every operations until fix creations *)
-      tclTHENSEQ 
-	[ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); 
-	  (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); 
-	  (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); 
-	  (* observe_tac "building fixes" *) mk_fixes;
-	]
-    in
-    let intros_after_fixes : tactic = 
-      fun gl -> 
-	let ctxt,pte_app =  (Sign.decompose_prod_assum (pf_concl gl)) in
-	let pte,pte_args = (decompose_app pte_app) in
-	try
-	  let pte = try destVar pte with _ -> anomaly "Property is not a variable"  in 
-	  let fix_info = Idmap.find  pte ptes_to_fix in
-	  let nb_args = fix_info.nb_realargs in 
-	  tclTHENSEQ
-	    [
-	      (* observe_tac ("introducing args") *) (tclDO nb_args intro);
-	      (fun g -> (* replacement of the function by its body *)
-		 let args = nLastHyps nb_args g in 
-		 let fix_body = fix_info.body_with_param in
-(* 		 observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
-		 let args_id = List.map (fun (id,_,_) -> id) args in
-		 let dyn_infos = 
-		   {
-		     nb_rec_hyps = -100;
-		     rec_hyps = [];
-		     info = 
-		       Reductionops.nf_betaiota Evd.empty
-			 (applist(fix_body,List.rev_map mkVar args_id));
-		     eq_hyps = []
-		   }
-		 in
-		 tclTHENSEQ
-		   [
-(* 		     observe_tac "do_replace"  *)
-		       (do_replace 
-			  full_params 
-			  (fix_info.idx + List.length princ_params) 
-			  (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
-			  (all_funs.(fix_info.num_in_block)) 
-			  fix_info.num_in_block 
-			  all_funs
-		       );
-(* 		     observe_tac "do_replace"  *)
-(* 		       (do_replace princ_info.params fix_info.idx args_id *)
-(* 			  (List.hd (List.rev pte_args)) fix_body); *)
-		     let do_prove = 
-		       build_proof 
-			 interactive_proof
-			 (Array.to_list fnames) 
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
-		     in
-		     let prove_tac branches  = 
-		       let dyn_infos = 
-			 {dyn_infos with 
-			    rec_hyps = branches;
-			    nb_rec_hyps = List.length branches
-			 }
-		       in
-		       (* observe_tac "cleaning" *) (clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix) 
-			 do_prove 
-			 dyn_infos)
-		     in
-(* 		     observe (str "branches := " ++ *)
-(* 				prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++  fnl () ++ *)
-(* 			   str "args := " ++ prlist_with_sep spc Ppconstr.pr_id  args_id *)
-			   
-(* 			   ); *)
-		     (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac 
-		       (List.rev_map id_of_decl princ_info.branches) 
-		       (List.rev args_id))
-		   ]
-		   g
-	      );
-	    ] gl
-	with Not_found ->
-	  let nb_args = min (princ_info.nargs) (List.length ctxt) in
-	  tclTHENSEQ
-	    [
-	      tclDO nb_args intro;
-	      (fun g -> (* replacement of the function by its body *)
-		 let args = nLastHyps nb_args g in 
-		 let args_id = List.map (fun (id,_,_) -> id) args in
-		 let dyn_infos = 
-		   {
-		     nb_rec_hyps = -100;
-		     rec_hyps = [];
-		     info = 
-		       Reductionops.nf_betaiota Evd.empty 
-			 (applist(fbody_with_full_params,
-				  (List.rev_map var_of_decl princ_params)@
-				    (List.rev_map mkVar args_id)
-				 ));
-		     eq_hyps = []
-		   }
-		 in
-		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
-		 tclTHENSEQ
-		   [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
-		    let do_prove = 
-		      build_proof 
-			interactive_proof
-			(Array.to_list fnames) 
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
-		    in
-		    let prove_tac branches  = 
-		      let dyn_infos = 
-			 {dyn_infos with 
-			    rec_hyps = branches;
-			    nb_rec_hyps = List.length branches
-			 }
-		      in
-		       clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix) 
-			 do_prove 
-			 dyn_infos
-		    in
-		    instanciate_hyps_with_args prove_tac 
-		       (List.rev_map id_of_decl princ_info.branches) 
-		      (List.rev args_id)
-		   ]
-		   g
-	      )
-	    ] 
-	  gl
-    in
-    tclTHEN 
-      first_tac
-      intros_after_fixes
-      g
-	    
-
-
-
-
-
-(* Proof of principles of general functions *) 
-let h_id = Recdef.h_id
-and hrec_id = Recdef.hrec_id
-and acc_inv_id = Recdef.acc_inv_id
-and ltof_ref = Recdef.ltof_ref
-and acc_rel = Recdef.acc_rel
-and well_founded = Recdef.well_founded
-and delayed_force = Recdef.delayed_force
-and h_intros = Recdef.h_intros
-and list_rewrite = Recdef.list_rewrite
-and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
-
-
-
-
-
-let prove_with_tcc tcc_lemma_constr eqs : tactic =
-  match !tcc_lemma_constr with
-    | None -> anomaly "No tcc proof !!"
-    | Some lemma ->
-	fun gls ->
-(* 	  let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in *)
-(* 	  let ids = hid::pf_ids_of_hyps gls in  *)
-	  tclTHENSEQ
-	    [
-(* 	      generalize [lemma]; *)
-(* 	      h_intro hid; *)
-(* 	      Elim.h_decompose_and (mkVar hid); *)
-	      tclTRY(list_rewrite true eqs);
-(* 	      (fun g ->  *)
-(* 		 let ids' = pf_ids_of_hyps g in  *)
-(* 		 let ids = List.filter (fun id -> not (List.mem id ids)) ids' in  *)
-(* 		 rewrite *)
-(* 	      ) *)
-	      Eauto.gen_eauto false (false,5) [] (Some [])
-	    ]
-	    gls
-
-
-let backtrack_eqs_until_hrec hrec eqs : tactic = 
-  fun gls -> 
-    let eqs = List.map mkVar eqs in 
-    let rewrite = 
-      tclFIRST (List.map Equality.rewriteRL eqs )
-    in 
-    let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in 
-    let f_app = array_last (snd (destApp hrec_concl)) in 
-    let f =  (fst (destApp f_app)) in 
-    let rec backtrack : tactic = 
-      fun g -> 
-	let f_app = array_last (snd (destApp (pf_concl g))) in 
-	match kind_of_term f_app with 
-	  | App(f',_) when eq_constr f' f -> tclIDTAC g
-	  | _ -> tclTHEN rewrite backtrack g
-    in
-    backtrack gls
-
-    
-    
-let build_clause eqs = 
-  {
-    Tacexpr.onhyps = 
-      Some (List.map 
-	      (fun id -> (Rawterm.all_occurrences_expr,id),InHyp)
-	      eqs
-	   );
-    Tacexpr.concl_occs = Rawterm.no_occurrences_expr 
-  }
-
-let rec rewrite_eqs_in_eqs eqs = 
-  match eqs with 
-    | [] -> tclIDTAC
-    | eq::eqs -> 
-	
-	  tclTHEN 
-	    (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 = 
-  fun gls ->
-    (tclTHENSEQ 
-       [
-	 backtrack_eqs_until_hrec hrec eqs;
-	 (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
-	 (tclTHENS  (* We must have exactly ONE subgoal !*)
-	    (apply (mkVar hrec))
-	    [ tclTHENSEQ 
-		[
-		  keep (tcc_hyps@eqs);
-		  apply (Lazy.force acc_inv);
-		  (fun g -> 
-		     if is_mes 
-		     then 
-		       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));
-			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]
-				      [Auto.Hint_db.empty empty_transparent_state false]
-				  )
-			   )
-			)
-		       ]
-		    )
-		]
-	    ])
-       ])
-      gls
-      
-
-let is_valid_hypothesis predicates_name =
-  let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
-  let is_pte typ =
-    if isApp typ
-    then
-      let pte,_ = destApp typ in
-      if isVar pte
-      then Idset.mem (destVar pte) predicates_name
-      else false
-    else false
-  in
-  let rec is_valid_hypothesis typ =
-    is_pte typ ||
-      match kind_of_term typ with 
-	| Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
-	| _ -> false 
-  in
-  is_valid_hypothesis 
-
-let prove_principle_for_gen
-    (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
-    rec_arg_num rec_arg_type relation gl = 
-  let princ_type = pf_concl gl in 
-  let princ_info = compute_elim_sig princ_type in 
-  let fresh_id = 
-    let avoid = ref (pf_ids_of_hyps gl) in 
-    fun na -> 
-      let new_id = 
-	  match na with 
-	    | Name id -> fresh_id !avoid (string_of_id id) 
-	    | Anonymous -> fresh_id !avoid "H" 
-      in
-      avoid := new_id :: !avoid;
-      Name new_id
-  in
-  let fresh_decl (na,b,t) = (fresh_id na,b,t) in
-  let princ_info : elim_scheme = 
-    { princ_info with 
-	params = List.map fresh_decl princ_info.params;
-	predicates = List.map fresh_decl princ_info.predicates; 
-	branches = List.map fresh_decl princ_info.branches; 
-	args = List.map fresh_decl princ_info.args
-    }
-  in
-  let wf_tac = 
-    if is_mes 
-    then 
-      (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None)
-    else fun _ -> prove_with_tcc tcc_lemma_ref []
-  in
-  let real_rec_arg_num = rec_arg_num - princ_info.nparams in 
-  let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in 
-(*   observe ( *)
-(*     str "princ_type := " ++ pr_lconstr  princ_type ++ fnl () ++ *)
-(*     str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++  *)
-      
-(*       str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++  *)
-(*     str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++  *)
-(* 	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
-(* 	     str "npost_rec_arg := " ++ int npost_rec_arg ); *)
-  let (post_rec_arg,pre_rec_arg) = 
-    Util.list_chop npost_rec_arg princ_info.args
-  in
-  let rec_arg_id = 
-    match List.rev post_rec_arg with 
-      | (Name id,_,_)::_ -> id 
-      | _ -> assert false 
-  in
-(*   observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
-  let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in 
-  let relation = substl subst_constrs relation in 
-  let input_type = substl subst_constrs rec_arg_type in 
-  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in 
-  let acc_rec_arg_id = 
-    Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
-  in 
-  let revert l = 
-    tclTHEN (h_generalize (List.map mkVar l)) (clear l) 
-  in
-  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in 
-  let prove_rec_arg_acc g = 
-      ((* observe_tac "prove_rec_arg_acc"  *)
-	 (tclCOMPLETE
-	    (tclTHEN
-	       (assert_by (Name wf_thm_id)  
-		  (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
-	       (
-		 (* observe_tac  *)
-(* 		   "apply wf_thm"  *)
-		 h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))
-	       )
-	    )
-	 )
-      )
-      g
-  in
-  let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
-  let lemma = 
-    match !tcc_lemma_ref with 
-     | 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 tcc_list = ref [] in
-  let start_tac gls = 
-    let hyps = pf_ids_of_hyps gls in 
-      let hid = 
-	next_global_ident_away true 
-	  (id_of_string "prov") 
-	  hyps
-      in
-      tclTHENSEQ
-	[
-	  generalize [lemma];
-	  h_intro hid;
-	  Elim.h_decompose_and (mkVar hid);
-	  (fun g -> 
-	     let new_hyps = pf_ids_of_hyps g in 
-	     tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
-	     if !tcc_list = []
-	     then 
-	       begin 
-		 tcc_list := [hid];
-		 tclIDTAC g
-	       end
-	     else thin [hid] g
-	  )
-	  ]
-	  gls
-  in
-  tclTHENSEQ
-    [ 	      
-      observe_tac "start_tac" start_tac;
-      h_intros 
-	(List.rev_map (fun (na,_,_) -> Nameops.out_name na) 
-	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
-	);
-      (* observe_tac "" *) (assert_by
-	 (Name acc_rec_arg_id)
- 	 (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
-	 (prove_rec_arg_acc)
-      );
-(*       observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
-(*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++  *)
-(* 			   str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
-      (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); 
-(*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
-      h_intros (List.rev (acc_rec_arg_id::args_ids));
-      Equality.rewriteLR (mkConst eq_ref);
-      (* observe_tac "finish" *) (fun gl' -> 
-	 let body = 
-	   let _,args = destApp (pf_concl gl') in 
-	   array_last args
-	 in
-	 let body_info rec_hyps = 
-	   {
-	     nb_rec_hyps = List.length rec_hyps;
-	     rec_hyps = rec_hyps;
-	     eq_hyps = [];
-	     info = body
-	   }
-	 in 
-	 let acc_inv = 
-	   lazy (
-	     mkApp (
-	       delayed_force acc_inv_id,
-	       [|input_type;relation;mkVar rec_arg_id|]
-	     )
-	   )
-	 in
-	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
-	 let predicates_names = 
-	   List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
-	 in
-	 let pte_info = 
-	   { proving_tac =
-	       (fun eqs -> 
-(* 		  msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id  !tcc_list); *)
-(* 		  msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *)
-(* 		  msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id  (List.map  (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *)
-(* 		  msgnl (str "acc_rec_arg_id := "++  Ppconstr.pr_id acc_rec_arg_id); *)
-(* 		  msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id  eqs); *)
-
-		  (* observe_tac "new_prove_with_tcc"  *)
-		    (new_prove_with_tcc  
-		       is_mes acc_inv fix_id  
-		         
-		       (!tcc_list@(List.map 
-			   (fun (na,_,_) -> (Nameops.out_name na)) 
-			   (princ_info.args@princ_info.params)
-			)@ ([acc_rec_arg_id])) eqs
-		    )
-	       
-	       );
-	     is_valid = is_valid_hypothesis predicates_names
-	   }
-	 in
-	 let ptes_info : pte_info Idmap.t = 
-	   List.fold_left
-	     (fun map pte_id -> 
-		Idmap.add pte_id 
-		  pte_info			       
-		  map
-	     )
-	     Idmap.empty
-	     predicates_names
-	 in
-	 let make_proof rec_hyps = 
-	   build_proof 
-	     false 
-	     [f_ref]
-	     ptes_info
-	     (body_info rec_hyps)
-	 in
-	 (* observe_tac "instanciate_hyps_with_args"  *)
-	   (instanciate_hyps_with_args 
-	      make_proof
-	      (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
-	      (List.rev args_ids)
-	   )
-	   gl'
-      )
-			   
-    ]
-    gl    
-
-
-
-
-
-
-
-
diff --git a/contrib/funind/functional_principles_proofs.mli b/contrib/funind/functional_principles_proofs.mli
deleted file mode 100644
index 62eb528e..00000000
--- a/contrib/funind/functional_principles_proofs.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-open Names
-open Term
-
-val prove_princ_for_struct :
-  bool ->
-  int -> constant array -> constr array -> int -> Tacmach.tactic
-
-
-val prove_principle_for_gen : 
-  constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *)
-  constr option ref -> (* a pointer to the obligation proofs lemma *)
-  bool -> (* is that function uses measure *)
-  int -> (* the number of recursive argument *) 
-  types -> (* the type of the recursive argument *)
-  constr -> (* the wf relation used to prove the function *)
-  Tacmach.tactic
-
-
-(* val is_pte  : rel_declaration -> bool  *)
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
deleted file mode 100644
index b03bdf31..00000000
--- a/contrib/funind/functional_principles_types.ml
+++ /dev/null
@@ -1,733 +0,0 @@
-open Printer
-open Util
-open Term
-open Termops 
-open Names 
-open Declarations
-open Pp
-open Entries
-open Hiddentac
-open Evd
-open Tacmach
-open Proof_type
-open Tacticals
-open Tactics
-open Indfun_common
-open Functional_principles_proofs
-
-exception Toberemoved_with_rel of int*constr
-exception Toberemoved
-
-
-let pr_elim_scheme el = 
-  let env = Global.env () in 
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
-  let env = Environ.push_rel_context el.params env in 
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
-  let env = Environ.push_rel_context el.predicates env in 
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
-  let env = Environ.push_rel_context el.branches env in 
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
-  let env = Environ.push_rel_context el.args env in 
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
-let observe s = 
-  if do_observe () 
-  then Pp.msgnl s 
-
-
-let pr_elim_scheme el = 
-  let env = Global.env () in 
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
-  let env = Environ.push_rel_context el.params env in 
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
-  let env = Environ.push_rel_context el.predicates env in 
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
-  let env = Environ.push_rel_context el.branches env in 
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
-  let env = Environ.push_rel_context el.args env in 
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
-let observe s = 
-  if do_observe () 
-  then Pp.msgnl s 
-
-(* 
-   Transform an inductive induction principle into 
-   a functional one
-*)  
-let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
-  let princ_type_info = compute_elim_sig princ_type in 
-  let env = Global.env () in 
-  let env_with_params = Environ.push_rel_context princ_type_info.params env in
-  let tbl = Hashtbl.create 792 in
-  let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context)  : Sign.rel_context = 
-    match predicates with 
-    | [] -> []
-    |(Name x,v,t)::predicates -> 
-       let id =  Nameops.next_ident_away x avoid in 
-       Hashtbl.add tbl id x;
-       (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
-    | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
-  in
-  let avoid = (Termops.ids_of_context env_with_params ) in
-  let princ_type_info = 
-    { princ_type_info with
-	predicates = change_predicates_names avoid princ_type_info.predicates
-    }
-  in 
-(*   observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
-(*   observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
-  let change_predicate_sort i (x,_,t) = 
-    let new_sort = sorts.(i) in
-    let args,_ = decompose_prod t in 
-    let real_args = 
-      if princ_type_info.indarg_in_concl 
-      then List.tl args 
-      else args
-    in
-    Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) 
-  in
-  let new_predicates = 
-    list_map_i
-      change_predicate_sort 
-      0
-      princ_type_info.predicates
-  in
-  let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
-  let rel_as_kn = 
-    fst (match princ_type_info.indref with
-	   | Some (Libnames.IndRef ind) -> ind 
-	   | _ -> error "Not a valid predicate"
-	)
-  in
-  let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
-  let is_pte = 
-    let set = List.fold_right Idset.add ptes_vars Idset.empty in 
-    fun t -> 
-      match kind_of_term t with 
-	| Var id -> Idset.mem id set 
-	| _ -> false 
-  in
-  let pre_princ = 
-    it_mkProd_or_LetIn 
-      ~init:
-      (it_mkProd_or_LetIn 
-	 ~init:(Option.fold_right
-			   mkProd_or_LetIn
-			   princ_type_info.indarg
-			   princ_type_info.concl
-			)
-	 princ_type_info.args
-      )
-      princ_type_info.branches
-  in
-  let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
-  let is_dom c =
-    match kind_of_term c with
-      | Ind((u,_)) -> u = rel_as_kn
-      | Construct((u,_),_) -> u = rel_as_kn
-      | _ -> false
-  in
-  let get_fun_num c =
-    match kind_of_term c with
-      | Ind(_,num) -> num
-      | Construct((_,num),_) -> num
-      | _ -> assert false
-  in
-  let dummy_var = mkVar (id_of_string "________") in
-  let mk_replacement c i args =
-    let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in 
-(*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
-    res
-  in
-  let rec has_dummy_var t  =
-    fold_constr
-      (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t))
-      false
-      t
-  in
-  let rec compute_new_princ_type remove env pre_princ : types*(constr list) =
-    let (new_princ_type,_) as res =
-      match kind_of_term pre_princ with
-	| Rel n ->
-	    begin
-	      try match Environ.lookup_rel n env with
-		| _,_,t when is_dom t -> raise Toberemoved
-		| _ -> pre_princ,[] with Not_found -> assert false
-	    end
-	| Prod(x,t,b) ->
-	    compute_new_princ_type_for_binder remove mkProd env x t b
-	| Lambda(x,t,b) ->
-	    compute_new_princ_type_for_binder  remove mkLambda env x t b
-	| Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
-	| App(f,args) when is_dom f ->
-	    let var_to_be_removed = destRel (array_last args) in
-	    let num = get_fun_num f in
-	    raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
-	| App(f,args) ->
-	    let args = 
-	      if is_pte f && remove 
-	      then array_get_start args 
-	      else args 
-	    in
-	    let new_args,binders_to_remove =
-	      Array.fold_right (compute_new_princ_type_with_acc remove env)
-		args
-		([],[])
-	    in
-	    let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in
-	    applist(new_f, new_args),
-	    list_union_eq eq_constr binders_to_remove_from_f binders_to_remove
-	| LetIn(x,v,t,b) ->
-	    compute_new_princ_type_for_letin remove env x v t b
-	| _ -> pre_princ,[]
-    in
-(*     let _ = match kind_of_term pre_princ with *)
-(* 	| Prod _ -> *)
-(* 	    observe(str "compute_new_princ_type for "++ *)
-(* 	      pr_lconstr_env env pre_princ ++ *)
-(* 	      str" is "++ *)
-(* 	      pr_lconstr_env env new_princ_type ++ fnl ()) *)
-(* 	| _ -> () in *)
-    res
-	
-  and compute_new_princ_type_for_binder remove bind_fun env x t b =
-    begin
-      try
-	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
-	let new_x : name = get_name (ids_of_context env) x in
-	let new_env = Environ.push_rel (x,None,t) env in
-	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
-	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
-	 else
-	   (
-	     bind_fun(new_x,new_t,new_b),
-	     list_union_eq
-	       eq_constr
-	       binders_to_remove_from_t
-	       (List.map pop binders_to_remove_from_b)
-	   )
-
-       with
-	 | Toberemoved ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
-	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map pop binders_to_remove_from_b
-	| Toberemoved_with_rel (n,c) ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
-	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
-    end
-  and compute_new_princ_type_for_letin remove env x v t b =
-    begin
-      try
-	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
-	let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
-	let new_x : name = get_name (ids_of_context env) x in
-	let new_env = Environ.push_rel (x,Some v,t) env in
-	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
-	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
-	then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
-	else
-	  (
-	    mkLetIn(new_x,new_v,new_t,new_b),
-	    list_union_eq
-	      eq_constr
-	      (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
-	      (List.map pop binders_to_remove_from_b)
-	  )
-	
-      with
-	| Toberemoved ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
-	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
-	    new_b, List.map pop binders_to_remove_from_b
-	| Toberemoved_with_rel (n,c) ->
-(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
-	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
-	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
-    end
-  and  compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc)  =
-    let new_e,to_remove_from_e = compute_new_princ_type remove env e
-    in
-    new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
-  in
-(*   observe (str "Computing new principe from " ++ pr_lconstr_env  env_with_params_and_predicates pre_princ); *)
-  let pre_res,_ = 
-    compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ 
-  in 
-  let pre_res = 
-    replace_vars 
-      (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
-      (lift (List.length ptes_vars) pre_res)
-  in
-  it_mkProd_or_LetIn  	 
-    ~init:(it_mkProd_or_LetIn 
-	     ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) 
-			      new_predicates)
-	  )
-    princ_type_info.params
-    
-  
-
-let change_property_sort toSort princ princName = 
-  let princ_info = compute_elim_sig princ in 
-  let change_sort_in_predicate (x,v,t) = 
-    (x,None,
-     let args,_ = decompose_prod t in 
-     compose_prod args (mkSort toSort)
-    )
-  in 
-  let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in 
-  let init = 
-    let nargs =  (princ_info.nparams + (List.length  princ_info.predicates)) in 
-    mkApp(princName_as_constr,
-	  Array.init nargs
-	    (fun i -> mkRel (nargs - i )))
-  in
-  it_mkLambda_or_LetIn
-    ~init: 
-    (it_mkLambda_or_LetIn ~init 
-       (List.map change_sort_in_predicate princ_info.predicates)
-    )
-    princ_info.params
-    
-
-let pp_dur time time' = 
-  str (string_of_float (System.time_difference time time'))
-
-(* let qed () = save_named true  *)
-let defined () = 
-  try 
-    Command.save_named false 
-  with 
-    | UserError("extract_proof",msg) ->
-	Util.errorlabstrm
-	  "defined"
-	  ((try
-	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
-	    with _ -> mt ()
-	   ) ++msg)
-    | e -> raise e
-
-
-
-let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
-  (* First we get the type of the old graph principle *)
-  let mutr_nparams = (compute_elim_sig old_princ_type).nparams in 
-  (*   let time1 = System.get_time ()  in *)
-  let new_principle_type =
-    compute_new_princ_type_from_rel
-      (Array.map mkConst funs)
-      sorts
-      old_princ_type
-  in
-  (*    let time2 = System.get_time ()  in *)
-  (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
-  (*    observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *)
-  let new_princ_name =
-    next_global_ident_away true (id_of_string "___________princ_________") []
-  in
-  begin
-    Command.start_proof
-      new_princ_name
-      (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-      new_principle_type
-      (hook new_principle_type)
-    ;
-    (*       let _tim1 = System.get_time ()  in *)
-    Pfedit.by  (proof_tac (Array.map mkConst funs) mutr_nparams);
-    (*       let _tim2 =  System.get_time ()  in *)
-    (* 	begin *)
-    (* 	  let dur1 = System.time_difference tim1 tim2 in *)
-    (* 	  Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
-    (* 	end; *)
-    get_proof_clean true 
-  end
-
-
-
-let generate_functional_principle
-    interactive_proof
-    old_princ_type sorts new_princ_name funs i proof_tac
-    =
-  try 
-  let f = funs.(i) in
-  let type_sort = Termops.new_sort_in_family InType in
-  let new_sorts =
-    match sorts with
-      | None -> Array.make (Array.length funs) (type_sort)
-      | Some a -> a
-  in
-  let base_new_princ_name,new_princ_name =
-    match new_princ_name with
-      | Some (id) -> id,id
-      | None ->
-	  let id_of_f = id_of_label (con_label f) in
-	  id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
-  in
-  let names = ref [new_princ_name] in
-  let hook new_principle_type _ _  =
-    if sorts = None
-    then
-      (*     let id_of_f = id_of_label (con_label f) in *)
-      let register_with_sort fam_sort =
-	let s = Termops.new_sort_in_family fam_sort in
-	let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
-	let value = change_property_sort s new_principle_type new_princ_name in
-	(*       Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
-	let ce =
-	  { const_entry_body = value;
-	    const_entry_type = None;
-	    const_entry_opaque = false;
-	    const_entry_boxed = Flags.boxed_definitions()
-	  }
-	in
-	ignore(
-	  Declare.declare_constant
-	    name
-	    (Entries.DefinitionEntry ce,
-	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
-	    )
-	);
-	Flags.if_verbose 
-	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) 
-	  name;
-	names := name :: !names
-      in
-      register_with_sort InProp;
-      register_with_sort InSet
-  in
-  let (id,(entry,g_kind,hook)) =
-    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook 
-  in
-  (* Pr  1278 :
-     Don't forget to close the goal if an error is raised !!!!
-  *) 
-  save false new_princ_name entry g_kind hook
-  with e -> 
-    begin
-      begin 
-	try 
-	  let id = Pfedit.get_current_proof_name () in 
-	  let s = string_of_id id in 
-	  let n = String.length "___________princ_________" in
-	  if String.length s >= n 
-	  then if String.sub s 0 n = "___________princ_________" 
-	  then Pfedit.delete_current_proof ()
-	  else ()
-	  else ()
-	with _ -> ()
-      end;
-      raise (Defining_principle e)
-    end
-(*   defined  () *)
-
-
-exception Not_Rec
-
-let get_funs_constant mp dp = 
-  let rec get_funs_constant const e : (Names.constant*int) array = 
-    match kind_of_term (snd (decompose_lam e)) with 
-      | Fix((_,(na,_,_))) -> 
-	  Array.mapi 
-	    (fun i na -> 
-	       match na with 
-		 | Name id -> 
-		     let const = make_con mp dp (label_of_id id) in 
-		     const,i
-		 | Anonymous -> 
-		     anomaly "Anonymous fix" 
-	    )
-	    na
-      | _ -> [|const,0|]
-  in
-  function const -> 
-    let find_constant_body const = 
-      match (Global.lookup_constant const ).const_body with
-	| Some b ->
-	    let body = force b in
-	    let body = Tacred.cbv_norm_flags
-	      (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-	      (Global.env ())
-	      (Evd.empty)
-	      body
-	    in
-	    body
-	| None -> error ( "Cannot define a principle over an axiom ")
-    in
-    let f = find_constant_body const in
-    let l_const = get_funs_constant const f in 
-    (* 
-       We need to check that all the functions found are in the same block 
-       to prevent Reset stange thing
-    *) 
-    let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in 
-    let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in 
-    (* all the paremeter must be equal*) 
-    let _check_params = 
-      let first_params = List.hd l_params  in 
-      List.iter 
-	(fun params -> 
-	   if not ((=) first_params params) 
-	   then error "Not a mutal recursive block"
-	)
-	l_params
-    in
-    (* The bodies has to be very similar *) 
-    let _check_bodies = 
-      try 
-	let extract_info is_first body = 
-	  match kind_of_term body with 
-	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
-	    | _ -> 
-		if is_first && (List.length l_bodies = 1) 
-		then raise Not_Rec
-		else error "Not a mutal recursive block"
-	in
-	let first_infos = extract_info true (List.hd l_bodies) in 
-	let check body  = (* Hope this is correct *)
-	  if not (first_infos = (extract_info false body)) 
-	  then  error "Not a mutal recursive block"
-	in 
-	List.iter check l_bodies
-      with Not_Rec -> ()
-    in
-    l_const
-
-exception No_graph_found 
-exception Found_type of int 
-
-let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = 
-  let env = Global.env () 
-  and sigma = Evd.empty in
-  let funs = List.map fst fas in 
-  let first_fun = List.hd funs in 
-
-
-  let funs_mp,funs_dp,_ = Names.repr_con first_fun in
-  let first_fun_kn = 
-    try 
-      fst (find_Function_infos  first_fun).graph_ind 
-    with Not_found -> raise No_graph_found 
-  in
-  let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
-  let this_block_funs = Array.map fst this_block_funs_indexes in 
-  let prop_sort = InProp in
-  let funs_indexes = 
-    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
-    List.map
-      (function const -> List.assoc const this_block_funs_indexes)
-      funs
-  in
-  let ind_list = 
-    List.map 
-      (fun (idx) -> 
-	 let ind = first_fun_kn,idx in 
-	 let (mib,mip) = Global.lookup_inductive ind in
-	 ind,mib,mip,true,prop_sort
-      )
-      funs_indexes
-  in
-  let l_schemes = 
-    List.map
-      (Typing.type_of env sigma) 
-      (Indrec.build_mutual_indrec env sigma ind_list)
-  in 
-  let i = ref (-1) in
-  let sorts = 
-    List.rev_map (fun (_,x) -> 
-		Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
-	     ) 
-      fas 
-  in
-  (* We create the first priciple by tactic *)
-  let first_type,other_princ_types = 
-    match l_schemes with 
-	s::l_schemes -> s,l_schemes
-      | _ -> anomaly ""
-  in
-  let (_,(const,_,_)) = 
-    try
-      build_functional_principle false
-	first_type
-	(Array.of_list sorts)
-	this_block_funs
-	0
-	(prove_princ_for_struct false 0 (Array.of_list funs))
-	(fun _ _ _ -> ())
-  with e -> 
-    begin
-      begin 
-	try 
-	  let id = Pfedit.get_current_proof_name () in 
-	  let s = string_of_id id in 
-	  let n = String.length "___________princ_________" in
-	  if String.length s >= n 
-	  then if String.sub s 0 n = "___________princ_________" 
-	  then Pfedit.delete_current_proof ()
-	  else ()
-	  else ()
-	with _ -> ()
-      end;
-      raise (Defining_principle e)
-    end
-
-  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
-    [const]
-  else
-    let other_fun_princ_types = 
-      let funs = Array.map mkConst this_block_funs in 
-      let sorts = Array.of_list sorts in 
-      List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
-    in
-    let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in 
-    let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
-    let (idxs,_),(_,ta,_ as decl) = destFix fix in 
-    let other_result = 
-      List.map (* we can now compute the other principles *)
-	(fun scheme_type -> 
-	   incr i;
-	   observe (Printer.pr_lconstr scheme_type);
-	   let type_concl = snd (Sign.decompose_prod_assum scheme_type) in 
-	   let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in 
-	   let f = fst (decompose_app applied_f) in
-	   try (* we search the number of the function in the fix block (name of the function) *)
-	     Array.iteri 
-	     (fun j t -> 
-		let t =  snd (Sign.decompose_prod_assum t) in 
-		let applied_g = List.hd (List.rev (snd (decompose_app t))) in 
-		let g = fst (decompose_app applied_g) in
-		if eq_constr f g
-		then raise (Found_type j); 
-		observe (Printer.pr_lconstr f ++ str " <> " ++
-			   Printer.pr_lconstr g)
-		  
-	     )
-	     ta;
-	   (* If we reach this point, the two principle are not mutually recursive 
-	      We fall back to the previous method 
-	   *)
-	     let (_,(const,_,_)) = 
-	       build_functional_principle
-		 false 
-		 (List.nth other_princ_types (!i - 1))
-		 (Array.of_list sorts)
-		 this_block_funs
-		 !i
-		 (prove_princ_for_struct false !i (Array.of_list funs))
-		 (fun _ _ _ -> ())
-	     in 
-	     const
-	 with Found_type i -> 
-	   let princ_body = 
-	     Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
-	   in 
-	   {const with 
-	      Entries.const_entry_body = princ_body; 
-	      Entries.const_entry_type = Some scheme_type
-	   }
-      )
-      other_fun_princ_types
-    in
-    const::other_result
-
-let build_scheme fas = 
-  let bodies_types = 
-    make_scheme 
-      (List.map 
-	 (fun (_,f,sort) -> 
-	    let f_as_constant =
-	      try
-		match Nametab.global f with 
-		  | Libnames.ConstRef c -> c 
-		  | _ -> Util.error "Functional Scheme can only be used with functions"
-	      with Not_found ->
-	      	Util.error ("Cannot find "^ Libnames.string_of_reference f)
-	    in
-	    (f_as_constant,sort)
-	 ) 
-	 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));
-       Flags.if_verbose 
-	 (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
-    )
-    fas
-    bodies_types
-  
-
-
-let build_case_scheme fa = 
-  let env = Global.env () 
-  and sigma = Evd.empty in
-(*   let id_to_constr id =  *)
-(*     Tacinterp.constr_of_id env  id *)
-(*   in  *)
-  let funs =  (fun (_,f,_) ->  
-		 try Libnames.constr_of_global (Nametab.global f)
-		 with Not_found -> 
-		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in 
-  let first_fun = destConst  funs in 
-
-  let funs_mp,funs_dp,_ = Names.repr_con first_fun in
-  let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
-
-
-
-  let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
-  let this_block_funs = Array.map fst this_block_funs_indexes in 
-  let prop_sort = InProp in
-  let funs_indexes = 
-    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
-    List.assoc (destConst funs) this_block_funs_indexes
-  in
-  let ind_fun = 
-	 let ind = first_fun_kn,funs_indexes in 
-	 ind,prop_sort
-  in
-  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf)  ind_fun) in 
-  let sorts =
-    (fun (_,_,x) ->
-       Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
-    )
-      fa
-  in
-  let princ_name =  (fun (x,_,_) -> x) fa in
-  let _ = 
-(*     observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *)
-(* 	       pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *)
-(* 	    ); *)
-    generate_functional_principle
-      false
-      scheme_type
-      (Some ([|sorts|]))
-      (Some princ_name)
-      this_block_funs
-      0
-      (prove_princ_for_struct false 0 [|destConst funs|])
-  in
-  ()
diff --git a/contrib/funind/functional_principles_types.mli b/contrib/funind/functional_principles_types.mli
deleted file mode 100644
index cf28c6e6..00000000
--- a/contrib/funind/functional_principles_types.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-open Names
-open Term
-
-
-val generate_functional_principle : 
-  (* do we accept interactive proving *)
-  bool ->
-  (* induction principle on rel *) 
-  types ->
-  (* *)
-  sorts array option -> 
-  (* Name of the new principle *) 
-  (identifier) option -> 
-  (* the compute functions to use   *)
-  constant array -> 
-  (* We prove the nth- principle *)
-  int  ->
-  (* The tactic to use to make the proof w.r
-     the number of params
-  *)
-  (constr array -> int -> Tacmach.tactic) -> 
-  unit
-
-val compute_new_princ_type_from_rel : constr array -> sorts array -> 
-  types -> types
-
-
-exception No_graph_found
-
-val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list
-
-val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list ->  unit
-val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort)  ->  unit
-
diff --git a/contrib/funind/g_indfun.ml4 b/contrib/funind/g_indfun.ml4
deleted file mode 100644
index a79b46d9..00000000
--- a/contrib/funind/g_indfun.ml4
+++ /dev/null
@@ -1,524 +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        *)
-(************************************************************************)
-(*i camlp4deps: "parsing/grammar.cma" i*)
-open Util
-open Term
-open Names
-open Pp
-open Topconstr
-open Indfun_common 
-open Indfun
-open Genarg
-open Pcoq
-open Tacticals
-
-let pr_binding prc = function
-  | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ 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
-  | 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
-  | 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_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
-
-
-TACTIC EXTEND newfuninv
-   [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] -> 
-     [
-       Invfun.invfun hyp fname
-     ]
-END
-
-
-let pr_intro_as_pat prc _ _ pat = 
-  match pat with 
-    | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
-    | None -> mt ()
-
-
-ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
-|   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ] 
-| []  ->[ None ] 
-END
-
-
-
-
-TACTIC EXTEND newfunind
-   ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
-     [ 
-       let c = match cl with 
-	 | [] -> assert false
-	 | [c] -> c 
-	 | c::cl -> applist(c,cl)
-       in 
-       functional_induction true c  princl pat ]
-END
-(***** debug only ***)
-TACTIC EXTEND snewfunind
-   ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
-     [ 
-       let c = match cl with 
-	 | [] -> assert false
-	 | [c] -> c 
-	 | c::cl -> applist(c,cl)
-       in 
-       functional_induction false c princl pat ]
-END
-
-
-let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc
-
-ARGUMENT EXTEND constr_coma_sequence'
-  TYPED AS constr_list
-  PRINTED BY pr_constr_coma_sequence
-| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
-| [ constr(c) ] -> [ [c] ]
-END
-
-let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
-
-ARGUMENT EXTEND auto_using'
-  TYPED AS constr_list
-  PRINTED BY pr_auto_using
-| [ "using" constr_coma_sequence'(l) ] -> [ l ]
-| [ ] -> [ [] ]
-END
-
-let pr_rec_annotation2_aux s r id l =
-  str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ 
-    Util.pr_opt Nameops.pr_id id ++ 
-    Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}"
-
-let pr_rec_annotation2 = function
-  | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}"
-  | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l
-  | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l
-
-VERNAC ARGUMENT EXTEND rec_annotation2
-PRINTED BY pr_rec_annotation2
-  [ "{"  "struct" ident(id)  "}"] -> [ Struct id ]
-| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
-| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] 
-END
-
-let pr_binder2 (idl,c) =
-  str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ 
-    str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")"
-
-VERNAC ARGUMENT EXTEND binder2
-PRINTED BY pr_binder2
-    [ "(" ne_ident_list(idl) ":" lconstr(c)  ")"] -> [ (idl,c) ]
-END
-
-let make_binder2 (idl,c) =
-  LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c)
-
-let pr_rec_definition2 (id,bl,annot,type_,def) =
-  Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ 
-    Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++
-    Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ 
-    Ppconstr.pr_lconstr_expr def
-
-VERNAC ARGUMENT EXTEND rec_definition2
-PRINTED BY pr_rec_definition2
- [ ident(id)  binder2_list(bl)
-     rec_annotation2_opt(annot) ":" lconstr(type_)
-	":=" lconstr(def)] ->
-    [ (id,bl,annot,type_,def) ]
-END
-
-let make_rec_definitions2 (id,bl,annot,type_,def) =
-     let bl = List.map make_binder2 bl in
-     let names = List.map snd (Topconstr.names_of_local_assums bl) in
-     let check_one_name () =
-       if List.length names > 1 then
-         Util.user_err_loc
-           (Util.dummy_loc,"Function",
-            Pp.str "the recursive argument needs to be specified");
-     in
-     let check_exists_args an =
-       try 
-	 let id = match an with 
-	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id 
-	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" 
-	 in 
-	 (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)
-	 )
-       with Failure "check_exists_args" ->  check_one_name ();annot
-     in
-     let ni =
-       match annot with
-         | None ->
-             annot
-	 | Some an ->
-	     check_exists_args an
-     in
-     ((Util.dummy_loc,id), ni, bl, type_, def)
-
-
-VERNAC COMMAND EXTEND Function
-   ["Function" ne_rec_definition2_list_sep(recsl,"with")] ->
-	[ 
-	  do_generate_principle false (List.map make_rec_definitions2 recsl); 
-	  
-	]
-END
-
-let pr_fun_scheme_arg (princ_name,fun_name,s) = 
-  Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ 
-  Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ 
-  Ppconstr.pr_rawsort s
-
-VERNAC ARGUMENT EXTEND fun_scheme_arg
-PRINTED BY pr_fun_scheme_arg
-| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] 
-END 
-
-
-let warning_error names e = 
-  match e with 
-    | Building_graph e -> 
-	Pp.msg_warning 
-	  (str "Cannot define graph(s) for " ++ 
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
-    | Defining_principle e -> 
-	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++ 
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
-	     if do_observe () then Cerrors.explain_exn e else mt ())
-    | _ -> anomaly ""
-
-
-VERNAC COMMAND EXTEND NewFunctionalScheme
-   ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
-    [
-      begin
-	try 
-	  Functional_principles_types.build_scheme fas
-	with Functional_principles_types.No_graph_found -> 
-	  begin
-	    match fas with 
-	      | (_,fun_name,_)::_ -> 
-		  begin
-		    begin
-		      make_graph (Nametab.global fun_name)
-		    end
-		    ;
-		    try Functional_principles_types.build_scheme fas
-		    with Functional_principles_types.No_graph_found -> 
-		      Util.error ("Cannot generate induction principle(s)")
-    		      | e -> 
-			  let names = List.map (fun (_,na,_) -> na) fas in 
-			  warning_error names e
-			    
-		  end
-	      | _ -> assert false (* we can only have non empty  list *)
-	  end
-    	  | e -> 
-	      let names = List.map (fun (_,na,_) -> na) fas in 
-	      warning_error names e
-
-      end
-    ]
-END
-(***** debug only ***)
-
-VERNAC COMMAND EXTEND NewFunctionalCase
-   ["Functional" "Case" fun_scheme_arg(fas) ] ->
-    [
-      Functional_principles_types.build_case_scheme fas
-    ]
-END
-
-(***** debug only ***)
-VERNAC COMMAND EXTEND GenerateGraph 
-["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
-END
-
-
-
-
-
-(* FINDUCTION *)
-
-(* comment this line to see debug msgs *)
-let msg x = () ;; let pr_lconstr c = str ""
-  (* uncomment this to see debugging *)
-let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
-let prlistconstr lc = List.iter prconstr lc
-let prstr s = msg(str s)
-let prNamedConstr s c = 
-  begin
-    msg(str "");
-    msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
-    msg(str "");
-  end
-
-
-
-(** Information about an occurrence of a function call (application)
-    inside a term. *)
-type fapp_info = {
-  fname: constr; (** The function applied *)
-  largs: constr list; (** List of arguments *)
-  free: bool; (** [true] if all arguments are debruijn free *)
-  max_rel: int; (** max debruijn index in the funcall *)
-  onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *)
-}
-
-
-(** [constr_head_match(a b c) a] returns true, false otherwise. *)
-let constr_head_match u t=
-  if isApp u 
-  then 
-    let uhd,args= destApp u in
-    uhd=t
-  else false
-
-(** [hdMatchSub inu t] returns the list of occurrences of [t] in
-    [inu]. DeBruijn are not pushed, so some of them may be unbound in
-    the result. *)
-let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
-  let subres = 
-    match kind_of_term inu with
-      | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> 
-	  hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
-      | Fix (_,(lna,tl,bl))  -> (* not sure Fix is correct *)
-	  Array.fold_left 
-	    (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) 
-	    [] bl
-      | _ -> (* Cofix will be wrong *)
-	  fold_constr 
-	    (fun l cstr -> 
-	      l @ hdMatchSub cstr test) [] inu in 
-  if not (test inu) then subres
-  else
-    let f,args = decompose_app inu in
-    let freeset = Termops.free_rels inu in
-    let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
-    {fname = f; largs = args; free = Util.Intset.is_empty freeset;
-    max_rel = max_rel; onlyvars = List.for_all isVar args } 
-    ::subres
-
-let mkEq typ c1 c2 = 
-  mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
-
-
-let poseq_unsafe idunsafe cstr gl =
-  let typ = Tacmach.pf_type_of gl cstr in
-  tclTHEN
-    (Tactics.letin_tac None (Name idunsafe) cstr None allClauses)
-    (tclTHENFIRST 
-      (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) 
-      Tactics.reflexivity)
-    gl
-  
-
-let poseq id cstr gl =
-  let x = Tactics.fresh_id [] id gl in
-  poseq_unsafe x cstr gl
-
-(* dirty? *)
-
-let list_constr_largs = ref []
-
-let rec poseq_list_ids_rec lcstr gl =
-  match lcstr with
-    | [] -> tclIDTAC gl
-    | c::lcstr' -> 
-	match kind_of_term c with
-	  | Var _ -> 
-	      (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
-	  | _ -> 
-	      let _ = prstr "c = " in
-	      let _ = prconstr c in
-	      let _ = prstr "\n" in
-	      let typ = Tacmach.pf_type_of gl c in
-	      let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in
-	      let x = Tactics.fresh_id [] cname gl in
-	      let _ = list_constr_largs:=mkVar x :: !list_constr_largs in
-	      let _ = prstr " list_constr_largs = " in
-	      let _ = prlistconstr !list_constr_largs in
-	      let _ = prstr "\n" in
-
-	      tclTHEN
-		(poseq_unsafe x c)
-		(poseq_list_ids_rec lcstr')
-		gl
-
-let poseq_list_ids lcstr gl = 
-  let _ = list_constr_largs := [] in
-  poseq_list_ids_rec lcstr gl
-
-(** [find_fapp test g] returns the list of [app_info] of all calls to
-    functions that satisfy [test] in the conclusion of goal g. Trivial
-    repetition (not modulo conversion) are deleted. *)
-let find_fapp (test:constr -> bool) g : fapp_info list = 
-  let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
-  let res = 
-    List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
-  (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
-  res)
-
-
-
-(** [finduction id filter g] tries to apply functional induction on
-    an occurence of function [id] in the conclusion of goal [g]. If
-    [id]=[None] then calls to any function are selected. In any case
-    [heuristic] is used to select the most pertinent occurrence. *)
-let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
-    (nexttac:Proof_type.tactic) g =
-  let test = match oid with
-    | Some id -> 
-	let idconstr = mkConst (const_of_id id) in
-	(fun u -> constr_head_match u idconstr) (* select only id *)
-    | None -> (fun u -> isApp u) in (* select calls to any function *)
-  let info_list = find_fapp test g in
-  let ordered_info_list = heuristic info_list in
-  prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); 
-  if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
-  let taclist: Proof_type.tactic list = 
-    List.map 
-      (fun info ->
-	(tclTHEN
-	  (tclTHEN (poseq_list_ids info.largs)
-	    (
-	      fun gl -> 
-		  (functional_induction 
-		    true (applist (info.fname, List.rev !list_constr_largs)) 
-		    None None) gl)) 
-	  nexttac)) ordered_info_list in
-  (* we try each (f t u v) until one does not fail *)
-  (* TODO: try also to mix functional schemes *)
-  tclFIRST taclist g
-
-
-
-
-(** [chose_heuristic oi x] returns the heuristic for reordering
-    (and/or forgetting some elts of) a list of occurrences of
-     function calls infos to chose first with functional induction. *)
-let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
-  match oi with
-    | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
-    | None -> 
-	(* Default heuristic: put first occurrences where all arguments
-	   are *bound* (meaning already introduced) variables *)
-	let ordering x y =
-	  if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *)
-	  else if x.free && x.onlyvars then -1
-	  else if y.free && y.onlyvars then 1
-	  else 0 (* both not pertinent *)
-	in
-	List.sort ordering
-
-
-
-TACTIC EXTEND finduction
-    ["finduction" ident(id) natural_opt(oi)] -> 
-      [ 
-	match oi with
-	  | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
-	  | _ -> 
-	      let heuristic = chose_heuristic oi in
-	      finduction (Some id) heuristic tclIDTAC
-      ]
-END
-
-
-
-TACTIC EXTEND fauto
-    [ "fauto" tactic(tac)] -> 
-      [
-	let heuristic = chose_heuristic None in
-	finduction None heuristic (snd tac)
-      ]
-  |
-    [ "fauto" ] -> 
-      [
-	let heuristic = chose_heuristic None in
-	finduction None heuristic tclIDTAC
-      ]
-
-END
-
-
-TACTIC EXTEND poseq
-  [ "poseq" ident(x) constr(c) ] -> 
-      [ poseq x c ]
-END
-
-VERNAC COMMAND EXTEND Showindinfo
-  [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
-END
-
-VERNAC COMMAND EXTEND MergeFunind
-  [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" 
-      "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(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
deleted file mode 100644
index b6b2cbd1..00000000
--- a/contrib/funind/indfun.ml
+++ /dev/null
@@ -1,752 +0,0 @@
-open Util
-open Names
-open Term
-open Pp
-open Indfun_common
-open Libnames
-open Rawterm
-open Declarations
-
-let is_rec_info scheme_info = 
-  let test_branche min acc (_,_,br) = 
-    acc || (
-      let new_branche = 
-	Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in 
-      let free_rels_in_br = Termops.free_rels new_branche in 
-      let max = min + scheme_info.Tactics.npredicates in 
-      Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
-    )
-  in
-  Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
-
-
-let choose_dest_or_ind scheme_info =
-    if is_rec_info scheme_info
-    then Tactics.new_induct false
-    else Tactics.new_destruct false
-
-
-let functional_induction with_clean c princl pat =
-  let f,args = decompose_app c in 
-  fun g ->      
-    let princ,bindings, princ_type = 
-      match princl with 
-	| None -> (* No principle is given let's find the good one *)
-	    begin
-	      match kind_of_term f with
-		| Const c' ->
-		    let princ_option = 
-		      let finfo = (* we first try to find out a graph on f *)
-			try find_Function_infos c' 
-			with Not_found -> 
-			  errorlabstrm "" (str "Cannot find induction information on "++
-					     Printer.pr_lconstr (mkConst c') )
-		      in
-		      match Tacticals.elimination_sort_of_goal g with 
-			| InProp -> finfo.prop_lemma
-			| InSet -> finfo.rec_lemma
-			| InType -> finfo.rect_lemma
-		    in
-		    let princ =  (* then we get the principle *)
-		      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*)
-			let princ_name = 
-			  Indrec.make_elimination_ident
-			    (id_of_label (con_label c'))
-			    (Tacticals.elimination_sort_of_goal g)
-			in
-			try 
-			  mkConst(const_of_id princ_name )
-			with Not_found -> (* This one is neither defined ! *)
-			  errorlabstrm "" (str "Cannot find induction principle for "
-					   ++Printer.pr_lconstr (mkConst c') )
-		    in
-		    (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
-		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
-		    
-	    end
-	| Some ((princ,binding)) -> 
-	    princ,binding,Tacmach.pf_type_of g princ
-    in
-    let princ_infos = Tactics.compute_elim_sig princ_type in 
-    let args_as_induction_constr =
-      let c_list = 
-	if princ_infos.Tactics.farg_in_concl 
-	then [c] else [] 
-      in
-      List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) 
-    in 
-    let princ' = Some (princ,bindings) in 
-    let princ_vars = 
-      List.fold_right 
-	(fun a acc -> 
-	  try Idset.add (destVar a) acc
-	  with _ -> acc
-	)
-	args
-	Idset.empty
-    in
-    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in 
-    let old_idl = Idset.diff old_idl princ_vars in 
-    let subst_and_reduce g = 
-      if with_clean 
-      then
-	let idl = 
-	  map_succeed 
-	    (fun id -> 
-	       if Idset.mem id old_idl then failwith "subst_and_reduce";
-	       id 
-	    )
-	    (Tacmach.pf_ids_of_hyps g)
-	in 
-	let flag = 
-	  Rawterm.Cbv
-	    {Rawterm.all_flags 
-	     with Rawterm.rDelta = false; 		 
-	    }
-	in
-	Tacticals.tclTHEN
-	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
-	  (Hiddentac.h_reduce flag Tacticals.allClauses)	
-	  g
-      else Tacticals.tclIDTAC g 
-	
-    in
-    Tacticals.tclTHEN
-      (choose_dest_or_ind 
-	 princ_infos
-	 args_as_induction_constr
-	 princ'
-	 (None,pat)
-         None)
-      subst_and_reduce
-      g
-      
-      
-
-
-type annot = 
-    Struct of identifier 
-  | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
-  | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
-
-
-type newfixpoint_expr =
-    identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr
-
-let rec abstract_rawconstr c = function
-  | [] -> c
-  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl)
-  | 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_patvar:false  ~ltacvars:([],[]) c
-
-
-(* 
-   Construct a fixpoint as a Rawterm 
-   and not as a constr
-*)
-let build_newrecursive
-(lnameargsardef)  =
-  let env0 = Global.env()
-  and sigma = Evd.empty
-  in
-  let (rec_sign,rec_impls) =
-    List.fold_left
-      (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 =
-	  if Impargs.is_implicit_args()
-	  then Impargs.compute_implicits  env0 arity
-	  else [] in
-	let impls' =(recname,(Constrintern.Recursive,[],impl,Notation.compute_arguments_scope arity))::impls in
-        (Environ.push_named (recname,None,arity) env, impls'))
-      (env0,[]) lnameargsardef in
-  let recdef =
-    (* Declare local notations *)
-    let fs = States.freeze() in
-    let def =
-      try
-	List.map
-	  (fun (_,_,bl,_,def)  ->
-             let def = abstract_rawconstr def bl in
-             interp_casted_constr_with_implicits
-	       sigma rec_sign rec_impls def
-	  )
-          lnameargsardef
-	with e ->
-	States.unfreeze fs; raise e in
-    States.unfreeze fs; def
-  in
-  recdef,rec_impls
-	
-
-let compute_annot (name,annot,args,types,body) =
-  let names = List.map snd (Topconstr.names_of_local_assums args) in
-  match annot with
-    | None ->
-        if List.length names > 1 then
-          user_err_loc
-            (dummy_loc,"Function",
-             Pp.str "the recursive argument needs to be specified");
-        let new_annot = (id_of_name (List.hd names)) in
-	(name,Struct new_annot,args,types,body)
-    | Some r -> (name,r,args,types,body)
-
-
-(* Checks whether or not the mutual bloc is recursive *) 
-let rec is_rec names = 
-  let names = List.fold_right Idset.add names Idset.empty in 
-  let check_id id names =  Idset.mem id names in 
-  let rec lookup names = function 
-    | RVar(_,id) -> check_id id names
-    | RRef _ | REvar _ | RPatVar _ | RSort _ |  RHole _ | RDynamic _ -> false
-    | RCast(_,b,_) -> lookup names b
-    | 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)  -> 
-	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
-    | RLetTuple(_,nal,_,t,b) -> lookup names t || 
-	lookup 
-	  (List.fold_left 
-	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
-	     names
-	     nal
-	  )
-	  b
-    | RApp(_,f,args) -> List.exists (lookup names) (f::args)
-    | RCases(_,_,_,el,brl) -> 
-	List.exists (fun (e,_) -> lookup names e) el ||
-	  List.exists (lookup_br names) brl
-  and lookup_br names (_,idl,_,rt) = 
-    let new_names = List.fold_right Idset.remove idl names in 
-    lookup new_names rt
-  in
-  lookup names
-
-let prepare_body (name,annot,args,types,body) rt = 
-  let n = (Topconstr.local_binders_length args) in 
-(*   Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *)
-  let fun_args,rt' = chop_rlambda_n n rt in
-  (fun_args,rt')
-
-
-let derive_inversion fix_names =
-  try 
-    (* we first transform the fix_names identifier into their corresponding constant *)
-    let fix_names_as_constant = 
-      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names 
-    in 
-    (* 
-       Then we check that the graphs have been defined 
-       If one of the graphs haven't been defined 
-       we do nothing
-    *)
-    List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
-    try
-      Invfun.derive_correctness 
-	Functional_principles_types.make_scheme
-	functional_induction 
-	fix_names_as_constant
-	(*i The next call to mk_rel_id is valid since we have just construct the graph 
-	  Ensures by : register_built
-	  i*) 
-	(List.map
-	   (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
-	   fix_names
-	)
-    with e -> 
-      msg_warning 
-	(str "Cannot built inversion information" ++ 
-	   if do_observe () then Cerrors.explain_exn e else mt ())
-  with _ -> ()
-
-let warning_error names e = 
-  match e with 
-    | Building_graph e -> 
-	Pp.msg_warning 
-	  (str "Cannot define graph(s) for " ++ 
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
-    | Defining_principle e -> 
-	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++ 
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     if do_observe () then Cerrors.explain_exn e else mt ())
-    | _ -> anomaly ""
-
-let error_error names e = 
-  match e with 
-    | Building_graph e -> 
-	errorlabstrm ""  
-	  (str "Cannot define graph(s) for " ++ 
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
-    | _ -> anomaly ""
-
-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 fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
-  let funs_args = List.map fst fun_bodies in
-  let funs_types =  List.map (function (_,_,_,types,_) -> types) fix_rec_l in
-  try 
-    (* We then register the Inductive graphs of the functions  *)
-    Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
-    if do_built 
-    then
-      begin
-	(*i The next call to mk_rel_id is valid since we have just construct the graph 
-	   Ensures by : do_built
-	i*) 
-	let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
-	let ind_kn =
-	  fst (locate_with_msg
-		 (pr_reference f_R_mut++str ": Not an inductive type!")
-		 locate_ind
-		 f_R_mut)
-	in
-	let fname_kn (fname,_,_,_,_) =
-	  let f_ref = Ident fname in
-	  locate_with_msg
-	    (pr_reference f_ref++str ": Not an inductive type!")
-	    locate_constant
-	    f_ref
-	in
-	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in 
-	let _ = 
-	  list_map_i
-	    (fun i x ->
-	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in 
-	       let princ_type = Typeops.type_of_constant (Global.env()) princ
-	       in
-	       Functional_principles_types.generate_functional_principle
-		 interactive_proof 
-		 princ_type
-		 None
-		 None 
-		 funs_kn
-		 i
-		 (continue_proof  0 [|funs_kn.(i)|]) 
-	    )
-	    0
-	    fix_rec_l
-	in 
-	Array.iter (add_Function is_general) funs_kn;
-	()
-      end
-  with e -> 
-    on_error names e 
-
-let register_struct is_rec fixpoint_exprl = 
-  match fixpoint_exprl with 
-    | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> 
-	Command.declare_definition
-	  fname
-	  (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition)
-	  bl
-	  None
-  	  body
-	  (Some ret_type)
-	  (fun _ _ -> ())
-    | _ -> 
-	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
-    (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = 
-  Functional_principles_proofs.prove_principle_for_gen
-    (f_ref,functional_ref,eq_ref)
-    tcc_lemma_ref is_mes  rec_arg_num rec_arg_type relation
-
-
-let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
-    pre_hook 
-    =  
-  let type_of_f = Command.generalize_constr_expr ret_type args in 
-  let rec_arg_num = 
-    let names = 
-      List.map
-	snd
-	(Topconstr.names_of_local_assums args) 
-    in 
-    match wf_arg with 
-      | None -> 
-	  if List.length names = 1 then 1
-	  else error "Recursive argument must be specified"
-      | Some wf_arg -> 
-	  list_index (Name wf_arg) names 
-  in
-  let unbounded_eq = 
-    let f_app_args = 
-      Topconstr.CAppExpl 
-	(dummy_loc, 
-	 (None,(Ident (dummy_loc,fname))) ,
-	 (List.map 
-	    (function
-	       | _,Anonymous -> assert false 
-	       | _,Name e -> (Topconstr.mkIdentC e)
-	    ) 
-	    (Topconstr.names_of_local_assums args)
-	 )
-	) 
-    in
-    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 
-  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
-      nb_args relation =
-    try 
-      pre_hook 
-	(generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
-	   functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
-	);
-      derive_inversion [fname]
-    with e -> 
-      (* No proof done *) 
-      ()
-  in 
-  Recdef.recursive_definition 
-    is_mes fname rec_impls
-    type_of_f
-    wf_rel_expr
-    rec_arg_num
-    eq
-    hook
-    using_lemmas
-
-    
-let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = 
-  let wf_arg_type,wf_arg = 
-    match wf_arg with 
-      | None -> 
-	  begin
-	    match args with 
-	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x 
-	      | _ -> error "Recursive argument must be specified" 
-	  end
-      | Some wf_args -> 
-	  try 
-	    match 
-	      List.find 
-		(function 
-		   | Topconstr.LocalRawAssum(l,k,t) -> 
-		       List.exists 
-			 (function (_,Name id) -> id =  wf_args | _ -> false) 
-			 l 
-		   | _ -> false
-		)
-		args 
-	    with 
-	      | Topconstr.LocalRawAssum(_,k,t)  ->	    t,wf_args
-	      | _ -> assert false 
-	  with Not_found -> assert false 
-  in
-  let ltof = 
-    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in 
-    Libnames.Qualid (dummy_loc,Libnames.qualid_of_sp 
-      (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
-  in
-  let fun_from_mes = 
-    let applied_mes = 
-      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-    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])
-  in
-  register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) 
-    using_lemmas args ret_type body
-	  
-
-let do_generate_principle on_error register_built interactive_proof fixpoint_exprl  = 
-  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))] -> 
-	  let pre_hook = 
-	    generate_principle 
-	      on_error
-	      true
-	      register_built
-	      fixpoint_exprl 
-	      recdefs
-	      true
-	  in 
-	  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))] -> 
-	  let pre_hook = 
-	    generate_principle 
-	      on_error
-	      true
-	      register_built
-	      fixpoint_exprl 
-	      recdefs
-	      true
-	  in 
-	  if register_built 
-	  then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
-	  true
-      | _ -> 
-	  let fix_names = 
-	    List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl 
-	  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 annot = 
-		       try Some (dummy_loc, id), Topconstr.CStructRec 
-		       with Not_found -> 
-			 raise (UserError("",str "Cannot find argument " ++ 
-					    Ppconstr.pr_id id)) 
-		     in 
- 		     (name,annot,args,types,body),(None:Vernacexpr.decl_notation) 
-		 | (name,None,args,types,body),recdef -> 
-		     let names =  (Topconstr.names_of_local_assums args) in
-		     if  is_one_rec recdef  && List.length names > 1 then
-		       user_err_loc
-			 (dummy_loc,"Function",
-			  Pp.str "the recursive argument needs to be specified in Function")
-		     else 
-		       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 
-		       ("Cannot use mutual definition with well-founded recursion or measure")
-	      ) 
-	      (List.combine fixpoint_exprl recdefs)
-	  in
-	  (* ok all the expressions are structural *) 
-	  let fix_names = 
-	    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;
-	  generate_principle
-	    on_error
-	    false
-	    register_built
-	    fixpoint_exprl
-	    recdefs 
-	    interactive_proof
-	    (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
-	  if register_built then derive_inversion fix_names;
-	  true;
-  in
-  ()
-
-open Topconstr
-let rec add_args id new_args b = 
-  match b with 
-  | CRef r -> 
-      begin      match r with 
-	| Libnames.Ident(loc,fname) when fname = id -> 
-	    CAppExpl(dummy_loc,(None,r),new_args)
-	| _ -> b
-      end
-  | CFix  _  | CCoFix _ -> anomaly "add_args : todo"
-  | CArrow(loc,b1,b2) -> 
-      CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
-  | CProdN(loc,nal,b1) -> 
-      CProdN(loc,
-	     List.map (fun (nal,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,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)
-  | CAppExpl(loc,(pf,r),exprl) -> 
-      begin 
-	match r with 
-	| Libnames.Ident(loc,fname) when fname = id -> 
-	    CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
-	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
-      end
-  | CApp(loc,(pf,b),bl) -> 
-      CApp(loc,(pf,add_args id new_args b), 
-	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
-  | 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, 
-	     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),
-		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),
-	  add_args id new_args b2,
-	  add_args id new_args b3
-	 )
-  | CHole _ -> b
-  | CPatVar _ -> b
-  | CEvar _ -> b
-  | CSort _ -> b
-  | CCast(loc,b1,CastConv(ck,b2))  -> 
-      CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
-  | CCast(loc,b1,CastCoerce) ->
-      CCast(loc,add_args id new_args b1,CastCoerce)
-  | CRecord _ -> anomaly "add_args : CRecord"
-  | CNotation _ -> anomaly "add_args : CNotation"
-  | CGeneralization _ -> anomaly "add_args : CGeneralization"
-  | CPrim _ -> b
-  | CDelimiters _ -> anomaly "add_args : CDelimiters"
-  | CDynamic _ -> anomaly "add_args : CDynamic"
-exception Stop of  Topconstr.constr_expr
-
-
-(* [chop_n_arrow n t] chops the [n] first arrows in [t] 
-   Acts on Topconstr.constr_expr 
-*)
-let rec chop_n_arrow n t = 
-  if n <= 0 
-  then t (* If we have already removed all the arrows then return the type *)
-  else (* If not we check the form of [t] *) 
-    match t with 
-      | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
-	  chop_n_arrow (n-1) t
-      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : 
-					     either we need to discard more than the number of arrows contained
-					     in this product declaration then we just recall [chop_n_arrow] on
-					     the remaining number of arrow to chop and [t'] we discard it and 
-					     recall [chop_n_arrow], either this product contains more arrows 
-					     than the number we need to chop and then we return the new type
-					  *)
-	  begin 
-	    try 
-	      let new_n =
-		let rec aux (n:int) = function 
-		    [] -> n
-		| (nal,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)),k,t'')::nal_ta',t')
-		      in 
-		      raise (Stop new_t')
-		in
-		aux n nal_ta'
-	    in 
-	      chop_n_arrow new_n t'
-	    with Stop t -> t
-	  end
-      | _ -> anomaly "Not enough products"
-  
-
-let rec get_args b t : Topconstr.local_binder list * 
-    Topconstr.constr_expr * Topconstr.constr_expr = 
-  match b with 
-    | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
-	begin
-	  let n = 
-	    (List.fold_left (fun n (nal,_,_) -> 
-			       n+List.length nal) 0 nal_ta )
-	  in
-	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
-	  (List.map (fun (nal,k,ta) -> 
-		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' 
-	end
-    | _ -> [],b,t
-
-
-let make_graph (f_ref:global_reference) =
- let c,c_body = 
-      match f_ref with 
-	| ConstRef c -> 
-	    begin try c,Global.lookup_constant c 
-	    with Not_found -> 
-	      raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
-	    end
-	| _ -> raise (UserError ("", str "Not a function reference") )
-
-  in
-  match c_body.const_body with
-    | None -> error "Cannot build a graph over an axiom !"
-    | Some b ->
-	let env = Global.env () in
-	let body = (force b) in
-	let extern_body,extern_type = 
-	  with_full_print 
-	    (fun () -> 
-	       (Constrextern.extern_constr false env body, 
-		Constrextern.extern_type false env
-                  (Typeops.type_of_constant_type env c_body.const_type)
-	       )
-	    )
-	    ()
-	in
-	let (nal_tas,b,t)  = get_args extern_body extern_type in
-	let expr_list = 
-	  match b with 
-	    | Topconstr.CFix(loc,l_id,fixexprl) -> 
-		let l = 
-		  List.map
-		    (fun (id,(n,recexp),bl,t,b) -> 
-		       let loc, rec_id = Option.get n in
-		       let new_args = 
-			 List.flatten 
-			   (List.map 
-			      (function
- 				 | Topconstr.LocalRawDef (na,_)-> []
-			      	 | Topconstr.LocalRawAssum (nal,_,_) -> 
-				     List.map 
-				       (fun (loc,n) -> 
-					  CRef(Libnames.Ident(loc, Nameops.out_name n))) 
-				       nal
-			      )
-			      nal_tas
-			   )
-		       in
-		       let b' = add_args (snd id) new_args b in 
-		       (id, Some (Struct rec_id),nal_tas@bl,t,b')
-		    )
-		    fixexprl
-		in
-		l
-	    | _ ->   
-		let id = id_of_label (con_label c) in 
-		[((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))) 
-	  expr_list
-
-
-(* let make_graph _ = assert false	 *)
-	  
-let do_generate_principle = do_generate_principle warning_error true 
-
-
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
deleted file mode 100644
index a3c169b7..00000000
--- a/contrib/funind/indfun_common.ml
+++ /dev/null
@@ -1,512 +0,0 @@
-open Names
-open Pp
-
-open Libnames
-
-let mk_prefix pre id = id_of_string (pre^(string_of_id id))
-let mk_rel_id = mk_prefix "R_"
-let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
-let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
-let mk_equation_id id = Nameops.add_suffix id "_equation"
-
-let msgnl m =
-  ()
-
-let invalid_argument s = raise (Invalid_argument s)
-
-
-let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid
-
-let fresh_name avoid s = Name (fresh_id avoid s)
-
-let get_name avoid ?(default="H") = function
-  | Anonymous -> fresh_name avoid default
-  | Name n -> Name n
-
-let array_get_start a =
-  try 
-    Array.init
-      (Array.length a - 1)
-      (fun i -> a.(i))
-  with Invalid_argument "index out of bounds" -> 
-    invalid_argument "array_get_start"
-      
-let id_of_name = function
-    Name id -> id
-  | _ -> raise Not_found
-
-let locate  ref =
-    let (loc,qid) = qualid_of_reference ref in
-    Nametab.locate qid
-
-let locate_ind ref =
-  match locate ref with
-    | IndRef x -> x
-    | _ -> raise Not_found
-
-let locate_constant ref =
-  match locate ref with
-    | ConstRef x -> x
-    | _ -> raise Not_found
-
-
-let locate_with_msg msg f x =
-  try
-    f x
-  with
-    | Not_found -> raise (Util.UserError("", msg))
-    | e -> raise e
-
-
-let filter_map filter f =
-  let rec it = function
-    | [] -> []
-    | e::l ->
-	if filter e
-	then
-	  (f e) :: it l
-	else it l
-  in
-  it
-
-
-let chop_rlambda_n  =
-  let rec chop_lambda_n acc n rt =
-      if n == 0
-      then List.rev acc,rt
-      else
-	match rt with
-	  | 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",
-				    str "chop_rlambda_n: Not enough Lambdas"))
-  in
-  chop_lambda_n []
-
-let chop_rprod_n  =
-  let rec chop_prod_n acc n rt =
-      if n == 0
-      then List.rev acc,rt
-      else
-	match rt with
-	  | 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 []
-
-
-
-let list_union_eq eq_fun l1 l2 =
-  let rec urec = function
-    | [] -> l2
-    | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l
-  in
-  urec l1
-
-let list_add_set_eq eq_fun x l =
-  if List.exists (eq_fun x) l then l else x::l
-
-  
-
-
-let const_of_id id =
-  let _,princ_ref = 
-    qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
-  in
-  try Nametab.locate_constant princ_ref
-  with Not_found -> Util.error ("cannot find "^ string_of_id id)
-
-let def_of_const t =
-   match (Term.kind_of_term t) with
-    Term.Const sp -> 
-      (try (match (Global.lookup_constant sp) with
-             {Declarations.const_body=Some c} -> Declarations.force c
-	     |_ -> assert false)
-       with _ -> assert false)
-    |_ -> assert false
-
-let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition" 
-    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
-
-let constant sl s =
-  constr_of_global
-    (Nametab.locate (make_qualid(Names.make_dirpath 
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
-let find_reference sl s =
-    (Nametab.locate (make_qualid(Names.make_dirpath 
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
-let eq = lazy(coq_constant "eq")
-let refl_equal = lazy(coq_constant "refl_equal")
-
-(*****************************************************************)
-(* Copy of the standart save mechanism but without the much too  *)
-(* slow reduction function                                       *) 
-(*****************************************************************)
-open Declarations
-open Entries
-open Decl_kinds
-open Declare
-let definition_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is defined")
-
-
-let save with_clean id const (locality,kind) hook =
-  let {const_entry_body = pft;
-       const_entry_type = tpo;
-       const_entry_opaque = opacity } = const in
-  let l,r = match locality with
-    | Local when Lib.sections_are_opened () ->
-        let k = logical_kind_of_goal_kind kind in
-	let c = SectionLocalDef (pft, tpo, opacity) in
-	let _ = declare_variable id (Lib.cwd(), c, k) in
-	(Local, VarRef id)
-    | Local ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn)
-    | Global ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn) in
-  if with_clean then  Pfedit.delete_current_proof ();
-  hook l r;
-  definition_message id
-
-
-
-
-let extract_pftreestate pts =
-  let pfterm,subgoals = Refiner.extract_open_pftreestate pts in
-  let tpfsigma = Refiner.evc_of_pftreestate pts in 
-  let exl = Evarutil.non_instantiated tpfsigma  in
-  if subgoals <> [] or exl <> [] then
-    Util.errorlabstrm "extract_proof"
-      (if subgoals <> [] then
-        str "Attempt to save an incomplete proof"
-      else
-        str "Attempt to save a proof with existential variables still non-instantiated");
-  let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in
-  env,tpfsigma,pfterm
-
-
-let nf_betaiotazeta =
-  let clos_norm_flags flgs env sigma t =
-    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags Closure.betaiotazeta  
-
-let nf_betaiota =
-  let clos_norm_flags flgs env sigma t =
-    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags Closure.betaiota  
-
-let cook_proof do_reduce =
-  let pfs = Pfedit.get_pftreestate () 
-(*   and ident = Pfedit.get_current_proof_name ()  *)
-  and (ident,strength,concl,hook) = Pfedit.current_proof_statement ()  in
-  let env,sigma,pfterm = extract_pftreestate pfs in
-  let pfterm = 
-    if do_reduce
-    then nf_betaiota env sigma pfterm
-    else pfterm
-  in
-  (ident,
-   ({ const_entry_body = pfterm;
-      const_entry_type = Some concl;
-      const_entry_opaque = false;
-      const_entry_boxed = false},
-    strength, hook))
-
-
-let new_save_named opacity =
-  let id,(const,persistence,hook) = cook_proof true  in
-  let const = { const with const_entry_opaque = opacity } in
-  save true id const persistence hook
-
-let get_proof_clean do_reduce = 
-  let result = cook_proof do_reduce in 
-  Pfedit.delete_current_proof ();
-  result
-
-let with_full_print f a = 
-  let old_implicit_args = Impargs.is_implicit_args ()
-  and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
-  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
-  let old_rawprint = !Flags.raw_print 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;
-  Dumpglob.pause ();
-  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;
-    Flags.raw_print := old_rawprint;
-    Dumpglob.continue ();
-    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;
-	Flags.raw_print := old_rawprint;
-	Dumpglob.continue ();
-	raise e
-
-
-
-
-
-
-(**********************)
-
-type function_info = 
-    { 
-      function_constant : constant;
-      graph_ind : inductive;
-      equation_lemma : constant option;
-      correctness_lemma : constant option;
-      completeness_lemma : constant option; 
-      rect_lemma : constant option;
-      rec_lemma : constant option;
-      prop_lemma : constant option;
-      is_general : bool; (* Has this function been defined using general recursive definition *)
-    }
-      
-
-(* type function_db  = function_info list *)
-
-(* let function_table = ref ([] : function_db) *)
-
-
-let from_function = ref Cmap.empty
-let from_graph = ref Indmap.empty
-(*
-let rec do_cache_info finfo = function 
-  | [] -> raise Not_found 
-  | (finfo'::finfos as l) -> 
-      if finfo' == finfo then l 
-      else if finfo'.function_constant = finfo.function_constant 
-      then finfo::finfos
-      else
-	let res = do_cache_info finfo finfos in 
-	if res == finfos then l else  finfo'::l
-  
-
-let cache_Function (_,(finfos)) = 
-  let new_tbl = 
-    try do_cache_info finfos !function_table
-    with Not_found -> finfos::!function_table
-  in  
-  if new_tbl != !function_table 
-  then function_table := new_tbl
-*)
-
-let cache_Function (_,finfos) = 
-  from_function := Cmap.add finfos.function_constant finfos !from_function;
-  from_graph := Indmap.add finfos.graph_ind finfos !from_graph
-
-
-let load_Function _  = cache_Function
-let open_Function _ = cache_Function
-let subst_Function (_,subst,finfos) = 
-  let do_subst_con c = fst (Mod_subst.subst_con subst c)
-  and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i)
-  in
-  let function_constant' = do_subst_con finfos.function_constant in 
-  let graph_ind' = do_subst_ind finfos.graph_ind 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 &&
-    correctness_lemma' == finfos.correctness_lemma && 
-    completeness_lemma' == finfos.completeness_lemma && 
-    rect_lemma' == finfos.rect_lemma && 
-    rec_lemma' == finfos.rec_lemma && 
-    prop_lemma' == finfos.prop_lemma 
-  then finfos 
-  else
-    { function_constant = function_constant';
-      graph_ind = graph_ind';
-      equation_lemma = equation_lemma' ;
-      correctness_lemma = correctness_lemma' ;
-      completeness_lemma = completeness_lemma' ;
-      rect_lemma = rect_lemma' ;
-      rec_lemma = rec_lemma';
-      prop_lemma = prop_lemma';
-      is_general = finfos.is_general
-    }
-
-let classify_Function (_,infos) = Libobject.Substitute infos
-
-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' = 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 && 
-    equation_lemma' == finfos.equation_lemma &&
-    correctness_lemma' == finfos.correctness_lemma && 
-    completeness_lemma' == finfos.completeness_lemma && 
-    rect_lemma' == finfos.rect_lemma && 
-    rec_lemma' == finfos.rec_lemma && 
-    prop_lemma' == finfos.prop_lemma 
-  then Some finfos 
-  else
-    Some { function_constant = function_constant' ;
-	   graph_ind = graph_ind' ;
-	   equation_lemma = equation_lemma' ;
-	   correctness_lemma = correctness_lemma' ;
-	   completeness_lemma = completeness_lemma';
-	   rect_lemma = rect_lemma';
-	   rec_lemma = rec_lemma';
-	   prop_lemma = prop_lemma' ;
-	   is_general = finfos.is_general
-	 }    
-
-open Term
-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 := " ++ (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 = 
-  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in 
-  Util.prlist_with_sep fnl pr_info l
-
-let in_Function,out_Function = 
-  Libobject.declare_object
-    {(Libobject.default_object "FUNCTIONS_DB") with 
-       Libobject.cache_function = cache_Function;
-       Libobject.load_function  = load_Function;
-       Libobject.classify_function  = classify_Function;
-       Libobject.subst_function = subst_Function;
-       Libobject.export_function = export_Function;
-       Libobject.discharge_function = discharge_Function
-(*        Libobject.open_function = open_Function; *)
-    }
-
-
-
-(* Synchronisation with reset *)
-let freeze () = 
-  !from_function,!from_graph
-let unfreeze (functions,graphs) = 
-(*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
-  from_function := functions;
-  from_graph := graphs
-
-let init () = 
-(*   Pp.msgnl (str "reseting function_table");  *)
-  from_function := Cmap.empty;
-  from_graph := Indmap.empty
-
-let _ = 
-  Summary.declare_summary "functions_db_sum"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false; 
-      Summary.survive_section = false }
-
-let find_or_none id = 
-  try Some 
-    (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" 
-    ) 
-  with Not_found -> None
-
-
-
-let find_Function_infos f = 
-  Cmap.find f !from_function
-
-
-let find_Function_of_graph ind = 
-  Indmap.find ind !from_graph
-  
-let update_Function finfo = 
-(*   Pp.msgnl (pr_info finfo); *)
-  Lib.add_anonymous_leaf (in_Function finfo)
-      
-  
-let add_Function is_general f = 
-  let f_id = id_of_label (con_label f) in 
-  let equation_lemma = find_or_none (mk_equation_id f_id)
-  and correctness_lemma = find_or_none (mk_correct_id f_id) 
-  and completeness_lemma = find_or_none (mk_complete_id f_id) 
-  and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
-  and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
-  and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
-  and graph_ind = 
-    match Nametab.locate (make_short_qualid (mk_rel_id f_id)) 
-    with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
-  in
-  let finfos = 
-    { function_constant = f;
-      equation_lemma = equation_lemma;
-      completeness_lemma = completeness_lemma;
-      correctness_lemma = correctness_lemma;
-      rect_lemma = rect_lemma;
-      rec_lemma = rec_lemma;
-      prop_lemma = prop_lemma;
-      graph_ind = graph_ind;
-      is_general = is_general
-      
-    }
-  in
-  update_Function finfos
-
-let pr_table () = pr_table !from_function
-(*********************************)
-(* Debuging *)
-let function_debug = ref false 
-open Goptions
-
-let function_debug_sig =
-  {
-    optsync = false;
-    optname = "Function debug";
-    optkey =  PrimaryTable("Function_debug");
-    optread = (fun () -> !function_debug);
-    optwrite = (fun b -> function_debug := b)
-  }
-
-let _ = declare_bool_option function_debug_sig
-
-
-let do_observe () = 
-  !function_debug = true
-      
-      
-    
-exception Building_graph of exn 
-exception Defining_principle of exn
diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli
deleted file mode 100644
index 7da1d6f0..00000000
--- a/contrib/funind/indfun_common.mli
+++ /dev/null
@@ -1,117 +0,0 @@
-open Names
-open Pp
-
-(* 
-   The mk_?_id function build different name w.r.t. a function 
-   Each of their use is justified in the code 
-*) 
-val mk_rel_id : identifier -> identifier
-val mk_correct_id : identifier -> identifier
-val mk_complete_id : identifier -> identifier
-val mk_equation_id : identifier -> identifier
-
-
-val msgnl : std_ppcmds -> unit
-
-val invalid_argument : string -> 'a
-
-val fresh_id : identifier list -> string -> identifier
-val fresh_name : identifier list -> string -> name 
-val get_name : identifier list -> ?default:string -> name -> name 
-
-val array_get_start : 'a array -> 'a array
-
-val id_of_name : name -> identifier
-
-val locate_ind : Libnames.reference -> inductive
-val locate_constant : Libnames.reference -> constant
-val locate_with_msg :
-  Pp.std_ppcmds -> (Libnames.reference -> 'a) ->
-  Libnames.reference -> 'a
-
-val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
-val list_union_eq :
-  ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
-val list_add_set_eq :
-  ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
-
-val chop_rlambda_n : int -> Rawterm.rawconstr ->
-  (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr
-
-val chop_rprod_n : int -> Rawterm.rawconstr ->
-  (name*Rawterm.rawconstr) list * Rawterm.rawconstr
-
-val def_of_const : Term.constr -> Term.constr
-val eq : Term.constr Lazy.t
-val refl_equal : Term.constr Lazy.t
-val const_of_id: identifier -> constant
-
-
-(* [save_named] is a copy of [Command.save_named] but uses 
-   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] 
-   
-
-
-   DON'T USE IT if you cannot ensure that there is no VMcast in the proof
-
-*)
-
-(* val nf_betaiotazeta : Reductionops.reduction_function *)
-
-val new_save_named : bool -> unit 
-
-val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind -> 
-  Tacexpr.declaration_hook -> unit 
-
-(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and 
-   abort the proof 
-*)
-val get_proof_clean : bool ->     
-  Names.identifier *
-    (Entries.definition_entry * Decl_kinds.goal_kind *
-       Tacexpr.declaration_hook)
-    
-
-
-(* [with_full_print f a] applies [f] to [a] in full printing environment 
-   
-   This function preserves the print settings 
-*)
-val with_full_print : ('a -> 'b) -> 'a -> 'b
-
-
-(*****************)
-
-type function_info = 
-    { 
-      function_constant : constant;
-      graph_ind : inductive;
-      equation_lemma : constant option;
-      correctness_lemma : constant option;
-      completeness_lemma : constant option;
-      rect_lemma : constant option;
-      rec_lemma : constant option;
-      prop_lemma : constant option;
-      is_general : bool;
-    }
-
-val find_Function_infos : constant -> function_info
-val find_Function_of_graph : inductive -> function_info
-(* WARNING: To be used just after the graph definition !!! *)
-val add_Function : bool -> constant -> unit
-
-val update_Function : function_info -> unit 
-
-
-(** debugging *) 
-val pr_info : function_info -> Pp.std_ppcmds
-val pr_table : unit -> Pp.std_ppcmds
-
-
-(* val function_debug : bool ref  *)
-val do_observe : unit -> bool
-
-(* To localize pb *)
-exception Building_graph of exn 
-exception Defining_principle of exn
-
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
deleted file mode 100644
index 5c8f0871..00000000
--- a/contrib/funind/invfun.ml
+++ /dev/null
@@ -1,1022 +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        *)
-(************************************************************************)
-open Tacexpr
-open Declarations
-open Util
-open Names
-open Term
-open Pp
-open Libnames
-open Tacticals
-open Tactics
-open Indfun_common
-open Tacmach
-open Termops
-open Sign
-open Hiddentac
-
-(* Some pretty printing function for debugging purpose *)
-
-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)
-
-let pr_bindings prc prlc = function
-  | Rawterm.ImplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-      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
-  | Rawterm.NoBindings -> mt ()
-
-
-let pr_with_bindings prc prlc (c,bl) =
-  prc c ++ hv 0 (pr_bindings prc prlc bl)
-
-
-
-let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds = 
-  pr_with_bindings prc prc  (c,bl)
-
-(* The local debuging mechanism *)
-let msgnl = Pp.msgnl
-
-let observe strm =
-  if do_observe ()
-  then Pp.msgnl strm
-  else ()
-
-let observennl strm =
-  if do_observe ()
-  then begin Pp.msg strm;Pp.pp_flush () end
-  else ()
-
-
-let do_observe_tac s tac g =
-  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 =
-  if do_observe ()
-  then do_observe_tac (str s) tac g
-  else tac g
-
-(* [nf_zeta] $\zeta$-normalization of a term *)
-let nf_zeta =       
-  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-    Environ.empty_env
-    Evd.empty
-
-
-(* [id_to_constr id] finds the term associated to [id] in the global environment *)
-let id_to_constr id = 
-  try
-    Tacinterp.constr_of_id (Global.env ())  id
-  with Not_found -> 
-    raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
-
-(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] 
-   (resp. g_to_f = false) where [graph]  is the graph of [f] and is the [i]th function in the block. 
-
-   [generate_type true f i] returns 
-   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
-   graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion 
-
-   [generate_type false f i] returns 
-   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
-   res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion 
- *)
-
-let generate_type g_to_f f graph i = 
-  (*i we deduce the number of arguments of the function and its returned type from the graph i*)
-  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in 
-  let ctxt,_ = decompose_prod_assum graph_arity in 
-  let fun_ctxt,res_type = 
-    match ctxt with 
-      | [] | [_] -> anomaly "Not a valid context"
-      | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
-  in
-  let nb_args = List.length fun_ctxt in
-  let args_from_decl i decl = 
-    match decl with 
-      | (_,Some _,_) -> incr i; failwith "args_from_decl"
-      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1) 
-  in
-  (*i We need to name the vars [res] and [fv] i*)
-  let res_id = 
-    Termops.next_global_ident_away 
-      true
-      (id_of_string "res")
-      (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
-  in
-  let fv_id = 
-    Termops.next_global_ident_away 
-      true
-      (id_of_string "fv")
-      (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
-  in
-  (*i we can then type the argument to be applied to the function [f] i*)
-  let args_as_rels = 
-    let i = ref 0 in
-    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) 
-  in
-  let args_as_rels = Array.map Termops.pop args_as_rels in
-  (*i
-    the hypothesis [res = fv] can then be computed 
-    We will need to lift it by one in order to use it as a conclusion 
-    i*)
-  let res_eq_f_of_args =
-    mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
-  in 
-  (*i 
-    The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed 
-    We will need to lift it by one in order to use it as a conclusion 
-    i*)  
-  let graph_applied = 
-    let args_and_res_as_rels = 
-      let i = ref 0 in
-      Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
-    in
-    let args_and_res_as_rels = 
-      Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
-    in
-    mkApp(graph,args_and_res_as_rels) 
-  in 
-  (*i The [pre_context]  is the defined to be the context corresponding to 
-    \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
-    i*)
-  let pre_ctxt = 
-    (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt 
-  in 
-  (*i and we can return the solution depending on which lemma type we are defining i*)
-  if g_to_f 
-  then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
-  else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
-
-
-(* 
-   [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
-   
-   WARNING: while convertible, [type_of body] and [type] can be non equal
-*)
-let find_induction_principle f = 
-  let f_as_constant =  match kind_of_term f with  
-    | Const c' -> c'
-    | _ -> error "Must be used with a function"
-  in
-  let infos = find_Function_infos f_as_constant in 
-  match infos.rect_lemma with 
-    | None -> raise Not_found 
-    | Some rect_lemma -> 
-	let rect_lemma = mkConst rect_lemma in 
-	let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in 
-	rect_lemma,typ
-	
-  
-
-(*     let fname =  *)
-(*       match kind_of_term f with  *)
-(* 	| Const c' ->  *)
-(* 	    id_of_label (con_label c')  *)
-(* 	| _ -> error "Must be used with a function"  *)
-(*     in *)
-
-(*     let princ_name =  *)
-(*       ( *)
-(* 	Indrec.make_elimination_ident *)
-(* 	  fname *)
-(* 	  InType *)
-(*       ) *)
-(*     in *)
-(*     let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in  *\) failwith "" in  *)
-(*     c,Typing.type_of (Global.env ()) Evd.empty c *)
-
-
-let rec generate_fresh_id x avoid i = 
-  if i == 0 
-  then [] 
-  else
-    let id = Termops.next_global_ident_away true x avoid in 
-    id::(generate_fresh_id x (id::avoid) (pred i))
-
-
-(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] 
-   is the tactic used to prove correctness lemma. 
-   
-   [functional_induction] is the tactic defined in [indfun] (dependency problem)
-   [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
-   (resp. graphs of the functions and principles and correctness lemma types) to prove correct. 
-   
-   [i] is the indice of the function to prove correct
-
-   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
-   it looks like~:
-   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
-   res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
-
-
-   The sketch of the proof is the following one~: 
-   \begin{enumerate}
-   \item intros until $x_n$
-   \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
-   \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the 
-   apply the corresponding constructor of the corresponding graph inductive.
-   \end{enumerate}
-   
-*)
-let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
-  fun g ->
-    (* first of all we recreate the lemmas types to be used as predicates of the induction principle 
-       that is~:
-       \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
-    *)
-    let lemmas =
-      Array.map
-	(fun (_,(ctxt,concl)) ->
-	   match ctxt with
-	     | [] | [_] | [_;_] -> anomaly "bad context"
-	     | hres::res::(x,_,t)::ctxt ->
-		 Termops.it_mkLambda_or_LetIn
-		   ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res])
-		   ((x,None,t)::ctxt)
-	)
-	lemmas_types_infos
-    in
-    (* we the get the definition of the graphs block *)
-    let graph_ind = destInd graphs_constr.(i) in
-    let kn = fst graph_ind in 
-    let mib,_ = Global.lookup_inductive graph_ind in 
-    (* and the principle to use in this lemma in $\zeta$ normal form *)
-    let f_principle,princ_type = schemes.(i) in
-    let princ_type =  nf_zeta princ_type in
-    let princ_infos = Tactics.compute_elim_sig princ_type in
-    (* The number of args of the function is then easilly computable *)
-    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
-    let ids = args_names@(pf_ids_of_hyps g) in
-    (* Since we cannot ensure that the funcitonnal principle is defined in the 
-       environement and due to the bug #1174, we will need to pose the principle
-       using a name 
-    *)
-    let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in
-    let ids = principle_id :: ids in
-    (* We get the branches of the principle *)
-    let branches = List.rev princ_infos.branches in
-    (* and built the intro pattern for each of them *)
-    let intro_pats =
-      List.map
-	(fun (_,_,br_type) ->
-	   List.map
-	     (fun id -> dummy_loc, Genarg.IntroIdentifier id)
-	     (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
-	)
-	branches
-    in
-    (* before building the full intro pattern for the principle *)
-    let pat = Some (dummy_loc,Genarg.IntroOrAndPattern intro_pats) in
-    let eq_ind = Coqlib.build_coq_eq () in
-    let eq_construct = mkConstruct((destInd eq_ind),1) in
-    (* The next to referencies will be used to find out which constructor to apply in each branch *)
-    let ind_number = ref 0 
-    and min_constr_number = ref 0 in 
-    (* The tactic to prove the ith branch of the principle *)
-    let prove_branche i g =
-      (* We get the identifiers of this branch *)
-      let this_branche_ids =
-	List.fold_right
-	  (fun (_,pat) acc ->
-	     match pat with
-	       | Genarg.IntroIdentifier id -> Idset.add id acc
-	       | _ -> anomaly "Not an identifier"
-	  )
-	  (List.nth intro_pats (pred i))
-	  Idset.empty
-      in
-      (* and get the real args of the branch by unfolding the defined constant *)
-      let pre_args,pre_tac =
-	List.fold_right
-	  (fun (id,b,t) (pre_args,pre_tac) ->
-	     if Idset.mem id this_branche_ids
-	     then
-	       match b with
-		 | None -> (id::pre_args,pre_tac)
-		 | Some b ->
-		     (pre_args,
-		      tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
-		     )
-		     
-	     else (pre_args,pre_tac)
-	  )
-	  (pf_hyps g)
-	  ([],tclIDTAC)
-      in
-      (* 
-	 We can then recompute the arguments of the constructor. 
-	 For each [hid] introduced by this branch, if [hid] has type  
-	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
-	 [ fv (hid fv (refl_equal fv)) ]. 
-	 
-	 If [hid] has another type the corresponding argument of the constructor is [hid]
-      *)
-      let constructor_args =
-	List.fold_right
-	  (fun hid acc ->
-	     let type_of_hid = pf_type_of g (mkVar hid) in
-	     match kind_of_term type_of_hid with
-	       | Prod(_,_,t') ->
-		   begin
-		     match kind_of_term t' with
-		       | Prod(_,t'',t''') ->
-			   begin
-			     match kind_of_term t'',kind_of_term t''' with
-			       | App(eq,args), App(graph',_)
-				   when
-				     (eq_constr eq eq_ind) &&
-				       array_exists  (eq_constr graph') graphs_constr ->
-				   ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
-				    ::args.(2)::acc)
-			       | _ -> mkVar hid ::  acc
-			   end
-		       | _ -> mkVar hid :: acc
-		   end
-	       | _ -> mkVar hid :: acc
-	  ) pre_args []
-      in
-      (* in fact we must also add the parameters to the constructor args *)
-      let constructor_args =
-	let params_id = fst (list_chop princ_infos.nparams args_names) in
-	(List.map mkVar params_id)@(List.rev constructor_args)
-      in
-      (* We then get the constructor corresponding to this branch and 
-	 modifies the references has needed i.e. 
-	 if the constructor is the last one of the current inductive then 
-	 add one the number of the inductive to take and add the number of constructor of the previous 
-	 graph to the minimal constructor number 
-      *)
-      let constructor = 
-	let constructor_num = i - !min_constr_number in 
-	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in 
-	if constructor_num <= length
-	then 
-	  begin 
-	    (kn,!ind_number),constructor_num
-	  end
-	else 
-	  begin
-	    incr ind_number;
-	    min_constr_number := !min_constr_number + length ;
-	    (kn,!ind_number),1
-	  end
-      in
-      (* we can then build the final proof term *)
-      let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
-      (* an apply the tactic *)
-      let res,hres =
-	match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
-	  | [res;hres] -> res,hres
-	  | _ -> assert false
-      in
-      observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
-      (
-	tclTHENSEQ
-	  [
-	    (* unfolding of all the defined variables introduced by this branch *)
-	    observe_tac "unfolding" pre_tac;
-	    (* $zeta$ normalizing of the conclusion *)
-	    h_reduce
-	      (Rawterm.Cbv
-		 { Rawterm.all_flags with
-		     Rawterm.rDelta = false ;
-		     Rawterm.rConst = []
-		 }
-	      )
-	      onConcl;
-	    (* introducing the the result of the graph and the equality hypothesis *)
-	    observe_tac "introducing" (tclMAP h_intro [res;hres]);
-	    (* replacing [res] with its value *)
-	    observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
-	    (* Conclusion *)
-	    observe_tac "exact" (h_exact app_constructor)
-	  ]
-      )
-	g
-    in
-    (* end of branche proof *)
-    let param_names = fst (list_chop princ_infos.nparams args_names) in
-    let params = List.map mkVar param_names in
-    let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
-    (* The bindings of the principle 
-       that is the params of the principle and the different lemma types 
-    *)
-    let bindings =
-      let params_bindings,avoid =
-	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,inj_open p)::bindings,id::avoid
-	  )
-	  ([],pf_ids_of_hyps g)
-	  princ_infos.params
-	  (List.rev params)
-      in
-      let lemmas_bindings =
-	List.rev (fst  (List.fold_left2
-	  (fun (bindings,avoid) (x,_,_) p ->
-	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in 
-	     (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid)
-	  ([],avoid)
-	  princ_infos.predicates
-	  (lemmas)))
-      in
-      Rawterm.ExplicitBindings (params_bindings@lemmas_bindings)
-    in
-    tclTHENSEQ
-      [ observe_tac "intro args_names" (tclMAP h_intro args_names);
-	observe_tac "principle" (assert_by
-	  (Name principle_id)
-	  princ_type
-	  (h_exact f_principle));
-	tclTHEN_i
-	  (observe_tac "functional_induction" (
-	     fun g -> 
-	       observe
-		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
-	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
-		 (Some (mkVar principle_id,bindings))
-		 pat g
-	   ))
-	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
-      ]
-      g
-
-(* [generalize_dependent_of x hyp g] 
-   generalize every hypothesis which depends of [x] but [hyp] 
-*)
-let generalize_dependent_of x hyp g = 
-  tclMAP 
-    (function 
-       | (id,None,t) when not (id = hyp) && 
-	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
-       | _ -> tclIDTAC
-    )
-    (pf_hyps g)
-    g
-
-
-
-
-
-    (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis 
-       (unfolding, substituting, destructing cases \ldots)
-    *)
-let  rec intros_with_rewrite g = 
-  observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
-and intros_with_rewrite_aux : tactic = 
-  fun g -> 
-    let eq_ind = Coqlib.build_coq_eq () in 
-    match kind_of_term (pf_concl g) with 
-	  | Prod(_,t,t') -> 
-	      begin 
-		match kind_of_term t with 
-		  | 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_dependent_of (destVar args.(1)) id; 
-				     tclTRY (Equality.rewriteLR (mkVar id));
-				     intros_with_rewrite
-				   ] 
-			  g
-		      else
-			begin 
-			  let id = pf_get_new_id (id_of_string "y") g  in 
-			  tclTHENSEQ[
-			    h_intro id;
-			    tclTRY (Equality.rewriteLR (mkVar id));
-			    intros_with_rewrite
-			  ] g
-			end
-		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> 
-		      Tauto.tauto g
-		  | Case(_,_,v,_) -> 
-		      tclTHENSEQ[
-			h_case false (v,Rawterm.NoBindings);
-			intros_with_rewrite
-		      ] g
-		  | LetIn _ -> 
-		      tclTHENSEQ[
-			h_reduce 
-			  (Rawterm.Cbv
-			     {Rawterm.all_flags 
-			      with Rawterm.rDelta = false; 		 
-			     }) 
-			  onConcl
-			;
-			intros_with_rewrite
-		      ] g
-		  | _ -> 			
-		      let id = pf_get_new_id (id_of_string "y") g  in 
-		      tclTHENSEQ [ h_intro id;intros_with_rewrite] g
-	      end
-	  | LetIn _ -> 
-	      tclTHENSEQ[
-		h_reduce 
-		  (Rawterm.Cbv
-		     {Rawterm.all_flags 
-		      with Rawterm.rDelta = false; 		 
-		     }) 
-		  onConcl
-		;
-		intros_with_rewrite
-	      ] g
-	  | _ -> tclIDTAC g 
-  
-let rec reflexivity_with_destruct_cases g = 
-  let destruct_case () = 
-    try 
-      match kind_of_term (snd (destApp (pf_concl g))).(2) with 
-	| Case(_,_,v,_) -> 
-	    tclTHENSEQ[
-	      h_case false (v,Rawterm.NoBindings);
-	      intros;
-	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases 
-	    ]
-	| _ -> reflexivity
-    with _ -> reflexivity
-  in
-  let eq_ind =     Coqlib.build_coq_eq () in
-  let discr_inject =
-    Tacticals.onAllClauses (
-       fun sc g -> 
-	 match sc with 
-	     None -> tclIDTAC g
-	   | Some ((_,id),_) -> 
-	       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.discrHyp id g
-		     else if Equality.injectable (pf_env g) (project g) t1 t2
-		     then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite]  g
-		     else tclIDTAC g
-		 | _ -> tclIDTAC g
-    )
-  in
-  (tclFIRST
-    [ reflexivity;
-      tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
-      (*  We reach this point ONLY if 
-	  the same value is matched (at least) two times 
-	  along binding path.
-	  In this case, either we have a discriminable hypothesis and we are done, 
-	  either at least an injectable one and we do the injection before continuing
-      *)
-      tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
-    ])
-    g
-
-
-(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] 
-   is the tactic used to prove completness lemma. 
-   
-   [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
-   (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. 
-   
-   [i] is the indice of the function to prove complete
-
-   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
-   it looks like~:
-   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
-   graph\ x_1\ldots x_n\ res, \rightarrow  res = f x_1\ldots x_n in]
-
-
-   The sketch of the proof is the following one~: 
-   \begin{enumerate}
-   \item intros until $H:graph\ x_1\ldots x_n\ res$
-   \item $elim\ H$ using schemes.(i)
-   \item for each generated branch, intro  the news hyptohesis, for each such hyptohesis [h], if [h] has 
-   type [x=?] with [x] a variable, then subst [x], 
-   if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else 
-   if [h] is a match then destruct it, else do just introduce it, 
-   after all intros, the conclusion should be a reflexive equality.
-   \end{enumerate}
-   
-*)
-
-
-let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = 
-  fun g ->  
-    (* We compute the types of the different mutually recursive lemmas 
-       in $\zeta$ normal form
-    *)
-    let lemmas = 
-      Array.map 
-	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) 
-	lemmas_types_infos
-    in
-    (* We get the constant and the principle corresponding to this lemma *)
-    let f = funcs.(i) in
-    let graph_principle = nf_zeta schemes.(i)  in 
-    let princ_type = pf_type_of g graph_principle in 
-    let princ_infos = Tactics.compute_elim_sig princ_type in 
-    (* Then we get the number of argument of the function 
-       and compute a fresh name for each of them
-    *)
-    let nb_fun_args = nb_prod (pf_concl g)  - 2  in 
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
-    let ids = args_names@(pf_ids_of_hyps g) in
-    (* and fresh names for res H and the principle (cf bug bug #1174) *)
-    let res,hres,graph_principle_id = 
-      match generate_fresh_id (id_of_string "z") ids 3 with 
-	| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
-	| _ -> assert false 
-    in
-    let ids = res::hres::graph_principle_id::ids in 
-    (* we also compute fresh names for each hyptohesis of each branche of the principle *)
-    let branches = List.rev princ_infos.branches in 
-    let intro_pats = 
-      List.map 
-	(fun (_,_,br_type) -> 
-	   List.map 
-	     (fun id -> id) 
-	     (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
-	)
-	branches
-    in
-    (* We will need to change the function by its body 
-       using [f_equation] if it is recursive (that is the graph is infinite 
-       or unfold if the graph is finite 
-    *)
-    let rewrite_tac j ids : tactic = 
-      let graph_def = graphs.(j) in 
-      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in 
-      if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
-      then 
-	let eq_lemma = 
-	  try Option.get (infos).equation_lemma
-	  with Option.IsNone -> anomaly "Cannot find equation lemma"
-	in 
-	tclTHENSEQ[
-	  tclMAP h_intro ids;
-	  Equality.rewriteLR (mkConst eq_lemma);
-	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
-	  h_reduce 
-	    (Rawterm.Cbv
-	       {Rawterm.all_flags 
-		with Rawterm.rDelta = false; 		 
-	       }) 
-	    onConcl
-	  ;
-	  h_generalize (List.map mkVar ids);
-	  thin ids
-	]
-      else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
-    in
-    (* The proof of each branche itself *)
-    let ind_number = ref 0 in 
-    let min_constr_number = ref 0 in
-    let prove_branche i g = 
-      (* we fist compute the inductive corresponding to the branch *)
-      let this_ind_number = 
-	let constructor_num = i - !min_constr_number in 
-	let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in 
-	if constructor_num <= length
-	then !ind_number
-	else 
-	  begin
-	    incr ind_number;
-	    min_constr_number := !min_constr_number + length;
-	    !ind_number
-	  end
-      in
-      let this_branche_ids = List.nth intro_pats (pred i) in
-      tclTHENSEQ[
-	(* we expand the definition of the function *)
-        observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
-	(* introduce hypothesis with some rewrite *)
-        observe_tac "intros_with_rewrite" intros_with_rewrite;
-	(* The proof is (almost) complete *)
-        observe_tac "reflexivity" (reflexivity_with_destruct_cases)
-      ]
-	g
-    in
-    let params_names = fst (list_chop princ_infos.nparams args_names) in
-    let params = List.map mkVar params_names in 
-    tclTHENSEQ 
-      [ tclMAP h_intro (args_names@[res;hres]);
-	observe_tac "h_generalize" 
-	(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 false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
-	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
-      ]
-      g
-
-
-
-
-let do_save () = Command.save_named false
-
-
-(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness 
-   lemmas for each function in [funs] w.r.t. [graphs]
-   
-   [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and 
-   [functional_induction] is Indfun.functional_induction (same pb) 
-*)
-   
-let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = 
-  let funs = Array.of_list funs and graphs = Array.of_list graphs in
-  let funs_constr = Array.map mkConst funs  in
-  try 
-    let graphs_constr = Array.map mkInd graphs in 
-    let lemmas_types_infos = 
-      Util.array_map2_i 
-	(fun i f_constr graph -> 
-	   let const_of_f = destConst f_constr in 
-	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
-	     generate_type false const_of_f graph i
-	   in 
-	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
-	   let type_of_lemma = nf_zeta type_of_lemma in
-	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
-	   type_of_lemma,type_info
-	)
-	funs_constr
-	graphs_constr 
-    in
-    let schemes = 
-      (* The functional induction schemes are computed and not saved if there is more that one function 
-	 if the block contains only one function we can safely reuse [f_rect]
-      *)
-      try
-	if Array.length funs_constr <> 1 then raise Not_found;
-	[| find_induction_principle funs_constr.(0) |]
-      with Not_found -> 
-	  Array.of_list 
-	    (List.map 
-	       (fun entry -> 
-		  (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))
-	    )
-    in
-    let proving_tac = 
-      prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
-    in
-    Array.iteri 
-      (fun i f_as_constant -> 
-	 let f_id = id_of_label (con_label f_as_constant) in
-	 Command.start_proof 
-	   (*i The next call to mk_correct_id is valid since we are constructing the lemma
-	     Ensures by: obvious
-	     i*) 
-	   (mk_correct_id f_id)
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
-	 do_save ();
-	 let finfo = find_Function_infos f_as_constant in 
-	 update_Function
-	   {finfo with 
-	      correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
-	   }
-
-      )
-      funs;
-    let lemmas_types_infos = 
-      Util.array_map2_i 
-	(fun i f_constr graph -> 
-	   let const_of_f = destConst f_constr in 
-	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
-	     generate_type true  const_of_f graph i
-	   in 
-	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
-	   let type_of_lemma = nf_zeta type_of_lemma in
-	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
-	   type_of_lemma,type_info
-	)
-	funs_constr
-	graphs_constr 
-    in
-    let kn,_ as graph_ind  = destInd graphs_constr.(0) in 
-    let  mib,mip = Global.lookup_inductive graph_ind in
-    let schemes = 
-      Array.of_list 
-	(Indrec.build_mutual_indrec (Global.env ()) Evd.empty
-	   (Array.to_list 
-	      (Array.mapi
-		 (fun i mip -> (kn,i),mib,mip,true,InType)
-		 mib.Declarations.mind_packets
-	      )
-	   )
-	)
-    in
-    let proving_tac = 
-      prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
-    in
-    Array.iteri 
-      (fun i f_as_constant -> 
-	 let f_id = id_of_label (con_label f_as_constant) in
-	 Command.start_proof 
-	   (*i The next call to mk_complete_id is valid since we are constructing the lemma
-	     Ensures by: obvious
-	     i*) 
-	   (mk_complete_id f_id)
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
-	 do_save ();
-	 let finfo = find_Function_infos f_as_constant in 
-	 update_Function
-	   {finfo with 
-	      completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
-	   }
-      )
-      funs;
-  with e ->
-    (* In case of problem, we reset all the lemmas *)
-    (*i The next call to mk_correct_id is valid since we are erasing the lemmas
-      Ensures by: obvious
-      i*) 
-    let first_lemma_id = 
-      let f_id = id_of_label (con_label funs.(0)) in 
-      
-      mk_correct_id f_id 
-    in
-     ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
-    raise e
-	   
-		   
-
-
-
-(***********************************************)
-
-(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
-   when [kn] denotes a graph block  into
-   f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result 
-   
-   if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
-*)
-let revert_graph kn post_tac hid g =
-    let typ = pf_type_of g (mkVar hid) in 
-    match kind_of_term typ with 
-      | App(i,args) when isInd i -> 
-	  let ((kn',num) as ind') = destInd i in 
-	  if kn = kn' 
-	  then (* We have generated a graph hypothesis so that we must change it if we can *)
-	    let info = 
-	      try find_Function_of_graph ind'
-	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
-		anomaly "Cannot retrieve infos about a mutual block"
-	    in 
-	    (* if we can find a completeness lemma for this function 
-	       then we can come back to the functional form. If not, we do nothing 
-	    *)
-	    match info.completeness_lemma with 
-	      | None -> tclIDTAC g
-	      | Some f_complete -> 
-		  let f_args,res = array_chop (Array.length args - 1) args in
-		  tclTHENSEQ
-		    [
-		      h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
-		      thin [hid];
-		      h_intro hid; 
-		      post_tac hid
-		    ]
-		    g
-		    
-	  else tclIDTAC g
-      | _ -> tclIDTAC g
-
-
-(* 
-   [functional_inversion hid fconst f_correct ] is the functional version of [inversion]
-   
-   [hid] is the hypothesis to invert, [fconst] is the function to invert and  [f_correct]
-   is the correctness lemma for [fconst].
-
-   The sketch is the follwing~: 
-   \begin{enumerate} 
-   \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ 
-   (fails if it is not possible)
-   \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
-   \item apply [inversion] on [hid]
-   \item finally in each branch, replace each  hypothesis [R\_f ..]  by [f ...] using [f_complete] (whenever 
-   such a lemma exists)
-   \end{enumerate}
-*)
-     
-let functional_inversion kn hid fconst f_correct : tactic = 
-  fun g -> 
-    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in 
-    let type_of_h = pf_type_of g (mkVar hid) in 
-    match kind_of_term type_of_h with 
-      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  -> 
-	  let pre_tac,f_args,res = 
-	    match kind_of_term args.(1),kind_of_term args.(2) with 
-	      | App(f,f_args),_ when eq_constr f fconst -> 
-		  ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
-	      |_,App(f,f_args) when eq_constr f fconst -> 
-		 ((fun hid -> tclIDTAC),f_args,args.(1)) 
-	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
-	  in 
-	  tclTHENSEQ[
-	    pre_tac hid;
-	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
-	    thin [hid];
-	    h_intro hid;
-	    Inv.inv FullInversion None (Rawterm.NamedHyp hid);
-	    (fun g ->
-	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in 
-	       tclMAP (revert_graph kn pre_tac)  (hid::new_ids)  g
-	    );
-	  ] g
-      | _ -> tclFAIL 1 (mt ()) g
-
-
-
-let invfun qhyp f  =  
-  let f = 
-    match f with 
-      | ConstRef f -> f 
-      | _ -> raise (Util.UserError("",str "Not a function"))
-  in
-  try 
-    let finfos = find_Function_infos f in 
-    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" 
-    | Option.IsNone  -> error "Cannot use equivalence with graph!"
-
-
-let invfun qhyp f g = 
-  match f with 
-    | Some f -> invfun qhyp f g
-    | None -> 
-	Tactics.try_intros_until 
-	  (fun hid g -> 
-	     let hyp_typ = pf_type_of g (mkVar hid)  in 
-	     match kind_of_term hyp_typ with 
-	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> 
-		   begin
-		     let f1,_ = decompose_app args.(1) in 
-		     try 
-		       if not (isConst f1) then failwith "";
-		       let finfos = find_Function_infos (destConst f1) in 
-		       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 "" | 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(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")
-			 | Option.IsNone  ->  
-			     if do_observe () 
-			     then
-			       error "Cannot use equivalence with graph for any side of the equality"
-			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
-			 | Not_found -> 
-			     if do_observe () 
-			     then
-			       error "No graph found for any side of equality" 
-			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
-		   end
-	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
-	  )
-	  qhyp
-	  g
diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml
deleted file mode 100644
index 9bbd165d..00000000
--- a/contrib/funind/merge.ml
+++ /dev/null
@@ -1,1034 +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        *)
-(************************************************************************)
-
-(* 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
-open Rawtermops
-
-(** {1 Utilities}  *)
-
-(** {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 
-  then true
-  else false
-
-let rec compare_constr' t1 t2 =
-  if compare_constr_nosub t1 t2 
-  then true
-  else (compare_constr (compare_constr') t1 t2)
-
-let rec substitterm prof t by_t in_u =
-  if (compare_constr' (lift prof t) in_u)
-  then (lift prof by_t)
-  else map_constr_with_binders succ 
-    (fun i -> substitterm i t by_t) prof in_u
-
-let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
-
-let understand = Pretyping.Default.understand Evd.empty (Global.env())
-
-(** Operations on names and identifiers *)
-let id_of_name = function
-    Anonymous -> id_of_string "H"
-  | Name id   -> id;;
-let name_of_string str = Name (id_of_string str)
-let string_of_name nme = string_of_id (id_of_name nme)
-
-(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
-let isVarf f x = 
-    match x with
-      | RVar (_,x) -> Pervasives.compare x f = 0 
-      | _ -> false
-
-(** [ident_global_exist id] returns true if identifier [id] is linked
-    in global environment. *)
-let ident_global_exist id = 
-  try 
-    let ans = CRef (Libnames.Ident (dummy_loc,id)) in
-    let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
-    true
-  with _ -> false 
-
-(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
-    global env) with base [id]. *)
-let next_ident_fresh (id:identifier) = 
-    let res = ref id in
-    while ident_global_exist !res do res := Nameops.lift_ident !res done;
-    !res
-
-
-(** {2 Debugging} *)
-(* comment this line to see debug msgs *)
-let msg x = () ;; let pr_lconstr c = str ""
-(* uncomment this to see debugging *)
-let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c)
-let prconstrnl c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
-let prlistconstr lc = List.iter prconstr lc
-let prstr s = msg(str s)
-let prNamedConstr s c = 
-  begin
-    msg(str "");
-    msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
-    msg(str "");
-  end
-let prNamedRConstr s c = 
-  begin
-    msg(str "");
-    msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
-    msg(str "");
-  end
-let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
-let prNamedLConstr s lc = 
-  begin
-    prstr "[§§§ ";
-    prstr s;
-    prNamedLConstr_aux lc;
-    prstr " §§§]\n";
-  end
-let prNamedLDecl s lc = 
-  begin
-    prstr s; prstr "\n";
-    List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
-    prstr "\n";
-  end
-let 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
-  let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
-  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
-  List.iter (fun (nm, optcstr, tp) -> 
-    print_string (string_of_name nm^":");
-    prconstr tp; print_string "\n") 
-    ib1.mind_arity_ctxt;
-  (match ib1.mind_arity with
-    | Monomorphic x ->
-        Printf.printf "arity :"; prconstr x.mind_user_arity
-    | Polymorphic x -> 
-        Printf.printf "arity : universe?");
-  Array.iteri 
-    (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
-    ib1.mind_user_lc
-
-(** {2 Misc} *)
-
-exception Found of int
-
-(* Array scanning *)
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = 
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    None
-  with Found i -> Some i
-
-let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    Array.length arr (* all elt are positive *)
-  with Found i -> i
-
-let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = 
-  let i = ref 0 in 
-  Array.fold_left 
-    (fun acc x -> 
-      let res = f !i acc x in i := !i + 1; res)
-    acc arr
-
-(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
-let list_chop_end i l =
-  let size_prefix = List.length l -i in
-  if size_prefix < 0 then failwith "list_chop_end"
-  else list_chop size_prefix l
-
-let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = 
-  let i = ref 0 in 
-  List.fold_left 
-    (fun acc x -> 
-      let res = f !i acc x in i := !i + 1; res)
-    acc arr
-
-let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = 
-  let i = ref 0 in 
-  List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
-
-
-(** Iteration module *)
-module For = 
-struct
-  let rec map i j (f: int -> 'a)  = if i>j then [] else f i :: (map (i+1) j f)
-  let rec foldup i j (f: 'a -> int -> 'a) acc = 
-    if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
-  let rec folddown i j (f: 'a -> int -> 'a) acc = 
-    if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
-  let fold i j = if i<j then foldup i j else folddown i j
-end
-
-
-(** {1 Parameters shifting and linking information} *)
-
-(** This type is used to deal with debruijn linked indices. When a
-    variable is linked to a previous one, we will ignore it and refer
-    to previous one. *)
-type linked_var =
-    | Linked of int
-    | Unlinked
-    | Funres
-
-(** When merging two graphs, parameters may become regular arguments,
-    and thus be shifted. This type describes the result of computing
-    the changes. *)
-type 'a shifted_params =
-    {
-      nprm1:'a;
-      nprm2:'a;
-      prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *)
-      nuprm1:'a;
-      nuprm2:'a;
-      nargs1:'a;
-      nargs2:'a;
-    }
-
-
-let prlinked x =
-  match x with
-    | Linked i -> Printf.sprintf "Linked %d" i
-    | Unlinked -> Printf.sprintf "Unlinked"
-    | Funres -> Printf.sprintf "Funres"
-
-let linkmonad f lnkvar = 
-  match lnkvar with
-    | Linked i -> Linked (f i)
-    | Unlinked -> Unlinked
-    | Funres -> Funres
-
-let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
-
-(* This map is used to deal with debruijn linked indices. *)
-module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
-
-let pr_links l = 
-  Printf.printf "links:\n";
-  Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
-  Printf.printf "_____________\n"
-
-type 'a merged_arg =
-    | Prm_stable of 'a
-    | Prm_linked of 'a
-    | Prm_arg of 'a
-    | Arg_stable of 'a
-    | Arg_linked of 'a
-    | Arg_funres
-
-(** 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 *)
-      mib1: mutual_inductive_body;
-      oib1: one_inductive_body; 
-      mib2: mutual_inductive_body;
-      oib2: one_inductive_body; 
-
-      (** Array of links of the first inductive (should be all stable) *)
-      lnk1: int merged_arg array;
-
-      (** Array of links of the second inductive (point to the first ind param/args) *)
-      lnk2: int merged_arg array;
-
-      (** rec params which remain rec param (ie not linked) *)
-      recprms1: rel_declaration list;
-      recprms2: rel_declaration list;
-      nrecprms1: int; 
-      nrecprms2: int;
-
-      (** 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;
-
-      (** 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;
-    }
-
-
-let pr_merginfo x =
-  let i,s=
-    match x with 
-      | Prm_linked i -> Some i,"Prm_linked"
-      | Arg_linked i -> Some i,"Arg_linked"
-      | Prm_stable i -> Some i,"Prm_stable"
-      | Prm_arg i -> Some i,"Prm_arg"
-      | Arg_stable i -> Some i,"Arg_stable"
-      | Arg_funres -> None , "Arg_funres" in
-  match i with
-    | Some i -> Printf.sprintf "%s(%d)" s i
-    | None -> Printf.sprintf "%s" s
-
-let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
-
-(* ?? 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
-
-let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
-  let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in
-  let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in
-  let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in
-  prms@args@fres
-
-(** Reverse the link map, keeping only linked vars, elements are list
-    of int as several vars may be linked to the same var. *)
-let revlinked lnk =
-  For.fold 0 (Array.length lnk - 1)
-    (fun acc k -> 
-      match lnk.(k) with 
-        | Unlinked | Funres -> acc 
-        | Linked i -> 
-            let old = try Link.find i acc with Not_found -> [] in
-            Link.add i (k::old) acc)
-    Link.empty
-
-let array_switch arr i j = 
-  let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
-
-let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
-  let larr = Array.of_list l in
-  let _ =
-    Array.iteri
-      (fun j x -> 
-        match x with
-          | Prm_linked i -> array_switch larr i j
-          | Arg_linked i -> array_switch larr i j
-          | Prm_stable i -> ()
-          | Prm_arg i -> ()
-          | Arg_stable i -> ()
-          | Arg_funres -> ()
-      ) lnk in
-  filter_shift_stable lnk (Array.to_list larr)
-
-
-
-
-(** {1 Utilities for merging} *)
-
-let ind1name = id_of_string "__ind1"
-let ind2name = id_of_string "__ind2"
-
-(** Performs verifications on two graphs before merging: they must not
-    be co-inductive, and for the moment they must not be mutual
-    either. *)
-let verify_inds mib1 mib2 =
-  if not mib1.mind_finite then error "First argument is coinductive";
-  if not mib2.mind_finite then error "Second argument is coinductive";
-  if mib1.mind_ntypes <> 1 then error "First argument is mutual";
-  if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
-  ()
-
-(*
-(** [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} *)
-
-(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec
-    uniform and ordinary ones) of mutual inductives [mib1] and [mib2]
-    remain uniform when linked by [lnk]. All parameters are
-    considered, ie we take parameters of the first inductive body of
-    [mib1] and [mib2].
-    
-    Explanation: The two inductives have parameters, some of the first
-    are recursively uniform, some of the last are functional result of
-    the functional graph.
-
-   (I x1 x2 ... xk ... xk' ... xn)
-   (J y1 y2 ... xl ... yl' ... ym)
-
-   Problem is, if some rec unif params are linked to non rec unif
-   ones, they become non rec (and the following too). And functinal
-   argument have to be shifted at the end *)
-let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
-  let _ = 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
-  let is_targetted_by_non_recparam_lnk1 i = 
-    try 
-      let targets = Link.find i linked_targets in 
-      List.exists (fun x -> not (is_param_of_mib2 x)) targets
-    with Not_found -> false in
-  let mlnk1 = 
-    Array.mapi
-      (fun i lkv -> 
-        let isprm = is_param_of_mib1 i in
-        let prmlost = is_targetted_by_non_recparam_lnk1 i in
-        match isprm , prmlost, lnk1.(i) with
-          | true , true , _ -> Prm_arg i (* recparam becoming ordinary *)
-          | true , false , _-> Prm_stable i (* recparam remains recparam*)
-          | false , false , Funres -> Arg_funres
-          | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
-          | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
-      lnk1 in
-  let mlnk2 = 
-    Array.mapi
-      (fun i lkv -> 
-        (* Is this correct if some param of ind2 is lost? *)
-        let isprm = is_param_of_mib2 i in
-        match isprm , lnk2.(i) with
-          | true , Linked j when not (is_param_of_mib1 j) -> 
-              Prm_arg j (* recparam becoming ordinary *)
-          | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
-          | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
-          | false , Linked j -> Arg_linked j (* Args of lnk2 lost *)
-          | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *)
-          | false , Funres -> Arg_funres
-          | true , Funres -> assert false (* fun res cannot be a rec param *)
-      )
-      lnk2 in
-  let oib1 = mib1.mind_packets.(0) in
-  let oib2 = mib2.mind_packets.(0) in
-  (* count params remaining params *)
-  let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
-  let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
-  let bldprms arity_ctxt mlnk = 
-    list_fold_lefti
-      (fun i (acc1,acc2,acc3,acc4) x -> 
-        prstr (pr_merginfo mlnk.(i));prstr "\n";
-        match mlnk.(i) with
-          | 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;
-    oib1 = oib1;
-    mib2=mib2;
-    oib2 = oib2;
-    lnk1 = mlnk1;
-    lnk2 = mlnk2;
-    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;
-  }
-
-
-
-
-(** {1 Merging functions} *)
-
-exception NoMerge
-
-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
-    | 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)
-          (* 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 branch 1 with all rec calls of branch 2. *)
-(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-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,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
-
-
-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 = 
-  try
-    ignore
-      (List.map
-          (fun x -> 
-            match x with
-              | _,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 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,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
-  let _ = prstr "\nltyp 2 : " 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 rechyps =
-            if isrec1 && isrec2 
-            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",None,Some concl2]) filter_shift_stable
-            else if isrec2
-            then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
-              filter_shift_stable_right
-            else ltyp2 in
-          let _ = prstr"\nrechyps : " 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
-          let _ = prNamedRConstr "concl2" concl2 in
-          let _ = prstr "\n" in
-          let concl = 
-            merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
-          let _ = prstr "FIN " in
-          let _ = prNamedRConstr "concl" concl in
-          let _ = prstr "\n" in
-
-          rechyps , concl
-      | (nme,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,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
-
-
-(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of
-    linked args [allargs2] to target args of [allargs1] as specified
-    in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
-    returns the list of unlinked vars of [allargs2]. *)
-let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
-    (lnk:int merged_arg array) =
-  array_fold_lefti
-    (fun i acc e -> 
-      if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
-      else 
-        match e with 
-          | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
-          | _ -> acc)
-    Idmap.empty lnk
-
-let build_link_map allargs1 allargs2 lnk =
-  let allargs1 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in
-  let allargs2 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
-  build_link_map_aux allargs1 allargs2 lnk
-
-
-(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two
-    constructor rawtypes [typcstr1] and [typcstr2].  [typcstr1] and
-    [typcstr2] contain all parameters (including rec. unif. ones) of
-    their inductive.
-
-    if  [typcstr1] and [typcstr2] are of the form:
-
-    forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1)
-    forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2)
-
-    we build:
-
-    forall recparams1 (recparams2 without linked params),
-     forall ordparams1 (ordparams2 without linked params),
-      H1a' -> H2a' -> ...  -> H2a' -> H2b'(shifted) -> ... 
-        -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
-
-    where Hix' have been adapted, ie: 
-      - linked vars have been changed,
-      - rec calls to I1 and I2 have been replaced by rec calls to
-        newI. More precisely calls to I1 and I2 have been merge by an
-        experimental heuristic (in particular if n o rec calls for I1
-        or I2 is found, we use the conclusion as a rec call). See
-        [merge_types] above.
-
-    Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
-
-    TODO: return nothing if equalities (after linking) are contradictory. *)
-let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
-    (typcstr2:rawconstr) : rawconstr =
-  (* FIXME: les noms des parametres corerspondent en principe au
-     parametres du niveau mib, mais il faudrait s'en assurer *)
-  (* shift.nfunresprmsx last args are functional result *)
-  let nargs1 = 
-    shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
-  let nargs2 =
-    shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
-  let allargs1,rest1 = raw_decompose_prod_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_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 _ = 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 _ = 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
-
-
-(** constructor numbering *)
-let fresh_cstror_suffix , cstror_suffix_init =
-  let cstror_num = ref 0 in
-  (fun () -> 
-    let res = string_of_int !cstror_num in
-    cstror_num := !cstror_num + 1;
-    res) ,
-  (fun () -> cstror_num := 0)
-
-(** [merge_constructor_id id1 id2 shift] returns the identifier of the
-    new constructor from the id of the two merged constructor and
-    the merging info. *)
-let merge_constructor_id id1 id2 shift:identifier = 
-  let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
-  next_ident_fresh (id_of_string id)
-
-
-
-(** [merge_constructors lnk shift avoid] merges the two list of
-    constructor [(name*type)]. These are translated to rawterms
-    first, each of them having distinct var names. *)
-let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * rawconstr) list) 
-    (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
-  List.flatten 
-    (List.map
-        (fun (id1,rawtyp1) -> 
-          List.map
-            (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)
-    
-(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
-    inductive bodies [oib1] and [oib2], linking with [lnk], params
-    info in [shift], avoiding identifiers in [avoid]. *)
-let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
-    (oib2:one_inductive_body) =
-  (* 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();
-  params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2
-
-
-(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
-    inductive bodies [mib1] and [mib2] linking vars with
-    [lnk]. [shift] information on parameters of the new inductive.
-    For the moment, inductives are supposed to be non mutual.
-*)
-let rec merge_mutual_inductive_body
-    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
-  (* Mutual not treated, we take first ind body of each. *)
-  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 prms1 prms2 shift (concl:constr) = 
-  let params = prms2 @ prms1 in
-  let resparams =
-    List.fold_left
-      (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)],Topconstr.default_binder_kind,typ] , acc) , newenv)
-      (concl,Global.env())
-      (shift.funresprms2 @ shift.funresprms1 
-        @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in  
-  resparams,arity
-
-  
-
-(** [rawterm_list_to_inductive_expr ident rawlist] returns the
-    induct_expr corresponding to the the list of constructor types
-    [rawlist], named ident.
-    FIXME: params et cstr_expr (arity) *)
-let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
-    (rawlist:(identifier * rawconstr) list) =
-  let lident = dummy_loc, shift.ident in
-  let bindlist , cstr_expr = (* params , arities *)
-    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 , Some 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. *)
-let merge_inductive (ind1: inductive) (ind2: inductive) 
-    (lnk1: linked_var array) (lnk2: linked_var array) id =
-  let env = Global.env() in
-  let mib1,_ = Inductive.lookup_mind_specif env ind1 in
-  let mib2,_ = Inductive.lookup_mind_specif env ind2 in
-  let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
-  (* compute params that become ordinary args (because linked to ord. args) *)
-  let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
-  let 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 *)
-
-
-(* 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
-  (* 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",
-    title = "Rippling: A Heuristic for Guiding Inductive Proofs",
-    journal = "Artificial Intelligence",
-    volume = "62",
-    number = "2",
-    pages = "185-253",
-    year = "1993",
-    url = "citeseer.ist.psu.edu/bundy93rippling.html" }
-
- *)
-(* 
-*** Local Variables: ***
-*** compile-command: "make -C ../.. contrib/funind/merge.cmo" ***
-*** indent-tabs-mode: nil ***
-*** End: ***
-*)
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
deleted file mode 100644
index 09b7fbdf..00000000
--- a/contrib/funind/rawterm_to_relation.ml
+++ /dev/null
@@ -1,1262 +0,0 @@
-open Printer
-open Pp
-open Names 
-open Term
-open Rawterm
-open Libnames
-open Indfun_common
-open Util
-open Rawtermops
-
-let observe strm =  
-  if do_observe ()
-  then Pp.msgnl strm 
-  else ()
-let observennl strm =  
-  if do_observe ()
-  then Pp.msg strm 
-  else ()
-
-
-type binder_type =
-  | Lambda of name 
-  | Prod of name 
-  | LetIn of name
-
-type raw_context = (binder_type*rawconstr) list
-
-
-(* 
-   compose_raw_context [(bt_1,n_1,t_1);......] rt returns 
-   b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the 
-   binders corresponding to the bt_i's
-*)
-let compose_raw_context = 
-  let compose_binder  (bt,t) acc =
-    match bt with 
-      | Lambda n -> mkRLambda(n,t,acc)
-      | Prod n -> mkRProd(n,t,acc)
-      | LetIn n -> mkRLetIn(n,t,acc)
-  in
-  List.fold_right compose_binder
-  
-
-(* 
-   The main part deals with building a list of raw constructor expressions
-   from the rhs of a fixpoint equation. 
-*)
-
-type 'a build_entry_pre_return = 
-    {
-      context : raw_context;  (* the binding context of the result *)
-      value : 'a; (* The value *)
-    }
-
-type 'a build_entry_return = 
-    {
-      result : 'a build_entry_pre_return list; 
-      to_avoid : identifier list
-    }
-
-(*
-  [combine_results combine_fun res1 res2] combine two results [res1] and [res2] 
-  w.r.t. [combine_fun].
-
-  Informally, both [res1] and [res2] are lists of "constructors"  [res1_1;...] 
-  and [res2_1,....] and we need to produce 
-  [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........]
-*)
-
-let combine_results 
-    (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 
-      'c build_entry_pre_return
-    )  
-    (res1: 'a build_entry_return) 
-    (res2 : 'b build_entry_return) 
-    : 'c build_entry_return 
-    = 
-  let pre_result =     List.map 
-    ( fun res1 ->  (* for each result in arg_res *)
-	  List.map (* we add it in each args_res *) 
-	    (fun res2 -> 
-	       combine_fun res1 res2
-	    )
-	    res2.result
-      )
-      res1.result
-  in (* and then we flatten the map *)
-  {
-    result = List.concat pre_result; 
-    to_avoid = list_union res1.to_avoid res2.to_avoid
-  }
-    
-
-(* 
-   The combination function for an argument with a list of argument 
-*)
-
-let combine_args arg args = 
-  {
-    context = arg.context@args.context; 
-    (* Note that the binding context of [arg] MUST be placed before the one of 
-       [args] in order to preserve possible type dependencies 
-    *)
-    value = arg.value::args.value;
-  }
-
-
-let ids_of_binder =  function 
-  | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
-  | LetIn (Name id)  | Prod (Name id) | Lambda (Name id) -> [id]
-
-let rec change_vars_in_binder mapping = function 
-    [] -> []
-  | (bt,t)::l ->
-      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in 
-      (bt,change_vars mapping t)::
-	(if idmap_is_empty new_mapping
-	 then l 
-	 else change_vars_in_binder new_mapping l
-	)
-
-let rec replace_var_by_term_in_binder x_id term = function
-  | [] -> []
-  | (bt,t)::l -> 
-      (bt,replace_var_by_term x_id term t)::
-	if List.mem x_id (ids_of_binder bt) 
-	then l
-	else replace_var_by_term_in_binder x_id term l
-
-let add_bt_names bt = List.append (ids_of_binder bt)
-
-let apply_args ctxt body args = 
-  let need_convert_id avoid id = 
-    List.exists (is_free_in id) args || List.mem id avoid 
-  in 
-  let need_convert avoid  bt =  
-    List.exists (need_convert_id avoid) (ids_of_binder bt)
-  in
-  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = 
-    match na with 
-       | Name id when List.mem id avoid -> 
-	   let new_id = Nameops.next_ident_away id avoid in 
-	   Name new_id,Idmap.add id new_id mapping,new_id::avoid
-       | _ -> na,mapping,avoid
-  in
-  let next_bt_away bt (avoid:identifier list) = 
-    match bt with 
-      | LetIn na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
-	  LetIn new_na,mapping,new_avoid
-      | Prod na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
-	  Prod new_na,mapping,new_avoid
-      | Lambda na -> 
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
-	  Lambda new_na,mapping,new_avoid
-  in
-  let rec do_apply avoid ctxt body args = 
-    match ctxt,args with  
-      | _,[] -> (* No more args *)
-	  (ctxt,body)
-      | [],_ -> (* no more fun *)
-	  let f,args' = raw_decompose_app body in
-	  (ctxt,mkRApp(f,args'@args))
-      | (Lambda Anonymous,t)::ctxt',arg::args' -> 
-	  do_apply avoid ctxt' body args'
-      | (Lambda (Name id),t)::ctxt',arg::args' -> 
-	  let new_avoid,new_ctxt',new_body,new_id = 
-	    if need_convert_id avoid id 
-	    then 
-	      let new_avoid =  id::avoid in 
-	      let new_id = Nameops.next_ident_away id new_avoid in 
-	      let new_avoid' = new_id :: new_avoid in 
-	      let mapping = Idmap.add id new_id Idmap.empty in 
-	      let new_ctxt' = change_vars_in_binder mapping ctxt' in 
-	      let new_body = change_vars mapping body in 
-	      new_avoid',new_ctxt',new_body,new_id
-	    else 
-	      id::avoid,ctxt',body,id 
-	  in
-	  let new_body = replace_var_by_term new_id arg new_body in
-	  let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
-	  do_apply avoid new_ctxt' new_body args'
-      | (bt,t)::ctxt',_ -> 
-	  let new_avoid,new_ctxt',new_body,new_bt = 
-	    let new_avoid = add_bt_names bt avoid in 
-	    if need_convert avoid bt 
-	    then 
-	      let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in 
-	      (
-		new_avoid,
-		change_vars_in_binder mapping ctxt',
-		change_vars mapping body,
-		new_bt
-	     )
-	    else new_avoid,ctxt',body,bt
-	  in
-	  let new_ctxt',new_body = 
-	    do_apply new_avoid new_ctxt' new_body args 
-	  in
-	  (new_bt,t)::new_ctxt',new_body
-  in 
-  do_apply []  ctxt body args
-
-
-let combine_app f args = 
-  let new_ctxt,new_value = apply_args f.context f.value args.value in 
-  { 
-    (* Note that the binding context of [args] MUST be placed before the one of 
-       the applied value in order to preserve possible type dependencies 
-    *)
-      context = args.context@new_ctxt;
-      value = new_value;
-  }
-
-let combine_lam n t b = 
-  {
-    context = []; 
-    value = mkRLambda(n, compose_raw_context t.context t.value, 
-		      compose_raw_context b.context b.value )
-  }
-
-
-
-let combine_prod n t b = 
-  { context = t.context@((Prod n,t.value)::b.context); value = b.value}
-
-let combine_letin n t b = 
-  { context = t.context@((LetIn n,t.value)::b.context); value = b.value}
-
-
-let mk_result ctxt value avoid = 
-  { 
-    result = 
-      [{context = ctxt;
-	value = value}]
-	;
-    to_avoid = avoid
-  }
-(*************************************************
-  Some functions to deal with overlapping patterns 
-**************************************************)
-
-let coq_True_ref = 
-  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "True")
-
-let coq_False_ref = 
-  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "False")
-
-(*
-  [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
-  (the list of expresions on which we will do the matching)
- *) 
-let make_discr_match_el  = 
-  List.map (fun e -> (e,(Anonymous,None)))
-
-(*
-  [make_discr_match_brl i \[pat_1,...,pat_n\]]  constructs a discrimination pattern matching on the ith expression. 
-  that is. 
-  match ?????? with \\
-  | pat_1 => False  \\
-  | pat_{i-1} => False \\
-  | pat_i => True \\
-  | pat_{i+1} => False \\
-  \vdots 
-  | pat_n => False
-  end
-*)
-let make_discr_match_brl i = 
-  list_map_i 
-    (fun j (_,idl,patl,_) -> 
-       if j=i
-       then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
-       else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
-    )
-    0 
-(* 
-   [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff 
-   brl_{i} is the first branch matched by [el] 
-
-   Used when we want to simulate the coq pattern matching algorithm
-*)
-let make_discr_match brl = 
-  fun el i -> 
-  mkRCases(None,
-	   make_discr_match_el el,
-	   make_discr_match_brl i brl)
-
-let pr_name = function
-  | Name id -> Ppconstr.pr_id id
-  | Anonymous -> str "_"
-
-(**********************************************************************)
-(*  functions used to build case expression from lettuple and if ones *)
-(**********************************************************************)		
-
-(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)	  
-let build_constructors_of_type ind' argl = 
-  let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
-  let npar = mib.Declarations.mind_nparams in
-  Array.mapi (fun i _ ->
-		let construct = ind',i+1 in 
-		let constructref = ConstructRef(construct) in 
-		let _implicit_positions_of_cst =
-		  Impargs.implicits_of_global constructref
-		in
-		let cst_narg = 
-		  Inductiveops.mis_constructor_nargs_env
-		    (Global.env ())
-		    construct
-		in 
-		let argl = 
-		  if argl = [] 
-		  then
- 		    Array.to_list 
-		      (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
-		      )
-		  else argl
-		in
-		let pat_as_term = 
-		  mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
-		in
-		cases_pattern_of_rawconstr Anonymous pat_as_term
-	     )
-    ind.Declarations.mind_consnames
-
-(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
-let rec find_type_of nb b = 
-  let f,_ = raw_decompose_app b in 
-  match f with 
-    | RRef(_,ref) -> 
-	begin 
-	  let ind_type  = 
-	    match ref with 
-	      | VarRef _ | ConstRef _ -> 
-		  let constr_of_ref = constr_of_global ref in  
-		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in 
-		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in 
-		  let ret_type,_ = decompose_app ret_type in 
-		  if not (isInd ret_type) then 
-		    begin
-(* 		      Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
-		      raise (Invalid_argument "not an inductive")
-		    end;
-		  destInd ret_type
-	      | IndRef ind -> ind
-	      | ConstructRef c -> fst c 
-	  in
-	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in 
-	  if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
-	  then raise (Invalid_argument "find_type_of : not a valid inductive");
-	  ind_type	   
-	end
-    | RCast(_,b,_) -> find_type_of nb b 
-    | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
-    | _ -> raise (Invalid_argument "not a ref")
-    
-
-
-
-(******************)
-(* Main functions *)
-(******************)
-
-
-
-let raw_push_named (na,raw_value,raw_typ) env = 
-  match na with 
-    | Anonymous -> env 
-    | Name id -> 
-	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
-
-
-let add_pat_variables pat typ env : Environ.env = 
-  let rec add_pat_variables env pat typ  : Environ.env = 
-    observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
-
-    match pat with 
-      | PatVar(_,na) -> Environ.push_rel (na,None,typ) env 
-      | PatCstr(_,c,patl,na) -> 
-	  let Inductiveops.IndType(indf,indargs) = 
-	    try Inductiveops.find_rectype env Evd.empty typ
-	    with Not_found -> assert false 
-	  in
-	  let constructors = Inductiveops.get_constructors env indf in 
-	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in 
-	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
-	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) 
-  in
-  let new_env = add_pat_variables  env pat typ in 
-  let res =
-    fst (
-      Sign.fold_rel_context
-	(fun (na,v,t) (env,ctxt) ->
-	 match na with
-	   | Anonymous -> assert false
-	   | Name id ->
-	       let new_t =  substl ctxt t 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 ())
-		       );
-	       (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
-      )
-	(Environ.rel_context new_env)
-	~init:(env,[])
-    )
-  in
-  observe (str "new var env := " ++ Printer.pr_named_context_of res);
-  res
-
-
-
-
-let rec pattern_to_term_and_type env typ  = function
-  | PatVar(loc,Anonymous) -> assert false
-  | PatVar(loc,Name id) ->
-	mkRVar id
-  | PatCstr(loc,constr,patternl,_) ->
-      let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
-	  (Global.env ())
-	  constr
-      in
-      let Inductiveops.IndType(indf,indargs) = 
-	try Inductiveops.find_rectype env Evd.empty typ
-	with Not_found -> assert false 
-      in
-      let constructors = Inductiveops.get_constructors env indf in 
-      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in 
-      let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
-      let _,cstl = Inductiveops.dest_ind_family indf in 
-      let csta = Array.of_list cstl in 
-      let implicit_args =
-	Array.to_list
-	  (Array.init
-	     (cst_narg - List.length patternl)
-	     (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
-	  )
-      in
-      let patl_as_term =
-	List.map2 (pattern_to_term_and_type env)  (List.rev cs_args_types)  patternl
-      in
-      mkRApp(mkRRef(ConstructRef constr),
-	     implicit_args@patl_as_term
-	    )
-
-(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) 
-   of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the 
-   corresponding graphs. 
-
-
-   The idea to transform a term [t] into a list of constructors [lc] is the following:
-   \begin{itemize} 
-   \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding 
-   to [body] and add (bind x. _) to each elements of [lc]
-   \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) 
-   then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
-   then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], 
-   [g c1 ... cn] is an element of [lc]
-   \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then 
-   compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
-   then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
-   create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
-   \item if the term is a cast just treat its body part
-   \item 
-   if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case 
-   and concatenate them (informally, each branch of a match produces a new constructor)
-   \end{itemize}
-   
-   WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. 
-   We must wait to have complete all the current calculi to set the recursive calls. 
-   At this point, each term [f t1 ... tn]  (where f appears in [funnames]) is replaced by 
-   a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. 
-   We in fact not create a constructor list since then end of each constructor has not the expected form 
-   but only the value of the function 
-*)
-
-
-let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return = 
-  observe (str " Entering : " ++ Printer.pr_rawconstr rt);
-  match rt with 
-    | RRef _ | RVar _ | REvar _ | RPatVar _     | RSort _  | RHole _  -> 
-	(* do nothing (except changing type of course) *)
-	mk_result [] rt avoid 
-    | RApp(_,_,_) ->
-	let f,args = raw_decompose_app rt in
-	let args_res : (rawconstr list) build_entry_return =
-	  List.fold_right (* create the arguments lists of constructors and combine them *)
-	    (fun arg ctxt_argsl ->
-	       let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
-	       combine_results combine_args arg_res ctxt_argsl
-	    )
-	    args
-	    (mk_result [] [] avoid)
-	in
-	begin
-	  match f with
-	    | RVar(_,id) when Idset.mem id funnames ->
-		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
-		   then we create a fresh variable [res], 
-		   add [res] and its "value" (i.e. [res v1 ... vn]) to each 
-		   pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and 
-		   a pseudo value "v1 ... vn". 
-		   The "value" of this branch is then simply [res]
-		*)
-		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in 
-		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in 
-		let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
-		let res = fresh_id args_res.to_avoid "res" in
-		let new_avoid = res::args_res.to_avoid in
-		let res_rt = mkRVar res in 
-		let new_result = 
-		  List.map 
-		    (fun arg_res -> 
-		       let new_hyps = 
-			 [Prod (Name res),res_raw_type;
-			  Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
-		       in
-		       {context =  arg_res.context@new_hyps; value = res_rt } 
-		    )
-		    args_res.result
-		in 
-		{ result = new_result; to_avoid = new_avoid }
-	    | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> 
-		(* if have [g t1 ... tn] with [g] not appearing in [funnames] 
-		   then  
-		   foreach [ctxt,v1 ... vn] in [args_res] we return  
-		   [ctxt, g v1 .... vn]
-		*)
-		{
-		  args_res with 
-		    result = 
-		    List.map 
-		      (fun args_res -> 
-			 {args_res with value = mkRApp(f,args_res.value)})
-		      args_res.result
-		}
-	    | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
-       	    | RLetIn(_,n,t,b) -> 
-		(* if we have [(let x := v in b) t1 ... tn] , 
-		   we discard our work and compute the list of constructor for 
-		   [let x = v in (b t1 ... tn)] up to alpha conversion 
-		*)
-		let new_n,new_b,new_avoid = 
-		  match n with 
-		    | Name id when List.exists (is_free_in id) args -> 
-			(* need to alpha-convert the name *)
-			let new_id = Nameops.next_ident_away id avoid in 
-			let new_avoid = id:: avoid in
-			let new_b = 
-			  replace_var_by_term
-			    id
-			    (RVar(dummy_loc,id)) 
-			    b
-			in 
-			(Name new_id,new_b,new_avoid)
-		    | _ -> n,b,avoid
-		in
-		build_entry_lc 
-		  env
-		  funnames 
-		  avoid
-		  (mkRLetIn(new_n,t,mkRApp(new_b,args)))
-	    | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> 
-		(* we have [(match e1, ...., en with ..... end) t1 tn]
-		   we first compute the result from the case and 
-		   then combine each of them with each of args one
-		*)
-		let f_res = build_entry_lc env funnames args_res.to_avoid f in
-		combine_results combine_app f_res  args_res
-	    | RDynamic _ ->error "Not handled RDynamic" 
-	    | RCast(_,b,_) -> 
-		(* for an applied cast we just trash the cast part 
-		   and restart the work. 
-
-		   WARNING: We need to restart since [b] itself should be an application term
-		*)
-		build_entry_lc env funnames avoid (mkRApp(b,args))
-	    | RRec _ -> error "Not handled RRec"
-	    | RProd _ -> error "Cannot apply a type"
-	end (* end of the application treatement *) 
-
-    | 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 
-	   and combine the two result
-	*)
-	let t_res = build_entry_lc env funnames avoid t  in
-	let new_n = 
-	  match n with 
-	    | Name _ -> n 
-	    | Anonymous -> Name (Indfun_common.fresh_id [] "_x")
-	in
-	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) ->
-	(* we first compute the list of constructor 
-	   corresponding to the body of the function, 
-	   then the one corresponding to the type 
-	   and combine the two result
-	*)
-	let t_res = build_entry_lc env funnames avoid t in
-	let new_env = raw_push_named (n,None,t) env in
-	let b_res = build_entry_lc new_env funnames avoid b in
-	combine_results (combine_prod n) t_res b_res
-    | RLetIn(_,n,v,b) ->
-	(* we first compute the list of constructor 
-	   corresponding to the body of the function, 
-	   then the one corresponding to the value [t] 
-	   and combine the two result
-	*)
-	let v_res = build_entry_lc env funnames avoid v in
-	let v_as_constr = Pretyping.Default.understand Evd.empty env v in 
-	let v_type = Typing.type_of env Evd.empty v_as_constr in 
-	let new_env = 
-	  match n with
-	      Anonymous -> env
-	    | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env 
-	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) -> 
-	(* we create the discrimination function 
-	   and treat the case itself 
-	*)
-	let make_discr = make_discr_match brl in 
-	build_entry_lc_from_case env funnames make_discr el brl avoid
-    | RIf(_,b,(na,e_option),lhs,rhs) -> 
-	let b_as_constr = Pretyping.Default.understand Evd.empty env b in
-	let b_typ = Typing.type_of env Evd.empty b_as_constr in 
-	let (ind,_) =  
-	  try Inductiveops.find_inductive env Evd.empty b_typ 
-	  with Not_found -> 
-	    errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
-			       Printer.pr_rawconstr b ++ str " in " ++
-			       Printer.pr_rawconstr rt ++ str ". try again with a cast")
-	in
-	let case_pats = build_constructors_of_type ind [] in 
-	assert (Array.length case_pats = 2);
-	let brl =
-	  list_map_i
-	    (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
-	    0
-	    [lhs;rhs]
-	in
-	let match_expr =
-	  mkRCases(None,[(b,(Anonymous,None))],brl)
-	in
-	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
-	build_entry_lc env funnames avoid match_expr
-    | RLetTuple(_,nal,_,b,e) ->  
-	begin
-	  let nal_as_rawconstr =
-	    List.map
-	      (function
-		   Name id -> mkRVar id
-		 | Anonymous -> mkRHole ()
-	      )
-	      nal
-	  in
-	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
-	  let b_typ = Typing.type_of env Evd.empty b_as_constr in 
-	  let (ind,_) = 
-	    try Inductiveops.find_inductive env Evd.empty b_typ 
-	    with Not_found -> 
-	      errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
-				 Printer.pr_rawconstr b ++ str " in " ++
-				 Printer.pr_rawconstr rt ++ str ". try again with a cast")
-	  in
-	  let case_pats = build_constructors_of_type ind nal_as_rawconstr in 
-	  assert (Array.length case_pats = 1);
-	  let br =
-	    (dummy_loc,[],[case_pats.(0)],e)
-	  in
-	  let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
-	  build_entry_lc env funnames avoid match_expr
-
-	end
-    | RRec _ -> error "Not handled RRec"
-    | RCast(_,b,_) -> 
-	build_entry_lc env funnames  avoid b
-    | RDynamic _ -> error "Not handled RDynamic"
-and build_entry_lc_from_case env funname make_discr
-    (el:tomatch_tuples)
-    (brl:Rawterm.cases_clauses) avoid : 
-    rawconstr build_entry_return = 
-  match el with 
-    | [] -> assert false (* this case correspond to match <nothing> with .... !*) 
-    | el -> 
-	(* this case correspond to 
-	   match el with brl end
-	   we first compute the list of lists corresponding to [el] and 
-	   combine them . 
-	   Then for each elemeent of the combinations, 
-	   we compute the result we compute one list per branch in [brl] and 
-	   finally we just concatenate those list 
-	*)
-	let case_resl = 
-	    List.fold_right
-	    (fun (case_arg,_) ctxt_argsl ->
-	       let arg_res = build_entry_lc env funname avoid case_arg  in
-	       combine_results combine_args arg_res ctxt_argsl
-	    )
-	    el
-	      (mk_result [] [] avoid)
-	in
-	(****** The next works only if the match is not dependent ****)
-	let types = 
-	  List.map (fun (case_arg,_) -> 
-		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in 
-		      Typing.type_of env Evd.empty case_arg_as_constr
-		   ) el
-	in
-	let results =
-	  List.map 
-	    (build_entry_lc_from_case_term
-	       env types
-	       funname (make_discr (* (List.map fst el) *))
-	       []  brl 
-	       case_resl.to_avoid) 
-	    case_resl.result 
-	in 
-	{ 
-	  result = List.concat (List.map (fun r -> r.result) results);
-	  to_avoid = 
-	    List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
-	} 
-
-and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
-    matched_expr =
-  match brl with
-    | [] -> (* computed_branches  *) {result = [];to_avoid = avoid}
-    | br::brl' ->
-	(* alpha convertion to prevent name clashes *)
-	let _,idl,patl,return = alpha_br avoid br in
-	let new_avoid  = idl@avoid in 	(* for now we can no more use idl as an indentifier *)
-	(* building a list of precondition stating that we are not in this branch 
-	   (will be used in the following recursive calls)
-	*)
-	let new_env = List.fold_right2 add_pat_variables patl types env in 
-	let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = 
-	  List.map2
-	    (fun pat typ -> 
-	       fun avoid pat'_as_term -> 
-		 let renamed_pat,_,_ = alpha_pat avoid pat in
-		 let pat_ids = get_pattern_id renamed_pat  in 
-		 let env_with_pat_ids = add_pat_variables pat typ new_env in 
-		   List.fold_right 
-		   (fun id acc -> 		 
-		      let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in 
-		      let raw_typ_of_id = 
-			Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
-		      in
-		      mkRProd (Name id,raw_typ_of_id,acc))
-		   pat_ids
-		   (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
-	    )
-	    patl
-	    types
-	in
-	(* Checking if we can be in this branch 
-	   (will be used in the following recursive calls)
-	*)	   
-	let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
-	  List.map 
-	    (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') 
-	    patl
-	in
-	(* 
-	   we first compute the other branch result (in ordrer to keep the order of the matching 
-	   as much as possible)
-	*)
-	let brl'_res =
-	  build_entry_lc_from_case_term
-	    env 
-	    types
-	    funname
-	    make_discr
-	    ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent)
-	    brl'
-	    avoid
-	    matched_expr
-	in
-	(* We now create the precondition of this branch i.e.
-
-	   1- the list of variable appearing in the different patterns of this branch and 
-	      the list of equation stating than el = patl (List.flatten ...)
-	   2- If there exists a previous branch which pattern unify with the one of this branch 
-              then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
-	*)
-      	let those_pattern_preconds =
-	  (List.flatten
-	    (
-	      list_map3
-	      (fun pat e typ_as_constr ->
-		 let this_pat_ids = ids_of_pat pat in 
-		 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
-		 let pat_as_term = pattern_to_term pat in
-		 List.fold_right 
-		   (fun id  acc -> 
-		      if Idset.mem id this_pat_ids 
-		      then (Prod (Name id),
-		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in 
-		      let raw_typ_of_id = 
-			Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
-		      in
-		      raw_typ_of_id
-			   )::acc
-		      else acc
-			
-		   )
-		   idl
-		   [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
-	      )
-	      patl
-	      matched_expr.value
-	      types
-	  )
-	  )
-	  @
-	  (if List.exists (function (unifl,_) ->
-			     let (unif,_) = 
-			       List.split (List.map2 (fun x y -> x y) unifl patl)
-			     in
-			     List.for_all (fun x -> x) unif) patterns_to_prevent
-	   then 
-	     let i = List.length patterns_to_prevent in 
-	     let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
-	     [(Prod Anonymous,make_discr pats_as_constr i  )]
-	   else 
-	     []
-	  )
-	in
-	(* We compute the result of the value returned by the branch*)
-	let return_res = build_entry_lc new_env funname new_avoid return in
-	(* and combine it with the preconds computed for this branch *)
-	let this_branch_res =
-	  List.map
-	    (fun res  ->
-	       { context = matched_expr.context@those_pattern_preconds@res.context ;
-		 value = res.value}
-	    )
-	    return_res.result
-	in
-	{ brl'_res with result = this_branch_res@brl'_res.result }
-	  
-	  
-let is_res id = 
-  try
-    String.sub (string_of_id id) 0 3 = "res"
-  with Invalid_argument _ -> false 
-
-(* 
-   The second phase which reconstruct the real type of the constructor. 
-   rebuild the raw constructors expression. 
-   eliminates some meaningless equalities, applies some rewrites......
-*)
-let rec rebuild_cons nb_args relname args crossed_types depth rt = 
-  match rt with 
-    | 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
-	  match t with 
-	    | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
-		begin
-		  match args' with 
-		    | (RVar(_,this_relname))::args' -> 
-			let new_b,id_to_exclude =  
-			  rebuild_cons 
-			    nb_args relname
-			    args new_crossed_types
-			    (depth + 1) b
-			in 
-			(*i The next call to mk_rel_id is valid since we are constructing the graph
-			  Ensures by: obvious
-			  i*) 
-
-			let new_t = 
-			  mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) 
-			in mkRProd(n,new_t,new_b),
-			Idset.filter not_free_in_t id_to_exclude
-		    | _ -> (* the first args is the name of the function! *)
-			assert false 
-		end
-	    | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt]) 
-		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
-		  -> 
-		let is_in_b = is_free_in id b in
-		let _keep_eq = 
-		  not (List.exists (is_free_in id) args) || is_in_b  || 
-		    List.exists (is_free_in id) crossed_types 
-		in 
-		let new_args = List.map (replace_var_by_term id rt) args in 
-		let subst_b = 
-		  if is_in_b then b else  replace_var_by_term id rt b 
-		in 
-		let new_b,id_to_exclude =  
-		  rebuild_cons 
-		    nb_args relname
-		    new_args new_crossed_types
-		    (depth + 1) subst_b
-		in 
-		mkRProd(n,t,new_b),id_to_exclude
-		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities 
-		     if keep_eq then
-		     mkRProd(n,t,new_b),id_to_exclude
-		     else new_b, Idset.add id id_to_exclude
-		  *)
-	    | _ -> 
-		let new_b,id_to_exclude =  
-		  rebuild_cons 
-		    nb_args relname
-		    args new_crossed_types
-		    (depth + 1) b
-		in 
-		match n with
-		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id 
-			(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,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
-	  match n with
-	    | Name id ->
-		let new_b,id_to_exclude = 
-		  rebuild_cons 
-		    nb_args relname
-		    (args@[mkRVar id])new_crossed_types
-		    (depth + 1 ) b 
-		in
-		if Idset.mem id id_to_exclude && depth >= nb_args
-		then 
-		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
-		else
-		  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 *)
-	  
-	end
-    | RLetIn(_,n,t,b) -> 
-	begin
-	  let not_free_in_t id = not (is_free_in id t) in 
-	  let new_b,id_to_exclude = 
-	    rebuild_cons 
-	      nb_args relname
-	      args (t::crossed_types)
-	      (depth + 1 ) b in
-	  match n with 
-	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  -> 
-		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
-	    | _ -> RLetIn(dummy_loc,n,t,new_b),
-		Idset.filter not_free_in_t id_to_exclude
-	end
-    | RLetTuple(_,nal,(na,rto),t,b) -> 
-	assert (rto=None);
-	begin
-	  let not_free_in_t id = not (is_free_in id t) in 
-	  let new_t,id_to_exclude' = 
-	    rebuild_cons 
-	      nb_args
-	      relname 
-	      args (crossed_types) 
-	      depth t 
-	  in
-	  let new_b,id_to_exclude = 
-	    rebuild_cons 
-	      nb_args relname
-	      args (t::crossed_types) 
-	      (depth + 1) b 
-	  in
-(* 	  match n with  *)
-(* 	    | Name id when Idset.mem id id_to_exclude ->  *)
-(* 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
-(* 	    | _ -> *)
-	  RLetTuple(dummy_loc,nal,(na,None),t,new_b),
-		Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
-
-	end
-
-    | _ -> mkRApp(mkRVar  relname,args@[rt]),Idset.empty
-
-
-(* debuging wrapper *)
-let rebuild_cons nb_args relname args crossed_types rt = 
-(*   observennl  (str "rebuild_cons : rt := "++ pr_rawconstr rt ++  *)
-(* 		 str "nb_args := " ++ str (string_of_int nb_args)); *)
-  let res = 
-    rebuild_cons nb_args relname args crossed_types 0 rt 
-  in
-(*   observe (str " leads to "++ pr_rawconstr (fst res)); *)
-  res
-
-
-(* naive implementation of parameter detection. 
-
-   A parameter is an argument which is only preceded by parameters and whose 
-   calls are all syntaxically equal. 
-
-   TODO: Find a valid way to deal with implicit arguments here! 
-*)
-let rec compute_cst_params relnames params = function 
-  | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
-  | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
-      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) -> 
-      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 *)
-  | RSort _ -> params
-  | RHole _ -> params
-  | RIf _ | RRec _ | RCast _ | RDynamic _  ->
-      raise (UserError("compute_cst_params", str "Not handled case"))
-and compute_cst_params_from_app acc (params,rtl) = 
-  match params,rtl with 
-    | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
-    | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' 
-	when id_ord id id' == 0 && not is_defined -> 
-	compute_cst_params_from_app (param::acc) (params',rtl')
-    | _  -> List.rev acc 
-   
-let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =  
-  let rels_params = 
-    Array.mapi 
-      (fun i args -> 
-	 List.fold_left 
-	   (fun params (_,cst) -> compute_cst_params relnames params cst) 
-	   args
-	   csts.(i)
-      )
-      args
-  in 
-  let l = ref [] in 
-  let _ = 
-    try 
-      list_iter_i
-	(fun i ((n,nt,is_defined) as param) -> 
-	   if array_for_all 
-	     (fun l -> 
-		let (n',nt',is_defined') = List.nth l i in 
-		n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
-	     rels_params
-	   then 
-	     l := param::!l
-	) 
-	rels_params.(0)
-    with _ -> 
-      ()
-  in 
-  List.rev !l
-
-let rec rebuild_return_type rt = 
-  match rt with 
-    | Topconstr.CProdN(loc,n,t') -> 
-	Topconstr.CProdN(loc,n,rebuild_return_type t') 
-    | Topconstr.CArrow(loc,t,t') -> 
-	Topconstr.CArrow(loc,t,rebuild_return_type t')
-    | Topconstr.CLetIn(loc,na,t,t') -> 
-	Topconstr.CLetIn(loc,na,t,rebuild_return_type t') 
-    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
-
-
-let do_build_inductive 
-    funnames (funsargs: (Names.name * rawconstr * bool) list list)  
-    returned_types 
-    (rtl:rawconstr list) =
-  let _time1 = System.get_time () in
-(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
-  let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
-  let funnames = Array.of_list funnames in  
-  let funsargs = Array.of_list funsargs in 
-  let returned_types = Array.of_list returned_types in
-  (* alpha_renaming of the body to prevent variable capture during manipulation *)
-  let rtl_alpha = List.map (function rt ->  expand_as (alpha_rt [] rt)) rtl in
-  let rta = Array.of_list rtl_alpha in
-  (*i The next call to mk_rel_id is valid since we are constructing the graph
-    Ensures by: obvious
-    i*) 
-  let relnames = Array.map mk_rel_id funnames in
-  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in 
-  (* Construction of the pseudo constructors *)
-  let env = 
-    Array.fold_right 
-      (fun id env -> 
-	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id))  env
-      )
-      funnames 
-      (Global.env ())
-  in      
-  let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in 
-  (* and of the real constructors*)
-  let constr i res = 
-    List.map 
-      (function result (* (args',concl') *) -> 
-	 let rt = compose_raw_context result.context result.value in 
-	 let nb_args = List.length funsargs.(i) in 
-	 (*  with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
-	 fst (
-	   rebuild_cons nb_args relnames.(i)
-	     []
-	     []
-	     rt 
-	 )
-      ) 
-      res.result 
-  in 
-  (* adding names to constructors  *)
- let next_constructor_id = ref (-1) in 
-  let mk_constructor_id i = 
-    incr next_constructor_id;
-    (*i The next call to mk_rel_id is valid since we are constructing the graph
-      Ensures by: obvious
-      i*) 
-    id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
-  in
-  let rel_constructors i rt : (identifier*rawconstr) list = 
-    next_constructor_id := (-1);
-    List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
-  in
-  let rel_constructors = Array.mapi rel_constructors resa in
-  (* Computing the set of parameters if asked *)
-  let rels_params = compute_params_name relnames_as_set funsargs  rel_constructors in
-  let nrel_params = List.length rels_params in
-  let rel_constructors = (* Taking into account the parameters in constructors *)
-    Array.map (List.map 
-    (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
-    rel_constructors
-  in
-  let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-    let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  = 
-      (snd (list_chop nrel_params funargs))
-    in 
-    List.fold_right
-      (fun (n,t,is_defined) acc -> 
-	 if is_defined
-	 then 
-	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
-			    acc)
-	 else
-	   Topconstr.CProdN
-	   (dummy_loc,
-	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
-	    acc
-	   )
-      )
-      rel_first_args
-      (rebuild_return_type returned_types.(i))
-  in
-  (* We need to lift back our work topconstr but only with all information 
-     We mimick a Set Printing All. 
-     Then save the graphs and reset Printing options to their primitive values 
-  *)
-  let rel_arities = Array.mapi rel_arity funsargs in
-  let rel_params =  
-    List.map 
-      (fun (n,t,is_defined) -> 
-	 if is_defined 
-	 then
-	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
-	 else
-	 Topconstr.LocalRawAssum 
-	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
-      )
-      rels_params
-  in 
-  let ext_rels_constructors = 
-    Array.map (List.map 
-      (fun (id,t) -> 
-	 false,((dummy_loc,id),
-		Flags.with_option
-		  Flags.raw_print
-		  (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
-	       )
-      ))
-      (rel_constructors)
-  in
-  let rel_ind i ext_rel_constructors = 
-    ((dummy_loc,relnames.(i)),
-    rel_params,
-    Some rel_arities.(i),
-    ext_rel_constructors),None
-  in
-  let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in 
-  let rel_inds = Array.to_list ext_rel_constructors in 
-(*   let _ =  *)
-(*   Pp.msgnl  (\* observe *\) ( *)
-(*       str "Inductive" ++ spc () ++ *)
-(* 	prlist_with_sep  *)
-(* 	(fun () -> fnl ()++spc () ++ str "with" ++ spc ())  *)
-(* 	(function ((_,id),_,params,ar,constr) ->  *)
-(* 	   Ppconstr.pr_id id ++ spc () ++  *)
-(* 	     Ppconstr.pr_binders params ++ spc () ++ *)
-(* 	     str ":" ++ spc () ++  *)
-(* 	     Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *)
-(* 	     prlist_with_sep  *)
-(* 	     (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *)
-(* 	     (function (_,((_,id),t)) ->  *)
-(* 		Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *)
-(* 		  Ppconstr.pr_lconstr_expr t) *)
-(* 	     constr *)
-(* 	) *)
-(* 	rel_inds *)
-(*     ) *)
-(*   in *)
-  let _time2 = System.get_time () in 
-  try 
-    with_full_print (Flags.silently (Command.build_mutual rel_inds)) true
-  with 
-    | UserError(s,msg) as e ->
-	let _time3 = System.get_time () in
-(* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	let repacked_rel_inds = 
-	  List.map  (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
-	                  rel_inds
-	in
-	let msg = 		     
-	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds))
-	    ++ fnl () ++
-	    msg
-	in
-	observe (msg);
-	raise e
-    | e -> 
-	let _time3 = System.get_time () in
-(* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
-	let repacked_rel_inds = 
-	  List.map  (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
-	                  rel_inds
-	in
-	let msg = 		     
-	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) 
-	    ++ fnl () ++
-	    Cerrors.explain_exn e
-	in
- 	observe msg;
-	raise e
-
-
-
-let build_inductive funnames funsargs returned_types rtl = 
-  try 
-    do_build_inductive funnames funsargs returned_types rtl
-  with e -> raise (Building_graph e)
-      
-
diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli
deleted file mode 100644
index 0075fb0a..00000000
--- a/contrib/funind/rawterm_to_relation.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-
-
-
-(*
-  [build_inductive parametrize funnames funargs returned_types bodies] 
-  constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments 
-  and returning [returned_types] using bodies [bodies]
-*)
-
-val build_inductive :
-  Names.identifier list -> (* The list of function name *)
-  (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
-  Topconstr.constr_expr list -> (* The list of function returned type *)
-  Rawterm.rawconstr list -> (* the list of body *)
-  unit
-
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
deleted file mode 100644
index 92396af5..00000000
--- a/contrib/funind/rawtermops.ml
+++ /dev/null
@@ -1,718 +0,0 @@
-open Pp 
-open Rawterm
-open Util
-open Names
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-let idmap_is_empty m = m = Idmap.empty
-
-(* 
-   Some basic functions to rebuild rawconstr
-   In each of them the location is Util.dummy_loc
-*)
-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,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,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))
-
-(*
-  Some basic functions to decompose rawconstrs
-  These are analogous to the ones constrs
-*)
-let raw_decompose_prod = 
-  let rec raw_decompose_prod args = function 
-  | 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) -> 
-	    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); *)
-    match rt with 
-    | RApp(_,rt,rtl) -> 
-	decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
-    | rt -> rt,List.rev acc
-  in
-  decompose_rapp [] 
-
-
-
-
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
-let raw_make_eq ?(typ= mkRHole ()) t1 t2  = 
-  mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
-
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
-let raw_make_neq t1 t2 = 
-  mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
-
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
-let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
-
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
-   to [P1 \/ ( .... \/ Pn)] 
-*) 
-let rec raw_make_or_list = function  
-  | [] -> raise (Invalid_argument "mk_or")
-  | [e] -> e
-  | e::l -> raw_make_or e (raw_make_or_list l)
-
-  
-let remove_name_from_mapping mapping na = 
-  match na with 
-    | Anonymous -> mapping 
-    | Name id -> Idmap.remove id mapping
-
-let change_vars = 
-  let rec change_vars mapping rt = 
-    match rt with 
-      | RRef _ -> rt 
-      | RVar(loc,id) ->  
-	  let new_id = 
-	    try 
-	      Idmap.find id mapping 
-	    with Not_found -> id 
-	  in
-	  RVar(loc,new_id)
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
-	  RApp(loc,
-	       change_vars mapping rt',
-	       List.map (change_vars mapping) rtl
-	      )
-      | 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,k,t,b) -> 
-	  RProd(loc,
-		  name,
-	          k,
-		  change_vars mapping t,
-		  change_vars (remove_name_from_mapping mapping name) b
-		 )
-      | RLetIn(loc,name,def,b) -> 
-	  RLetIn(loc,
-		 name,
-		 change_vars mapping def,
-		 change_vars (remove_name_from_mapping mapping name) b
-		)
-      | RLetTuple(loc,nal,(na,rto),b,e) -> 
-	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in 
-	  RLetTuple(loc,
-		    nal,
-		    (na, Option.map (change_vars mapping) rto), 
-		    change_vars mapping b, 
-		    change_vars new_mapping e
-		   )
-      | 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
-		)
-      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
-	  RIf(loc,
-	      change_vars mapping b,
-	      (na,Option.map (change_vars mapping) e_option),
-	      change_vars mapping lhs,
-	      change_vars mapping rhs
-	     )
-      | RRec _ -> error "Local (co)fixes are not supported"
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv (k,t)) -> 
-	  RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
-      | RCast(loc,b,CastCoerce) -> 
-	  RCast(loc,change_vars mapping b,CastCoerce)
-      | RDynamic _ -> error "Not handled RDynamic"
-  and change_vars_br mapping ((loc,idl,patl,res) as br) = 
-    let new_mapping = List.fold_right Idmap.remove idl mapping in 
-    if idmap_is_empty new_mapping 
-    then br 
-    else (loc,idl,patl,change_vars new_mapping res)
-  in
-  change_vars 
-
-
-
-let rec alpha_pat excluded pat = 
-  match pat with 
-    | PatVar(loc,Anonymous) -> 
-	let new_id = Indfun_common.fresh_id excluded "_x" in 
-	PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
-    | PatVar(loc,Name id) -> 
-	if List.mem id excluded 
-	then 
-	  let new_id = Nameops.next_ident_away id excluded in 
-	  PatVar(loc,Name new_id),(new_id::excluded),
-	(Idmap.add id new_id Idmap.empty)
-	else pat,excluded,Idmap.empty
-    | PatCstr(loc,constr,patl,na) -> 
-	let new_na,new_excluded,map = 
-	  match na with 
-	    | Name id when List.mem id excluded -> 
-		let new_id = Nameops.next_ident_away id excluded in 
-		Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
-	    | _ -> na,excluded,Idmap.empty
-	in 
-	let new_patl,new_excluded,new_map = 
-	  List.fold_left 
-	    (fun (patl,excluded,map) pat -> 
-	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
-	       (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
-	    )
-	    ([],new_excluded,map)
-	    patl
-	in 
-	PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
-
-let alpha_patl excluded patl  = 
-  let patl,new_excluded,map = 
-    List.fold_left 
-      (fun (patl,excluded,map) pat -> 
-	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
-	 new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
-      )
-      ([],excluded,Idmap.empty)
-      patl
-  in 
-  (List.rev patl,new_excluded,map)
-
-
-
-  
-let raw_get_pattern_id pat acc = 
-  let rec get_pattern_id pat = 
-    match pat with 
-      | PatVar(loc,Anonymous) -> assert false
-      | PatVar(loc,Name id) -> 
-	  [id]
-      | PatCstr(loc,constr,patternl,_) -> 
-	  List.fold_right 
-	  (fun pat idl -> 
-	     let idl' = get_pattern_id pat in 
-	     idl'@idl
-	  )
-	    patternl 
-	    []
-  in
-  (get_pattern_id pat)@acc
-
-let get_pattern_id pat = raw_get_pattern_id pat []
-	      
-let rec alpha_rt excluded rt = 
-  let new_rt = 
-    match rt with   
-      | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
-      | 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,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,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,k,t,b) -> 
-	let new_id = Nameops.next_ident_away id excluded in 
-	let t,b = 
-	  if new_id = id 
-	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
-	    (t,replace b)
-	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,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 = 
-	  if new_id = id 
-	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
-	    (t,replace b)
-	in
-	let new_t = alpha_rt new_excluded t in 
-	let new_b = alpha_rt new_excluded b in 
-	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 = 
-	  if new_id = id 
-	  then t,b
-	  else 
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
-	    (t,replace b)
-	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 
-	RLetIn(loc,Name new_id,new_t,new_b)
-
-
-    | RLetTuple(loc,nal,(na,rto),t,b) -> 
-	let rev_new_nal,new_excluded,mapping = 
-	  List.fold_left 
-	    (fun (nal,excluded,mapping) na -> 
-	       match na with 
-		 | Anonymous -> (na::nal,excluded,mapping)
-		 | Name id ->  
-		     let new_id = Nameops.next_ident_away id excluded in 
-		     if new_id = id 
-		     then 
-		       na::nal,id::excluded,mapping 
-		     else 
-		       (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
-	    )
-	    ([],excluded,Idmap.empty)
-	    nal
-	in
-	let new_nal = List.rev rev_new_nal in 
-	let new_rto,new_t,new_b = 
-	  if idmap_is_empty mapping
-	  then rto,t,b
-	  else let replace = change_vars mapping in 
-	  (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
-	RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
-    | RCases(loc,sty,infos,el,brl) -> 
-	let new_el = 
-	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el 
-	in 
-	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),
-	    alpha_rt excluded lhs,
-	    alpha_rt excluded rhs
-	   )
-    | RRec _ -> error "Not handled RRec"
-    | RSort _ -> rt 
-    | RHole _ -> rt 
-    | RCast (loc,b,CastConv (k,t)) -> 
-	RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
-    | RCast (loc,b,CastCoerce) -> 
-	RCast(loc,alpha_rt excluded b,CastCoerce)
-    | RDynamic _ -> error "Not handled RDynamic"
-    | RApp(loc,f,args) -> 
-	RApp(loc,
-	     alpha_rt excluded f,
-	     List.map (alpha_rt excluded) args
-	    )
-  in 
-  new_rt
-
-and alpha_br excluded (loc,ids,patl,res) = 
-  let new_patl,new_excluded,mapping = alpha_patl excluded patl in 
-  let new_ids = List.fold_right raw_get_pattern_id new_patl [] in 
-  let new_excluded = new_ids@excluded in 
-  let renamed_res = change_vars mapping res in 
-  let new_res = alpha_rt new_excluded renamed_res in 
-  (loc,new_ids,new_patl,new_res)
-    
-(* 
-   [is_free_in id rt] checks if [id] is a free variable in [rt]
-*)
-let is_free_in id =
-  let rec is_free_in = function
-    | RRef _ ->  false
-    | RVar(_,id') -> id_ord id' id == 0
-    | 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) ->
-	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) ->
-	(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) 
-	in 
-	is_free_in t  || (check_in_nal && is_free_in b)
-	  
-    | RIf(_,cond,_,br1,br2) ->
-	is_free_in cond || is_free_in br1 || is_free_in br2
-    | RRec _ -> raise (UserError("",str "Not handled RRec"))
-    | RSort _ -> false
-    | RHole _ -> false
-    | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
-    | RCast (_,b,CastCoerce) -> is_free_in b
-    | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
-  and is_free_in_br (_,ids,_,rt) =
-    (not (List.mem id ids)) && is_free_in rt
-  in
-  is_free_in
-      
-
-
-let rec pattern_to_term  = function
-  | PatVar(loc,Anonymous) -> assert false
-  | PatVar(loc,Name id) ->
-	mkRVar id
-  | PatCstr(loc,constr,patternl,_) ->
-      let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
-	  (Global.env ())
-	  constr
-      in
-      let implicit_args =
-	Array.to_list
-	  (Array.init
-	     (cst_narg - List.length patternl)
-	     (fun _ -> mkRHole ())
-	  )
-      in
-      let patl_as_term =
-	List.map pattern_to_term patternl
-      in
-      mkRApp(mkRRef(Libnames.ConstructRef constr),
-	     implicit_args@patl_as_term
-	    )
-
-  
-
-let replace_var_by_term x_id term = 
-  let rec replace_var_by_pattern rt = 
-    match rt with 
-      | RRef _ -> rt 
-      | RVar(_,id) when id_ord id x_id == 0 -> term
-      | RVar _ -> rt 
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
-	  RApp(loc,
-	       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,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,k,t,b) -> 
-	  RProd(loc,
-		  name,
-	          k,
-		  replace_var_by_pattern t,
-		  replace_var_by_pattern b
-		 )
-      | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
-      | RLetIn(loc,name,def,b) -> 
-	  RLetIn(loc,
-		 name,
-		 replace_var_by_pattern def,
-		 replace_var_by_pattern b
-		)
-      | RLetTuple(_,nal,_,_,_) 
-	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->  
-	  rt
-      | RLetTuple(loc,nal,(na,rto),def,b) -> 
-	  RLetTuple(loc,
-		    nal,
-		    (na,Option.map replace_var_by_pattern rto),
-		    replace_var_by_pattern def,
-		    replace_var_by_pattern b
-		   )
-      | 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),
-	      replace_var_by_pattern lhs,
-	      replace_var_by_pattern rhs
-	     )
-      | RRec _ -> raise (UserError("",str "Not handled RRec"))
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv(k,t)) -> 
-	  RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
-      | RCast(loc,b,CastCoerce) -> 
-	  RCast(loc,replace_var_by_pattern b,CastCoerce)
-      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
-  and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = 
-    if List.exists (fun id -> id_ord id x_id == 0) idl 
-    then br 
-    else (loc,idl,patl,replace_var_by_pattern res)
-  in
-  replace_var_by_pattern 
-
-
-
-
-(* checking unifiability of patterns *) 
-exception NotUnifiable  
-
-let rec are_unifiable_aux  = function 
-  | [] -> () 
-  | eq::eqs -> 
-      match eq with 
-	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs 
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
-	     if constructor2 <> constructor1 
-	     then raise NotUnifiable
-	     else 
-	       let eqs' = 
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "are_unifiable_aux" 
-	       in
-	       are_unifiable_aux eqs'
-		 
-let are_unifiable pat1 pat2 = 
-  try 
-    are_unifiable_aux [pat1,pat2];
-    true
-  with NotUnifiable -> false
-
-
-let rec eq_cases_pattern_aux  = function 
-  | [] -> () 
-  | eq::eqs -> 
-      match eq with 
-	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs 
-	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
-	     if constructor2 <> constructor1 
-	     then raise NotUnifiable
-	     else 
-	       let eqs' = 
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "eq_cases_pattern_aux" 
-	       in
-	       eq_cases_pattern_aux eqs'
-	 | _ -> raise NotUnifiable
-
-let eq_cases_pattern pat1 pat2 = 
-  try
-    eq_cases_pattern_aux [pat1,pat2];
-    true
-  with NotUnifiable -> false
-
-
-
-let ids_of_pat = 
-  let rec ids_of_pat ids = function 
-    | PatVar(_,Anonymous) -> ids 
-    | PatVar(_,Name id) -> Idset.add id ids 
-    | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
-  in
-  ids_of_pat Idset.empty 
-  
-let id_of_name = function 
-  | Names.Anonymous -> id_of_string "x" 
-  | Names.Name x -> x
-
-(* TODO: finish Rec caes *)
-let ids_of_rawterm c = 
-  let rec ids_of_rawterm acc c = 
-    let idof = id_of_name in
-    match c with
-      | RVar (_,id) -> id::acc
-      | RApp (loc,g,args) -> 
-          ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
-      | RLambda (loc,na,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,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 _) -> []
-  in
-  (* build the set *)
-  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
-  
-
-
-
-
-let zeta_normalize = 
-  let rec zeta_normalize_term rt = 
-    match rt with 
-      | RRef _ -> rt 
-      | RVar _ -> rt 
-      | REvar _ -> rt 
-      | RPatVar _ -> rt 
-      | RApp(loc,rt',rtl) -> 
-	  RApp(loc,
-	       zeta_normalize_term rt',
-	       List.map zeta_normalize_term rtl
-	      )
-      | RLambda(loc,name,k,t,b) -> 
-	  RLambda(loc,
-		  name,
-		  k,
-		  zeta_normalize_term t,
-		  zeta_normalize_term b
-		 )
-      | RProd(loc,name,k,t,b) -> 
-	  RProd(loc,
-		name, 		
-	        k,
-		zeta_normalize_term t,
-		zeta_normalize_term b
-		 )
-      | RLetIn(_,Name id,def,b) -> 
-	  zeta_normalize_term (replace_var_by_term id def b)
-      | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
-      | RLetTuple(loc,nal,(na,rto),def,b) -> 
-	  RLetTuple(loc,
-		    nal,
-		    (na,Option.map zeta_normalize_term rto),
-		    zeta_normalize_term def,
-		    zeta_normalize_term b
-		   )
-      | 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),
-	      zeta_normalize_term lhs,
-	      zeta_normalize_term rhs
-	     )
-      | RRec _ -> raise (UserError("",str "Not handled RRec"))
-      | RSort _ -> rt 
-      | RHole _ -> rt 
-      | RCast(loc,b,CastConv(k,t)) -> 
-	  RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
-      | RCast(loc,b,CastCoerce) -> 
-	  RCast(loc,zeta_normalize_term b,CastCoerce)
-      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
-  and zeta_normalize_br (loc,idl,patl,res) = 
-    (loc,idl,patl,zeta_normalize_term res)
-  in
-  zeta_normalize_term 
-
-
-
-
-let expand_as = 
-  
-  let rec add_as map pat = 
-    match pat with 
-      | PatVar _ -> map 
-      | PatCstr(_,_,patl,Name id) -> 
-	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
-      | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
-  in 
-  let rec expand_as map rt = 
-    match rt with 
-      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt 
-      | RVar(_,id) -> 
-	  begin
-	    try 
-	      Idmap.find id map
-	    with Not_found -> rt 
-	  end
-      | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
-      | RLambda(loc,na,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),
-		    expand_as map v, expand_as map b)
-      | RIf(loc,e,(na,po),br1,br2) ->
-	  RIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
-	      expand_as map br1, expand_as map br2)
-      | RRec _ ->  error "Not handled RRec"
-      | RDynamic _ -> error "Not handled RDynamic"
-      | RCast(loc,b,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,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)
-  in
-  expand_as Idmap.empty 
diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli
deleted file mode 100644
index 358c6ba6..00000000
--- a/contrib/funind/rawtermops.mli
+++ /dev/null
@@ -1,126 +0,0 @@
-open Rawterm
-
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-val idmap_is_empty : 'a Names.Idmap.t -> bool
-
-
-(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
-val get_pattern_id : cases_pattern -> Names.identifier list
-
-(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. 
-   [pat] must not contain occurences of anonymous pattern 
-*)
-val pattern_to_term : cases_pattern -> rawconstr 
-
-(* 
-   Some basic functions to rebuild rawconstr
-   In each of them the location is Util.dummy_loc
-*)
-val mkRRef : Libnames.global_reference -> rawconstr
-val mkRVar : Names.identifier -> rawconstr
-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_tuples * cases_clauses -> rawconstr
-val mkRSort : rawsort -> rawconstr 
-val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
-val mkRCast : rawconstr* rawconstr -> rawconstr 
-(*
-  Some basic functions to decompose rawconstrs
-  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)
-
-
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
-val  raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
-val  raw_make_neq : rawconstr -> rawconstr -> rawconstr
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
-val  raw_make_or : rawconstr -> rawconstr -> rawconstr
-
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
-   to [P1 \/ ( .... \/ Pn)] 
-*) 
-val  raw_make_or_list : rawconstr list -> rawconstr
-
-
-(* alpha_conversion functions *)
-
-
-
-(* Replace the var mapped in the rawconstr/context *)
-val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
-
-
-
-(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. 
-   the result does not share variables with [avoid]. This function create 
-   a fresh variable for each occurence of the anonymous pattern.
-
-   Also returns a mapping  from old variables to new ones and the concatenation of
-   [avoid] with the variables appearing in the result.
-*)
-  val alpha_pat :
-    Names.Idmap.key list ->
-    Rawterm.cases_pattern ->
-    Rawterm.cases_pattern * Names.Idmap.key list *
-      Names.identifier Names.Idmap.t
-
-(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt 
-   conventions and  does not share bound variables with avoid 
-*)
-val alpha_rt : Names.identifier list -> rawconstr -> rawconstr
-
-(* same as alpha_rt but for case branches *)
-val alpha_br : Names.identifier list ->
-    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
-    Rawterm.rawconstr ->
-    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
-    Rawterm.rawconstr
-
-
-(* Reduction function *) 
-val replace_var_by_term  :     
-  Names.identifier ->
-  Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr
-
-
-
-(* 
-   [is_free_in id rt] checks if [id] is a free variable in [rt]
-*)
-val is_free_in : Names.identifier -> rawconstr -> bool
-
-
-val are_unifiable : cases_pattern -> cases_pattern -> bool 
-val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
-
-
-
-(* 
-   ids_of_pat : cases_pattern -> Idset.t 
-   returns the set of variables appearing in a pattern 
-*)
-val   ids_of_pat : cases_pattern -> Names.Idset.t 
-
-(* TODO: finish this function (Fix not treated) *)
-val ids_of_rawterm: rawconstr -> Names.Idset.t
-
-(* 
-   removing let_in construction in a rawterm 
-*)
-val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
-
-
-val expand_as : rawconstr -> rawconstr
diff --git a/contrib/funind/recdef.ml b/contrib/funind/recdef.ml
deleted file mode 100644
index 14bf7cf8..00000000
--- a/contrib/funind/recdef.ml
+++ /dev/null
@@ -1,1436 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: recdef.ml 12221 2009-07-04 21:53:12Z jforest $ *)
-
-open Term
-open Termops
-open Environ
-open Declarations
-open Entries
-open Pp
-open Names
-open Libnames
-open Nameops
-open Util
-open Closure
-open RedFlags
-open Tacticals
-open Typing
-open Tacmach
-open Tactics
-open Nametab
-open Decls
-open Declare
-open Decl_kinds
-open Tacred
-open Proof_type
-open Vernacinterp
-open Pfedit
-open Topconstr
-open Rawterm
-open Pretyping
-open Pretyping.Default
-open Safe_typing
-open Constrintern
-open Hiddentac
-
-open Equality
-open Auto
-open Eauto
-
-open Genarg
-
-
-let compute_renamed_type gls c = 
-  rename_bound_var (pf_env gls) [] (pf_type_of gls c)
-
-let qed () = Command.save_named true 
-let defined () = Command.save_named false
-
-let pf_get_new_ids idl g = 
-  let ids = pf_ids_of_hyps g in 
-  List.fold_right
-    (fun id acc -> next_global_ident_away false id (acc@ids)::acc)
-    idl 
-    []
-
-let pf_get_new_id id g = 
-  List.hd (pf_get_new_ids [id] g)
-
-let h_intros l = 
-  tclMAP h_intro 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 "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 ); 
-   raise e;;
-
-
-let observe_tac s tac g = 
-  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
-  then do_observe_tac s tac g
-  else tac g
-
-let hyp_ids = List.map id_of_string
-    ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
-     "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];;
-
-let rec nthtl = function
-    l, 0 -> l  | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
-
-let hyp_id n l = List.nth l n;;
-
-let (x_id:identifier) = hyp_id 0 hyp_ids;;
-let (v_id:identifier) = hyp_id 1 hyp_ids;;
-let (k_id:identifier) = hyp_id 2 hyp_ids;;
-let (def_id:identifier) = hyp_id 3 hyp_ids;;
-let (p_id:identifier) = hyp_id 4 hyp_ids;;
-let (h_id:identifier) = hyp_id 5 hyp_ids;;
-let (n_id:identifier) = hyp_id 6 hyp_ids;;
-let (h'_id:identifier) = hyp_id 7 hyp_ids;;
-let (ano_id:identifier) = hyp_id 8 hyp_ids;;
-let (rec_res_id:identifier) = hyp_id 10 hyp_ids;;
-let (hspec_id:identifier) = hyp_id 11 hyp_ids;;
-let (heq_id:identifier) = hyp_id 12 hyp_ids;;
-let (hrec_id:identifier) = hyp_id 13 hyp_ids;;
-let (hex_id:identifier) = hyp_id 14 hyp_ids;;
-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 Flags.is_verbose () then msgnl(str s);;
-
-let def_of_const t =
-   match (kind_of_term t) with
-    Const sp -> 
-      (try (match (Global.lookup_constant sp) with
-             {const_body=Some c} -> Declarations.force c
-	     |_ -> assert false)
-       with _ -> 
-	 anomaly ("Cannot find definition of constant "^
-		    (string_of_id (id_of_label (con_label sp))))
-      )
-     |_ -> assert false
-
-let type_of_const t =
-   match (kind_of_term t) with
-    Const sp -> Typeops.type_of_constant (Global.env()) sp
-    |_ -> assert false
-
-let arg_type t =
-  match kind_of_term (def_of_const t) with
-      Lambda(a,b,c) -> b
-    | _ -> assert false;;
-
-let evaluable_of_global_reference r =
-  match r with 
-      ConstRef sp -> EvalConstRef sp
-    | VarRef id -> EvalVarRef id
-    | _ -> assert false;;
-
-
-let rank_for_arg_list h = 
-  let predicate a b = 
-      try List.for_all2 eq_constr a b with
-        Invalid_argument _ -> false in
-  let rec rank_aux i = function
-  | [] -> None
-  | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
-  rank_aux 0;;
-
-let rec (find_call_occs : 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]
-  | App (g, args) ->
-     let (largs: constr list) = Array.to_list args in
-     let rec find_aux = function
-	 []    -> (fun x -> []), []
-       | a::upper_tl ->
-         (match find_aux upper_tl with
-          (cf, ((arg1::args) as args_for_upper_tl)) -> 
-           (match find_call_occs nb_lam f a with
-             cf2, (_ :: _ as other_args) ->
-               let rec avoid_duplicates args =
-                  match args with
-                  | [] -> (fun _ -> []), []
-                  | h::tl -> 
-                      let recomb_tl, args_for_tl =
-                          avoid_duplicates tl in
-                    match rank_for_arg_list h args_for_upper_tl with
-                    | None -> 
-                        (fun l -> List.hd l::recomb_tl(List.tl l)),
-                        h::args_for_tl
-                    | Some i ->
-                        (fun l -> List.nth l (i+List.length args_for_tl)::
-                            recomb_tl l),
-                        args_for_tl
-               in
-               let recombine, other_args' =
-                   avoid_duplicates other_args in
-	       let len1 = List.length other_args' in                   
-                   (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
-                     other_args'@args_for_upper_tl
-           | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
-	 | _, [] ->
-	   (match find_call_occs nb_lam f a with
-	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
-	   | _, [] -> (fun x -> a::upper_tl), [])) in
-     begin
-       match (find_aux largs) with
-	   cf, [] -> (fun l -> mkApp(g, args)), []
-	 | cf, args ->
-	     (fun l -> mkApp (g, Array.of_list (cf l))), args
-     end
-  | 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(_)  -> (fun l -> expr), []
-  | Cast(b,_,_) -> find_call_occs nb_lam f b
-  | Prod(_,_,_) -> error "find_call_occs : Prod"
-  | 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 nb_lam f a with
-	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
-      | _ -> (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_global
-    (locate (make_qualid(Names.make_dirpath 
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
-let find_reference sl s =
-    (locate (make_qualid(Names.make_dirpath 
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
-let delayed_force f = f ()
-
-let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
-let le_lt_n_Sm = function () -> (coq_constant "le_lt_n_Sm")
-
-let le_trans = function () -> (coq_constant "le_trans")
-let le_lt_trans = function () -> (coq_constant "le_lt_trans")
-let lt_S_n = function () -> (coq_constant "lt_S_n")
-let le_n = function () -> (coq_constant "le_n")
-let refl_equal = function () -> (coq_constant "refl_equal")
-let eq = function () -> (coq_constant "eq")
-let ex = function () -> (coq_constant "ex")
-let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
-let coq_sig = function () -> (coq_constant "sig")
-let coq_O = function () -> (coq_constant "O")
-let coq_S = function () -> (coq_constant "S")
-
-let gt_antirefl = function () -> (coq_constant "gt_irrefl")
-let lt_n_O = function () -> (coq_constant "lt_n_O")
-let lt_n_Sn = function () -> (coq_constant "lt_n_Sn")
-
-let f_equal = function () -> (coq_constant "f_equal")
-let well_founded_induction = function () -> (coq_constant "well_founded_induction")
-let well_founded = function () -> (coq_constant "well_founded")
-let acc_rel = function () -> (coq_constant "Acc")
-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_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"
-
-(* These are specific to experiments in nat with lt as well_founded_relation, *)
-(*    but this should be made more general. *)
-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 ->
-       let type_of_a = pf_type_of g a in
-       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 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 = 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
-		)
-	      ]
-	      g
-	else
-	  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 clause =
-  reduce 
-    (Lazy
-       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
-        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
-(*     (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 tac is_mes l g = 
-  let clear_tac = 
-    match l with 
-      | None -> h_clear true []
-      | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
-  in
-  tclTHENSEQ 
-    [
-      clear_tac;
-      if is_mes 
-      then tclTHEN
-             (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
-                                      (delayed_force ltof_ref))])
-             tac
-      else tac
-    ]
-    g
-    
-    
-let list_rewrite (rev:bool) (eqs: constr list) =
-  tclREPEAT
-    (List.fold_right
-       (fun eq i -> tclORELSE (rewriteLR eq) i)
-       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
-
-let base_leaf_terminate (func:global_reference) eqs expr =
-(*  let _ = msgnl (str "entering base_leaf") in *)
-  (fun g ->
-     let k',h = 
-       match pf_get_new_ids [k_id;h_id] g with 
-	   [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 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 ...
-   Pour recuperer la fonction f a partir de la 
-   fonctionnelle *)
-
-let get_f foncl = 
-  match (kind_of_term (def_of_const foncl)) with
-      Lambda (Name f, _, _) -> f  
-    |_ -> error "la fonctionnelle est mal definie";;
-
-
-let rec compute_le_proofs = function
-    [] -> assumption
-  | a::tl ->
-      tclORELSE assumption 
-	(tclTHENS
-	   (fun g -> 
-	      let le_trans = delayed_force le_trans in 
-	      let t_le_trans = compute_renamed_type g le_trans in 
-	      let m_id = 
-		let _,_,t = destProd t_le_trans in 
-		let na,_,_ = destProd t in 
-		Nameops.out_name na
-	      in
-	      apply_with_bindings
-		(le_trans,
-		 ExplicitBindings[dummy_loc,NamedHyp m_id,a])
-		g)
-	   [compute_le_proofs tl; 
-            tclORELSE (apply (delayed_force le_n)) assumption])
-
-let make_lt_proof pmax le_proof =
-  tclTHENS
-    (fun g -> 
-       let le_lt_trans = delayed_force le_lt_trans in 
-       let t_le_lt_trans = compute_renamed_type g le_lt_trans in 
-       let m_id = 
-	 let _,_,t = destProd t_le_lt_trans in 
-	 let na,_,_ = destProd t in 
-	 Nameops.out_name na
-       in
-       apply_with_bindings
-	 (le_lt_trans,
-	  ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
-    [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); 
-     tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
-
-let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
-  match cond_eqs with
-    [] -> tclIDTAC
-  | eq::eqs ->
-      (fun g -> 
-	 let t_eq = compute_renamed_type g (mkVar eq) 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
-	 in
-	 tclTHENS
-	   (general_rewrite_bindings false all_occurrences
-	      (mkVar eq,
-	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
-				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
-      ) 
-
-let rec introduce_all_equalities func eqs values specs bound le_proofs 
-    cond_eqs =
-  match specs with
-    [] -> 
-      fun g ->
-	let ids = pf_ids_of_hyps g in
-	let s_max = mkApp(delayed_force coq_S, [|bound|]) in
-	let k = next_global_ident_away true k_id ids in
-        let ids = k::ids in
-	let h' = next_global_ident_away true (h'_id) ids in
-        let ids = h'::ids in
-	let def = next_global_ident_away true def_id ids in
-	tclTHENLIST
-	  [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
-	   observe_tac "introduce_all_equalities_final intro k" (h_intro  k);
-	   tclTHENS
-	     (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k)))
-	     [
-	       tclTHENLIST[h_intro h';
-			   simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]));
-			   default_full_auto];
-	       tclIDTAC
-	     ];
-	   observe_tac "clearing k " (clear [k]);
-	   observe_tac "intros k h' def" (h_intros [k;h';def]);
-	   observe_tac "simple_iter" (simpl_iter onConcl);
-	   observe_tac "unfold functional" 
-	     (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
-	   observe_tac "rewriting equations" 
-	     (list_rewrite true eqs);
-           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 ->
-	let ids = ids_of_named_context (pf_hyps g) in
-	let p = next_global_ident_away true p_id ids in
-        let ids = p::ids in
-	let pmax = next_global_ident_away true pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_global_ident_away true hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_global_ident_away true  hle_id ids in
-	let ids = hle2::ids in
-	let heq = next_global_ident_away true heq_id ids in
-	tclTHENLIST
-	  [simplest_elim (mkVar spec1);
-	   list_rewrite true eqs;
-	   h_intros [p; heq];
-	   simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
-	   h_intros [pmax; hle1; hle2];
-	   introduce_all_equalities func eqs values specs 
-	     (mkVar pmax) ((mkVar pmax)::le_proofs)
-	     (heq::cond_eqs)] g;;
-    
-let string_match s =
-  if String.length s < 3 then failwith "string_match";
-  try 
-    for i = 0 to 3  do
-      if String.get s i <> String.get "Acc_" i then failwith "string_match"
-    done;
-  with Invalid_argument _ -> failwith "string_match"
-	  
-let retrieve_acc_var g = 
-  (* Julien: I don't like this version .... *) 
-  let hyps = pf_ids_of_hyps g  in 
-  map_succeed 
-    (fun id -> string_match (string_of_id id);id)
-    hyps 
-
-let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
-    eqs  hrec args values specs =
-    (match args with
-    [] -> 
-      tclTHENLIST
-	[observe_tac "split" (split(ImplicitBindings
-		 [context_fn (List.map mkVar (List.rev values))]));
-	 observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs
-	   (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])]
-  | arg::args ->
-      (fun g ->
-	let ids = ids_of_named_context (pf_hyps g) in
-	let rec_res = next_global_ident_away true rec_res_id ids in
-        let ids = rec_res::ids in
-	let hspec = next_global_ident_away true hspec_id ids in
-	let tac =  
-	  observe_tac "introduce_all_values" (
-	    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)))
-	   )
-	   [tclTHENLIST [h_intros [rec_res; hspec];
-			 tac]; 
-	    (tclTHENS
-		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
-		 [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
-		    (observe_tac "h_assumption" h_assumption)
-		 ;
-		  tclTHENLIST
-		    [
-		      tclTRY(list_rewrite true eqs);
-		      observe_tac "user proof" 
-			(fun g ->  
-			   tclUSER
-			     concl_tac
-			     is_mes
-			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
-			     g
-			)		     
-		    ]
-		 ]
-	    )
-	   ]) g)
-	
-    )
- 
-	   
-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 concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
-
-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 (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
-  in 
-  proveterminate 
-
-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_global func::mkRel 1::
-	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
-	    )
-	 )
-  in
-  let right = mkRel 5 in 
-  let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
-  let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
-  let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
-  let nb_iter =
-    mkApp(delayed_force ex,
-	  [|delayed_force nat;
-	    (mkLambda 
-	       (Name
-		  p_id,
-		  delayed_force nat, 
-		  (mkProd (Name k_id, delayed_force nat, 
-			   mkArrow cond result))))|])in
-  let value = mkApp(delayed_force coq_sig, 
-		    [|b;
-		      (mkLambda (Name v_id, b, nb_iter))|]) in
-  compose_prod rev_args value
-	     
-
-
-let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = 
-  if is_mes 
-  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 = 
-  begin 
-    fun g -> 
-      let nargs = List.length args_id in
-      let pre_rec_args = 
-	List.rev_map
-	  mkVar (fst (list_chop (rec_arg_num - 1) args_id)) 
-      in 
-      let relation = substl pre_rec_args relation in 
-      let input_type = substl pre_rec_args input_type in 
-      let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in 
-      let wf_rec_arg = 
-	next_global_ident_away true 
-	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
-	  (wf_thm::ids) 
-      in 
-      let hrec = next_global_ident_away true hrec_id
-	(wf_rec_arg::wf_thm::ids) in 
-      let acc_inv = 
-	  lazy (
-	    mkApp (
-	      delayed_force acc_inv_id,
-	      [|input_type;relation;mkVar rec_arg_id|]
-	    )
-	  )
-      in
-      tclTHEN
-	(h_intros args_id)
-	(tclTHENS
-	   (observe_tac 
-	      "first assert" 
-	      (assert_tac 
-		 (Name wf_rec_arg) 
-		 (mkApp (delayed_force acc_rel,
-			 [|input_type;relation;mkVar rec_arg_id|])
-		 )
-	      )
-	   )
-	   [
-	     (* accesibility proof *) 
-	     tclTHENS 
-	       (observe_tac 
-		  "second assert" 
-		  (assert_tac 
-		     (Name wf_thm)
-		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  )
-	       )
-	       [ 
-		 (* interactive proof that the relation is well_founded *)
-		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
-		 (* this gives the accessibility argument *)
-		 observe_tac 
-		   "apply wf_thm" 
-		   (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
-		   )
-	       ]
-	     ;
-	     (* rest of the proof *)
-	     tclTHENSEQ 
-	       [observe_tac "generalize" 
-		  (onNLastHyps (nargs+1)
-		     (fun (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 wf_rec_arg hrec acc_inv)
-	       ]
-	   ]
-	) g  
-  end
-
-
-
-let rec instantiate_lambda t l = 
-  match l with
-  | [] -> t
-  | a::l -> 
-      let (bound_name, _, body) = destLambda t in
-      instantiate_lambda (subst1 a body) l
-;;
-
-
-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_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_n nb_args body1 in 
-      let n_ids,ids = 
-	List.fold_left 
-	  (fun (n_ids,ids) (n_name,_) -> 
-	     match n_name with 
-	       | Name id -> 
-		   let n_id = next_global_ident_away true id ids in 
-		   n_id::n_ids,n_id::ids
-	       | _ -> anomaly "anonymous argument"
-	  )
-	  ([],(f_id::ids))
-	  n_names_types
-      in
-      let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
-      let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in 
-      termination_proof_header 
-	is_mes
-	input_type
-	ids
-	n_ids
-	relation 
-	rec_arg_num
-	rec_arg_id
-	(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 (mkVar f_id) concl_tac)
-	      []
-	      expr
-	   )
-	     g 
-	)
-	(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 )
-
-let build_and_l l = 
-  let and_constr =  Coqlib.build_coq_and () in 
-  let conj_constr = coq_conj () in 
-  let mk_and p1 p2 = 
-    Term.mkApp(and_constr,[|p1;p2|]) in 
-  let rec f  = function 
-    | [] -> failwith "empty list of subgoals!" 
-    | [p] -> p,tclIDTAC,1 
-    | p1::pl -> 
-	let c,tac,nb = f pl in 
-	mk_and p1 c, 
-	tclTHENS
-	  (apply (constr_of_global conj_constr)) 
-	  [tclIDTAC;
-	   tac
-	  ],nb+1
-  in f l
-
-
-let is_rec_res id = 
-  let rec_res_name = string_of_id rec_res_id   in 
-  let id_name = string_of_id id in 
-  try 
-    String.sub id_name 0 (String.length rec_res_name) = rec_res_name 
-  with _ -> false
-
-let clear_goals = 
-  let rec clear_goal t = 
-    match kind_of_term t with 
-      | Prod(Name id as na,t,b) -> 
-	  let b' = clear_goal b in 
-	  if noccurn 1 b' && (is_rec_res id) 
-	  then pop b' 
-	  else if b' == b then t 
-	  else mkProd(na,t,b')
-      | _ -> map_constr clear_goal t
-  in 
-  List.map clear_goal 
-
-
-let build_new_goal_type () = 
-  let sub_gls_types = get_current_subgoals_types () in 
-  let sub_gls_types = clear_goals sub_gls_types in 
-  let res = build_and_l sub_gls_types in 
-  res
-  
-
-    (*
-let prove_with_tcc lemma _ : tactic = 
-  fun gls ->
-    let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
-    tclTHENSEQ 
-      [
-	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 (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 
-    | None   ->  
-	try (add_suffix current_proof_name "_subproof") 
-	with _ -> anomaly "open_new_goal with an unamed theorem"
-  in  
-  let sign = Global.named_context () in
-  let sign = clear_proofs sign in
-  let na = next_global_ident_away false name [] in
-  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 
-    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];
-		       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;
-	       (observe_tac "finishing using"
-		  (
-		    tclCOMPLETE(
-		      tclFIRST[
-			tclTHEN
-			  (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
-			  e_assumption;			  
-		      Eauto.eauto_with_bases
-			false
-			(true,5)
-			[delayed_force refl_equal]
-			[Auto.Hint_db.empty empty_transparent_state false]
-		      ]
-		    )
-		  )
-	       ) 
-      		 g)
-;
-    Command.save_named opacity;
-  in
-  start_proof
-    na
-    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) 
-    sign
-    gls_type 
-    hook ;
-  by (
-    fun g -> 
-      tclTHEN 
-	(decompose_and_tac)
-	(tclORELSE 
-	(tclFIRST 
-	   (List.map
-	      (fun c -> 
-		 tclTHENSEQ
-		   [intros; 
-		    h_simplest_apply (interp_constr Evd.empty (Global.env()) c); 
-		    tclCOMPLETE Auto.default_auto
-		   ]
-	      )
-	      using_lemmas)
-	) tclIDTAC)
-	g);
-  try
-    by tclIDTAC; (* raises UserError _ if the proof is complete *)
-    if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
-  with UserError _ -> 
-    defined ()
-  
-;;    
-
-
-let com_terminate 
-    tcc_lemma_name 
-    tcc_lemma_ref 
-    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 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 ()
-    
-
-    
-
-let ind_of_ref = function 
-  | IndRef (ind,i) -> (ind,i)
-  | _ -> anomaly "IndRef expected"
-
-let (value_f:constr list -> global_reference -> constr) =
-  fun al fterm ->
-    let d0 = dummy_loc in 
-    let rev_x_id_l =  
-      (
-	List.fold_left 
-	  (fun x_id_l _ -> 
-	     let x_id = next_global_ident_away true x_id x_id_l in 
-	     x_id::x_id_l
-	  )
-	  []
-	  al
-      )
-    in
-    let fun_body = 
-      RCases
-	(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 
-				     (delayed_force coq_sig_ref),1),
-			       [PatVar(d0, Name v_id);
-				PatVar(d0, Anonymous)],
-			       Anonymous)],
-	  RVar(d0,v_id)])
-    in
-    let value =
-      List.fold_left2 
-	(fun acc x_id a -> 
-	   RLambda
-      	     (d0, Name x_id, Explicit, RDynamic(d0, constr_in a),
-	      acc
-	     ) 
-	)
-	fun_body
-	rev_x_id_l
-	(List.rev al)
-    in
-    understand Evd.empty (Global.env()) value;;
-
-let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
-  fun f_id kind value ->
-    let ce = {const_entry_body = value;
-	      const_entry_type = None;
-	      const_entry_opaque = false;
-              const_entry_boxed = true} in
-      ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
-
-let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> 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_global term_f in 
-  let nargs = nb_prod (type_of_const terminate_constr) in 
-  let x = n_x_id ids nargs in
-  tclTHENLIST [
-    h_intros x;
-    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
-  let k = next_global_ident_away true k_id ids in
-  let p = next_global_ident_away true p_id (k::ids) in
-  let v = next_global_ident_away true v_id (p::k::ids) in
-  let heq = next_global_ident_away true heq_id (v::p::k::ids) in
-  let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in
-  let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in
-    tclTHENLIST [
-      h_intros [v; hex]; 
-      simplest_elim (mkVar hex);
-      h_intros [p;heq1];
-      tclTRY
-	(rewriteRL 
-	   (mkApp(mkVar heq1, 
-		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
-		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
-      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 
-    f p heq1 pmax bounds le_proofs eqs ids =
-  function
-      [] ->
-       let heq2 = next_global_ident_away true heq_id ids in
-	tclTHENLIST
-	  [pose_proof (Name 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), InHyp);
-           tclTHENS
-	     (fun gls -> 
-		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
-		observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences
-		(mkVar heq2,
-		 ExplicitBindings[dummy_loc,NamedHyp def_id,
-				  f]) false) gls)
-	     [tclTHENLIST
-		[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 ->
-	let v' = next_global_ident_away true v_id ids in
-        let ids = v'::ids in
-	let hex' = next_global_ident_away true hex_id ids in
-        let ids = hex'::ids in
-	let p' = next_global_ident_away true p_id ids in
-        let ids = p'::ids in
-	let new_pmax = next_global_ident_away true pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_global_ident_away true hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_global_ident_away true hle_id ids in
-        let ids = hle2::ids in
-	let heq = next_global_ident_away true heq_id ids in
-        let ids = heq::ids in
-	let heq2 = next_global_ident_away true heq_id ids in
-        let ids = heq2::ids in
-	tclTHENLIST
-	  [mkCaseEq(mkApp(termine, Array.of_list arg));
-	   h_intros [v'; hex'];
-	   simplest_elim(mkVar hex');
-	   h_intros [p'];
-	   simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
-							mkVar p'|]));
-	   h_intros [new_pmax;hle1;hle2];
-           introduce_all_values_eq 
-              (fun pmax' le_proofs'->
-		tclTHENLIST
-		  [cont_tac pmax' le_proofs';
-		   h_intros [heq;heq2];
-		   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 = 
-			   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
-			 in
-			 let c_b = (mkVar heq,
-			    ExplicitBindings
-			      [dummy_loc, NamedHyp k_id,
-			       f_S(mkVar pmax');
-			       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']])])
-	     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]
-  
-
-let rec_leaf_eq termine f ids functional eqs expr fn args =
-  let p = next_global_ident_away true p_id ids in
-  let ids = p::ids in
-  let v = next_global_ident_away true v_id ids in
-  let ids = v::ids in
-  let hex = next_global_ident_away true hex_id ids in
-  let ids = hex::ids in
-  let heq1 = next_global_ident_away true heq_id ids in
-  let ids = heq1::ids in
-  let hle1 = next_global_ident_away true hle_id ids in
-  let ids = hle1::ids in
-    tclTHENLIST
-      [observe_tac "intros v hex" (h_intros [v;hex]);
-       simplest_elim (mkVar hex);
-       h_intros [p;heq1];
-       h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
-       h_intros [hle1];
-       observe_tac "introduce_all_values_eq" (introduce_all_values_eq
-	 (fun _ _ -> tclIDTAC)
-	 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(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 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 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_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_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 ->
-	     prove_eq 
-	       (constr_of_global terminate_ref)
-	       f_constr 
-	       functional_ref
-	       []
-	       (instantiate_lambda
-	       	  (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); *)
-     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
-  let env = push_named (function_name,None,function_type) (Global.env()) in
-(*   Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
-  let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in 
-(*   Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *)
-  let res_vars,eq' = decompose_prod equation_lemma_type in 
-  let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in
-  let eq' = nf_zeta env_eq' eq'  in 
-  let res = 
-(*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
-(*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
-(*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
-    match kind_of_term eq' with 
-      | App(e,[|_;_;eq_fix|]) -> 
-	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
-      | _ -> failwith "Recursive Definition (res not eq)"
-  in
-  let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in 
-  let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
-  let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
-  let equation_id = add_suffix function_name "_equation" in
-  let functional_id =  add_suffix function_name "_F" in
-  let term_id = add_suffix function_name "_terminate" in
-  let functional_ref = declare_fun functional_id (IsDefinition Definition) res in
-  let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in 
-  let relation = 
-    interp_constr
-      Evd.empty 
-      env_with_pre_rec_args
-      r
-  in 
-  let tcc_lemma_name = add_suffix function_name "_tcc" in
-  let tcc_lemma_constr = ref None in 
-(*   let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
-  let hook _ _ =   
-    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 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 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 not !stop
-    then
-      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 
-      tcc_lemma_name
-      tcc_lemma_constr
-      is_mes functional_ref
-      rec_arg_type
-      relation rec_arg_num
-      term_id
-      using_lemmas
-      (List.length res_vars)
-      hook
-  with e -> 
-    begin
-      ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
-(*       anomaly "Cannot create termination Lemma" *)
-      raise e
-    end
-
-
-
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT
deleted file mode 100644
index 23aeb6bb..00000000
--- a/contrib/interface/COPYRIGHT
+++ /dev/null
@@ -1,23 +0,0 @@
-(*****************************************************************************)
-(*                                                                           *)
-(*      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                         *)
-(*                                                                           *)
-(*****************************************************************************)
-
-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)
-
-The files of the current directory are distributed under the terms of
-the GNU Lesser General Public License Version 2.1.
-
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
deleted file mode 100644
index 2eb2c381..00000000
--- a/contrib/interface/ascent.mli
+++ /dev/null
@@ -1,795 +0,0 @@
-type ct_AST =
-    CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT
-  | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING
-  | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE
-  | CT_astnode of ct_ID * ct_AST_LIST
-  | CT_astpath of ct_ID_LIST
-  | CT_astslam of ct_ID_OPT * ct_AST
-and ct_AST_LIST =
-    CT_ast_list of ct_AST list
-and ct_BINARY =
-    CT_binary of int
-and ct_BINDER =
-    CT_coerce_DEF_to_BINDER of ct_DEF
-  | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA
-  | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA
-and ct_BINDER_LIST =
-    CT_binder_list of ct_BINDER list
-and ct_BINDER_NE_LIST =
-    CT_binder_ne_list of ct_BINDER * ct_BINDER list
-and ct_BINDING =
-    CT_binding of ct_ID_OR_INT * ct_FORMULA
-and ct_BINDING_LIST =
-    CT_binding_list of ct_BINDING list
-and t_BOOL =
-    CT_false
-  | CT_true
-and ct_CASE =
-    CT_case of string
-and ct_CLAUSE =
-    CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT
-and ct_COERCION_OPT =
-    CT_coerce_NONE_to_COERCION_OPT of ct_NONE
-  | CT_coercion_atm
-and ct_COFIXTAC =
-    CT_cofixtac of ct_ID * ct_FORMULA
-and ct_COFIX_REC =
-    CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA
-and ct_COFIX_REC_LIST =
-    CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list
-and ct_COFIX_TAC_LIST =
-    CT_cofix_tac_list of ct_COFIXTAC list
-and ct_COMMAND =
-    CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST
-  | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD
-  | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN
-  | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL
-  | CT_abort of ct_ID_OPT_OR_ALL
-  | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST
-  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT
-  | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID
-  | CT_addpath of ct_STRING * ct_ID_OPT
-  | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST
-  | CT_bind_scope of ct_ID * ct_ID_NE_LIST
-  | CT_cd of ct_STRING_OPT
-  | CT_check of ct_FORMULA
-  | CT_class of ct_ID
-  | CT_close_scope of ct_ID
-  | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID
-  | CT_cofix_decl of ct_COFIX_REC_LIST
-  | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT
-  | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
-  | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT
-  | CT_delim_scope of ct_ID * ct_ID
-  | CT_delpath of ct_STRING
-  | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
-  | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID
-  | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
-  | CT_explain_proof of ct_INT_LIST
-  | CT_explain_prooftree of ct_INT_LIST
-  | CT_export_id of ct_ID_NE_LIST
-  | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST
-  | CT_extraction of ct_ID_OPT
-  | CT_fix_decl of ct_FIX_REC_LIST
-  | CT_focus of ct_INT_OPT
-  | CT_go of ct_INT_OR_LOCN
-  | CT_guarded
-  | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST
-  | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM
-  | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
-  | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_implicits of ct_ID * ct_ID_LIST_OPT
-  | CT_import_id of ct_ID_NE_LIST
-  | CT_ind_scheme of ct_SCHEME_SPEC_LIST
-  | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_inline of ct_ID_NE_LIST
-  | CT_inspect of ct_INT
-  | CT_kill_node of ct_INT
-  | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING
-  | CT_local_close_scope of ct_ID
-  | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
-  | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
-  | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
-  | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
-  | CT_local_open_scope of ct_ID
-  | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST
-  | CT_locate of ct_ID
-  | CT_locate_file of ct_STRING
-  | CT_locate_lib of ct_ID
-  | CT_locate_notation of ct_STRING
-  | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST
-  | CT_ml_add_path of ct_STRING
-  | CT_ml_declare_modules of ct_STRING_NE_LIST
-  | CT_ml_print_modules
-  | CT_ml_print_path
-  | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
-  | 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_open_scope of ct_ID
-  | CT_print
-  | CT_print_about of ct_ID
-  | CT_print_all
-  | CT_print_classes
-  | CT_print_ltac of ct_ID
-  | CT_print_coercions
-  | CT_print_grammar of ct_GRAMMAR
-  | CT_print_graph
-  | CT_print_hint of ct_ID_OPT
-  | CT_print_hintdb of ct_ID_OR_STAR
-  | CT_print_rewrite_hintdb of ct_ID
-  | CT_print_id of ct_ID
-  | CT_print_implicit of ct_ID
-  | CT_print_loadpath
-  | CT_print_module of ct_ID
-  | CT_print_module_type of ct_ID
-  | CT_print_modules
-  | CT_print_natural of ct_ID
-  | CT_print_natural_feature of ct_NATURAL_FEATURE
-  | CT_print_opaqueid of ct_ID
-  | CT_print_path of ct_ID * ct_ID
-  | CT_print_proof of ct_ID
-  | CT_print_setoids
-  | CT_print_scope of ct_ID
-  | CT_print_scopes
-  | CT_print_section of ct_ID
-  | CT_print_states
-  | CT_print_tables
-  | CT_print_universes of ct_STRING_OPT
-  | CT_print_visibility of ct_ID_OPT
-  | CT_proof of ct_FORMULA
-  | CT_proof_no_op
-  | CT_proof_with of ct_TACTIC_COM
-  | CT_pwd
-  | CT_quit
-  | CT_read_module of ct_ID
-  | CT_rec_ml_add_path of ct_STRING
-  | CT_recaddpath of ct_STRING * ct_ID_OPT
-  | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST
-  | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID
-  | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING
-  | CT_reserve of ct_ID_NE_LIST * ct_FORMULA
-  | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST
-  | CT_reset of ct_ID
-  | CT_reset_section of ct_ID
-  | CT_restart
-  | CT_restore_state of ct_ID
-  | CT_resume of ct_ID_OPT
-  | CT_save of ct_THM_OPT * ct_ID_OPT
-  | CT_scomments of ct_SCOMMENT_CONTENT_LIST
-  | CT_search of ct_ID * ct_IN_OR_OUT_MODULES
-  | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES
-  | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES
-  | CT_section_end of ct_ID
-  | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND
-  | CT_set_natural of ct_ID
-  | CT_set_natural_default
-  | CT_set_option of ct_TABLE
-  | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE
-  | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST
-  | CT_sethyp of ct_INT
-  | CT_setundo of ct_INT
-  | CT_show_existentials
-  | CT_show_goal of ct_INT_OPT
-  | CT_show_implicit of ct_INT
-  | CT_show_intro
-  | CT_show_intros
-  | CT_show_node
-  | CT_show_proof
-  | CT_show_proofs
-  | 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_undo of ct_INT_OPT
-  | CT_unfocus
-  | CT_unset_option of ct_TABLE
-  | CT_unsethyp
-  | CT_unsetundo
-  | 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 =
-    CT_comment of string
-and ct_COMMENT_S =
-    CT_comment_s of ct_COMMENT list
-and ct_CONSTR =
-    CT_constr of ct_ID * ct_FORMULA
-  | CT_constr_coercion of ct_ID * ct_FORMULA
-and ct_CONSTR_LIST =
-    CT_constr_list of ct_CONSTR list
-and ct_CONTEXT_HYP_LIST =
-    CT_context_hyp_list of ct_PREMISE_PATTERN list
-and ct_CONTEXT_PATTERN =
-    CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA
-  | CT_context of ct_ID_OPT * ct_FORMULA
-and ct_CONTEXT_RULE =
-    CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM
-  | CT_def_context_rule of ct_TACTIC_COM
-and ct_CONVERSION_FLAG =
-    CT_beta
-  | CT_delta
-  | CT_evar
-  | CT_iota
-  | CT_zeta
-and ct_CONVERSION_FLAG_LIST =
-    CT_conversion_flag_list of ct_CONVERSION_FLAG list
-and ct_CONV_SET =
-    CT_unf of ct_ID list
-  | CT_unfbut of ct_ID list
-and ct_CO_IND =
-    CT_co_ind of string
-and ct_DECL_NOTATION_OPT =
-    CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE
-  | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT
-and ct_DEF =
-    CT_def of ct_ID_OPT * ct_FORMULA
-and ct_DEFN =
-    CT_defn of string
-and ct_DEFN_OR_THM =
-    CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN
-  | CT_coerce_THM_to_DEFN_OR_THM of ct_THM
-and ct_DEF_BODY =
-    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN
-  | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD
-  | CT_type_of of ct_FORMULA
-and ct_DEF_BODY_OPT =
-    CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY
-  | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT
-and ct_DEP =
-    CT_dep of string
-and ct_DESTRUCTING =
-    CT_coerce_NONE_to_DESTRUCTING of ct_NONE
-  | CT_destructing
-and ct_DESTRUCT_LOCATION =
-    CT_conclusion_location
-  | CT_discardable_hypothesis
-  | CT_hypothesis_location
-and ct_DOTDOT_OPT =
-    CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE
-  | CT_dotdot
-and ct_EQN =
-    CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA
-and ct_EQN_LIST =
-    CT_eqn_list of ct_EQN list
-and ct_EVAL_CMD =
-    CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA
-and ct_FIXTAC =
-    CT_fixtac of ct_ID * ct_INT * ct_FORMULA
-and ct_FIX_BINDER =
-    CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC
-  | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA
-and ct_FIX_BINDER_LIST =
-    CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list
-and ct_FIX_REC =
-    CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT *
-      ct_FORMULA * ct_FORMULA
-and ct_FIX_REC_LIST =
-    CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list
-and ct_FIX_TAC_LIST =
-    CT_fix_tac_list of ct_FIXTAC list
-and ct_FORMULA =
-    CT_coerce_BINARY_to_FORMULA of ct_BINARY
-  | CT_coerce_ID_to_FORMULA of ct_ID
-  | CT_coerce_NUM_to_FORMULA of ct_NUM
-  | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE
-  | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA
-  | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST
-  | CT_arrowc of ct_FORMULA * ct_FORMULA
-  | CT_bang of ct_FORMULA
-  | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST
-  | CT_cofixc of ct_ID * ct_COFIX_REC_LIST
-  | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST
-  | CT_existvarc
-  | CT_fixc of ct_ID * ct_FIX_BINDER_LIST
-  | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
-  | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA
-  | CT_labelled_arg of ct_ID * ct_FORMULA
-  | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA
-  | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
-  | CT_letin of ct_DEF * ct_FORMULA
-  | CT_notation of ct_STRING * ct_FORMULA_LIST
-  | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA
-  | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA
-  | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST
-and ct_FORMULA_LIST =
-    CT_formula_list of ct_FORMULA list
-and ct_FORMULA_NE_LIST =
-    CT_formula_ne_list of ct_FORMULA * ct_FORMULA list
-and ct_FORMULA_OPT =
-    CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA
-  | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT
-and ct_FORMULA_OR_INT =
-    CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA
-  | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT
-and ct_GRAMMAR =
-    CT_grammar_none
-and ct_HYP_LOCATION =
-    CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD
-  | CT_intype of ct_ID * ct_INT_LIST
-  | CT_invalue of ct_ID * ct_INT_LIST
-and ct_HYP_LOCATION_LIST_OR_STAR =
-    CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR
-  | CT_hyp_location_list of ct_HYP_LOCATION list
-and ct_ID =
-    CT_ident of string
-  | CT_metac of ct_INT
-  | CT_metaid of string
-and ct_IDENTITY_OPT =
-    CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE
-  | CT_identity
-and ct_ID_LIST =
-    CT_id_list of ct_ID list
-and ct_ID_LIST_LIST =
-    CT_id_list_list of ct_ID_LIST list
-and ct_ID_LIST_OPT =
-    CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST
-  | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE
-and ct_ID_NE_LIST =
-    CT_id_ne_list of ct_ID * ct_ID list
-and ct_ID_NE_LIST_OR_STAR =
-    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST
-  | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR
-and ct_ID_NE_LIST_OR_STRING =
-    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST
-  | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING
-and ct_ID_OPT =
-    CT_coerce_ID_to_ID_OPT of ct_ID
-  | CT_coerce_NONE_to_ID_OPT of ct_NONE
-and ct_ID_OPT_LIST =
-    CT_id_opt_list of ct_ID_OPT list
-and ct_ID_OPT_NE_LIST =
-    CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list
-and ct_ID_OPT_OR_ALL =
-    CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT
-  | CT_all
-and ct_ID_OR_INT =
-    CT_coerce_ID_to_ID_OR_INT of ct_ID
-  | CT_coerce_INT_to_ID_OR_INT of ct_INT
-and ct_ID_OR_INT_OPT =
-    CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT
-  | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT
-  | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT
-and ct_ID_OR_STAR =
-    CT_coerce_ID_to_ID_OR_STAR of ct_ID
-  | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR
-and ct_ID_OR_STRING =
-    CT_coerce_ID_to_ID_OR_STRING of ct_ID
-  | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING
-and ct_ID_OR_STRING_NE_LIST =
-    CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list
-and ct_IMPEXP =
-    CT_coerce_NONE_to_IMPEXP of ct_NONE
-  | CT_export
-  | CT_import
-and ct_IND_SPEC =
-    CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT
-and ct_IND_SPEC_LIST =
-    CT_ind_spec_list of ct_IND_SPEC list
-and ct_INT =
-    CT_int of int
-and ct_INTRO_PATT =
-    CT_coerce_ID_to_INTRO_PATT of ct_ID
-  | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list
-and ct_INTRO_PATT_LIST =
-    CT_intro_patt_list of ct_INTRO_PATT list
-and ct_INTRO_PATT_OPT =
-    CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT
-  | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT
-and ct_INT_LIST =
-    CT_int_list of ct_INT list
-and ct_INT_NE_LIST =
-    CT_int_ne_list of ct_INT * ct_INT list
-and ct_INT_OPT =
-    CT_coerce_INT_to_INT_OPT of ct_INT
-  | CT_coerce_NONE_to_INT_OPT of ct_NONE
-and ct_INT_OR_LOCN =
-    CT_coerce_INT_to_INT_OR_LOCN of ct_INT
-  | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN
-and ct_INT_OR_NEXT =
-    CT_coerce_INT_to_INT_OR_NEXT of ct_INT
-  | CT_next_level
-and ct_INV_TYPE =
-    CT_inv_clear
-  | CT_inv_regular
-  | CT_inv_simple
-and ct_IN_OR_OUT_MODULES =
-    CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE
-  | CT_in_modules of ct_ID_NE_LIST
-  | CT_out_modules of ct_ID_NE_LIST
-and ct_LET_CLAUSE =
-    CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE
-and ct_LET_CLAUSES =
-    CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list
-and ct_LET_VALUE =
-    CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY
-  | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM
-and ct_LOCAL_OPT =
-    CT_coerce_NONE_to_LOCAL_OPT of ct_NONE
-  | CT_local
-and ct_LOCN =
-    CT_locn of string
-and ct_MATCHED_FORMULA =
-    CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA
-  | CT_formula_as of ct_FORMULA * ct_ID_OPT
-  | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA
-  | CT_formula_in of ct_FORMULA * ct_FORMULA
-and ct_MATCHED_FORMULA_NE_LIST =
-    CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list
-and ct_MATCH_PATTERN =
-    CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT
-  | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM
-  | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST
-  | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT
-  | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN
-  | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST
-and ct_MATCH_PATTERN_LIST =
-    CT_match_pattern_list of ct_MATCH_PATTERN list
-and ct_MATCH_PATTERN_NE_LIST =
-    CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list
-and ct_MATCH_TAC_RULE =
-    CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE
-and ct_MATCH_TAC_RULES =
-    CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list
-and ct_MODIFIER =
-    CT_entry_type of ct_ID * ct_ID
-  | CT_format of ct_STRING
-  | CT_lefta
-  | CT_nona
-  | CT_only_parsing
-  | CT_righta
-  | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT
-  | CT_set_level of ct_INT
-and ct_MODIFIER_LIST =
-    CT_modifier_list of ct_MODIFIER list
-and ct_MODULE_BINDER =
-    CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE
-and ct_MODULE_BINDER_LIST =
-    CT_module_binder_list of ct_MODULE_BINDER list
-and ct_MODULE_EXPR =
-    CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT
-  | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR
-and ct_MODULE_TYPE =
-    CT_coerce_ID_to_MODULE_TYPE of ct_ID
-  | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID_LIST * ct_FORMULA
-  | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID_LIST * ct_ID
-and ct_MODULE_TYPE_CHECK =
-    CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT
-  | CT_only_check of ct_MODULE_TYPE
-and ct_MODULE_TYPE_OPT =
-    CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT
-  | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE
-and ct_NATURAL_FEATURE =
-    CT_contractible
-  | CT_implicit
-  | CT_nat_transparent
-and ct_NONE =
-    CT_none
-and ct_NUM =
-    CT_int_encapsulator of string
-and ct_NUM_TYPE =
-    CT_num_type of string
-and ct_OMEGA_FEATURE =
-    CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING
-  | CT_flag_action
-  | CT_flag_system
-  | CT_flag_time
-and ct_OMEGA_MODE =
-    CT_set
-  | CT_switch
-  | CT_unset
-and ct_ORIENTATION =
-    CT_lr
-  | CT_rl
-and ct_PATTERN =
-    CT_pattern_occ of ct_INT_LIST * ct_FORMULA
-and ct_PATTERN_NE_LIST =
-    CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list
-and ct_PATTERN_OPT =
-    CT_coerce_NONE_to_PATTERN_OPT of ct_NONE
-  | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN
-and ct_PREMISE =
-    CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA
-  | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA
-  | CT_premise of ct_ID * ct_FORMULA
-and ct_PREMISES_LIST =
-    CT_premises_list of ct_PREMISE list
-and ct_PREMISE_PATTERN =
-    CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN
-and ct_PROOF_SCRIPT =
-    CT_proof_script of ct_COMMAND list
-and ct_RECCONSTR =
-    CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
-  | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
-  | CT_recconstr of ct_ID_OPT * ct_FORMULA
-  | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA
-and ct_RECCONSTR_LIST =
-    CT_recconstr_list of ct_RECCONSTR list
-and ct_REC_TACTIC_FUN =
-    CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM
-and ct_REC_TACTIC_FUN_LIST =
-    CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list
-and ct_RED_COM =
-    CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
-  | CT_fold of ct_FORMULA_LIST
-  | CT_hnf
-  | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
-  | CT_pattern of ct_PATTERN_NE_LIST
-  | CT_red
-  | CT_cbvvm
-  | CT_simpl of ct_PATTERN_OPT
-  | CT_unfold of ct_UNFOLD_NE_LIST
-and ct_RETURN_INFO =
-    CT_coerce_NONE_to_RETURN_INFO of ct_NONE
-  | CT_as_and_return of ct_ID_OPT * ct_FORMULA
-  | CT_return of ct_FORMULA
-and ct_RULE =
-    CT_rule of ct_PREMISES_LIST * ct_FORMULA
-and ct_RULE_LIST =
-    CT_rule_list of ct_RULE list
-and ct_SCHEME_SPEC =
-    CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE
-and ct_SCHEME_SPEC_LIST =
-    CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list
-and ct_SCOMMENT_CONTENT =
-    CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA
-  | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING
-and ct_SCOMMENT_CONTENT_LIST =
-    CT_scomment_content_list of ct_SCOMMENT_CONTENT list
-and ct_SECTION_BEGIN =
-    CT_section of ct_ID
-and ct_SECTION_BODY =
-    CT_section_body of ct_COMMAND list
-and ct_SIGNED_INT =
-    CT_coerce_INT_to_SIGNED_INT of ct_INT
-  | CT_minus of ct_INT
-and ct_SIGNED_INT_LIST =
-    CT_signed_int_list of ct_SIGNED_INT list
-and ct_SINGLE_OPTION_VALUE =
-    CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT
-  | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING
-and ct_SORT_TYPE =
-    CT_sortc of string
-and ct_SPEC_LIST =
-    CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST
-  | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST
-and ct_SPEC_OPT =
-    CT_coerce_NONE_to_SPEC_OPT of ct_NONE
-  | CT_spec
-and ct_STAR =
-    CT_star
-and ct_STAR_OPT =
-    CT_coerce_NONE_to_STAR_OPT of ct_NONE
-  | CT_coerce_STAR_to_STAR_OPT of ct_STAR
-and ct_STRING =
-    CT_string of string
-and ct_STRING_NE_LIST =
-    CT_string_ne_list of ct_STRING * ct_STRING list
-and ct_STRING_OPT =
-    CT_coerce_NONE_to_STRING_OPT of ct_NONE
-  | CT_coerce_STRING_to_STRING_OPT of ct_STRING
-and ct_TABLE =
-    CT_coerce_ID_to_TABLE of ct_ID
-  | CT_table of ct_ID * ct_ID
-and ct_TACTIC_ARG =
-    CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD
-  | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT
-  | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM
-  | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE
-  | CT_void
-and ct_TACTIC_ARG_LIST =
-    CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list
-and ct_TACTIC_COM =
-    CT_abstract of ct_ID_OPT * ct_TACTIC_COM
-  | CT_absurd of ct_FORMULA
-  | CT_any_constructor of ct_TACTIC_OPT
-  | CT_apply of ct_FORMULA * ct_SPEC_LIST
-  | CT_assert of ct_ID_OPT * ct_FORMULA
-  | CT_assumption
-  | CT_auto of ct_INT_OPT
-  | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR
-  | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT
-  | CT_autotdb of ct_INT_OPT
-  | CT_case_type of ct_FORMULA
-  | CT_casetac of ct_FORMULA * ct_SPEC_LIST
-  | CT_cdhyp of ct_ID
-  | CT_change of ct_FORMULA * ct_CLAUSE
-  | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE
-  | CT_clear of ct_ID_NE_LIST
-  | CT_clear_body of ct_ID_NE_LIST
-  | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST
-  | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
-  | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
-  | CT_constructor of ct_INT * ct_SPEC_LIST
-  | CT_contradiction
-  | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST
-  | CT_cut of ct_FORMULA
-  | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT
-  | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT
-  | CT_dauto of ct_INT_OPT * ct_INT_OPT
-  | CT_dconcl
-  | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA
-  | CT_decompose_record of ct_FORMULA
-  | CT_decompose_sum of ct_FORMULA
-  | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT
-  | CT_deprewrite_lr of ct_ID
-  | CT_deprewrite_rl of ct_ID
-  | CT_destruct of ct_ID_OR_INT
-  | CT_dhyp of ct_ID
-  | CT_discriminate_eq of ct_ID_OR_INT_OPT
-  | CT_do of ct_ID_OR_INT * ct_TACTIC_COM
-  | CT_eapply of ct_FORMULA * ct_SPEC_LIST
-  | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT
-  | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR
-  | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING
-  | CT_elim_type of ct_FORMULA
-  | CT_exact of ct_FORMULA
-  | CT_exact_no_check of ct_FORMULA
-  | CT_vm_cast_no_check of ct_FORMULA
-  | CT_exists of ct_SPEC_LIST
-  | CT_fail of ct_ID_OR_INT * ct_STRING_OPT
-  | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_firstorder of ct_TACTIC_OPT
-  | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST
-  | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST
-  | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST
-  | CT_formula_marker of ct_FORMULA
-  | CT_fresh of ct_STRING_OPT
-  | CT_generalize of ct_FORMULA_NE_LIST
-  | CT_generalize_dependent of ct_FORMULA
-  | CT_idtac of ct_STRING_OPT
-  | CT_induction of ct_ID_OR_INT
-  | CT_info of ct_TACTIC_COM
-  | CT_injection_eq of ct_ID_OR_INT_OPT
-  | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE
-  | CT_intro of ct_ID_OPT
-  | CT_intro_after of ct_ID_OPT * ct_ID
-  | CT_intros of ct_INTRO_PATT_LIST
-  | CT_intros_until of ct_ID_OR_INT
-  | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST
-  | CT_left of ct_SPEC_LIST
-  | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE
-  | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE
-  | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
-  | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
-  | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES
-  | CT_move_after of ct_ID * ct_ID
-  | CT_new_destruct of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
-  | CT_new_induction of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
-  | CT_omega
-  | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM
-  | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_pose of ct_ID_OPT * ct_FORMULA
-  | CT_progress of ct_TACTIC_COM
-  | CT_prolog of ct_FORMULA_LIST * ct_INT
-  | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM
-  | CT_reduce of ct_RED_COM * ct_CLAUSE
-  | CT_refine of ct_FORMULA
-  | CT_reflexivity
-  | CT_rename of ct_ID * ct_ID
-  | CT_repeat of ct_TACTIC_COM
-  | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT
-  | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
-  | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
-  | CT_right of ct_SPEC_LIST
-  | CT_ring of ct_FORMULA_LIST
-  | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST
-  | CT_simplify_eq of ct_ID_OR_INT_OPT
-  | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST
-  | CT_split of ct_SPEC_LIST
-  | CT_subst of ct_ID_LIST
-  | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB
-  | CT_symmetry of ct_CLAUSE
-  | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT
-  | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM
-  | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list
-  | CT_transitivity of ct_FORMULA
-  | CT_trivial
-  | CT_trivial_with of ct_ID_NE_LIST_OR_STAR
-  | CT_truecut of ct_ID_OPT * ct_FORMULA
-  | CT_try of ct_TACTIC_COM
-  | CT_use of ct_FORMULA
-  | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST
-  | CT_user_tac of ct_ID * ct_TARG_LIST
-and ct_TACTIC_OPT =
-    CT_coerce_NONE_to_TACTIC_OPT of ct_NONE
-  | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM
-and ct_TAC_DEF =
-    CT_tac_def of ct_ID * ct_TACTIC_COM
-and ct_TAC_DEF_NE_LIST =
-    CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list
-and ct_TARG =
-    CT_coerce_BINDING_to_TARG of ct_BINDING
-  | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC
-  | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC
-  | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT
-  | CT_coerce_PATTERN_to_TARG of ct_PATTERN
-  | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT
-  | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST
-  | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE
-  | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST
-  | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM
-  | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST
-  | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD
-  | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST
-and ct_TARG_LIST =
-    CT_targ_list of ct_TARG list
-and ct_TERM_CHANGE =
-    CT_check_term of ct_FORMULA
-  | CT_inst_term of ct_ID * ct_FORMULA
-and ct_TEXT =
-    CT_coerce_ID_to_TEXT of ct_ID
-  | CT_text_formula of ct_FORMULA
-  | CT_text_h of ct_TEXT list
-  | CT_text_hv of ct_TEXT list
-  | CT_text_op of ct_TEXT list
-  | CT_text_path of ct_SIGNED_INT_LIST
-  | CT_text_v of ct_TEXT list
-and ct_THEOREM_GOAL =
-    CT_goal of ct_FORMULA
-  | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA
-and ct_THM =
-    CT_thm of string
-and ct_THM_OPT =
-    CT_coerce_NONE_to_THM_OPT of ct_NONE
-  | CT_coerce_THM_to_THM_OPT of ct_THM
-and ct_TYPED_FORMULA =
-    CT_typed_formula of ct_FORMULA * ct_FORMULA
-and ct_UNFOLD =
-    CT_coerce_ID_to_UNFOLD of ct_ID
-  | CT_unfold_occ of ct_ID * ct_INT_NE_LIST
-and ct_UNFOLD_NE_LIST =
-    CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list
-and ct_USING =
-    CT_coerce_NONE_to_USING of ct_NONE
-  | CT_using of ct_FORMULA * ct_SPEC_LIST
-and ct_USINGTDB =
-    CT_coerce_NONE_to_USINGTDB of ct_NONE
-  | CT_usingtdb
-and ct_VAR =
-    CT_var of string
-and ct_VARG =
-    CT_coerce_AST_to_VARG of ct_AST
-  | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST
-  | CT_coerce_BINDER_to_VARG of ct_BINDER
-  | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST
-  | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST
-  | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST
-  | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT
-  | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT
-  | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL
-  | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT
-  | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST
-  | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT
-  | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT
-  | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT
-  | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST
-and ct_VARG_LIST =
-    CT_varg_list of ct_VARG list
-and ct_VERBOSE_OPT =
-    CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE
-  | CT_verbose
-;;
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
deleted file mode 100644
index 483453cb..00000000
--- a/contrib/interface/blast.ml
+++ /dev/null
@@ -1,627 +0,0 @@
-(* Une tactique qui tente de démontrer toute seule le but courant,
-   interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A)
-*)
-open Termops;;
-open Nameops;;
-open Auto;;
-open Clenv;;
-open Command;;
-open Declarations;;
-open Declare;;
-open Eauto;;
-open Environ;;
-open Equality;;
-open Evd;;
-open Hipattern;;
-open Inductive;;
-open Names;;
-open Pattern;;
-open Pbp;;
-open Pfedit;;
-open Pp;;
-open Printer
-open Proof_trees;;
-open Proof_type;;
-open Rawterm;;
-open Reduction;;
-open Refiner;;
-open Sign;;
-open String;;
-open Tacmach;;
-open Tacred;;
-open Tacticals;;
-open Tactics;;
-open Term;;
-open Typing;;
-open Util;;
-open Vernacentries;;
-open Vernacinterp;;
-
-
-let parse_com   = Pcoq.parse_string Pcoq.Constr.constr;;
-let parse_tac  t =
-    try (Pcoq.parse_string Pcoq.Tactic.tactic t)
-    with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t));
-	       failwith "tactic")
-;;
-
-let is_free () =
-   let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in
-   let c=input_char st in
-   close_in st;
-   c = 'A'
-;;
-
-(* marche pas *)
-(*
-let is_free () =
-   msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]);
-   let s = Stream.of_channel stdin in
-   msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]);
-   try (Stream.empty s;
-        msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]);
-        true)
-   with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]);
-              false)
-;;
-*)
-let free_try tac g =
-    if is_free()
-    then (tac g)
-    else (failwith "not free")
-;;
-let adrel (x,t) e =
-    match x with 
-      Name(xid) -> Environ.push_rel (x,None,t) e
-    | Anonymous -> Environ.push_rel (x,None,t) e
-(* les constantes ayant une définition apparaissant dans x *)
-let rec def_const_in_term_rec vl x = 
-     match (kind_of_term x) with
-     Prod(n,t,c)->
-        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
-   | Lambda(n,t,c) ->
-        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
-   | App(f,args) -> def_const_in_term_rec vl f
-   | Sort(Prop(Null)) -> Prop(Null)
-   | Sort(c) -> c
-   | Ind(ind) ->
-          let (mib, mip) = Global.lookup_inductive ind in
-	  new_sort_in_family (inductive_sort_family mip)
-   | Construct(c) ->
-          def_const_in_term_rec vl (mkInd (inductive_of_constructor c))
-   | Case(_,x,t,a) 
-        -> def_const_in_term_rec vl x
-   | Cast(x,_,t)-> def_const_in_term_rec vl t
-   | Const(c)  -> def_const_in_term_rec vl (Typeops.type_of_constant vl c)
-   | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x)
-;;
-let def_const_in_term_ x =
-    def_const_in_term_rec  (Global.env()) (strip_outer_cast x)
-;;
-(*************************************************************************
- recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli 
- modif de print_info_script avec pr_bar
-*)
-
-let pr_bar () = str "|"
-
-let rec print_info_script sigma osign pf =
-  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
-  match pf.ref with
-    | None -> (mt ())
-    | Some(r,spfl) ->
-        Tactic_printer.pr_rule r ++
-           match spfl with
-             | [] ->
-		   (str " " ++ fnl())
-             | [pf1] ->
-                 if pf1.ref = None then 
-		   (str " " ++ fnl())
-                 else 
-		   (str";" ++ brk(1,3) ++
-		      print_info_script sigma sign pf1)
-             | _ -> ( str";[" ++ fnl() ++
-                       prlist_with_sep pr_bar
-                         (print_info_script sigma sign) spfl ++
-                       str"]")
-
-let format_print_info_script sigma osign pf = 
-  hov 0 (print_info_script sigma osign pf)
-    
-let print_subscript sigma sign pf = 
- (* if is_tactic_proof pf then 
-    format_print_info_script sigma sign (subproof_of_proof pf)
-  else *)
-    format_print_info_script sigma sign pf
-(****************)
-
-let pp_string x =
-   msgnl_with Format.str_formatter x;
-   Format.flush_str_formatter ()
-;;
-
-(***********************************************************************
-   copié de tactics/eauto.ml
-*)
-
-(***************************************************************************)
-(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
-(***************************************************************************)
-
-let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
-
-let unify_e_resolve  (c,clenv) gls = 
-  let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false clenv' gls in
-    Hiddentac.h_simplest_eapply c gls
-
-let rec e_trivial_fail_db db_list local_db goal =
-  let tacl = 
-    registered_e_assumption ::
-    (tclTHEN Tactics.intro 
-       (function g'->
-	  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'))) ::
-    (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 hintl =
-    if occur_existential concl then 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
-    else 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
-  in 
-  let tac_of_hint = 
-    fun (st, ({pri=b; pat = p; code=t} as _patac)) -> 
-      (b, 
-       let tac =
-	 match t with
-	   | 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 [all_occurrences,c]
-	   | Extern tacast -> Auto.conclPattern concl p tacast
-       in 
-       (free_try tac,pr_autotactic t))
-       (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush (); 
-                     try tac gls
-		     with e when Logic.catchable_exception(e) -> 
-                            (Format.print_string "Fail\n"; 
-			     Format.print_flush (); 
-			     raise e)
-       i*)
-  in 
-  List.map tac_of_hint hintl
-    
-and e_trivial_resolve db_list local_db gl = 
-  try 
-    priority 
-      (e_my_find_search db_list local_db 
-	 (fst (head_constr_bound gl)) gl)
-  with Bound | Not_found -> []
-
-let e_possible_resolve db_list local_db gl =
-  try List.map snd (e_my_find_search db_list local_db 
-		      (fst (head_constr_bound gl)) gl)
-  with Bound | Not_found -> []
-
-let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
-
-let find_first_goal gls = 
-  try first_goal gls with UserError _ -> assert false
-
-(*s The following module [SearchProblem] is used to instantiate the generic
-    exploration functor [Explore.Make]. *)
-      
-module MySearchProblem = struct
-
-  type state = { 
-    depth : int; (*r depth of search before failing *)
-    tacres : goal list sigma * validation;
-    last_tactic : std_ppcmds;
-    dblist : Auto.hint_db list;
-    localdb :  Auto.hint_db list }
-		 
-  let success s = (sig_it (fst s.tacres)) = []
-
-  let rec filter_tactics (glls,v) = function
-    | [] -> []
-    | (tac,pptac) :: tacl -> 
-	try 
-	  let (lgls,ptl) = apply_tac_list tac glls in 
-	  let v' p = v (ptl p) in
-	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
-	with e when Logic.catchable_exception e ->
-	  filter_tactics (glls,v) tacl
-
-  (* Ordering of states is lexicographic on depth (greatest first) then
-     number of remaining goals. *)
-  let compare s s' =
-    let d = s'.depth - s.depth in
-    let nbgoals s = List.length (sig_it (fst s.tacres)) in
-    if d <> 0 then d else nbgoals s - nbgoals s'
-
-  let branching s = 
-    if s.depth = 0 then 
-      []
-    else      
-      let lg = fst s.tacres in
-      let nbgl = List.length (sig_it lg) in
-      assert (nbgl > 0);
-      let g = find_first_goal lg in
-      let assumption_tacs = 
-	let l = 
-	  filter_tactics s.tacres
-	    (List.map 
-	       (fun id -> (e_give_exact_constr (mkVar id),
-			   (str "Exact" ++ spc()++ pr_id id)))
-	       (pf_ids_of_hyps g))
-	in
-	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
-				    last_tactic = pp; dblist = s.dblist;
-				    localdb = List.tl s.localdb }) l
-      in
-      let intro_tac = 
-	List.map 
-	  (fun ((lgls,_) as res,pp) -> 
-	     let g' = first_goal lgls in 
-	     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
-	     { depth = s.depth; tacres = res; 
-	       last_tactic = pp; dblist = s.dblist;
-	       localdb = ldb :: List.tl s.localdb })
-	  (filter_tactics s.tacres [Tactics.intro,(str "Intro" )])
-      in
-      let rec_tacs = 
-	let l = 
-	  filter_tactics s.tacres
-	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
-	in
-	List.map 
-	  (fun ((lgls,_) as res, pp) -> 
-	     let nbgl' = List.length (sig_it lgls) in
-	     if nbgl' < nbgl then
-	       { depth = s.depth; tacres = res; last_tactic = pp;
-		 dblist = s.dblist; localdb = List.tl s.localdb }
-	     else 
-	       { depth = pred s.depth; tacres = res; 
-		 dblist = s.dblist; last_tactic = pp;
-		 localdb = 
-		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
-	  l
-      in
-      List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
-
-  let pp s = 
-    msg (hov 0 (str " depth="++ int s.depth ++ spc() ++
-		  s.last_tactic ++ str "\n"))
-
-end
-
-module MySearch = Explore.Make(MySearchProblem)
-
-let make_initial_state n gl dblist localdb =
-  { MySearchProblem.depth = n;
-    MySearchProblem.tacres = tclIDTAC gl;
-    MySearchProblem.last_tactic = (mt ());
-    MySearchProblem.dblist = dblist;
-    MySearchProblem.localdb = [localdb] }
-
-let e_depth_search debug p db_list local_db gl =
-  try
-    let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in
-    let s = tac (make_initial_state p gl db_list local_db) in
-    s.MySearchProblem.tacres
-  with Not_found -> error "EAuto: depth first search failed"
-
-let e_breadth_search debug n db_list local_db gl =
-  try
-    let tac = 
-      if debug then MySearch.debug_breadth_first else MySearch.breadth_first 
-    in
-    let s = tac (make_initial_state n gl db_list local_db) in
-    s.MySearchProblem.tacres
-  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 true [] gl in 
-  if n = 0 then 
-    e_depth_search debug p db_list local_db gl
-  else 
-    e_breadth_search debug n db_list local_db gl
-
-let eauto debug np dbnames = 
-  let db_list =
-    List.map
-      (fun x -> 
-	 try searchtable_map x
-	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
-      ("core"::dbnames) 
-  in
-  tclTRY (e_search_auto debug np db_list)
-
-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 true [] gl in
-  tclTRY (e_search_auto debug n db_list) gl
-
-let my_full_eauto n gl = full_eauto false (n,0) gl
-
-(**********************************************************************
-   copié de tactics/auto.ml on a juste modifié search_gen
-*)
-
-(* local_db is a Hint database containing the hypotheses of current goal *)
-(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
-  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
-
-let rec trivial_fail_db db_list local_db gl =
-  let intro_tac = 
-    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
-  tclFIRST 
-    (assumption::intro_tac::
-     (List.map tclCOMPLETE 
-	(trivial_resolve db_list local_db (pf_concl gl)))) gl
-
-and my_find_search db_list local_db hdc concl =
-  let tacl = 
-    if occur_existential concl then 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
-    else 
-      list_map_append (fun db -> 
-	let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
-  in
-  List.map 
-    (fun (st, {pri=b; pat=p; code=t} as _patac) -> 
-       (b,
-	match t with
-	  | 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 st (term,cl)) 
-		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
-	  | Extern tacast -> conclPattern concl p tacast))
-    tacl
-
-and trivial_resolve db_list local_db cl = 
-  try 
-    let hdconstr = fst (head_constr_bound cl) in
-    priority 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
-  with Bound | Not_found -> 
-    []
-
-(**************************************************************************)
-(*                       The classical Auto tactic                        *)
-(**************************************************************************)
-
-let possible_resolve db_list local_db cl =
-  try 
-    let hdconstr = fst (head_constr_bound cl) in
-    List.map snd 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
-  with Bound | Not_found -> 
-    []
-
-let decomp_unary_term c gls = 
-  let typc = pf_type_of gls c in 
-  let t = head_constr typc in 
-  if Hipattern.is_conjunction (applist t) then 
-    simplest_case c gls 
-  else 
-    errorlabstrm "Auto.decomp_unary_term" (str "not a unary type")
-
-let decomp_empty_term c gls = 
-  let typc = pf_type_of gls c in 
-  let (hd,_) = decompose_app typc in 
-  if Hipattern.is_empty_type hd then 
-    simplest_case c gls 
-  else 
-    errorlabstrm "Auto.decomp_empty_term" (str "not an empty type")
-
-
-(* decomp is an natural number giving an indication on decomposition 
-   of conjunction in hypotheses, 0 corresponds to no decomposition *)
-(* n is the max depth of search *)
-(* local_db contains the local Hypotheses *)
-
-let rec search_gen decomp n db_list local_db extra_sign goal =
-  if n=0 then error "BOUND 2";
-  let decomp_tacs = match decomp with 
-    | 0 -> [] 
-    | p -> 
-	(tclTRY_sign decomp_empty_term extra_sign)
-	::
-	(List.map 
-	   (fun id -> tclTHEN (decomp_unary_term (mkVar id)) 
-		(tclTHEN 
-		   (clear [id])
-		   (free_try (search_gen decomp p db_list local_db []))))
-	   (pf_ids_of_hyps goal)) 
-  in
-  let intro_tac = 
-    tclTHEN intro 
-      (fun g' -> 
-	 let (hid,_,htyp as d) = pf_last_hyp g' in
-	 let hintl = 
-	   try 
-	     [make_apply_entry (pf_env g') (project g')
-		(true,true,false) 
-		None
-		(mkVar hid,htyp)]
-	   with Failure _ -> [] 
-	 in
-         (free_try
-	  (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d])
-	  g'))
-  in
-  let rec_tacs = 
-    List.map 
-      (fun ntac -> 
-	 tclTHEN ntac
-	   (free_try
-	    (search_gen decomp (n-1) db_list local_db empty_named_context)))
-      (possible_resolve db_list local_db (pf_concl goal))
-  in 
-  tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
-
-
-let search = search_gen 0
-
-let default_search_depth = ref 5
-			     
-let full_auto 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 hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl
-  
-let default_full_auto gl = full_auto !default_search_depth gl
-(************************************************************************)
-
-let blast_tactic = ref (free_try default_full_auto)
-;;
-
-let blast_auto = (free_try default_full_auto)
-(*                  (tclTHEN (free_try default_full_auto)
-			  (free_try (my_full_eauto 2)))
-*)
-;;
-let blast_simpl = (free_try (reduce (Simpl None) onConcl))
-;;
-let blast_induction1 = 
-    (free_try (tclTHEN (tclTRY intro)
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-let blast_induction2 = 
-    (free_try (tclTHEN (tclTRY (tclTHEN intro intro))
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-let blast_induction3 = 
-    (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro)))
-		       (tclTRY (tclLAST_HYP simplest_elim))))
-;;
-
-blast_tactic :=
-  (tclORELSE (tclCOMPLETE blast_auto)
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto))
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1
-                          (tclTHEN blast_simpl blast_auto)))
-  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2
-                          (tclTHEN blast_simpl blast_auto)))
-             (tclCOMPLETE (tclTHEN blast_induction3
-                          (tclTHEN blast_simpl blast_auto)))))))
-;;
-(*
-blast_tactic := (tclTHEN (free_try default_full_auto)
-			 (free_try (my_full_eauto 4)))
-;;
-*)
-
-let vire_extvar s =
-   let interro = ref false in
-   let interro_pos = ref 0 in
-   for i=0 to (length s)-1 do
-     if get s i = '?'
-     then (interro := true;
-           interro_pos := i)
-     else if (!interro && 
-              (List.mem (get s i)
-			['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']))
-     then set s i ' '
-     else interro:=false
-   done;
-   s
-;;
-
-let blast gls =
-   let leaf g = {
-      open_subgoals = 1;
-      goal = g;
-      ref = None } in
-     try (let (sgl,v) as _res = !blast_tactic gls in
-	  let {it=lg} = sgl in
-          if lg = [] 
-          then (let pf = v (List.map leaf (sig_it sgl)) in
-                let sign = (sig_it gls).evar_hyps in
-                let x = print_subscript 
-                     (sig_sig gls) sign pf in
-		msgnl (hov 0 (str"Blast ==> " ++ x));
-                let x = print_subscript 
-                     (sig_sig gls) sign pf in
-                let tac_string =
-                pp_string  (hov 0 x ) in
-    (* on remplace les ?1 ?2 ... de refine par ? *)
-		parse_tac ((vire_extvar tac_string)
-			   ^ ".")
-	  )
-	  else (msgnl (hov 0 (str"Blast failed to prove the goal..."));
-		failwith "echec de blast"))
-     with _ -> failwith "echec de blast"
-;;
-
-let blast_tac display_function = function 
-          | (n::_) as _l -> 
-                 (function g ->
-                    let exp_ast = (blast g) in
-                     (display_function exp_ast;
-                       tclIDTAC g))
-          |  _ -> failwith "expecting other arguments";;
-
-let blast_tac_txt = 
-  blast_tac
-    (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));;
-
-(* Obsolète ?
-overwriting_add_tactic "Blast1" blast_tac_txt;;
-*)
-
-(*
-Grammar tactic ne_numarg_list : list :=
-  ne_numarg_single [numarg($n)] ->[$n]
-| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ].
-Grammar tactic simple_tactic : ast :=
-  blast1 [ "Blast1" ne_numarg_list($ns) ] ->
-         [ (Blast1 ($LIST $ns)) ].
-
-
-
-PATH=/usr/local/bin:/usr/bin:$PATH
-COQTOP=d:/Tools/coq-7.0-3mai
-CAMLLIB=/usr/local/lib/ocaml
-CAMLP4LIB=/usr/local/lib/camlp4
-export CAMLLIB
-export COQTOP
-export CAMLP4LIB 
-d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe 
-Drop.
-#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";;
-*)
diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli
deleted file mode 100644
index f6701943..00000000
--- a/contrib/interface/blast.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    int list -> Proof_type.tactic
-
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
deleted file mode 100644
index 51dce4f7..00000000
--- a/contrib/interface/centaur.ml4
+++ /dev/null
@@ -1,885 +0,0 @@
-(*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;;
-open Vernacinterp;;
-open Evd;;
-open Proof_trees;;
-open Tacmach;;
-open Pfedit;;
-open Proof_type;;
-open Parsing;;
-open Environ;;
-open Declare;;
-open Declarations;;
-open Rawterm;;
-open Reduction;;
-open Classops;;
-open Vernacinterp;;
-open Vernac;;
-open Command;;
-open Protectedtoplevel;;
-open Line_oriented_parser;;
-open Xlate;;
-open Vtp;;
-open Ascent;;
-open Translate;;
-open Name_to_ast;;
-open Pbp;;
-open Blast;;
-(* open Dad;; *)
-open Debug_tac;;
-open Search;;
-open Constrintern;;
-open Nametab;;
-open Showproof;;
-open Showproof_ct;;
-open Tacexpr;;
-open Vernacexpr;;
-open Printer;;
-
-let pcoq_started = ref None;;
-
-let if_pcoq f a =
-  if !pcoq_started <> None then f a else error "Pcoq is not started";;
-
-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 ())
-  with
-      UserError("Pfedit.get_proof", _) -> "";;
-
-let current_goal_index = ref 0;;
-
-let guarded_force_eval_stream (s : std_ppcmds) = 
-  let l = ref [] in
-  let f elt = l:= elt :: !l in 
-  (try  Stream.iter f s with
-  | _ -> f (Stream.next (str "error guarded_force_eval_stream")));
-  Stream.of_list (List.rev !l);;
-
-
-let rec string_of_path p =
-    match p with [] -> "\n"
-              | i::p -> (string_of_int i)^" "^ (string_of_path p)
-;;
-let print_path p =
-    output_results_nl (str "Path:" ++ str  (string_of_path p))
-;;
-
-let kill_proof_node index =
- let paths = History.historical_undo (current_proof_name()) index in
- let _ =  List.iter
-            (fun path -> (traverse_to path;
-                          Pfedit.mutate weak_undo_pftreestate;
-			  traverse_to []))
-          paths in
- 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 =
- str "message" ++ fnl() ++ str message_name ++ fnl() ++
- int request_id ++ fnl();;
-
-let ctf_acknowledge_command request_id command_count opt_exn =
-  let goal_count, goal_index = 
-    if refining() then
-      let g_count =
-        List.length 
-          (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in
-        g_count, !current_goal_index
-    else
-      (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 ());;
-
-let ctf_undoResults = ctf_header "undo_results";;
-
-let ctf_TextMessage = ctf_header "text_proof";;
-
-let ctf_SearchResults = ctf_header "search_results";;
-
-let ctf_OtherGoal = ctf_header "other_goal";;
-
-let ctf_Location = ctf_header "location";;
-
-let ctf_StateMessage = ctf_header "state";;
-
-let ctf_PathGoalMessage () =
- fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();;
-
-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 () ++
-			  str "saved" ++ fnl();;
-
-let ctf_KilledMessage req_id ngoals =
- ctf_header "killed" req_id ++ int ngoals ++ fnl ();;
-
-let ctf_AbortedAllMessage () =
-  fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();;
-
-let ctf_AbortedMessage request_id na =
-  ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ 
-  str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
-
-let ctf_UserErrorMessage request_id stream =
- let stream = guarded_force_eval_stream stream in
- ctf_header "user_error" request_id ++ stream ++ fnl() ++
- str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-
-let ctf_ResetInitialMessage () =
- fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();;
-
-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();;
-
-
-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 -> mt()));;
-
-let output_results_nl stream =
-    let _ = Sys.signal Sys.sigint
-       (Sys.Signal_handle(fun i -> break_happened := true;()))
-    in
-    msgnl stream;;
-
-
-let rearm_break () =
-    let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break))
-    in ();;
-
-let check_break () =
-   if (!break_happened) then
-    begin
-      break_happened := false;
-      raise Sys.Break
-    end
-   else ();;
-
-let print_past_goal index =
- let path = History.get_path_for_rank (current_proof_name()) index in
- try traverse_to path;
-     let pf = proof_of_pftreestate (get_pftreestate ()) in
-     output_results  (ctf_PathGoalMessage ())
-       (Some (P_r (translate_goal pf.goal)))
- with
-   | Invalid_argument s ->
-      ((try traverse_to [] with _ -> ());
-       error "No focused proof (No proof-editing in progress)")
-   | e -> (try traverse_to [] with _ -> ()); raise e
-;;
-
-let show_nth n =
-  try
-    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)";;
-
-(* The rest of the file contains commands that are changed from the plain
-   Coq distribution *)
-
-let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);;
-
-(*
-let filter_by_module_from_varg_list l =
-  let dir_list, b = Vernacentries.interp_search_restriction l in
-    Search.filter_by_module_from_list (dir_list, b);;
-*)
-
-let add_search (global_reference:global_reference) assumptions cstr =
-  try 
-  let id_string =
-    string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty
-			global_reference) in
-  let ast = 
-    try
-      CT_premise (CT_ident id_string, translate_constr false assumptions cstr)
-    with Not_found ->
-      CT_premise (CT_ident id_string,
-                  CT_coerce_ID_to_FORMULA(
-                    CT_ident ("Error printing" ^ id_string))) in
-    ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST
-  with e -> msgnl (str "add_search raised an exception"); raise e;;
-
-(*
-let make_error_stream node_string =
-  str "The syntax of " ++ str node_string ++
-  str " is inconsistent with the vernac interpreter entry";;
-*)
-
-let ctf_EmptyGoalMessage id =
-  fnl () ++ str "Empty Goal is a no-op.  Fun oh fun." ++ fnl ();;
-
-
-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) -> 
-      output_results
-        (ctf_header "pbp_results" !global_request_id)
-       (Some (P_t(xlate_tactic x))));;
-
-let blast_tac_pcoq =
-    blast_tac (function (x:raw_tactic_expr) -> 
-      output_results
-	(ctf_header "pbp_results" !global_request_id)
-       (Some (P_t(xlate_tactic x))));;
-
-(* <\cpa> 
-let dad_tac_pcoq =
-  dad_tac(function x -> 
-    output_results
-    (ctf_header "pbp_results" !global_request_id)
-    (Some (P_t(xlate_tactic x))));;
-</cpa> *)
-
-let search_output_results () =
-  (* LEM: See comments for pcoq_search *)
-  output_results
-       (ctf_SearchResults !global_request_id)
-       (Some (P_pl (CT_premises_list
-                      (List.rev !ctv_SEARCH_LIST))));;
-
-
-let debug_tac2_pcoq tac =
-      (fun g ->
-	let the_goal = ref (None : goal sigma option) in
-	let the_ast = ref tac in
-	let the_path = ref ([] : int list) in
-	try
-	  let _result = report_error tac the_goal the_ast the_path [] g in
-	  (errorlabstrm "DEBUG TACTIC"
-	     (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++
-	      fnl () ++ str "the tactic is" ++ fnl () ++
-	      Pptactic.pr_glob_tactic (Global.env()) tac) (*
-Caution, this is in the middle of what looks like dead code. ;
-	   result *))
-	with
-	  e ->
-	    match !the_goal with
-	      None -> raise e
-	    | Some g -> 
-                (output_results
-		   (ctf_Location !global_request_id)
-		   (Some (P_s_int
-			    (CT_signed_int_list
-                               (List.map
-                                  (fun n -> CT_coerce_INT_to_SIGNED_INT
-                                                 (CT_int n))
-                                  (clean_path tac 
-					       (List.rev !the_path)))))));
-	    	(output_results
-		   (ctf_OtherGoal !global_request_id)
-		   (Some (P_r (translate_goal (sig_it g)))));
-	    raise e);;
-
-let rec selectinspect n env =
-    match env with
-      [] -> []
-    | a::tl ->
-      if n = 0 then
-         []
-      else
-         match a with
-           (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl)
-         | _ -> (selectinspect n tl);;
-
-open Term;;
-
-let inspect n =
-  let env = Global.env() in
-  let add_search2 x y = add_search x env y in
-  let l = selectinspect n (Lib.contents_after None) in
-    ctv_SEARCH_LIST := [];
-    List.iter
-      (fun a ->
-	 try
-           (match a with
-             	oname, Lib.Leaf lobj ->
-		  (match oname, object_tag lobj with
-                       (sp,_), "VARIABLE" ->
-			 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
-			   add_search2 (Nametab.locate (qualid_of_sp sp)) typ
-		     | (sp,kn), "MUTUALINDUCTIVE" ->
-			 add_search2 (Nametab.locate (qualid_of_sp sp))
-			   (Pretyping.Default.understand Evd.empty (Global.env())
-			      (RRef(dummy_loc, IndRef(kn,0))))
-		     | _ -> failwith ("unexpected value 1 for "^ 
-				      (string_of_id (basename (fst oname)))))
-              | _ -> failwith "unexpected value")
-	 with e -> ())
-      l;
-    output_results
-      (ctf_SearchResults !global_request_id)
-      (Some
-         (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
-
-let ct_int_to_TARG n = 
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)));;
-
-let pair_list_to_ct l =
-    CT_user_tac(CT_ident "pair_int_list",
-		CT_targ_list
-		  (List.map (fun (a,b) ->
-			       CT_coerce_TACTIC_COM_to_TARG
-				 (CT_user_tac
-				    (CT_ident "pair_int",
-				     CT_targ_list
-				       [ct_int_to_TARG a; ct_int_to_TARG b])))
-		     l));;
-
-(* Annule toutes les commandes qui s'appliquent sur les sous-buts du
-   but auquel a été appliquée la n-ième tactique *)
-let logical_kill n =
-  let path = History.get_path_for_rank (current_proof_name()) n in
-  begin
-    traverse_to path;
-    Pfedit.mutate weak_undo_pftreestate;
-    (let kept_cmds, undone_cmds, remaining_goals, current_goal =
-      History.logical_undo (current_proof_name()) n in
-       output_results (ctf_undoResults !global_request_id)
-	 (Some
-	    (P_t
-	       (CT_user_tac
-		  (CT_ident "log_undo_result",
-		   CT_targ_list
-		     [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds);
-		      CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds);
-		      ct_int_to_TARG remaining_goals;
-		      ct_int_to_TARG current_goal])))));
-    traverse_to []
-  end;;
-
-let simulate_solve n tac =
-  let path = History.get_nth_open_path (current_proof_name()) n in
-  solve_nth n (Tacinterp.hide_interp tac (get_end_tac()));
-  traverse_to path;
-  Pfedit.mutate weak_undo_pftreestate;
-  traverse_to []
-
-let kill_node_verbose n =
-  let ngoals = kill_proof_node n in
-  output_results_nl (ctf_KilledMessage !global_request_id ngoals)
-
-let set_text_mode s = text_proof_flag := s
-
-let pcoq_reset_initial() =
-  output_results(ctf_AbortedAllMessage()) None;
-  Vernacentries.abort_refine Lib.reset_initial ();
-  output_results(ctf_ResetInitialMessage()) None;;
-
-let pcoq_reset x =
-  if refining() then
-    output_results (ctf_AbortedAllMessage ()) None;
-    Vernacentries.abort_refine Lib.reset_name (dummy_loc,x);
-    output_results
-      (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;;
-
-
-VERNAC ARGUMENT EXTEND text_mode
-| [ "fr" ] -> [ "fr" ]
-| [ "en" ] -> [ "en" ]
-| [ "Off" ] -> [ "off" ]
-END
-
-VERNAC COMMAND EXTEND TextMode
-| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ]
-END
-
-VERNAC COMMAND EXTEND OutputGoal
-  [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ]
-END
-
-VERNAC COMMAND EXTEND OutputGoal
-  [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ]
-END
-
-VERNAC COMMAND EXTEND KillProofAfter
-| [ "Kill" "Proof" "after"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
-END
-
-VERNAC COMMAND EXTEND KillProofAt
-| [ "Kill" "Proof" "at"  natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
-END
-
-VERNAC COMMAND EXTEND KillSubProof
-  [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ]
-END
-
-VERNAC COMMAND EXTEND PcoqReset
-  [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ]
-END
-
-VERNAC COMMAND EXTEND PcoqResetInitial
-  [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ]
-END
-
-let start_proof_hook () =
-  if !pcoq_history then History.start_proof (current_proof_name());
-  current_goal_index := 1
-
-let solve_hook n =
-  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)
-
-let interp_search_about_item = function
-  | SearchSubPattern pat ->
-      let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in
-      GlobSearchSubPattern pat
-  | SearchString (s,_) ->
-      warning "Notation case not taken into account";
-      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 -> 
-      raw_search_about (filter_by_module_from_list l) add_search
-	(List.map (on_snd interp_search_about_item) sl)
-  | SearchPattern c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
-      raw_pattern_search (filter_by_module_from_list l) add_search pat
-  | SearchRewrite c ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in
-      raw_search_rewrite (filter_by_module_from_list l) add_search pat;
-  | SearchHead locqid ->
-      filtered_search
-	(filter_by_module_from_list l) add_search (Nametab.global locqid)
-  end;
-  search_output_results()
-
-(* Check sequentially whether the pattern is one of the premises *)
-let rec hyp_pattern_filter pat name a c =
-  let _c1 = strip_outer_cast c in
-    match kind_of_term c with
-      | Prod(_, hyp, c2) -> 
-	  (try
-(*	     let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in
-             let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *)
-             if Matching.is_matching pat hyp then
-	       (msgnl (str "ok"); true)
-	     else
-	       false
-           with UserError _ -> false) or
-	  hyp_pattern_filter pat name a c2
-      | _ -> false;;
-
-let hyp_search_pattern c l =
-  let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in
-    ctv_SEARCH_LIST := [];
-    gen_filtered_search
-      (fun s a c -> (filter_by_module_from_list l s a c &&
-		     (if hyp_pattern_filter pat s a c then
-		   	(msgnl (str "ok2"); true) else false)))
-      (fun s a c -> (msgnl (str "ok3"); add_search s a c));
-    output_results
-      (ctf_SearchResults !global_request_id)
-      (Some
-	 (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
-let pcoq_print_name ref =
-  output_results 
-    (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref )
-    None
-
-let pcoq_print_check env j =
-  let a,b = print_check env j in output_results a b
-
-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 -> show_subgoals ()
-;;
-
-let pcoq_hook = {
-  start_proof = start_proof_hook;
-  solve = solve_hook;
-  abort = abort_hook;
-  search = pcoq_search;
-  print_name = pcoq_print_name;
-  print_check = pcoq_print_check;
-  print_eval = pcoq_print_eval;
-  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_constr_pattern_expr  = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr  c));
-  pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n"  ++ (default_term_pr.pr_lconstr_pattern_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) ] -> 
-    [ if_pcoq pbp_tac_pcoq idopt nl ]
-END
-
-TACTIC EXTEND ct_debugtac
-| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
-END
-
-TACTIC EXTEND ct_debugtac2
-| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
-END
-
-
-let start_pcoq_mode debug = 
-  begin
-    pcoq_started := Some debug;
-(* <\cpa> 
-    start_dad();
-</cpa> *)
-(* The following ones are added to enable rich comments in pcoq *)
-(* TODO ...
-    add_tactic "Image" (fun _ -> tclIDTAC);
-*)
-(* "Comments" moved to Vernacentries, other obsolete ?
-    List.iter (fun (a,b) -> vinterp_add a b) command_creations;
-*)
-(* Now hooks in Vernacentries
-    List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes;
-    if not debug then
-      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;;
-
-
-let start_pcoq () =
-  start_pcoq_mode false;
-  set_acknowledge_command ctf_acknowledge_command;
-  set_start_marker "CENTAUR_RESERVED_TOKEN_start_command";
-  set_end_marker "CENTAUR_RESERVED_TOKEN_end_command";
-  raise Vernacexpr.ProtectedLoop;;
-
-let start_pcoq_debug () =
-  start_pcoq_mode true;
-  set_acknowledge_command ctf_acknowledge_command;
-  set_start_marker "--->";
-  set_end_marker "<---";
-  raise Vernacexpr.ProtectedLoop;;
-
-VERNAC COMMAND EXTEND HypSearchPattern
-  [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ]
-END
-
-VERNAC COMMAND EXTEND StartPcoq
-  [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ]
-END
-
-VERNAC COMMAND EXTEND Pcoq_inspect
-  [ "Pcoq_inspect" ] -> [ inspect 15 ]
-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/dad.ml b/contrib/interface/dad.ml
deleted file mode 100644
index c2ab2dc8..00000000
--- a/contrib/interface/dad.ml
+++ /dev/null
@@ -1,382 +0,0 @@
-(* This file contains an ml version of drag-and-drop. *)
-
-(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *)
-
-open Names;;
-open Term;;
-open Rawterm;;
-open Util;;
-open Environ;;
-open Tactics;;
-open Tacticals;;
-open Pattern;;
-open Matching;;
-open Reduction;;
-open Constrextern;;
-open Constrintern;;
-open Vernacinterp;;
-open Libnames;;
-open Nametab
-
-open Proof_type;;
-open Proof_trees;;
-open Tacmach;;
-open Typing;;
-open Pp;;
-
-open Paths;;
-
-open Topconstr;;
-open Genarg;;
-open Tacexpr;;
-open Rawterm;;
-
-(* In a first approximation, drag-and-drop rules are like in CtCoq
-   1/ a pattern,
-   2,3/ Two paths: start and end positions,
-   4/ the degree: the number of steps the algorithm should go up from the
-      longest common prefix,
-   5/ the tail path: the suffix of the longest common prefix of length the
-      degree,
-   6/ the command pattern, where meta variables are represented by objects
-      of the form Node(_,"META"; [Num(_,i)])
-*)
-
-
-type dad_rule =
-    constr_expr * int list * int list * int * int list
-    * raw_atomic_tactic_expr;;
-
-(* This value will be used systematically when constructing objects *)
-
-let zz = Util.dummy_loc;;
-
-(* This function receives a length n, a path p, and a term and returns a
-   couple whose first component is the subterm designated by the prefix
-   of p of length n, and the second component is the rest of the path *)
-
-let rec get_subterm  (depth:int) (path: int list) (constr:constr) =
-  match depth, path, kind_of_term constr with
-    0, l, c -> (constr,l)
-  | n, 2::a::tl, App(func,arr) -> 
-      get_subterm (n - 2) tl arr.(a-1)
-  | _,l,_ -> failwith (int_list_to_string 
-                        "wrong path or wrong form of term"
-                        l);;
-
-(* This function maps a substitution on an abstract syntax tree.  The
-   first argument, an object of type env, is necessary to
-   transform constr terms into abstract syntax trees.  The second argument is
-   the substitution, a list of pairs linking an integer and a constr term. *)
-
-let rec map_subst (env :env) (subst:patvar_map) = function
-  | CPatVar (_,(_,i)) ->
-      let constr = List.assoc i subst in
-      extern_constr false env constr
-  | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;;
-
-let map_subst_tactic env subst = function
-  | TacExtend (loc,("Rewrite" as x),[b;cbl]) ->
-      let c,bl = out_gen rawwit_constr_with_bindings cbl in
-      assert (bl = NoBindings);
-      let c = (map_subst env subst c,NoBindings) in
-      TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c])
-  | _ -> failwith "map_subst_tactic: unsupported tactic"
-
-(* This function is really the one that is important. *)
-let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 =
-  match l with
-    [] -> failwith "nothing happens"
-  | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl ->
-     let length = List.length p in
-     try
-       if deg > length then
-         failwith "internal"
-       else
-         let term_to_match, p_r = 
-             try 
-                get_subterm (length - deg) p constr
-             with
-                Failure s -> failwith "internal" in
-         let _, constr_pat = 
-            intern_constr_pattern Evd.empty (Global.env())
-               ((*ct_to_ast*) pat) in
-         let subst = matches constr_pat term_to_match in
-         if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then
-           TacAtom (zz, map_subst_tactic env subst cmd)
-         else
-	   failwith "internal"
-     with
-       Failure "internal" -> find_cmd tl env constr p p1 p2
-     | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;;
-
-
-let dad_rule_list = ref ([]: (string * dad_rule) list);;
-
-(*
-(* \\ This function is also used in pbp. *)
-let rec tactic_args_to_ints = function
-    [] -> []
-  | (Integer n)::l -> n::(tactic_args_to_ints l)
-  | _ -> failwith "expecting only numbers";;
-
-(* We assume that the two lists of integers for the tactic are simply
-   given in one list, separated by a dummy tactic. *)
-let rec part_tac_args l = function
-    [] -> l,[]
-  | (Tacexp a)::tl -> l, (tactic_args_to_ints tl)
-  | (Integer n)::tl -> part_tac_args (n::l) tl
-  | _ -> failwith "expecting only numbers and the word \"to\"";;
-
-
-(* The dad_tac tactic takes a display_function as argument.  This makes
-   it possible to use it in pcoq, but also in other contexts, just by
-   changing the output routine. *)
-let dad_tac display_function = function
-   l -> let p1, p2 = part_tac_args [] l in
-        (function g ->
-           let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in
-           (display_function 
-            (find_cmd (!dad_rule_list) (pf_env g)
-	       (pf_concl g) p_a p1prime p2prime));
-            tclIDTAC g);;
-*)
-let dad_tac display_function p1 p2 g =
-  let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in
-  (display_function 
-    (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime));
-  tclIDTAC g;;
-
-(* Now we enter dad rule list management. *)
-
-let add_dad_rule name patt p1 p2 depth pr command =
-  dad_rule_list := (name, 
-		    (patt, p1, p2, depth, pr, command))::!dad_rule_list;;
-
-let rec remove_if_exists name = function
-    [] -> false, []
-  | ((a,b) as rule1)::tl -> if a = name then 
-               let result1, l = (remove_if_exists name tl) in
-               true, l
-             else
-               let result1, l = remove_if_exists name tl in
-               result1, (rule1::l);;
-
-let remove_dad_rule name =
-  let result1, result2 = remove_if_exists name !dad_rule_list in
-  if result1 then
-    failwith("No such name among the drag and drop rules " ^ name)
-  else
-     dad_rule_list := result2;;
-
-let dad_rule_names () =
-    List.map (function (s,_) -> s) !dad_rule_list;;
-
-(* this function is inspired from matches_core in pattern.ml *)
-let constrain ((n : patvar),(pat : constr_pattern)) sigma =
-  if List.mem_assoc n sigma then
-    if pat = (List.assoc n sigma) then sigma
-    else failwith "internal"
-  else 
-    (n,pat)::sigma
-    
-(* This function is inspired from matches_core in pattern.ml *)
-let more_general_pat pat1 pat2 = 
-  let rec match_rec sigma p1 p2 =
-    match p1, p2 with
-      | PMeta (Some n), m -> constrain (n,m) sigma
-
-      | PMeta None, m -> sigma
-
-      | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma
-
-      | PVar v1, PVar v2 when v1 = v2 -> sigma
-
-      | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma
-
-      | PRel n1, PRel n2 when n1 = n2 -> sigma
-
-      | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma
-
-      | PSort (RType _), PSort (RType _) -> sigma
-
-      | PApp (c1,arg1), PApp (c2,arg2) ->
-        (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2
-         with Invalid_argument _ -> failwith "internal")
-      | _ -> failwith "unexpected case in more_general_pat" in 
-  try let _ = match_rec [] pat1 pat2 in true
-  with Failure "internal" -> false;;
-
-let more_general r1 r2 =
-  match r1,r2 with
-    (_,(patt1,p11,p12,_,_,_)),
-    (_,(patt2,p21,p22,_,_,_)) ->
-	(more_general_pat patt1 patt2) &
-      (is_prefix p11 p21) & (is_prefix p12 p22);;
-
-let not_less_general r1 r2 = 
-  not (match r1,r2 with
-    (_,(patt1,p11,p12,_,_,_)),
-    (_,(patt2,p21,p22,_,_,_)) ->
-	(more_general_pat patt1 patt2) &
-      (is_prefix p21 p11) & (is_prefix p22 p12));;
-
-let rec add_in_list_sorting rule1 = function
-    [] -> [rule1]
-  | (b::tl) as this_list ->
-      if more_general rule1 b  then
-	b::(add_in_list_sorting rule1 tl)
-      else if not_less_general rule1 b then
-	let tl2 = add_in_list_sorting_aux rule1 tl in
-	(match tl2 with
-	  [] -> rule1::this_list
-	| _ -> b::tl2)
-      else
-	rule1::this_list
-and add_in_list_sorting_aux rule1 = function
-    [] -> []
-  | b::tl -> 
-      if more_general rule1 b then
-      	b::(add_in_list_sorting rule1 tl)
-      else
-	let tl2 = add_in_list_sorting_aux rule1 tl in
-	(match tl2 with
-	  [] -> []
-	| _ -> rule1::tl2);;
-
-let rec sort_list = function
-    [] -> [] 
-  | a::l -> add_in_list_sorting a (sort_list l);;
-
-let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));;
-let mk_rewrite lr ast =
-  let b = in_gen rawwit_bool lr in
-  let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in
-  TacExtend (zz,"Rewrite",[b;cb])
-
-open Vernacexpr
-
-let dad_status = ref false;;
-
-let start_dad () = dad_status := true;;
-
-let add_dad_rule_fn name pat p1 p2 tac =
-  let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in
-  add_dad_rule name pat p1 p2 (List.length pr) pr tac;;
-
-(* To be parsed by camlp4
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-VERNAC COMMAND EXTEND AddDadRule
-  [ "Add" "Dad" "Rule" string(name) constr(pat)
-    "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] ->
-  [ add_dad_rule_fn name pat p1 p2 tac ]
-END
-
-*)
-
-let mk_id s = mkIdentC (id_of_string s);;
-let mkMetaC = mk_dad_meta;;
-
-add_dad_rule "distributivity-inv"
-(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "distributivity1-r"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 2; 2; 2]
-[]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "distributivity1-l"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 1; 2; 2]
-[]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "associativity"
-(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
-[2; 1]
-[]
-0
-[]
-(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "minus-identity-lr"
-(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
-[2; 1]
-[2; 2]
-1
-[2]
-(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "minus-identity-rl"
-(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-sym-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
-[2; 2]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-sym-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
-[2; 1]
-[2; 2]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "absorb-0-r-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
-[2; 2]
-[1]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "absorb-0-r-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
-[1]
-[2; 2]
-0
-[]
-(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-permute-lr"
-(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 1]
-[2; 2; 2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
-
-add_dad_rule "plus-permute-rl"
-(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
-[2; 2; 2; 1]
-[2; 1]
-1
-[2]
-(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));;
-
-vinterp_add "StartDad"
-   (function
-     | [] ->
-       (function () -> start_dad())
-     | _ -> errorlabstrm "StartDad" (mt()));;
diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli
deleted file mode 100644
index f556c192..00000000
--- a/contrib/interface/dad.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-open Proof_type;;
-open Tacmach;;
-open Topconstr;;
-
-val dad_rule_names : unit -> string list;;
-val start_dad : unit -> unit;;
-val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma ->
-                  goal list sigma * validation;;
-val add_dad_rule : string -> constr_expr -> (int list) -> (int list) ->
-                   int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;;
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
deleted file mode 100644
index aad3a765..00000000
--- a/contrib/interface/debug_tac.ml4
+++ /dev/null
@@ -1,458 +0,0 @@
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Tacmach;;
-open Tacticals;;
-open Proof_trees;;
-open Pp;;
-open Pptactic;;
-open Util;;
-open Proof_type;;
-open Tacexpr;;
-open Genarg;;
-
-let pr_glob_tactic = Pptactic.pr_glob_tactic (Global.env())
-
-(* Compacting and uncompacting proof commands *)
-
-type report_tree =
-    Report_node of bool *int * report_tree list
-  | Mismatch of int * int
-  | Tree_fail of report_tree
-  | Failed of int;;
-
-type report_card =
-    Ngoals of int
-  | Goals_mismatch of int
-  | Recursive_fail of report_tree
-  | Fail;;
-
-type card_holder = report_card ref;;
-type report_holder = report_tree list ref;;
-
-(* This tactical receives an integer and a tactic and checks that the
-   tactic produces that number of goals.  It never fails but signals failure
-   by updating the boolean reference given as third argument to false.
-   It is especially suited for use in checked_thens below. *)
-
-let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic =
-  fun card_holder count flag t g ->
-    try
-      let (gls, v) as result = t g in
-      let len = List.length (sig_it gls) in
-      card_holder :=
-      (if len = count then
-	  (flag := true;
-	  Ngoals count)
-       else
-          (flag := false;
-          Goals_mismatch len));
-      result
-    with
-      e -> card_holder := Fail;
-           flag := false;
-           tclIDTAC g;;
-
-let no_failure = function
-    [Report_node(true,_,_)] -> true
-  | _ -> false;;
-
-let check_subgoals_count2 
-    : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic =
-  fun card_holder count flag t g ->
-    let new_report_holder = ref ([] : report_tree list) in
-    let (gls, v) as result = t new_report_holder g in
-    let succeeded = no_failure !new_report_holder in
-    let len = List.length (sig_it gls) in
-    card_holder :=
-      (if (len = count) & succeeded then
-	(flag := true;
-	 Ngoals count)
-      else
-	(flag := false;
-	 Recursive_fail (List.hd !new_report_holder)));
-    result;;
-
-let traceable = function
-  | TacThen _ | TacThens _ -> true
-  | _ -> false;;
-
-let rec collect_status = function
-    Report_node(true,_,_)::tl -> collect_status tl
-  | [] -> true
-  | _ -> false;;
-
-(* This tactical receives a tactic and executes it, reporting information
-   about success in the report holder and a boolean reference. *)
-
-let count_subgoals : card_holder -> bool ref -> tactic -> tactic =
-  fun card_holder flag t g ->
-    try
-      let (gls, _) as result = t g in
-      card_holder := (Ngoals(List.length (sig_it gls)));
-      flag := true;
-      result
-    with
-      e -> card_holder := Fail;
-           flag := false;
-           tclIDTAC g;;
-   
-let count_subgoals2
-    : card_holder -> bool ref -> (report_holder -> tactic) -> tactic =
-  fun card_holder flag t g ->
-    let new_report_holder = ref([] : report_tree list) in
-    let (gls, v) as result = t new_report_holder g in
-    let succeeded = no_failure !new_report_holder in
-    if succeeded then
-      (flag := true;
-       card_holder := Ngoals (List.length (sig_it gls)))
-    else
-      (flag := false;
-       card_holder := Recursive_fail(List.hd !new_report_holder));
-    result;;
-
-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,[||]) ->
-      (fun report_holder -> checked_then report_holder a b)
-  | t ->
-      (fun report_holder g ->
-	try
-	  let (gls, _) as result = Tacinterp.eval_tactic t g in
-	  report_holder := (Report_node(true, List.length (sig_it gls), []))
-			    ::!report_holder;
-	  result
-	with e -> (report_holder := (Failed 1)::!report_holder;
-		   tclIDTAC g))
-
-
-(* This tactical receives a tactic and a list of tactics as argument.
-   It applies the first tactic and then maps the list of tactics to
-   various produced sub-goals.  This tactic will never fail, but reports
-   are added in the report_holder in the following way:
-   - In case of partial success, a new report_tree is added to the report_holder
-   - In case of failure of the first tactic, with no more indications
-     then Failed 0 is added to the report_holder,
-   - In case of partial failure of the first tactic then (Failed n) is added to
-     the report holder.
-   - In case of success of the first tactic, but count mismatch, then
-     Mismatch n is added to the report holder. *)
-
-and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = 
-  (fun report_holder t1 l g ->
-    let flag = ref true in
-    let traceable_t1 = traceable t1 in
-    let card_holder = ref Fail in
-    let new_holder = ref ([]:report_tree list) in
-    let tac_t1 = 
-      if traceable_t1 then
-	(check_subgoals_count2 card_holder (List.length l)
-           flag (local_interp t1))
-      else
-	(check_subgoals_count card_holder (List.length l)
-           flag (Tacinterp.eval_tactic t1)) in
-    let (gls, _) as result = 
-      tclTHEN_i tac_t1
-	(fun i ->
-	  if !flag then
-	    (fun g -> 
-              let tac_i = (List.nth l i) in
-	      if traceable tac_i then
-                 local_interp tac_i new_holder g
-              else
-		 try
-		   let (gls,_) as result = Tacinterp.eval_tactic tac_i g in
-		   let len = List.length (sig_it gls) in
-				   new_holder :=
-		     (Report_node(true, len, []))::!new_holder;
-		   result
-		 with
-			       e -> (new_holder := (Failed 1)::!new_holder;
-			 tclIDTAC g))
-	  else
-	    tclIDTAC) g in
-      let new_goal_list = sig_it gls in
-      (if !flag then
-	report_holder := 
-	  (Report_node(collect_status !new_holder,
-		    (List.length new_goal_list),
-		    List.rev !new_holder))::!report_holder
-      else
-	report_holder :=
-	  (match !card_holder with
-	    Goals_mismatch(n) -> Mismatch(n, List.length l)
-	  | Recursive_fail tr -> Tree_fail tr
-	  | Fail -> Failed 1
-	  | _ -> errorlabstrm "check_thens"
-                  (str "this case should not happen in check_thens"))::
-	  !report_holder);
-      result)
-
-(* This tactical receives two tactics as argument, it executes the
-   first tactic and applies the second one to all the produced goals,
-   reporting information about the success of all tactics in the report
-   holder. It never fails. *)
-
-and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic =
-  (fun report_holder t1 t2 g ->
-    let flag = ref true in
-    let card_holder = ref Fail in
-    let tac_t1 =
-      if traceable t1 then
-	(count_subgoals2 card_holder flag (local_interp t1))
-      else
-	(count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in
-    let new_tree_holder = ref ([] : report_tree list) in
-    let (gls, _) as result =
-      tclTHEN tac_t1
-	(fun (g:goal sigma) -> 
-	  if !flag then
-	    if traceable t2 then
-	      local_interp t2 new_tree_holder g
-	    else
-	      try
-		let (gls, _) as result = Tacinterp.eval_tactic t2 g in
-	      	new_tree_holder :=
-		  (Report_node(true, List.length (sig_it gls),[]))::
-		  !new_tree_holder;
-		result
-	      with
-		e ->
-		  (new_tree_holder := ((Failed 1)::!new_tree_holder);
-		   tclIDTAC g)
-	  else
-	    tclIDTAC g) g in
-    (if !flag then
-      report_holder :=
-	(Report_node(collect_status !new_tree_holder,
-		     List.length (sig_it gls),
-		     List.rev !new_tree_holder))::!report_holder
-    else
-      report_holder :=
-	(match !card_holder with
-	  Recursive_fail tr -> Tree_fail tr
-	| Fail -> Failed 1
-	| _ -> error "this case should not happen in check_then")::!report_holder);
-    result);;
-
-(* This tactic applies the given tactic only to those subgoals designated
-   by the list of integers given as extra arguments.
- *)
-
-let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
-let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level
-let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level
-
-
-let on_then = function [t1;t2;l] ->
-  let t1 = out_gen wit_main_tactic t1 in
-  let t2 = out_gen wit_main_tactic t2 in
-  let l = out_gen (wit_list0 wit_int) l in
-  tclTHEN_i (Tacinterp.eval_tactic t1)
-    (fun i ->
-      if List.mem (i + 1) l then
-      	(Tacinterp.eval_tactic t2)
-      else
-	tclIDTAC)
-  | _ -> anomaly "bad arguments for on_then";;
-
-let mkOnThen t1 t2 selected_indices =
-  let a = in_gen rawwit_main_tactic t1 in
-  let b = in_gen rawwit_main_tactic t2 in
-  let l = in_gen (wit_list0 rawwit_int) selected_indices in
-  TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));;
-
-(* Analyzing error reports *)
-
-let rec select_success n = function
-    [] -> []
-  | Report_node(true,_,_)::tl -> n::select_success (n+1) tl
-  | _::tl -> select_success (n+1) tl;;
-
-let rec reconstruct_success_tac (tac:glob_tactic_expr) =
-  match tac with
-    TacThens (a,l) ->
-      (function 
-	  Report_node(true, n, l) -> tac
-      	| Report_node(false, n, rl) ->
-	    TacThens (a,List.map2 reconstruct_success_tac l rl)
-      	| Failed n -> TacId []
-      	| Tree_fail r -> reconstruct_success_tac a r
-      	| Mismatch (n,p) -> a)
-  | TacThen (a,[||],b,[||]) ->
-      (function
-	  Report_node(true, n, l) -> tac
-	| Report_node(false, n, rl) ->
-	    let selected_indices = select_success 1 rl in
-	    TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen",
-	      [in_gen globwit_main_tactic a;
-	       in_gen globwit_main_tactic b;
-	       in_gen (wit_list0 globwit_int) selected_indices]))
-	| Failed n -> TacId []
-	| Tree_fail r -> reconstruct_success_tac a r
-	| _ -> error "this error case should not happen in a THEN tactic")
-  | _ -> 
-      (function
-	  Report_node(true, n, l) -> tac
-	| Failed n -> TacId []
-	| _ ->
-	    errorlabstrm
-	      "this error case should not happen on an unknown tactic"
-              (str "error in reconstruction with " ++ fnl () ++
-	       (pr_glob_tactic tac)));;
-	  
-
-let rec path_to_first_error = function
-| Report_node(true, _, l) ->
-  let rec find_first_error n = function
-  | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl
-  | it::tl -> n, it
-  | [] -> error "no error detected" in
-  let p, t = find_first_error 1 l in
-    p::(path_to_first_error t)
-| _ -> [];;
-
-let debug_tac = function
-    [(Tacexp ast)] ->
-      (fun g -> 
-      	let report = ref ([] : report_tree list) in
-      	let result = local_interp ast report g in
-      	let clean_ast = (* expand_tactic *) ast in
-      	let report_tree =
-          try List.hd !report with
-	    Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in
-      	let success_tac = 
-	  reconstruct_success_tac clean_ast report_tree in
-        let compact_success_tac = (* flatten_then *) success_tac in
-      	msgnl (fnl () ++
-	       str "=========    Successful tactic    =============" ++
-               fnl () ++
-	       pr_glob_tactic compact_success_tac ++ fnl () ++
-	       str "========= End of successful tactic ============");
-      	result)
-  | _ -> error "wrong arguments for debug_tac";;
-
-(* TODO ... used ?
-add_tactic "DebugTac" debug_tac;;
-*)
-
-Tacinterp.add_tactic "OnThen" on_then;;
-
-let rec clean_path tac l = 
-  match tac, l with
-  | 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)
-  | TacThens (a,tacs), 2::fst::tl ->
-      2::fst::(clean_path (List.nth tacs (fst - 1)) tl)
-  | _, [] -> []
-  | _, _ -> failwith "this case should not happen in clean_path";;
-
-let rec report_error
-    : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> 
-      int list -> tactic =
-  fun tac the_goal the_ast returned_path path -> 
-    match tac with
-      TacThens (a,l) ->
-      let the_card_holder = ref Fail in
-      let the_flag = ref false in
-      let the_exn = ref (Failure "") in
-      tclTHENS
-	(fun g ->
-	  let result =
-	    check_subgoals_count 
-	      the_card_holder
-	      (List.length l) 
-	      the_flag
-	      (fun g2 -> 
-		try 
-		  (report_error a the_goal the_ast returned_path (1::path) g2)
-	  	with
-		  e -> (the_exn := e; raise e))
-	      g in
-	  if !the_flag then
-	    result
-	  else
-	    (match !the_card_holder with
-			Fail -> 
-			  the_ast := TacThens (!the_ast, l);
-			  raise !the_exn
-	    | Goals_mismatch p -> 
-		the_ast := tac;
-		returned_path := path;
-		error ("Wrong number of tactics: expected " ^
-		       (string_of_int (List.length l)) ^ " received " ^
-		       (string_of_int p))
-	    | _ -> error "this should not happen"))
-        (let rec fold_num n = function
-	    [] -> []
-	  | 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,[||]) ->
-	let the_count = ref 1 in
-	tclTHEN
-	  (fun g ->
-	    try
-	      report_error a the_goal the_ast returned_path (1::path) g
-	    with
-	      e ->
-		(the_ast := TacThen (!the_ast,[||], b,[||]);
-		 raise e))
-	  (fun g ->
-	    try
-	      let result = 
-		report_error b the_goal the_ast returned_path (2::path) g in
-	      the_count := !the_count + 1;
-	      result
-	    with
-	      e ->
-		if !the_count > 1 then
-		  msgnl
-		    (str "in branch no " ++ int !the_count ++
-		     str " after tactic " ++ pr_glob_tactic a);
-		raise e)
-    | tac ->
-	(fun g ->
-	  try
-	   Tacinterp.eval_tactic tac g
-	  with
-	    e ->
-	      (the_ast := tac;
-	       the_goal := Some g;
-	       returned_path := path;
-	       raise e));;
-
-let strip_some = function
-    Some n -> n
-  | None -> failwith "No optional value";;
-
-let descr_first_error tac =
-      (fun g ->
-	let the_goal = ref (None : goal sigma option) in
-	let the_ast = ref tac in
-	let the_path = ref ([] : int list) in
-	try
-	  let result = report_error tac the_goal the_ast the_path [] g in
-	  msgnl (str "no Error here");
-	  result
-	with
-	  e ->
-	    (msgnl (str "Execution of this tactic raised message " ++ fnl () ++
-		    fnl () ++ Cerrors.explain_exn e ++ fnl () ++
-		    fnl () ++ str "on goal"  ++ fnl () ++
-		    Printer.pr_goal (sig_it (strip_some !the_goal)) ++
-                    fnl () ++ str "faulty tactic is" ++ fnl () ++ fnl () ++
-		    pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ());
-	     tclIDTAC g))
-
-(* TODO ... used ??
-add_tactic "DebugTac2" descr_first_error;;
-*)
-
-(*
-TACTIC EXTEND DebugTac2
-  [ ??? ] -> [ descr_first_error tac ]
-END
-*)
diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli
deleted file mode 100644
index da4bbaa0..00000000
--- a/contrib/interface/debug_tac.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-
-val report_error : Tacexpr.glob_tactic_expr ->
-    Proof_type.goal Evd.sigma option ref ->
-    Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;;
-
-val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;;
diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml
deleted file mode 100644
index e0f43193..00000000
--- a/contrib/interface/depends.ml
+++ /dev/null
@@ -1,454 +0,0 @@
-(************************************************************************)
-(*  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"
-    | 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"
-    | Order _ -> "Order"
-  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"
-    | TacMatchGoal (_, _, 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], None) -> depends_of_'constr_with_bindings cb acc
-    | TacApply (_, _, _, _) -> failwith "TODO"
-    | 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 *)
-    | TacSimpleInductionDestruct _
-    | TacDoubleInduction _ -> acc
-    | TacInductionDestruct (_, _, [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)
-    | TacInductionDestruct (_, _, _) -> failwith "TODO"
-    | 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
-  | Cut (_, _, _, t)             -> depends_of_constr t acc (* TODO: check what 3nd 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
-  | Order _                      -> 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/history.ml b/contrib/interface/history.ml
deleted file mode 100644
index f73c2084..00000000
--- a/contrib/interface/history.ml
+++ /dev/null
@@ -1,373 +0,0 @@
-open Paths;;
-
-type tree = {mutable index : int;
-             parent : tree option;
-             path_to_root : int list;
-             mutable is_open : bool;
-             mutable sub_proofs : tree list};;
-
-type prf_info = {
-    mutable prf_length : int;
-    mutable ranks_and_goals : (int * int * tree) list;
-    mutable border : tree list;
-    prf_struct : tree};;
-
-let theorem_proofs = ((Hashtbl.create 17): 
-			(string, prf_info) Hashtbl.t);;
-
-
-let rec mk_trees_for_goals path tree rank k n =
-  if k = (n + 1) then
-    []
-  else
-    { index = rank;
-      parent = tree;
-      path_to_root = k::path;
-      is_open = true;
-      sub_proofs = [] } ::(mk_trees_for_goals  path tree rank (k+1) n);;
-
-
-let push_command s rank ngoals =
-  let ({prf_length = this_length;
- 	ranks_and_goals = these_ranks;
-	border = this_border} as proof_info) =
-         Hashtbl.find theorem_proofs s in
-  let rec push_command_aux n = function
-      [] -> failwith "the given rank was too large"
-    | a::l ->
-	if n = 1 then
-	 let {path_to_root = p} = a in
-	 let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in
-	 new_trees,(new_trees@l),a
-	else
-	  let new_trees, res, this_tree = push_command_aux (n-1) l in
-	  new_trees,(a::res),this_tree in
-  let new_trees, new_border, this_tree =
-      push_command_aux rank this_border in
-  let new_length = this_length + 1 in
-  begin
-    proof_info.border <- new_border;
-    proof_info.prf_length <- new_length;
-    proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks;
-    this_tree.index <- new_length;
-    this_tree.is_open <- false;
-    this_tree.sub_proofs <- new_trees
-  end;;
-
-let get_tree_for_rank thm_name rank = 
-  let {ranks_and_goals=l;prf_length=n} = 
-         Hashtbl.find theorem_proofs thm_name in
-  let rec get_tree_aux = function
-      [] ->
- 	failwith 
-         "inconsistent values for thm_name and rank in get_tree_for_rank"
-    | (_,_,({index=i} as tree))::tl ->
-	if i = rank then
-	  tree
-	else
-	  get_tree_aux tl in
-  get_tree_aux l;;
-
-let get_path_for_rank thm_name rank =
-  let {path_to_root=l}=get_tree_for_rank thm_name rank in
-  l;;
-
-let rec list_descendants_aux l tree =
-  let {index = i; is_open = open_status; sub_proofs = tl} = tree in
-  let res = (List.fold_left list_descendants_aux  l tl) in
-  if open_status then i::res else res;;
-
-let list_descendants thm_name rank =
-  list_descendants_aux [] (get_tree_for_rank thm_name rank);;
-
-let parent_from_rank thm_name rank =
-  let {parent=mommy} = get_tree_for_rank thm_name rank in
-  match mommy with
-   Some x -> Some x.index
-  | None -> None;;
-
-let first_child_command thm_name rank =
-  let {sub_proofs = l} = get_tree_for_rank thm_name rank in
-  let rec first_child_rec = function 
-      [] -> None
-    | {index=i;is_open=b}::l -> 
-	if b then
-	  (first_child_rec l)
-	else
- 	  Some i in
-  first_child_rec l;;
-
-type index_or_rank = Is_index of int | Is_rank of int;;
-
-let first_child_command_or_goal thm_name rank =
-  let proof_info = Hashtbl.find theorem_proofs thm_name in
-  let {sub_proofs=l}=get_tree_for_rank thm_name rank in
-  match l with
-    [] -> None
-  | ({index=i;is_open=b} as t)::_ -> 
-      if b then
-	let rec get_rank n = function
-	    [] -> failwith "A goal is lost in first_child_command_or_goal"
-	  | a::l ->
-	      if a==t then
-		n
-	      else
-		get_rank (n + 1) l in
-	Some(Is_rank(get_rank 1 proof_info.border))
-      else
-	Some(Is_index i);;
-
-let next_sibling thm_name rank =
-  let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in
-  match mommy with
-    None -> None
-  |  Some real_mommy ->
-  let {sub_proofs=l}=real_mommy in
-  let rec next_sibling_aux b = function
-      (opt_first, []) -> 
-	if b then
-	  opt_first
-	else
-	  failwith "inconsistency detected in next_sibling"
-    | (opt_first, {is_open=true}::l) -> 
-	next_sibling_aux b (opt_first, l)
-    | (Some(first),({index=i; is_open=false} as t')::l) ->
-	if b then
-	  Some i
-	else
-	  next_sibling_aux (t == t') (Some first,l)
-    | None,({index=i;is_open=false} as t')::l ->
-  	next_sibling_aux (t == t') ((Some i), l)
-  in
-  Some (next_sibling_aux false (None, l));;
-
-
-let prefix l1 l2 =
-  let l1rev = List.rev l1 in
-  let l2rev = List.rev l2 in
-  is_prefix l1rev l2rev;;
-
-let rec remove_all_prefixes p = function
-    [] -> []
-  | a::l -> 
-      if is_prefix p a then
- 	(remove_all_prefixes p l)
-      else
-	a::(remove_all_prefixes p l);;
-
-let recompute_border tree =
-  let rec recompute_border_aux tree acc =
-    let {is_open=b;sub_proofs=l}=tree in
-    if b then
-      tree::acc
-    else
-      List.fold_right recompute_border_aux l acc in
-  recompute_border_aux tree [];;
- 
-   
-let historical_undo thm_name rank =
-  let ({ranks_and_goals=l} as proof_info)=
-       Hashtbl.find theorem_proofs thm_name in
-  let rec undo_aux acc = function
-      [] ->  failwith "bad rank provided for undoing in historical_undo"
-    | (r, n, ({index=i} as tree))::tl  ->
-	let this_path_reversed = List.rev tree.path_to_root in
-	let res = remove_all_prefixes this_path_reversed acc in
-	if i = rank then
-	  begin
-	    proof_info.prf_length <- i-1;
-	    proof_info.ranks_and_goals <- tl;
-	    tree.is_open <- true;
-	    tree.sub_proofs <- [];
-	    proof_info.border <- recompute_border proof_info.prf_struct;
-            this_path_reversed::res 
-	  end
-	else
-	  begin
-	    tree.is_open <- true;
-	    tree.sub_proofs <- [];
-	    undo_aux (this_path_reversed::res) tl
-	  end
-  in
-  List.map List.rev (undo_aux [] l);;
-
-(* The following function takes a list of trees and compute the
-   number of elements whose path is lexically smaller or a suffixe of
-   the path given as a first argument.  This works under the precondition that
-   the list is lexicographically order. *)
-
-let rec logical_undo_on_border the_tree rev_path = function
-    [] -> (0,[the_tree])
-  | ({path_to_root=p}as tree)::tl ->
-    let p_rev = List.rev p in
-    if is_prefix rev_path p_rev then
-      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
-          (k+1,res)
-    else if lex_smaller p_rev rev_path then
-      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
-          (k,tree::res)
-    else
-          (0, the_tree::tree::tl);;
-   
-
-let logical_undo thm_name rank =
-  let ({ranks_and_goals=l; border=last_border} as proof_info)=
-           Hashtbl.find theorem_proofs thm_name in
-  let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in
-  let rev_ref_path = List.rev ref_path in
-  let rec logical_aux lex_smaller_offset family_width = function
-      [] -> failwith "this case should never happen in logical_undo"
-    | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree))::
-        tl ->
-        let this_path_rev = List.rev this_path in
-        let new_rank, new_offset, new_width, kept =
-	  if is_prefix rev_ref_path this_path_rev then
-	    (r + lex_smaller_offset), lex_smaller_offset,
-              (family_width + 1 - n), false 
-	  else if lex_smaller this_path_rev rev_ref_path then
-            r, (lex_smaller_offset -  1 + n), family_width, true
-          else
-            (r + 1 - family_width+ lex_smaller_offset),
-	    lex_smaller_offset, family_width, true in
-        if i=rank then
-	  [i,new_rank],[], tl, rank
-        else
-          let ranks_undone, ranks_kept, ranks_and_goals, current_rank =
-	    (logical_aux new_offset new_width tl) in
-          begin
-	    if kept then
-	      begin
-	      	tree.index <- current_rank;
-	    	ranks_undone, ((i,new_rank)::ranks_kept),
-	    	((new_rank, n, tree)::ranks_and_goals), 
-                (current_rank + 1)
-	      end
-	    else
-	      ((i,new_rank)::ranks_undone), ranks_kept,
-	      ranks_and_goals, current_rank
-	  end in
-  let number_suffix, new_border = 
-     logical_undo_on_border ref_tree rev_ref_path last_border in
-  let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals,
-    new_length_plus_one = logical_aux 0 number_suffix l in
-  let the_goal_index =
-    let rec compute_goal_index n = function
-	[] -> failwith "this case should never happen in logical undo (2)"
-      |	{path_to_root=path}::tl ->
-	  if List.rev path = (rev_ref_path) then
-	    n
-	  else
-	    compute_goal_index (n+1) tl in
-    compute_goal_index 1 new_border in
-  begin
-    ref_tree.is_open <- true;
-    ref_tree.sub_proofs <- [];
-    proof_info.border <- new_border;
-    proof_info.ranks_and_goals <- new_ranks_and_goals;
-    proof_info.prf_length <- new_length_plus_one - 1;
-    changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, 
-    the_goal_index
-  end;;
-	
-let start_proof thm_name =
-   let the_tree = 
-      {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in
-   Hashtbl.add theorem_proofs thm_name
-     {prf_length=0;
-      ranks_and_goals=[];
-      border=[the_tree];
-      prf_struct=the_tree};;
-      
-let dump_sequence chan s =
-    match (Hashtbl.find theorem_proofs s) with
-    {ranks_and_goals=l}->
-      let rec dump_rec = function
-	  [] -> ()
-  	| (r,n,_)::tl ->
-	    dump_rec tl;
-	    output_string chan (string_of_int r);
-	    output_string chan ",";
-	    output_string chan (string_of_int n);
-	    output_string chan "\n" in
-      begin
-      	dump_rec l;
-	output_string chan "end\n"
-      end;;
-
-      
-let proof_info_as_string s =
-  let res = ref "" in
-  match (Hashtbl.find theorem_proofs s) with
-  {prf_struct=tree} ->
-  let open_goal_counter = ref 0 in
-  let rec dump_rec = function
-    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
-    begin
-      (match the_parent with
-         None ->
-	   if op then
-	     res := !res ^  "\"open goal\"\n"
-       | Some {index=j} -> 
-           begin
-             res := !res ^  (string_of_int j);
-             res := !res ^  " -> ";
-	     if op then
-	       begin
-		 res := !res ^  "\"open goal ";
-		 open_goal_counter := !open_goal_counter + 1;
-		 res := !res ^  (string_of_int !open_goal_counter);
-		 res := !res ^  "\"\n";
-	       end
-	     else
-	       begin
-		 res := !res ^  (string_of_int i);
-		 res := !res ^  "\n"
-	       end
-           end);
-      	List.iter dump_rec trees
-     end in
-  dump_rec tree;
-  !res;;
-
-
-let dump_proof_info chan s = 
-  match (Hashtbl.find theorem_proofs s) with
-  {prf_struct=tree} ->
-  let open_goal_counter = ref 0 in
-  let rec dump_rec = function
-    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
-    begin
-      (match the_parent with
-         None ->
-	   if op then
-	     output_string chan "\"open goal\"\n"
-       | Some {index=j} -> 
-           begin
-             output_string chan (string_of_int j);
-             output_string chan " -> ";
-	     if op then
-	       begin
-		 output_string chan "\"open goal ";
-		 open_goal_counter := !open_goal_counter + 1;
-		 output_string chan (string_of_int !open_goal_counter);
-		 output_string chan "\"\n";
-	       end
-	     else
-	       begin
-		 output_string chan (string_of_int i);
-		 output_string chan "\n"
-	       end
-           end);
-      	List.iter dump_rec trees
-     end in
-  dump_rec tree;;
-
-let get_nth_open_path s n =
-  match Hashtbl.find theorem_proofs s with
-    {border=l} ->
-    let {path_to_root=p}=List.nth l (n - 1) in
-    p;;
-
-let border_length s =
-  match Hashtbl.find theorem_proofs s with
-    {border=l} -> List.length l;;
diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli
deleted file mode 100644
index 053883f0..00000000
--- a/contrib/interface/history.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-type prf_info;;
-
-val start_proof : string -> unit;;
-val historical_undo : string -> int -> int list list
-val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int
-val dump_sequence : out_channel -> string -> unit
-val proof_info_as_string : string -> string
-val dump_proof_info : out_channel -> string -> unit
-val push_command : string -> int -> int -> unit
-val get_path_for_rank : string -> int -> int list
-val get_nth_open_path : string -> int -> int list
-val border_length : string -> int
diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4
deleted file mode 100755
index 0b13a092..00000000
--- a/contrib/interface/line_parser.ml4
+++ /dev/null
@@ -1,241 +0,0 @@
-(* line-oriented Syntactic analyser for a Coq parser *)
-(* This parser expects a very small number of commands, each given on a complete
-line.  Some of these commands are then followed by a text fragment terminated
-by a precise keyword, which is also expected to appear alone on a line. *)
-
-(* The main parsing loop procedure is "parser_loop", given at the end of this
-file.  It read lines one by one and checks whether they can be parsed using
-a very simple parser.  This very simple parser uses a lexer, which is also given
-in this file.  
-
-The lexical analyser:
- There are only 5 sorts of tokens *)
-type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string |
-      Tlbracket | Trbracket;;
-
-(* When recognizing identifiers or strings, the lexical analyser accumulates
-   the characters in a buffer, using the command add_in_buff.  To recuperate
-   the characters, one can use get_buff (this code was inspired by the
-   code in src/meta/lexer.ml of Coq revision 6.1) *)
-let add_in_buff,get_buff =
-  let buff = ref (String.create 80) in
-    (fun i x -> 
-       let len = String.length !buff in
-        if i >= len then (buff := !buff ^ (String.create len);());
-         String.set !buff i x;
-         succ i),
-     (fun len -> String.sub !buff 0 len);;
-
-(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*.  When arriving here the first
-   character has already been recognized. *)
-let rec ident len = parser
-  [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] ->
-    ident (add_in_buff len c) s
-| [< >] -> let str = get_buff len in Tid(str);;
-
-(* While recognizing integers, one constructs directly the integer value.
-   The ascii code of '0' is important for this. *)
-let code0 = Char.code '0';;
-
-let get_digit c =  Char.code c - code0;;
-
-(* Integers are [0-9]*
-   The variable intval is the integer value of the text that has already
-   been recognized.  As for identifiers, the first character has already been
-   recognized. *)
-
-let rec parse_int intval = parser
-  [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i
-| [< >] -> Tint intval;;
-      
-(* The string lexer is borrowed from the string parser of Coq V6.1 
-   This may be a problem if convention have changed in Coq,
-   However this parser is only used to recognize file names which should
-   not contain too many special characters *)
-
-let rec spec_char = parser
-  [< ''n' >] -> '\n' 
-| [< ''t' >] -> '\t'
-| [< ''b' >] -> '\008' 
-| [< ''r' >] -> '\013'
-| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] ->
-    Char.chr v
-| [< 'x >] -> x
-
-and spec1 v = parser
-  [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s
-| [< >] -> v
-;;
-
-(* This is the actual string lexical analyser.  Strings are
-   QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used
-   to represents double quotation characters, that cannot be used
-   freely, even inside comments. *)
-
-let rec string len = parser
-  [< ''"' >] -> len
-| [<''\\' ;
-      len = (parser [< ''\n' >] -> len
-             | [< c=spec_char >] -> add_in_buff len c);
-      s >] -> string len s
-| [< 'x; s >] -> string (add_in_buff len x) s;;
-
-(* The lexical analyser repeats the recognized given by next_token:
-   spaces and tabulations are ignored, identifiers, integers,
-   strings, opening and closing square brackets.  Lexical errors are
-   ignored ! *)
-let rec next_token = parser _count
-  [< '' ' | '\t'; tok = next_token >] -> tok
-| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i
-| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i
-| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len)
-| [< ''[' >] -> Tlbracket
-| [< '']' >] -> Trbracket
-| [< '_ ; x = next_token >] -> x;;
-
-(* A very simple lexical analyser to recognize a integer value behind 
-   blank characters *)
-
-let rec next_int = parser _count
-  [< '' ' | '\t'; v = next_int >] -> v
-| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] ->
-     (match i with
-        Tint n -> n
-     |  _ -> failwith "unexpected branch in next_int");;
-
-(* This is the actual lexical analyser, implemented as a function on a stream.
-   It will be used with the Stream.from primitive to construct a function
-   of type char Stream.t -> simple_token option Stream.t *)
-let token_stream cs _ =
- try  let tok = next_token cs in
-      Some tok
- with Stream.Failure -> None;;
-
-(* Two of the actions of the parser request that one reads the rest of
-   the input up to a specific string stop_string.  This is done
-   with a function that transform the input_channel into a pair of
-   char Stream.t, reading from the input_channel all the lines to
-   the stop_string first. *)
-
-
-let rec gather_strings stop_string input_channel =
-   let buff = input_line input_channel in
-   if buff = stop_string then
-     []
-   else
-     (buff::(gather_strings stop_string input_channel));;
-
-
-(* the result of this function is supposed to be used in a Stream.from
-   construction. *)
-
-let line_list_to_stream string_list =
-   let count = ref 0 in
-   let buff = ref "" in
-   let reserve = ref string_list in
-   let current_length = ref 0 in
-   (fun i -> if (i - !count) >= !current_length then
-               begin
-                  count := !count + !current_length + 1;
-                  match !reserve with
-		  | [] -> None
-                  | s1::rest -> 
-                    begin
-                      buff := s1;
-                      current_length := String.length !buff;
-		      reserve := rest;
-                      Some '\n'
-                    end
-               end
-             else
-               Some(String.get !buff (i - !count)));;
- 
-
-(* In older revisions of this file you would find a function that
-   does line oriented breakdown of the input channel without resorting to
-   a list of lines.  However, the need for the list of line appeared when
-   we wanted to have  a channel and a list of strings describing the same
-   data, one for regular parsing and the other for error recovery. *)
-
-let channel_to_stream_and_string_list stop_string input_channel =
-   let string_list = gather_strings stop_string input_channel in
-   (line_list_to_stream string_list, string_list);;
-
-let flush_until_end_of_stream char_stream =
- Stream.iter (function _ -> ()) char_stream;;
-
-(* There are only 5 kinds of lines recognized by our little parser.
-   Unrecognized lines are ignored. *)
-type parser_request =
-  | PRINT_VERSION
-  | PARSE_STRING of string
-      (* parse_string <int> [<ident>] then text and && END--OF--DATA *)
-  | QUIET_PARSE_STRING
-      (* quiet_parse_string then text and && END--OF--DATA *)
-  | PARSE_FILE of string
-      (* parse_file <int> <string> *)
-  | ADD_PATH of string
-      (* add_path <int> <string> *)
-  | ADD_REC_PATH of string * string
-      (* add_rec_path <int> <string> <ident> *)
-  | LOAD_SYNTAX of string
-      (* load_syntax_file <int> <ident> *)
-  | GARBAGE
-;;
-
-(* The procedure parser_loop should never terminate while the input_channel is
-   not closed. This procedure receives the functions called for each sentence
-   as arguments.  Thus the code is completely independent from the Coq sources. *)
-let parser_loop functions input_channel =
-  let print_version_action,
-      parse_string_action,
-      quiet_parse_string_action,
-      parse_file_action,
-      add_path_action,
-      add_rec_path_action,
-      load_syntax_action = functions in
-  let rec parser_loop_rec input_channel =
-  (let line = input_line input_channel in
-  let reqid, parser_request = 
-      try 
-      (match Stream.from (token_stream (Stream.of_string line)) with
-        parser
-        | [< 'Tid "print_version" >] ->
-                     0, PRINT_VERSION
-        | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ;
-             'Tid phylum ; 'Trbracket >] 
-                  -> reqid,PARSE_STRING phylum
-        | [< 'Tid "quiet_parse_string" >] ->
-                     0,QUIET_PARSE_STRING
-        | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] ->
-                     reqid, PARSE_FILE fname
-        | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ;  'Tid alias >]
-            -> reqid, ADD_REC_PATH(directory, alias)
-        | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >]
-            -> reqid, ADD_PATH directory
-        | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] ->
-               reqid, LOAD_SYNTAX module_name
-	| [< 'Tid "quit_parser" >] -> raise End_of_file
-        | [< >] -> 0, GARBAGE)
-       with
-         Stream.Failure | Stream.Error _ -> 0,GARBAGE in
-   match parser_request with
-     PRINT_VERSION -> print_version_action ()
-   | PARSE_STRING phylum ->
-     let regular_stream, string_list =
-        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
-      parse_string_action reqid phylum (Stream.from regular_stream)
-        string_list;()
-   | QUIET_PARSE_STRING ->
-     let regular_stream, string_list =
-        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
-       quiet_parse_string_action
-        (Stream.from regular_stream);()
-   | PARSE_FILE file_name ->
-        parse_file_action reqid file_name
-   | ADD_PATH path -> add_path_action reqid path
-   | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias
-   | LOAD_SYNTAX syn -> load_syntax_action reqid syn
-   | GARBAGE -> ());
-   parser_loop_rec input_channel in
-   parser_loop_rec input_channel;;
diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli
deleted file mode 100644
index b0b043c7..00000000
--- a/contrib/interface/line_parser.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-val parser_loop :
-  (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) *
-  (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) *
-  (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c
-val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
deleted file mode 100644
index 0dc8f024..00000000
--- a/contrib/interface/name_to_ast.ml
+++ /dev/null
@@ -1,232 +0,0 @@
-open Sign;;
-open Classops;;
-open Names;;
-open Nameops
-open Term;;
-open Impargs;;
-open Reduction;;
-open Libnames;;
-open Libobject;;
-open Environ;;
-open Declarations;;
-open Prettyp;;
-open Inductive;;
-open Util;;
-open Pp;;
-open Declare;;
-open Nametab
-open Vernacexpr;;
-open Decl_kinds;;
-open Constrextern;;
-open Topconstr;;
-
-(* This function converts the parameter binders of an inductive definition,
-   in particular you have to be careful to handle each element in the
-   context containing all previously defined variables.  This squeleton
-   of this procedure is taken from the function print_env in pretty.ml *)
-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], 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
-    cvrec (Global.env());;
-
-(* let mib string = 
-     let sp = Nametab.sp_of_id CCI (id_of_string string) in
-     let lobj = Lib.map_leaf (objsp_of sp) in
-     let (cmap, _) = outMutualInductive lobj in
-     Listmap.map cmap CCI;; *)
-
-(* This function is directly inspired by print_impl_args in pretty.ml *)
-
-let impl_args_to_string_by_pos = function
-    [] -> None
-  | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.")
-  | l -> Some (" positions " ^
-                (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s)
-                     l
-                     " are implicit."));;
-
-(* This function is directly inspired by implicit_args_id in pretty.ml *)
-
-let impl_args_to_string l = 
-  impl_args_to_string_by_pos (positions_of_implicits l)
-
-let implicit_args_id_to_ast_list id l ast_list = 
-    (match impl_args_to_string l with
-           None -> ast_list
-         | Some(s) -> CommentString s::
-                      CommentString ("For " ^ (string_of_id id))::
-                      ast_list);;
-
-(* This function construct an ast to enumerate the implicit positions for an
-   inductive type and its constructors. It is obtained directly from
-   implicit_args_msg in pretty.ml.  *)
-
-let implicit_args_to_ast_list sp mipv =
-    let implicit_args_descriptions = 
-      let ast_list = ref [] in
-       	(Array.iteri
-           (fun i mip  ->
-	      let imps = implicits_of_global (IndRef (sp, i)) in
-		      (ast_list :=
-	      	implicit_args_id_to_ast_list mip.mind_typename imps !ast_list;
-	      	Array.iteri
-		  (fun j idc ->
-		     let impls = implicits_of_global
-		       (ConstructRef ((sp,i),j+1)) in
-		       ast_list := 
-		       implicit_args_id_to_ast_list idc impls !ast_list)
-		  mip.mind_consnames))
-	  mipv;
-	 !ast_list) in
-      match implicit_args_descriptions with
-	  [] -> []
-	| _ -> [VernacComments (List.rev implicit_args_descriptions)];;
-	      
-(* This function converts constructors for an inductive definition to a
-   Coqast.t.  It is obtained directly from print_constructors in pretty.ml *)
-
-let convert_constructors envpar names types =
-  let array_idC = 
-    array_map2 
-      (fun n t -> 
-	let coercion_flag = false (* arbitrary *) in
-	(coercion_flag, ((dummy_loc,n), extern_constr true envpar t)))
-      names types in
-  Array.to_list array_idC;;
-  
-(* this function converts one inductive type in a possibly multiple inductive
-   definition *)
-
-let convert_one_inductive sp tyi =
-  let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in
-  let env = Global.env () in
-  let envpar = push_rel_context params env in
-  let sp = sp_of_global (IndRef (sp, tyi)) in
-  (((false,(dummy_loc,basename sp)),
-   convert_env(List.rev params),
-   Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw ,
-   Constructors (convert_constructors envpar cstrnames cstrtypes)), None);;
-
-(* This function converts a Mutual inductive definition to a Coqast.t.
-   It is obtained directly from print_mutual in pretty.ml.  However, all
-   references to kinds have been removed and it treats only CCI stuff. *)
-
-let mutual_to_ast_list sp mib =
-  let mipv = (Global.lookup_mind sp).mind_packets in
-  let _, l =
-    Array.fold_right
-      (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in
-  VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l)
-  :: (implicit_args_to_ast_list sp mipv);;
-
-let constr_to_ast v = 
-  extern_constr true (Global.env()) v;;
-
-let implicits_to_ast_list implicits =
-  match (impl_args_to_string implicits) with
-    | None -> []
-    | Some s -> [VernacComments [CommentString s]];;
-
-let make_variable_ast name typ implicits =
-  (VernacAssumption
-    ((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 typ)),
-    (fun _ _ -> ()))
-  ::(implicits_to_ast_list implicits);;
-
-(* This function is inspired by print_constant *)
-let constant_to_ast_list kn =
-  let cb = Global.lookup_constant kn in
-  let c = cb.const_body in
-  let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in
-  let l = implicits_of_global (ConstRef kn) in
-  (match c with
-      None -> 
-	make_variable_ast (id_of_label (con_label kn)) typ l
-    | Some c1 ->
-	make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l)
-
-let variable_to_ast_list sp =
-  let (id, c, v) = Global.lookup_named sp in
-  let l = implicits_of_global (VarRef sp) in
-    (match c with
-	 None -> 
-	   make_variable_ast id v l
-       | Some c1 ->
-	   make_definition_ast id c1 v l);;
-
-(* this function is taken from print_inductive in file pretty.ml *)
-
-let inductive_to_ast_list sp =
-  let mib = Global.lookup_mind sp in
-  mutual_to_ast_list sp mib
-
-(* this function is inspired by print_leaf_entry from pretty.ml *)
-
-let leaf_entry_to_ast_list ((sp,kn),lobj) =
-  let tag = object_tag lobj in
-  match tag with
-  | "VARIABLE" -> variable_to_ast_list (basename sp)
-  | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn)
-  | "INDUCTIVE" -> inductive_to_ast_list kn
-  | s -> 
-      errorlabstrm 
-      	"print" (str ("printing of unrecognized object " ^
-		      s ^ " has been required"));;
-
-
-
-
-(* this function is inspired by print_name *)
-let name_to_ast ref =
-  let (loc,qid) = qualid_of_reference ref in
-  let l = 
-    try
-      let sp = Nametab.locate_obj qid in
-      let (sp,lobj) = 
-      	let (sp,entry) =
-          List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
-      	in
-	  match entry with
-            | Lib.Leaf obj -> (sp,obj)
-            | _ -> raise Not_found
-      in
-    	leaf_entry_to_ast_list (sp,lobj)
-    with Not_found -> 
-      try 
-    	match Nametab.locate qid with
-	  | ConstRef sp -> constant_to_ast_list sp
-	  | IndRef (sp,_) -> inductive_to_ast_list sp
-	  | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp
-	  | VarRef sp -> variable_to_ast_list sp
-  	with Not_found -> 
-	  try  (* Var locale de but, pas var de section... donc pas d'implicits *)
-	    let dir,name = repr_qualid qid in 
-	      if (repr_dirpath dir) <> [] then raise Not_found;
-	      let (_,c,typ) = Global.lookup_named name in 
-		(match c with
-		     None -> make_variable_ast name typ []
-		   | Some c1 -> make_definition_ast name c1 typ [])
-	  with Not_found ->
-	    try
-	      let _sp = Nametab.locate_syntactic_definition qid in
-		errorlabstrm "print"
-      		  (str "printing of syntax definitions not implemented")
-	    with Not_found ->
-	      errorlabstrm "print"
-		(pr_qualid qid ++
-		 spc () ++ str "not a defined object")
-  in
-  VernacList (List.map (fun x -> (dummy_loc,x)) l)
-
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
deleted file mode 100644
index f9e83b5e..00000000
--- a/contrib/interface/name_to_ast.mli
+++ /dev/null
@@ -1,5 +0,0 @@
-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
deleted file mode 100644
index 1bbab5fe..00000000
--- a/contrib/interface/parse.ml
+++ /dev/null
@@ -1,422 +0,0 @@
-open Util;;
-open System;;
-open Pp;;
-open Libnames;;
-open Library;;
-open Ascent;;
-open Vtp;;
-open Xlate;;
-open Line_parser;;
-open Pcoq;;
-open Vernacexpr;;
-open Mltop;;
-
-type parsed_tree =
-  | P_cl of ct_COMMAND_LIST
-  | P_c of ct_COMMAND
-  | P_t of ct_TACTIC_COM
-  | P_f of ct_FORMULA
-  | P_id of ct_ID
-  | P_s of ct_STRING
-  | P_i of ct_INT;;
-
-let print_parse_results n msg =
-  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 =
- fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++
-   int reqid ++ fnl () ++
-   pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
-let ctf_SyntaxWarningMessage reqid pps =
-  fnl () ++  str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++
-  int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-
-let ctf_FileErrorMessage reqid pps =
-  fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++
-  int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++
-  fnl ();;
-
-let execute_when_necessary v =
- (match v with
-  | VernacOpenCloseScope sc -> Vernacentries.interp v
-  | VernacRequire (_,_,l) ->
-      (try 
-	Vernacentries.interp v
-       with _ ->
-	 let l=prlist_with_sep spc pr_reference l in
-	 msgnl (str "Reinterning of " ++ l ++ str " failed"))
-  | VernacRequireFrom (_,_,f) ->
-      (try 
-	Vernacentries.interp v
-       with _ ->
-	 msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed"))
-  | _ -> ()); v;;
-
-let parse_to_dot =
-  let rec dot st = match Stream.next st with
-    | ("", ".") -> ()
-    | ("EOI", "") -> raise End_of_file
-    | _ -> dot st in
-    Gram.Entry.of_parser "Coqtoplevel.dot" dot;;
-
-let rec discard_to_dot stream =
-  try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with
-  | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;;
-
-let rec decompose_string_aux s n =
-    try let index = String.index_from s n '\n' in
-            (String.sub s n (index - n))::
-            (decompose_string_aux s (index + 1))
-    with Not_found -> [String.sub s n ((String.length s) - n)];;
-
-let decompose_string s n =
-  match decompose_string_aux s n with
-      ""::tl -> tl
-    | a -> a;;
-
-let make_string_list file_chan fst_pos snd_pos =
-    let len = (snd_pos - fst_pos) in
-    let s = String.create len in
-    begin
-      seek_in file_chan fst_pos;
-      really_input file_chan s 0 len;
-      decompose_string s 0;
-    end;;
-
-let rec get_sub_aux string_list snd_pos =
-    match string_list with
-      [] -> []
-    | s::l ->
-      let len = String.length s in
-        if len >= snd_pos then
-          if snd_pos < 0 then
-            []
-          else
-            [String.sub s 0 snd_pos]
-        else
-          s::(get_sub_aux l (snd_pos - len - 1));;
-
-let rec get_substring_list string_list fst_pos snd_pos =
-  match string_list with
-    [] -> []
-  | s::l -> 
-    let len = String.length s in
-    if fst_pos > len then
-       get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1)
-    else
-       (* take into account the fact that carriage returns are not in the *)
-       (* strings. *)
-       let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in
-       if snd_pos > len then
-         String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2)::
-         (get_sub_aux l (snd_pos - len - 2))
-       else
-         let gap = (snd_pos - fst_pos2) in
-         if gap < 0 then
-            []
-         else
-            [String.sub s (fst_pos2 - 1) gap];;
-
-(* When parsing a list of commands, we try to recover error messages for
-   each individual command. *)
-
-type parse_result =
-  | ParseOK of Vernacexpr.vernac_expr located option
-  | ParseError of string * string list
-
-let embed_string s =
-  CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s))
-
-let make_parse_error_item s l =
-  CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l))
-
-let parse_command_list reqid stream string_list =
-    let rec parse_whole_stream () =
-    let this_pos = Stream.count stream in
-    let first_ast = 
-        try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
-        with
-        | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> 
-          begin
-             msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e));
-             try
-                discard_to_dot stream;
-                msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++
-		       int (Stream.count stream));
-		ParseError ("PARSING_ERROR",
-                  get_substring_list string_list this_pos
-		    (Stream.count stream))
-             with End_of_file -> ParseOK None
-           end
-        | e-> 
-          begin
-            discard_to_dot stream;
-	    ParseError ("PARSING_ERROR2",
-	      get_substring_list string_list this_pos (Stream.count stream))
-          end in
-    match first_ast with
-    | ParseOK (Some (loc,ast)) ->
-        let _ast0 = (execute_when_necessary ast) in
-          (try xlate_vernac ast
-	  with e ->
-	    make_parse_error_item "PARSING_ERROR2" 
-		     (get_substring_list string_list this_pos
-		       (Stream.count stream)))::parse_whole_stream()
-    | ParseOK None -> []
-    | ParseError (s,l) -> 
-	(make_parse_error_item s l)::parse_whole_stream()
- in
-    match parse_whole_stream () with
-    | first_one::tail -> (P_cl (CT_command_list(first_one, tail)))
-    | [] -> raise (UserError ("parse_string", (str "empty text.")));;
-
-(*When parsing a string using a phylum, the string is first transformed
-  into a Coq Ast using the regular Coq parser, then it is transformed into
-  the right ascent term using xlate functions, then it is transformed into
-  a stream, using the right vtp function. There is a special case for commands,
-  since some of these must be executed!*)
-let parse_string_action reqid phylum char_stream string_list =
- try let msg =
-      match phylum with
-      | "COMMAND_LIST" ->
-        parse_command_list reqid char_stream string_list
-      | "COMMAND" ->
-       P_c
-        (xlate_vernac
-        (execute_when_necessary
-        (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream))))
-      | "TACTIC_COM" ->
-       P_t
-        (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi 
-                         (Gram.parsable char_stream)))
-      | "FORMULA" ->
-       P_f
-        (xlate_formula
-	   (Gram.Entry.parse 
-              (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream)))
-      | "ID" -> P_id (CT_ident
-                        (Libnames.string_of_qualid 
-			 (snd 
-			       (Gram.Entry.parse  (Pcoq.eoi_entry Pcoq.Prim.qualid)
-						 (Gram.parsable char_stream)))))
-      | "STRING" ->
-	  P_s
-         (CT_string (Gram.Entry.parse Pcoq.Prim.string 
-                  (Gram.parsable char_stream)))
-      | "INT" ->
-	  P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural
-                              (Gram.parsable char_stream)))
-      | _ -> error "parse_string_action : bad phylum" in
-      print_parse_results reqid msg
- with
- | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
-    flush_until_end_of_stream char_stream;
-    msgnl (ctf_SyntaxErrorMessage reqid
-              (Cerrors.explain_exn 
-                 (Stdpp.Exc_located(l,Stream.Error "match failure"))))
- | e ->
-    flush_until_end_of_stream char_stream;
-    msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));;
-
-
-let quiet_parse_string_action char_stream =
- try let _ = 
-         Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in
-     ()
- with
- | _ -> flush_until_end_of_stream char_stream; ();;
-
-
-let parse_file_action reqid file_name =
- try let file_chan = open_in file_name in
-     (* file_chan_err, stream_err are the channel and stream  used to 
-        get the text when a syntax error occurs *)
-     let file_chan_err = open_in file_name in 
-     let stream = Stream.of_channel file_chan in
-     let _stream_err = Stream.of_channel file_chan_err in
-     let rec discard_to_dot () =
-       try Gram.Entry.parse parse_to_dot (Gram.parsable stream)
-       with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in
-       match let rec parse_whole_file () =
-	 let this_pos = Stream.count stream in
-           match 
-             try
-	       ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
-             with
-               | Stdpp.Exc_located(l,Stream.Error txt) -> 
-                   msgnl (ctf_SyntaxWarningMessage reqid
-			    (str "Error with file" ++ spc () ++
-			     str file_name ++ fnl () ++
-			     Cerrors.explain_exn 
-				 (Stdpp.Exc_located(l,Stream.Error txt))));
-		   (try 
-		      begin
-                      	discard_to_dot ();
-                    	ParseError ("PARSING_ERROR",
-				   (make_string_list file_chan_err this_pos 
-			       	      (Stream.count stream)))
-		      end
-                    with End_of_file -> ParseOK None)
-               | e ->
-                   begin
-                     Gram.Entry.parse parse_to_dot (Gram.parsable stream);
-                     ParseError ("PARSING_ERROR2",
-			       (make_string_list file_chan this_pos
-				  (Stream.count stream)))
-                   end
-		   
-             with
-               | ParseOK (Some (_,ast)) ->
-		   let _ast0=(execute_when_necessary ast) in 
-		   let term =
-                     (try xlate_vernac ast
-		      with e ->
-                    	print_string ("translation error between " ^
-				      (string_of_int this_pos) ^
-				      " " ^
-				      (string_of_int (Stream.count stream)) ^
-				      "\n");
-			make_parse_error_item "PARSING_ERROR2"
-			  (make_string_list file_chan_err this_pos
-			    (Stream.count stream))) in 
-		     term::parse_whole_file ()
-               | ParseOK None -> []
-	       | ParseError (s,l) -> 
-		   (make_parse_error_item s l)::parse_whole_file () in
-         parse_whole_file () with
-	   | first_one :: tail ->
-	       print_parse_results reqid
-		 (P_cl (CT_command_list (first_one, tail)))
-	   | [] -> raise (UserError ("parse_file_action", str "empty file."))
-       with
-	 | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
-	     msgnl
-	       (ctf_SyntaxErrorMessage reqid
-		  (str "Error with file" ++ spc () ++ str file_name ++ 
-		   fnl () ++
-		     Cerrors.explain_exn
-		       (Stdpp.Exc_located(l,Stream.Error "match failure"))))
-	 | e ->
-	     msgnl
-	       (ctf_SyntaxErrorMessage reqid
-		  (str "Error with file" ++ spc () ++ str file_name ++
-		   fnl () ++ Cerrors.explain_exn e));;
-
-let add_rec_path_action reqid string_arg ident_arg =
-  let directory_name = expand_path_macros string_arg in
-    begin
-      add_rec_path directory_name (Libnames.dirpath_of_string ident_arg)
-    end;;
-	
-
-let add_path_action reqid string_arg =
-  let directory_name = expand_path_macros string_arg in
-    begin
-      add_path directory_name Names.empty_dirpath
-    end;;
-
-let print_version_action () =
-  msgnl (mt ());
-  msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");;
-
-let load_syntax_action reqid module_name =
- msg (str "loading " ++ str module_name ++ str "... ");
- try
-      (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in
-      require_library [dummy_loc,qid] None;
-      msg (str "opening... ");
-      Declaremods.import_module false (Nametab.locate_module qid); 
-      msgnl (str "done" ++ fnl ());
-      ())
- with
- | UserError (label, pp_stream) ->
- (*This one may be necessary to make sure that the message won't be indented *)
- msgnl (mt ());
- msgnl
-  (fnl () ++ str "error while loading syntax module " ++ str module_name ++
-   str ": " ++ str label ++ fnl () ++ pp_stream)
- | e ->
-  msgnl (mt ());
-  msgnl
-   (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++
-    int reqid ++ fnl ());
-  ();;
-
-let coqparser_loop inchan =
- (parser_loop : (unit -> unit) *
-                (int -> string -> char Stream.t -> string list -> unit) *
-                (char Stream.t -> unit) * (int -> string -> unit) *
-                (int -> string -> unit) * (int -> string -> string -> unit) *
-                (int -> string -> unit) -> in_channel -> unit)
- (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action,
- add_path_action, add_rec_path_action, load_syntax_action) inchan;;
-
-if !Sys.interactive then ()
- else 
-Libobject.relax true;
-(let coqdir = 
-   try Sys.getenv "COQDIR"
-   with Not_found -> 
-     let coqdir = Envars.coqlib () in
-       if Sys.file_exists coqdir then
-	 coqdir
-       else
-	 (msgnl (str "could not find the value of COQDIR"); exit 1) in
-     begin
-       add_rec_path (Filename.concat coqdir "theories")
-	 (Names.make_dirpath [Nameops.coq_root]);
-       add_rec_path (Filename.concat coqdir "contrib")
-	 (Names.make_dirpath [Nameops.coq_root])
-     end;
-(let vernacrc =
-   try
-     Sys.getenv "VERNACRC"
-   with
-       Not_found -> 
-	 List.fold_left 
-	   (fun s1 s2 -> (Filename.concat s1 s2))
-	   coqdir [ "contrib"; "interface"; "vernacrc"] in
-   try
-     (Gramext.warning_verbose := false;
-      coqparser_loop (open_in vernacrc))
-   with
-     | End_of_file -> ()
-     | e ->
-	 (msgnl (Cerrors.explain_exn e);
-	  msgnl (str "could not load the VERNACRC file"));
-	 try
-	   msgnl (str vernacrc)
-	 with
-	     e -> ());
-(try let user_vernacrc =
-   try Some(Sys.getenv "USERVERNACRC")
-   with
-     | Not_found ->
-	 msgnl (str "no .vernacrc file"); None in
-   (match user_vernacrc with
-      	Some f -> coqparser_loop (open_in f)
-      | None -> ())
- with
-   | End_of_file -> ()
-   | e ->
-       msgnl (Cerrors.explain_exn e);
-       msgnl (str "error in your .vernacrc file"));
-msgnl (str "Starting Centaur Specialized Parser Loop");
-try
-  coqparser_loop stdin
-with 
-  | End_of_file -> ()
-  | e -> msgnl(Cerrors.explain_exn e))
diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml
deleted file mode 100644
index a157ca92..00000000
--- a/contrib/interface/paths.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-let int_list_to_string s l =
-    List.fold_left 
-       (fun s -> (fun v -> s ^ " " ^ (string_of_int v)))
-       s
-       l;;
-
-(* Given two paths, this function returns the longest common prefix and the
-   two suffixes. *)
-let rec decompose_path
-     : (int list * int list) -> (int list * int list * int list) =
-   function
-       (a::l,b::m) when a = b ->
-         let (c,p1,p2) = decompose_path (l,m) in
-         (a::c,p1,p2)
-     |  p1,p2 -> [], p1, p2;;
-
-let rec is_prefix p1 p2 = match p1,p2 with
-  [], _ -> true
-| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2
-| _ -> false;;
-
-let rec lex_smaller p1 p2 = match p1,p2 with
-  [], _ -> true
-| a::tl1, b::tl2 when a < b -> true
-| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2
-| _ -> false;;
diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli
deleted file mode 100644
index 26620723..00000000
--- a/contrib/interface/paths.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-val decompose_path : (int list * int list) -> (int list * int list * int list);;
-val int_list_to_string : string -> int list -> string;;
-val is_prefix : int list -> int list -> bool;;
-val lex_smaller : int list -> int list -> bool;;
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
deleted file mode 100644
index 01747aa5..00000000
--- a/contrib/interface/pbp.ml
+++ /dev/null
@@ -1,758 +0,0 @@
-(* A proof by pointing algorithm. *)
-open Util;;
-open Names;;
-open Term;;
-open Tactics;;
-open Tacticals;;
-open Hipattern;;
-open Pattern;;
-open Matching;;
-open Reduction;;
-open Rawterm;;
-open Environ;;
-
-open Proof_trees;;
-open Proof_type;;
-open Tacmach;;
-open Tacexpr;;
-open Typing;;
-open Pp;;
-open Libnames;;
-open Genarg;;
-open Topconstr;;
-open Termops;;
-
-let zz = Util.dummy_loc;;
-
-let hyp_radix = id_of_string "H";;
-
-let next_global_ident = next_global_ident_away true
-
-(* get_hyp_by_name : goal sigma -> string -> constr,
-   looks up for an hypothesis (or a global constant), from its name *)
-let get_hyp_by_name g name =
-  let evd = project g in
-  let env = pf_env g in
-  try (let judgment = 
-         Pretyping.Default.understand_judgment 
-          evd env (RVar(zz, name)) in
-       ("hyp",judgment.uj_type))
-(* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up...
-   Loïc *)
-  with _ -> (let c = Nametab.global (Ident (zz,name)) in
-             ("cste",type_of (Global.env()) Evd.empty (constr_of_global c)))
-;;
-
-type pbp_atom =
-  | PbpTryAssumption of identifier option
-  | PbpTryClear of identifier list
-  | PbpGeneralize of identifier * identifier list
-  | PbpLApply of identifier (* = CutAndApply *)
-  | PbpIntros of intro_pattern_expr located list
-  | PbpSplit
-  (* Existential *)
-  | PbpExists of identifier
-  (* Or *)
-  | PbpLeft
-  | PbpRight
-  (* Head *)
-  | PbpApply of identifier
-  | PbpElim of identifier * identifier list;;
-
-(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics
-   [a1]..[an-1] are atomic (or try of an atomic) tactic and produce
-   exactly one goal, and [an] produces exactly p subgoals
-
-   In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and
-   produces exactly one subgoal, except the last one which may complete the
-   goal
-
-   Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion
-   from atomic to composed tactic
-*)
-
-type pbp_sequence =
-  | PbpThens of pbp_atom list * pbp_sequence list
-  | PbpThen of pbp_atom list
-
-(* This flattens sequences of tactics producing just one subgoal *)
-let chain_tactics tl1 = function
-  | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3)
-  | PbpThen tl2 -> PbpThen (tl1@tl2)
-
-type pbp_rule = (identifier list *
-                    identifier list *
-                    bool *
-                    identifier option *
-                    (types, constr) kind_of_term *
-                    int list *
-                    (identifier list ->
-                     identifier list ->
-                     bool ->
-                       identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) ->
-                    pbp_sequence option;;
-
-
-let make_named_intro id = PbpIntros [zz,IntroIdentifier id];;
-
-let make_clears str_list = PbpThen [PbpTryClear str_list]
-
-let add_clear_names_if_necessary tactic clear_names =
-    match clear_names with
-      [] -> tactic
-    | l -> chain_tactics [PbpTryClear l] tactic;;
-
-let make_final_cmd f optname clear_names constr path =
-    add_clear_names_if_necessary (f optname constr path) clear_names;;
-
-let (rem_cast:pbp_rule) = function
-    (a,c,cf,o, Cast(f,_,_), p, func) ->
-      Some(func a c cf o (kind_of_term f) p)
-  | _ -> None;;
-
-let (forall_intro: pbp_rule) = function
-  (avoid,
-   clear_names,
-   clear_flag,
-   None,
-   Prod(Name x, _, body),
-   (2::path),
-   f) ->
-     let x' = next_global_ident x avoid in
-      Some(chain_tactics [make_named_intro x']
-	      (f (x'::avoid)
-		clear_names clear_flag None (kind_of_term body) path))
-| _ -> None;;
-
-let (imply_intro2: pbp_rule) = function
-  avoid, clear_names,
-  clear_flag, None, Prod(Anonymous, _, body), 2::path, f ->
-   let h' = next_global_ident hyp_radix avoid in
-     Some(chain_tactics [make_named_intro h']
-          (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path))
-  | _ -> None;;
-
-      
-(*
-let (imply_intro1: pbp_rule) = function
-  avoid, clear_names,
-  clear_flag, None, Prod(Anonymous, prem, body), 1::path, f ->
-   let h' = next_global_ident hyp_radix avoid in
-   let str_h' = h' in
-     Some(chain_tactics [make_named_intro str_h']
-            (f (h'::avoid) clear_names clear_flag (Some str_h') 
-		(kind_of_term prem) path))
-  | _ -> None;;
-*)
-
-let make_var id = CRef (Ident(zz, id))
-
-let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l)
-
-let make_pbp_pattern x =
-  make_app (make_var (id_of_string "PBP_META"))
-     [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))]
-
-let rec make_then = function
-  | [] -> TacId []
-  | [t] -> t
-  | 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 (false,true,ImplicitBindings [make_pbp_pattern x]))
-  | PbpGeneralize (h,args) ->
-      let l = List.map make_pbp_pattern args in
-      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 (true,false,[make_var h,NoBindings],None))
-  | PbpElim (hyp_name, names) ->
-      let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in
-      TacAtom
-	(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,false,NoBindings));;
-
-let rec make_pbp_tactic = function
-  | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl)
-  | PbpThens (l,tl) ->
-      TacThens
-        (make_then (List.map make_pbp_atomic_tactic l),
-	 List.map make_pbp_tactic tl)
-
-let (forall_elim: pbp_rule) = function
-  avoid, clear_names, clear_flag, 
-  Some h, Prod(Name x, _, body), 2::path, f ->
-  let h' = next_global_ident hyp_radix avoid in
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-    Some
-     (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h']
-        (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path))
-  | _ -> None;;
-
-
-let (imply_elim1: pbp_rule) = function
-  avoid, clear_names, clear_flag,
-  Some h, Prod(Anonymous, prem, body), 1::path, f ->
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-  let h' = next_global_ident hyp_radix avoid in
-  let _str_h' = (string_of_id h') in
-  Some(PbpThens
-	  ([PbpLApply h],
-	   [chain_tactics [make_named_intro h'] (make_clears (h::clear_names));
-	    f avoid clear_names' false None (kind_of_term prem) path]))
-  | _ -> None;;
-
-
-let (imply_elim2: pbp_rule) = function
-  avoid, clear_names, clear_flag,
-  Some h, Prod(Anonymous, prem, body), 2::path, f ->
-  let clear_names' = if clear_flag then h::clear_names else clear_names in
-  let h' = next_global_ident hyp_radix avoid in
-  Some(PbpThens
-	 ([PbpLApply h],
-          [chain_tactics [make_named_intro h']
-              (f (h'::avoid) clear_names' false (Some h') 
-		      (kind_of_term body) path);
-           make_clears clear_names]))
-  | _ -> None;;
-
-let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s
-
-let constant dir s =  Coqlib.gen_constant "Pbp" ("Init"::dir) s
-
-let andconstr: unit -> constr = Coqlib.build_coq_and;;
-let prodconstr () = constant ["Datatypes"] "prod";;
-let exconstr = Coqlib.build_coq_ex;;
-let sigconstr () = constant ["Specif"] "sig";;
-let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;;
-let orconstr = Coqlib.build_coq_or;;
-let sumboolconstr = Coqlib.build_coq_sumbool;;
-let sumconstr() = constant ["Datatypes"] "sum";;
-let notconstr = Coqlib.build_coq_not;;
-let notTconstr () = constant ["Logic_Type"] "notT";;
-
-let is_matching_local a b = is_matching (pattern_of_constr a) b;;
-
-let rec (or_and_tree_to_intro_pattern: identifier list -> 
-	   constr -> int list -> 
-	     intro_pattern_expr * identifier list * identifier *constr
-	     * int list * int * int) =
-fun avoid c path -> match kind_of_term c, path with
-  | (App(oper, [|c1; c2|]), 2::a::path)
-    when ((is_matching_local (andconstr()) oper) or
-	  (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
-      let id2 = next_global_ident hyp_radix avoid in
-      let cont_expr = if a = 1 then c1 else c2 in
-      let cont_patt, avoid_names, id, c, path, rank, total_branches = 
-	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
-      let patt_list = 
-	if a = 1 then
-	  [zz,cont_patt; zz,IntroIdentifier id2]
-	else
-	  [zz,IntroIdentifier id2; zz,cont_patt] in
-      	(IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, 
-	 total_branches)
-  | (App(oper, [|c1; c2|]), 2::3::path)
-    when ((is_matching_local (exconstr()) oper) or
-	  (is_matching_local (sigconstr()) oper)) ->
-      (match (kind_of_term c2) with 
-	   Lambda (Name x, _, body) ->
-	     let id1 = next_global_ident x avoid in
-	     let cont_patt, avoid_names, id, c, path, rank, total_branches =
-	       or_and_tree_to_intro_pattern (id1::avoid) body path in
-	     (IntroOrAndPattern[[zz,IntroIdentifier id1; zz,cont_patt]],
-	      avoid_names, id, c, path, rank, total_branches)
-	 | _ -> assert false)
-  | (App(oper, [|c1; c2|]), 2::a::path)
-      when ((is_matching_local (orconstr ()) oper) or
-            (is_matching_local (sumboolconstr ()) oper) or
-	    (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) ->
-      let id2 = next_global_ident hyp_radix avoid in
-      let cont_expr = if a = 1 then c1 else c2 in
-      let cont_patt, avoid_names, id, c, path, rank, total_branches =
- 	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
-      let new_rank = if a = 1 then rank else rank+1 in
-      let patt_list =
-	if a = 1 then
-	  [[zz,cont_patt];[zz,IntroIdentifier id2]]
-	else
-	  [[zz,IntroIdentifier id2];[zz,cont_patt]] in
-	(IntroOrAndPattern patt_list, 
-	 avoid_names, id, c, path, new_rank, total_branches+1)
-  | (_, path) -> let id = next_global_ident hyp_radix avoid in
-      (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);;
-
-let auxiliary_goals clear_names clear_flag this_name n_aux others =
-  let clear_cmd = 
-    make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in
-  let rec clear_list = function
-      0 -> others
-    | n -> clear_cmd::(clear_list (n - 1)) in
-  clear_list n_aux;;
-
-
-let (imply_intro3: pbp_rule) = function
-    avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body),
-    1::path, f ->
-      let intro_patt, avoid_names, id, c, p, rank, total_branches =
-	or_and_tree_to_intro_pattern avoid prem path in
-	if total_branches = 1 then
-	  Some(chain_tactics [PbpIntros [zz,intro_patt]]
-		 (f avoid_names clear_names clear_flag (Some id)
-		    (kind_of_term c) path))
-	else
-	  Some
-	    (PbpThens
-	       ([PbpIntros [zz,intro_patt]],
-	    	auxiliary_goals clear_names clear_flag id
-		  (rank - 1)
-		  ((f avoid_names clear_names clear_flag (Some id)
-		      (kind_of_term c) path)::
-		     auxiliary_goals clear_names clear_flag id 
-		     (total_branches - rank) [])))
-  | _ -> None;;
-		 
-
-
-let (and_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag,
-    None, App(and_oper, [|c1; c2|]), 2::a::path, f 
-      ->
-      if ((is_matching_local (andconstr()) and_oper) or
-          (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then
-      	let cont_term = if a = 1 then c1 else c2 in
-      	let cont_cmd = f avoid clear_names false None 
-			 (kind_of_term cont_term) path in
-      	let clear_cmd = make_clears clear_names in
-      	let cmds =
-            (if a = 1 
-	    then [cont_cmd;clear_cmd] 
-	    else [clear_cmd;cont_cmd]) in
-      	Some (PbpThens ([PbpSplit],cmds))
-      else None
-  | _ -> None;;
-
-let exists_from_lambda avoid clear_names clear_flag c2 path f =
-  match kind_of_term c2 with
-    Lambda(Name x, _, body) -> 
-      Some (PbpThens ([PbpExists x],
-		      [f avoid clear_names false None (kind_of_term body) path]))
-  | _ -> None;;
-
-
-let (ex_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(oper, [| c1; c2|]), 2::3::path, f
-      when (is_matching_local (exconstr ()) oper)
- 	or (is_matching_local (sigconstr ()) oper) ->
-	  exists_from_lambda avoid clear_names clear_flag c2 path f
-  | _ -> None;;
-
-let (exT_intro : pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(oper, [| c1; c2|]), 2::2::2::path, f
-      when (is_matching_local (sigTconstr ()) oper) ->
-	exists_from_lambda avoid clear_names clear_flag c2 path f
-  | _ -> None;;
-
-let (or_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(or_oper, [|c1; c2 |]), 2::a::path, f ->
-      if ((is_matching_local (orconstr ()) or_oper) or
-        (is_matching_local (sumboolconstr ()) or_oper) or 
-	(is_matching_local (sumconstr ()) or_oper))
-	  & (a = 1 or a = 2) then
-	let cont_term = if a = 1 then c1 else c2 in
-	let fst_cmd = if a = 1 then PbpLeft else PbpRight in
-	let cont_cmd = f avoid clear_names false None 
-			 (kind_of_term cont_term) path in
-	Some(chain_tactics [fst_cmd] cont_cmd)
-      else
-	None
-  | _ -> None;;
-	
-let dummy_id = id_of_string "Dummy";;
-
-let (not_intro: pbp_rule) = function
-    avoid, clear_names, clear_flag, None,
-    App(not_oper, [|c1|]), 2::1::path, f ->
-      if(is_matching_local (notconstr ()) not_oper) or 
-	(is_matching_local (notTconstr ()) not_oper) then
-	let h' = next_global_ident hyp_radix avoid in
-	Some(chain_tactics [make_named_intro h']
-	       (f (h'::avoid) clear_names false (Some h') 
-		  (kind_of_term c1) path))
-      else
- 	None
-  | _ -> None;;
-
-
-
-
-let elim_with_bindings hyp_name names =
-  PbpElim (hyp_name, names);;
-
-(* This function is used to follow down a path, while staying on the spine of
-   successive products (universal quantifications or implications).
-   Arguments are the current observed constr object and the path that remains
-   to be followed, and an integer indicating how many products have already been
-   crossed.
-   Result is:
-     - a list of string indicating the names of universally quantified variables.
-     - a list of integers indicating the positions of the successive 
-       universally quantified variables.
-     - an integer indicating the number of non-dependent products.
-     - the last constr object encountered during the walk down, and
-     - the remaining path.
-
-   For instance the following session should happen:
-  let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign()))
-     (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in
-     down_prods (tt, [2;2;2], 0)
-  ---> ["P","x"],[0;1], 1, <<(P x)>>, []
-*)
-
-
-let rec down_prods: (types, constr) kind_of_term * (int list) * int -> 
-           identifier list * (int list) * int * (types, constr) kind_of_term *
-  (int list) = 
-   function
-     Prod(Name x, _, body), 2::path, k ->
-	let res_sl, res_il, res_i, res_cstr, res_p 
-	    = down_prods (kind_of_term body, path, k+1) in
-	x::res_sl, (k::res_il), res_i, res_cstr, res_p
-   | Prod(Anonymous, _, body), 2::path, k ->
-        let res_sl, res_il, res_i, res_cstr, res_p 
-	    = down_prods (kind_of_term body, path, k+1) in
-	res_sl, res_il, res_i+1, res_cstr, res_p
-   | cstr, path, _ -> [], [], 0, cstr, path;;
-
-exception Pbp_internal of int list;;
-
-(* This function should be usable to check that a type can be used by the
-   Apply command.  Basically, c is supposed to be the head of some
-   type, where l gives the ranks of all universally quantified variables.
-   It check that these universally quantified variables occur in the head.
-
-   The knowledge I have on constr structures is incomplete.
-*)
-let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = 
-   function c -> function l ->
-   let rec delete n = function
-     | [] -> []
-     | p::tl -> if n = p then tl else p::(delete n tl) in
-   let rec check_rec l = function
-   | App(f, array) ->
-       Array.fold_left (fun l c -> check_rec l (kind_of_term c))
-	 (check_rec l (kind_of_term f)) array
-   | Const _ -> l
-   | Ind _ -> l
-   | Construct _ -> l
-   | Var _ -> l
-   | Rel p ->
-       let result = delete p l in
-       if result = [] then
-	 raise (Pbp_internal [])
-       else
-	 result
-   | _ -> raise (Pbp_internal l) in
-   try 
-     (check_rec l c) = []
-   with Pbp_internal l -> l = [];;
-
-let (mk_db_indices: int list -> int -> int list) =
-  function int_list -> function nprems ->
-   let total = (List.length int_list) + nprems  in
-   let rec mk_db_aux = function
-     [] -> []
-   | a::l -> (total - a)::(mk_db_aux l) in
-   mk_db_aux int_list;;
-     
-
-(* This proof-by-pointing rule is quite complicated, as it attempts to foresee
-   usages of head tactics.  A first operation is to follow the path as far
-   as possible while staying on the spine of products (function down_prods)
-   and then to check whether the next step will be an elim step.  If the 
-   answer is true, then the built command takes advantage of the power of
-   head tactics.  *)
-
-let (head_tactic_patt: pbp_rule) = function
-    avoid, clear_names, clear_flag, Some h, cstr, path, f ->
-    (match down_prods (cstr, path, 0) with
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path)
-      when (((is_matching_local (exconstr ()) oper) (* or
-	      (is_matching_local (sigconstr ()) oper) *))  && a = 3) ->
-		   (match (kind_of_term c2) with
-		     Lambda(Name x, _,body) ->
-		       Some(PbpThens
-		    		 ([elim_with_bindings h str_list],
-				   let x' = next_global_ident x avoid in
-				   let cont_body =
-				     Prod(Name x', c1,
-					    mkProd(Anonymous, body, 
-						   mkVar(dummy_id))) in
-				   let cont_tac 
-				       = f avoid (h::clear_names) false None
-				       cont_body (2::1::path) in
-				   cont_tac::(auxiliary_goals
-						       clear_names clear_flag
-						       h nprems [])))
-		     | _ -> None)
-    | (str_list, _, nprems, 
-       App(oper,[|c1|]), 2::1::path) 
-      	when
- 	  (is_matching_local (notconstr ()) oper) or
- 	  (is_matching_local (notTconstr ()) oper) ->
-	 Some(chain_tactics [elim_with_bindings h str_list]
-		 (f avoid clear_names false None (kind_of_term c1) path))
-    | (str_list, _, nprems, 
-       App(oper, [|c1; c2|]), 2::a::path) 
-      when ((is_matching_local (andconstr()) oper) or
-	    (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
-	let h1 = next_global_ident hyp_radix avoid in
-	let h2 = next_global_ident hyp_radix (h1::avoid) in
-	Some(PbpThens
-                  ([elim_with_bindings h str_list],
-		    let cont_body = 
-		      if a = 1 then c1 else c2 in
-		    let cont_tac = 
-		      f (h2::h1::avoid) (h::clear_names) 
-                        false (Some (if 1 = a then h1 else h2))
-                        (kind_of_term cont_body) path in
-		      (chain_tactics 
-			 [make_named_intro h1; make_named_intro h2]
-			 cont_tac)::
-	       (auxiliary_goals clear_names clear_flag h nprems [])))
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
-      when ((is_matching_local (sigTconstr()) oper)) & a = 2 ->
-		   (match (kind_of_term c2),path with
-		     Lambda(Name x, _,body), (2::path) ->
-		       Some(PbpThens
-		    		 ([elim_with_bindings h str_list],
-				   let x' = next_global_ident x avoid in
-				   let cont_body =
-				     Prod(Name x', c1,
-					    mkProd(Anonymous, body, 
-						   mkVar(dummy_id))) in
-				   let cont_tac 
-				       = f avoid (h::clear_names) false None
-				       cont_body (2::1::path) in
-				   cont_tac::(auxiliary_goals
-						       clear_names clear_flag
-						       h nprems [])))
-		     | _ -> None)
-    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
-	when ((is_matching_local (orconstr ()) oper) or
-              (is_matching_local (sumboolconstr ()) oper) or
-	      (is_matching_local (sumconstr ()) oper)) &
-                (a = 1 or a = 2) ->
-	  Some(PbpThens
-		    ([elim_with_bindings h str_list],
-		      let cont_body =
-			if a = 1 then c1 else c2 in
-                      (* h' is the name for the new intro *)
-		      let h' = next_global_ident hyp_radix avoid in
-		      let cont_tac =
-                        chain_tactics 
-			  [make_named_intro h']
-			  (f 
-			     (* h' should not be used again *)
-			     (h'::avoid)
-			     (* the disjunct itself can be discarded *)
-			     (h::clear_names) false (Some h')
-                             (kind_of_term cont_body) path) in
-		      let snd_tac = 
-			chain_tactics
-			   [make_named_intro h']
-			   (make_clears (h::clear_names)) in
-		      let tacs1 = 
-			if a = 1 then
-			  [cont_tac; snd_tac]
-		      	else
-			  [snd_tac; cont_tac] in
-		      tacs1@(auxiliary_goals (h::clear_names)
-				   false dummy_id nprems [])))
-    | (str_list, int_list, nprems, c, []) 
-        when  (check_apply c (mk_db_indices int_list nprems)) &
-              (match c with Prod(_,_,_) -> false
-              |  _ -> true) &
-              (List.length int_list) + nprems > 0 ->
-          Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names)
-    | _ -> None)
-  | _ -> None;;
-      
-
-let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2;
-                      forall_elim; imply_intro3; imply_elim1; imply_elim2;
-		      and_intro; or_intro; not_intro; ex_intro; exT_intro];;
-
-
-let try_trace = ref true;;
-
-let traced_try (f1:tactic) g =
-    try (try_trace := true; tclPROGRESS f1 g)
-    with e when Logic.catchable_exception e ->
-      (try_trace := false; tclIDTAC g);;
-
-let traced_try_entry = function
-     [Tacexp t] ->
-           traced_try (Tacinterp.interp t)
-  |  _ -> failwith "traced_try_entry received wrong arguments";;
-
-
-(* When the recursive descent along the path is over, one includes the
-   command requested by the point-and-shoot strategy.  Default is
-   Try Assumption--Try Exact.  *)
-
-
-let default_ast optname constr path = PbpThen [PbpTryAssumption optname]
-
-(* This is the main proof by pointing function. *)
-(* avoid: les noms a ne pas utiliser *)
-(* final_cmd: la fonction appelee par defaut *)
-(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *)
-
-let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path =
-  let rec try_all_rules rl =
-      match rl with 
-         f::tl ->
-           (match f (avoid, clear_names, clear_flag,
-                     opt_name, constr, path, pbpt final_cmd) with
-              Some(ast) -> ast
-            | None -> try_all_rules tl)
-      |	 [] -> make_final_cmd final_cmd opt_name clear_names constr path
-  in try_all_rules (!pbp_rules);;
-
-(* these are the optimisation functions. *)
-(* This function takes care of flattening successive then commands. *)
-
-
-(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy
-    that t is some [PbpAtom t] *)
-
-(* This optimization function takes care of compacting successive Intro commands
-   together. *)
-
-let rec group_intros names = function
-    [] -> (match names with
-        [] -> []
-      | l -> [PbpIntros l])
-  | (PbpIntros ids)::others -> group_intros (names@ids) others
-  | t1::others ->
-      (match names with
-	  [] -> t1::(group_intros [] others)
-	| l -> (PbpIntros l)::t1::(group_intros [] others))
-
-let rec optim2 = function
-  | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2)
-  | PbpThen tl -> PbpThen (group_intros [] tl)
-
-
-let rec cleanup_clears str_list = function
-    [] -> []
-  | x::tail ->
-      if List.mem x str_list then cleanup_clears str_list tail
-      else x::(cleanup_clears str_list tail);;
-
-(* This function takes care of compacting instanciations of universal
-   quantifications. *)
-
-let rec optim3_aux str_list = function
-    (PbpGeneralize (h,l1))::
-    (PbpIntros [zz,IntroIdentifier s])::(PbpGeneralize (h',l2))::others
-      when s=h' ->
-      optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others)
-  | (PbpTryClear names)::other ->
-      (match cleanup_clears str_list names with
-	  [] -> other
-	| l -> (PbpTryClear l)::other)
-  | a::l -> a::(optim3_aux str_list l) 
-  | [] -> [];;
-
-let rec optim3 str_list = function
-    PbpThens (tl1, tl2) ->
-      PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2)
-  | PbpThen tl -> PbpThen (optim3_aux str_list tl)
-
-let optim x = make_pbp_tactic (optim3 [] (optim2 x));;
-
-(* TODO
-add_tactic "Traced_Try" traced_try_entry;;
-*)
-
-let rec tactic_args_to_ints = function
-    [] -> []
-  | (Integer n)::l -> n::(tactic_args_to_ints l)
-  | _ -> failwith "expecting only numbers";;
-
-(*
-let pbp_tac display_function = function 
-            (Identifier a)::l -> 
-                 (function g ->
-                    let str = (string_of_id a) in
-		    let (ou,tstr) = (get_hyp_by_name g str) in
-		    let exp_ast =
-		      pbpt default_ast
-		        (match ou with
-			       "hyp" ->(pf_ids_of_hyps g)
-			       |_ -> (a::(pf_ids_of_hyps g)))
-                        []
-			false
-			(Some str)
-			(kind_of_term tstr)
-                        (tactic_args_to_ints l) in
-                    (display_function (optim exp_ast);
-                        tclIDTAC g))
-          | ((Integer n)::_) as l -> 
-                 (function g ->
-                    let exp_ast =
-                       (pbpt default_ast (pf_ids_of_hyps g) [] false
-                          None (kind_of_term (pf_concl g))
-			  (tactic_args_to_ints l)) in
-                     (display_function (optim exp_ast);
-                       tclIDTAC g))
-          | [] -> (function g ->
-                     (display_function (default_ast None (pf_concl g) []);
-                      tclIDTAC g))
-          |  _ -> failwith "expecting other arguments";;
-
-
-*)
-let pbp_tac display_function idopt nl =
-  match idopt with
-    | Some str ->
-        (function g ->
-	  let (ou,tstr) = (get_hyp_by_name g str) in
-	  let exp_ast =
-	    pbpt default_ast
-	      (match ou with
-		  "hyp" ->(pf_ids_of_hyps g)
-		|_ -> (str::(pf_ids_of_hyps g)))
-              []
-	      false
-	      (Some str)
-	      (kind_of_term tstr)
-              nl in
-              (display_function (optim exp_ast); tclIDTAC g))
-    | None ->
-	if nl <> [] then
-          (function g ->
-            let exp_ast =
-              (pbpt default_ast (pf_ids_of_hyps g) [] false
-		None (kind_of_term (pf_concl g)) nl) in
-            (display_function (optim exp_ast); tclIDTAC g))
-	else
-          (function g ->
-            (display_function
-	       (make_pbp_tactic (default_ast None (pf_concl g) []));
-            tclIDTAC g));;
-
-
diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli
deleted file mode 100644
index 9daba184..00000000
--- a/contrib/interface/pbp.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    Names.identifier option -> int list -> Proof_type.tactic
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
deleted file mode 100644
index 2ab62763..00000000
--- a/contrib/interface/showproof.ml
+++ /dev/null
@@ -1,1813 +0,0 @@
-(*
-#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
-open Coqast;;
-*)
-open Environ
-open Evd
-open Names
-open Nameops
-open Libnames
-open Term
-open Termops
-open Util
-open Proof_type
-open Pfedit
-open Translate
-open Term
-open Reductionops
-open Clenv
-open Typing
-open Inductive
-open Inductiveops
-open Vernacinterp
-open Declarations
-open Showproof_ct
-open Proof_trees
-open Sign
-open Pp
-open Printer
-open Rawterm
-open Tacexpr
-open Genarg
-(*****************************************************************************)
-(*
-   Arbre de preuve maison:
-   
-*)
-
-(* hypotheses *)
-
-type nhyp = {hyp_name : identifier;
-             hyp_type : Term.constr;
-             hyp_full_type: Term.constr}
-;;
-
-type ntactic = tactic_expr
-;;
-
-type nproof =
-    Notproved
-  | Proof of ntactic * (ntree list)
-
-and ngoal=
-     {newhyp : nhyp list;
-      t_concl : Term.constr;
-      t_full_concl: Term.constr;
-      t_full_env: Environ.named_context_val}
-and ntree=
-      {t_info:string;
-	t_goal:ngoal;
-       	t_proof : nproof}
-;;
-
-
-let hyps {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = lh
-;;
-
-let concl {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = g
-;;
-
-let proof {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = p
-;;
-let g_env {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = ge
-;;
-let sub_ntrees t =
-  match (proof t) with
-    Notproved -> []
-  | Proof (_,l) -> l
-;;
-
-let tactic t =
-  match (proof t) with
-    Notproved -> failwith "no tactic applied"
-  | Proof (t,_) -> t
-;;
-
-
-(* 
-un arbre est clos s'il ne contient pas de sous-but non prouves,
-ou bien s'il a un cousin gauche qui n'est pas clos 
-ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but.
-*)
-let update_closed nt =
-  let found_not_closed=ref false in
-  let rec update {t_info=b; t_goal=g; t_proof =p} =
-    if !found_not_closed
-    then  {t_info="to_prove"; t_goal=g; t_proof =p}
-    else
-      match p with
-      	Notproved -> found_not_closed:=true;
-	  {t_info="not_proved"; t_goal=g; t_proof =p}
-      | Proof(tac,lt) ->
-	  let lt1=List.map update lt in
-	  let b=ref "proved" in
-	  (List.iter
-	     (fun x ->
-	       if x.t_info ="not_proved" then b:="not_proved") lt1;
-	   {t_info=(!b);
-	     t_goal=g;
-             t_proof=Proof(tac,lt1)})
-  in update nt
-    ;;
-    
-      
-(*
-    type complet avec les hypotheses.
-*)
-
-let long_type_hyp lh t=
-   let t=ref t in
-   List.iter (fun (n,th) ->
-         let ni = match n with Name ni -> ni | _ -> assert false in
-         t:= mkProd(n,th,subst_term (mkVar ni) !t))
-       (List.rev lh);
-   !t
-;;
-
-(* let long_type_hyp x y = y;; *)
-
-(* Expansion des tactikelles *)
-
-let seq_to_lnhyp sign sign' cl =
-      let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in
-      let nh=List.map (fun (id,c,ty) -> 
-             {hyp_name=id;
-              hyp_type=ty;
-              hyp_full_type=
-                let res= long_type_hyp !lh ty in
-                lh:=(!lh)@[(Name id,ty)];
-                res})
-              sign'
-      in
-      {newhyp=nh;
-       t_concl=cl;
-       t_full_concl=long_type_hyp !lh cl;
-       t_full_env = Environ.val_of_named_context (sign@sign')}
-;;
-
-
-let rule_is_complex r =
-   match r with
-       Nested (Tactic 
-		 ((TacArg (Tacexp _)
-		 |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true
-   |_ -> false
-;;
-
-let rule_to_ntactic r =
-   let rt =
-     (match r with
-       Nested(Tactic (t,_),_) -> t
-     | 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
-           TacArg (Tacexp _) as t -> t
-          | _ -> assert false)
-
-   else rt
-;;
-
-(* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt  *)
-
-
-let fill_unproved nt l =
-  let lnt = ref l in
-  let rec fill nt =
-    let {t_goal=g;t_proof=p}=nt in
-       match p with
-        Notproved -> let p=List.hd (!lnt) in
-                     lnt:=List.tl (!lnt);
-                     {t_info="to_prove";t_goal=g;t_proof=p}
-       |Proof(tac,lt) ->
-          {t_info="to_prove";t_goal=g;
-           t_proof=Proof(tac,List.map fill lt)}
-  in fill nt
-;;
-(* Differences entre signatures *)
-
-let new_sign osign sign =
-    let res=ref [] in
-    List.iter (fun (id,c,ty) ->
-		   try (let  (_,_,_ty1)= (lookup_named id osign) in
-			())
-		   with Not_found -> res:=(id,c,ty)::(!res))
-              sign;
-    !res
-;;
-
-let old_sign osign sign =
-    let res=ref [] in
-    List.iter (fun (id,c,ty) ->
-		   try (let (_,_,ty1) = (lookup_named id osign) in
-			if ty1 = ty then res:=(id,c,ty)::(!res))
-		   with Not_found -> ())
-              sign;
-    !res
-;;
-
-(* convertit l'arbre de preuve courant en ntree *)
-let  to_nproof sigma osign pf =
-  let rec to_nproof_rec sigma osign pf =
-    let {evar_hyps=sign;evar_concl=cl} = pf.goal in
-    let sign = Environ.named_context_of_val sign in
-    let nsign = new_sign osign sign in 
-    let oldsign = old_sign osign sign in 
-    match pf.ref with
-      
-      None -> {t_info="to_prove";
-	      	t_goal=(seq_to_lnhyp oldsign nsign cl);
-              	t_proof=Notproved}
-    | Some(r,spfl) ->
-      	if rule_is_complex r
-      	then (
-	  let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in
-          let ntree= fill_unproved p1 
-              (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof)
-		 spfl) in
-	  (match r with
-	       Nested(Tactic (TacAtom (_, TacAuto _),_),_) ->
-		 if spfl=[]
-		 then
-	      	   {t_info="to_prove";
-	    	    t_goal= {newhyp=[];
-			     t_concl=concl ntree;
-			     t_full_concl=ntree.t_goal.t_full_concl;
-			     t_full_env=ntree.t_goal.t_full_env};
-		    t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
-		 else ntree
-	     | _ -> ntree))
-      	else
-	  {t_info="to_prove";
-	    t_goal=(seq_to_lnhyp oldsign nsign cl);
-       	    t_proof=(Proof (rule_to_ntactic r,
-			      List.map (fun x -> to_nproof_rec sigma sign x) spfl))}
-  in update_closed (to_nproof_rec sigma osign pf)
-    ;;
-
-(* 
-  recupere l'arbre de preuve courant.
-*)
-
-let get_nproof () =
-  to_nproof (Global.env()) []
-            (Tacmach.proof_of_pftreestate (get_pftreestate()))
-;;
-
-    
-(*****************************************************************************)
-(*
-   Pprinter
-*)
-
-let pr_void () = sphs "";;
-
-let list_rem l = match l with [] -> [] |x::l1->l1;;
-
-(* liste de chaines *)
-let prls l = 
-   let res = ref (sps (List.hd l)) in
-   List.iter (fun s -> 
-     res:= sphv [ !res; spb; sps s]) (list_rem l);
-   !res
-;;
-
-let prphrases f l = 
-   spv (List.map (fun s -> sphv [f s; sps ","]) l)
-;;
-
-(* indentation *)
-let spi = spnb 3;;
-
-(* en colonne *)
-let prl f l = 
-   if l=[] then spe else spv (List.map f l);;
-(*en colonne,  avec indentation *)
-let prli f l =  
-   if l=[] then spe else sph [spi; spv (List.map f l)];;
-
-(* 
-  Langues.
-*)
-
-let rand l =
-  List.nth l (Random.int (List.length l))
-;;
-
-type natural_languages = French | English;;
-let natural_language = ref French;;
-
-(*****************************************************************************)
-(*
-   Les liens html pour proof-by-pointing
-*)
-
-(* le path du but en cours. *)
-
-let path=ref[1];;
-
-let ftag_apply =ref (fun (n:string) t -> spt t);;
-
-let ftag_case =ref (fun n -> sps n);;
-
-let ftag_elim =ref (fun n ->  sps n);;
-
-let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);;
-
-let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);;
-
-let ftag_uselemma =ref (fun h t ->
-  let intro = match !natural_language with
-    French -> "par"
-  | English -> "by"
-  in
-  spuselemma intro h t);;
-
-let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);;
-
-let tag_apply = !ftag_apply;;
-
-let tag_case = !ftag_case;;
-
-let tag_elim = !ftag_elim;;
-
-let tag_uselemma = !ftag_uselemma;;
-
-let tag_hyp = !ftag_hyp;;
-
-let tag_hypt = !ftag_hypt;;
-
-let tag_toprove = !ftag_toprove;;
-
-(*****************************************************************************)
-
-(* pluriel *)
-let txtn n s =
-  if n=1 then s
-  else match s with
-    |"un" -> "des"
-    |"a" -> ""
-    |"an" -> ""
-    |"une" -> "des"
-    |"Soit" -> "Soient"
-    |"Let" -> "Let"
-    | s -> s^"s"
-;;
-
-let _et () =  match !natural_language with
-    French -> sps "et"
-| English -> sps "and"
-;;
-
-let name_count = ref 0;;
-let new_name () =
-  name_count:=(!name_count)+1;
-  string_of_int !name_count
-;;
-
-let enumerate f ln =
-  match ln with
-    [] -> []
-  | [x] -> [f x]
-  |ln -> 
-  let rec enum_rec f ln = 
-     (match ln with 
-       [x;y] -> [f x; spb; sph [_et ();spb;f y]]
-      |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l)
-      | _ -> assert false)
-  in enum_rec f ln
-;;
-
-
-let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());;
-
-let sp_tac tac = failwith "TODO"
-
-let soit_A_une_proposition nh ln t=  match !natural_language with
-    French ->
-      sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-            @[spb; prls [txtn nh "une";txtn nh "proposition"]])
-| English ->
-      sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln)
-            @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]])
-;;
-
-let on_a ()=  match !natural_language with
-  French -> rand ["on a "]
-| English ->rand ["we have "]
-;;
-
-let bon_a ()=  match !natural_language with
-  French -> rand ["On a "]
-| English ->rand ["We have "]
-;;
-
-let soit_X_un_element_de_T nh ln t =  match !natural_language with
-  French ->
-    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls [txtn nh "un";txtn nh "élément";"de"]]
-          @[spb; spt t])
-| English ->
-    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]]
-          @[spb; spt t])
-;;
-
-let soit_F_une_fonction_de_type_T nh ln t =  match !natural_language with
-  French ->
-    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]]
-          @[spb; spt t])
-| English ->
-    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
-          @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]]
-          @[spb; spt t])
-;;
-
-
-let telle_que nh =  match !natural_language with
-    French -> [prls [" ";txtn nh "telle";"que";" "]]
-| English -> [prls [" "; "such";"that";" "]]
-;;
-
-let tel_que nh =  match !natural_language with
-    French -> [prls [" ";txtn nh "tel";"que";" "]]
-| English -> [prls [" ";"such";"that";" "]]
-;;
-
-let supposons () =  match !natural_language with
-    French -> "Supposons "
-|  English -> "Suppose "
-;;
-
-let cas () =  match !natural_language with
-    French -> "Cas"
-|  English -> "Case"
-;;
-
-let donnons_une_proposition () =  match !natural_language with
-    French -> sph[ (prls ["Donnons";"une";"proposition"])]
-|  English -> sph[ (prls ["Let us give";"a";"proposition"])]
-;;
-
-let montrons g =  match !natural_language with
-    French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]);
-		   spb; spt g; sps ". "]
-|  English -> sph[ sps (rand ["Let us";"Now"]);spb;
-		   sps (rand ["prove";"show"]);
-		   spb; spt g; sps ". "]
-;;
-
-let calculons_un_element_de g =  match !natural_language with
-    French -> sph[ (prls ["Calculons";"un";"élément";"de"]);
-		   spb; spt g; sps ". "]
-|  English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]);
-		   spb; spt g; sps ". "]
-;;
-
-let calculons_une_fonction_de_type g =  match !natural_language with
-    French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]);
-                spb; spt g; sps ". "]
-|  English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]);
-                spb; spt g; sps ". "];;
-
-let en_simplifiant_on_obtient g =  match !natural_language with
-    French ->
-      sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"];
-		     rand ["on doit";"il reste à"];
-		     rand ["prouver";"montrer";"démontrer"]]);
-		     spb; spt g; sps ". "]
-|  English ->
-      sphv [ (prls [rand ["After simplification,"; "Simplifying,"];
-		     rand ["we must";"it remains to"];
-		     rand ["prove";"show"]]);
-		     spb; spt g; sps ". "] ;;
-
-let on_obtient g =  match !natural_language with
-  French -> sph[ (prls [rand ["on doit";"il reste à"];
-			 rand ["prouver";"montrer";"démontrer"]]);
-                 spb; spt g; sps ". "]
-|  English ->sph[ (prls [rand ["we must";"it remains to"];
-		     rand ["prove";"show"]]);
-                  spb; spt g; sps ". "]
-;;
-
-let reste_a_montrer g =  match !natural_language with
-    French -> sph[ (prls ["Reste";"à";
-			   rand ["prouver";"montrer";"démontrer"]]);
-                spb; spt g; sps ". "]
-|  English -> sph[ (prls ["It remains";"to";
-			   rand ["prove";"show"]]);
-                spb; spt g; sps ". "] 
-;;
-
-let discutons_avec_A type_arg  =  match !natural_language with
-    French -> sphv [sps "Discutons"; spb; sps "avec"; spb;
-				   spt type_arg; sps ":"] 
-|  English -> sphv [sps "Let us discuss"; spb; sps "with"; spb;
-				   spt type_arg; sps ":"] 
-;;
-
-let utilisons_A arg1  =  match !natural_language with
-    French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]);
-		     spb; spt arg1; sps ":"] 
-|  English -> sphv [sps (rand ["Let us use";"With";"With the help of"]);
-		     spb; spt arg1; sps ":"] 
-;;
-
-let selon_les_valeurs_de_A arg1  =  match !natural_language with
-    French -> sphv [  (prls ["Selon";"les";"valeurs";"de"]);
-                      spb; spt arg1; sps ":"] 
-|  English -> sphv [  (prls ["According";"values";"of"]);
-                      spb; spt arg1; sps ":"] 
-;;
-
-let de_A_on_a arg1  =  match !natural_language with
-    French -> sphv [  sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb;
-		      sps (rand ["on a:";"on déduit:";"on obtient:"])]
-|  English -> sphv [  sps (rand ["From";"With";"Thanks to"]); spb;
-		     spt arg1; spb;
-		      sps (rand ["we have:";"we deduce:";"we obtain:"])]
-;;
-
-
-let procedons_par_recurrence_sur_A arg1  =  match !natural_language with
-    French ->  sphv [  (prls ["Procédons";"par";"récurrence";"sur"]);
-			  spb; spt arg1; sps ":"]
-|  English -> sphv [  (prls ["By";"induction";"on"]);
-			  spb; spt arg1; sps ":"]
-;;
-
-
-let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A 
-  nfun tfun narg =  match !natural_language with
-    French ->  sphv [  
-                    sphv [ prls ["Calculons";"la";"fonction"];
-                     spb; sps (string_of_id nfun);spb;
-                     prls ["de";"type"];
-                     spb; spt tfun;spb;
-                     prls ["par";"récurrence";"sur";"son";"argument"];
-                     spb; sps (string_of_int narg); sps ":"]
-                 ]
-|  English ->  sphv [  
-                    sphv [ prls ["Let us compute";"the";"function"];
-                     spb; sps (string_of_id nfun);spb;
-                     prls ["of";"type"];
-                     spb; spt tfun;spb;
-                     prls ["by";"induction";"on";"its";"argument"];
-                     spb; sps (string_of_int narg); sps ":"]
-                 ]
-
-;;
-let pour_montrer_G_la_valeur_recherchee_est_A g arg1  =
-  match !natural_language with
-    French ->  sph [sps "Pour";spb;sps "montrer"; spt g; spb;
-		     sps ","; spb; sps "choisissons";spb;
-		     spt arg1;sps ". " ]
-|  English ->  sph [sps "In order to";spb;sps "show"; spt g; spb;
-		     sps ","; spb; sps "let us choose";spb;
-		     spt arg1;sps ". " ]
-;;
-
-let on_se_sert_de_A   arg1  =  match !natural_language with
-    French ->  sph [sps "On se sert de";spb ;spt arg1;sps ":" ]
-|  English ->  sph [sps "We use";spb ;spt arg1;sps ":" ]
-;;
-
-
-let d_ou_A g  =  match !natural_language with
-    French ->  sph [spi; sps "d'où";spb ;spt g;sps ". " ]
-|  English -> sph [spi; sps "then";spb ;spt g;sps ". " ]
-;;
-
-
-let coq_le_demontre_seul ()  =  match !natural_language with
-    French ->   rand [prls ["Coq";"le";"démontre"; "seul."];
-		       sps "Fastoche.";
-		     sps "Trop cool"]
-|  English -> 	rand [prls ["Coq";"shows";"it"; "alone."];
-		       sps "Fingers in the nose."]	      
-;;
-
-let de_A_on_deduit_donc_B arg g  =  match !natural_language with
-    French -> sph
-             [  sps "De"; spb; spt arg; spb; sps "on";spb;
-                sps "déduit";spb; sps "donc";spb;  spt g ]
-|  English -> sph
-             [  sps "From"; spb; spt arg; spb; sps "we";spb;
-                sps "deduce";spb; sps "then";spb;  spt g ]
-;;
-
-let _A_est_immediat_par_B g arg  =  match !natural_language with
-    French -> sph [  spt g;  spb; (prls ["est";"immédiat";"par"]);
-                     spb;  spt arg ] 
-|  English -> sph [  spt g;  spb; (prls ["is";"immediate";"from"]);
-                     spb;  spt arg ] 
-;;
-
-let le_resultat_est arg  =  match !natural_language with
-    French -> sph [  (prls ["le";"résultat";"est"]);
-                    spb; spt arg ] 
-|  English -> sph [  (prls ["the";"result";"is"]);
-                    spb; spt arg ];;
-
-let on_applique_la_tactique tactic tac =  match !natural_language with
-  French -> sphv 
-      [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac]
-|  English -> sphv 
-      [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac]
-;;
-
-let de_A_il_vient_B arg g  =  match !natural_language with
-    French -> sph
-             [  sps "De"; spb; spt arg; spb; 
-               sps "il";spb; sps "vient";spb; spt g; sps ". " ] 
-|  English -> sph
-             [  sps "From"; spb; spt arg; spb; 
-               sps "it";spb; sps "comes";spb; spt g; sps ". " ] 
-;;
-
-let ce_qui_est_trivial ()  =  match !natural_language with
-    French -> sps "Trivial."
-|  English -> sps "Trivial."
-;;
-
-let en_utilisant_l_egalite_A arg  =  match !natural_language with
-    French -> sphv [  sps "En"; spb;sps "utilisant"; spb;
-                   sps "l'egalite"; spb; spt arg; sps ","
-                  ]
-|  English -> sphv [  sps "Using"; spb;
-                   sps "the equality"; spb; spt arg; sps ","
-                  ]
-;;
-
-let simplifions_H_T hyp thyp =  match !natural_language with
-    French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:";
-		     spb;spt thyp;sps "."]
-|  English ->  sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:";
-		     spb;spt thyp;sps "."]
-;;
-
-let grace_a_A_il_suffit_de_montrer_LA arg lg=
-  match !natural_language with
-    French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb;
-		      spt arg;sps ",";spb;
-		     sps "il suffit";spb; sps "de"; spb;
-		      sps (rand["prouver";"montrer";"démontrer"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-|  English -> sphv ([sps (rand ["Thanks to";"With"]);spb;
-		      spt arg;sps ",";spb;
-		     sps "it suffices";spb; sps "to"; spb;
-		      sps (rand["prove";"show"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-;;
-let reste_a_montrer_LA lg=
-  match !natural_language with
-    French -> sphv ([ sps "Il reste";spb; sps "à"; spb;
-		      sps (rand["prouver";"montrer";"démontrer"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-|  English -> sphv ([ sps "It remains";spb; sps "to"; spb;
-		      sps (rand["prove";"show"]); spb]
-		     @[spv (enumerate (fun x->x) lg)])
-;;
-(*****************************************************************************)
-(*
-  Traduction des hypothèses.
-*)
-
-type n_sort=
-      Nprop
-    | Nformula
-    | Ntype
-    | Nfunction
-;;
-
-   
-let sort_of_type t ts =
-   let t=(strip_outer_cast t) in
-   if is_Prop t
-   then Nprop
-   else 
-       match ts with
-         Prop(Null) -> Nformula
-        |_ -> (match (kind_of_term t) with
-                Prod(_,_,_) -> Nfunction
-               |_ -> Ntype)
-;;
-
-let adrel (x,t) e =
-    match x with 
-      Name(xid) -> Environ.push_rel (x,None,t) e
-    | Anonymous -> Environ.push_rel (x,None,t) e
-
-let rec nsortrec vl x = 
-     match (kind_of_term x) with
-     Prod(n,t,c)->
-        let vl = (adrel (n,t) vl) in nsortrec vl c
-   | Lambda(n,t,c) ->
-        let vl = (adrel (n,t) vl) in nsortrec vl c
-   | App(f,args) -> nsortrec vl f
-   | Sort(Prop(Null)) -> Prop(Null)
-   | Sort(c) -> c
-   | Ind(ind) ->
-          let (mib,mip) = lookup_mind_specif vl ind in
-	  new_sort_in_family (inductive_sort_family mip)
-   | Construct(c) ->
-          nsortrec vl (mkInd (inductive_of_constructor c))
-   | Case(_,x,t,a) 
-        -> nsortrec vl x
-   | Cast(x,_, t)-> nsortrec vl t
-   | Const c  -> nsortrec vl (Typeops.type_of_constant vl c)
-   | _ -> nsortrec vl (type_of vl Evd.empty x)
-;;
-let nsort x =
-    nsortrec  (Global.env()) (strip_outer_cast x)
-;;
-
-let sort_of_hyp h = 
-  (sort_of_type h.hyp_type (nsort h.hyp_full_type))
-;;
-
-(* grouper les hypotheses successives de meme type, ou logiques.
-   donne une liste de liste *)
-let rec group_lhyp lh =
-    match lh with
-     [] -> []
-    |[h] -> [[h]]
-    |h::lh ->
-      match group_lhyp lh with
-       (h1::lh1)::lh2 -> 
-        if h.hyp_type=h1.hyp_type
-          || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula)
-        then (h::(h1::lh1))::lh2
-        else [h]::((h1::lh1)::lh2)
-     |_-> assert false
-;;
-	
-(* ln noms des hypotheses, lt leurs types *)
-let natural_ghyp (sort,ln,lt) intro =
-  let t=List.hd lt in
-  let nh=List.length ln in
-  let _ns=List.hd ln in
-  match sort with
-    Nprop -> soit_A_une_proposition nh ln t
-  | Ntype -> soit_X_un_element_de_T nh ln t
-  | Nfunction -> soit_F_une_fonction_de_type_T nh ln t
-  | Nformula -> 
-      sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t)
-			    (List.combine ln lt)))
-;;
-
-(* Cas d'une hypothese *)
-let natural_hyp h = 
-   let ns= string_of_id h.hyp_name in
-   let t=h.hyp_type in
-   let ts= (nsort h.hyp_full_type) in
-   natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ())
-;;
-
-let rec pr_ghyp lh intro=
-     match lh with
-       [] -> []
-     | [(sort,ln,t)]->
-         (match sort with
-           Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "]
-         | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "])
-     | (sort,ln,t)::lh  ->
-       let hp= 
-        ([natural_ghyp(sort,ln,t) intro]
-         @(match lh with
-           [] -> [sps ". "]
-          |(sort1,ln1,t1)::lh1  ->
-             match sort1 with
-               Nformula -> 
-                 (let nh=List.length ln in
-                     match sort with
-                   Nprop -> telle_que nh 
-                  |Nfunction -> telle_que nh 
-                  |Ntype -> tel_que nh 
-                  |Nformula -> [sps ". "])
-             | _ -> [sps ". "])) in
-        (sphv hp)::(pr_ghyp lh "")
-;;
-
-(* traduction d'une liste d'hypotheses groupees. *)
-let prnatural_ghyp llh intro=
-  if llh=[]
-  then spe
-  else
-    sphv (pr_ghyp (List.map
-		     (fun lh ->
-		       let h=(List.hd lh) in
-		       let sh = sort_of_hyp h in
-		       let lhname = (List.map (fun h ->
-			 string_of_id h.hyp_name) lh) in
-		       let lhtype = (List.map (fun h -> h.hyp_type) lh) in
-		       (sh,lhname,lhtype))
-		     llh) intro)
-;;
-
-
-(*****************************************************************************)
-(*
-    Liste des hypotheses.
-*)
-type type_info_subgoals_hyp=
-    All_subgoals_hyp
-  | Reduce_hyp
-  | No_subgoals_hyp
-  | Case_subgoals_hyp of string (* word for introduction *)
-	* Term.constr (* variable *)
-        * string (* constructor *)
-        * int (* arity *)
-        * int (* number of constructors *)
-  | Case_prop_subgoals_hyp of string (* word for introduction *)
-	* Term.constr (* variable *)
-        * int (* index of constructor *)
-        * int (* arity *)
-        * int (* number of constructors *)
-  | Elim_subgoals_hyp of Term.constr (* variable *)
-        * string (* constructor *)
-        * int (* arity *)
-        * (string list) (* rec hyp *)
-        * int (* number of constructors *)
-  | Elim_prop_subgoals_hyp of Term.constr (* variable *)
-        * int (* index of constructor *)
-        * int (* arity *)
-        * (string list) (* rec hyp *)
-        * int (* number of constructors *)
-;;
-let rec nrem l n =
-  if n<=0 then l else nrem (list_rem l) (n-1)
-;;
-
-let rec nhd l n =
-  if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1))
-;;
-
-let par_hypothese_de_recurrence () =  match !natural_language with
-    French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])]
-| English -> sphv [(prls ["by";"induction";"hypothesis";","])]
-;;
-
-let  natural_lhyp lh hi =
-  match hi with
-    All_subgoals_hyp -> 
-        ( match lh with
-          [] -> spe
-        |_-> prnatural_ghyp (group_lhyp lh) (supposons ()))
-  | Reduce_hyp ->
-      (match lh with
-	[h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type
-      |	_-> spe)
-  | No_subgoals_hyp -> spe
-  |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *)
-      let s=ref c in
-      for i=1 to a do
-        let nh=(List.nth lh (i-1)) in
-        s:=(!s)^" "^(string_of_id nh.hyp_name);
-      done;
-      if a>0 then s:="("^(!s)^")";
-      sphv [  (if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb]
-                     else spe);
-                    (* spt var;sps "="; *) sps !s; sps ":";
-           (prphrases (natural_hyp) (nrem lh a))]
-  |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) ->
-      prnatural_ghyp (group_lhyp lh) sintro
-  |Elim_subgoals_hyp (var,c,a,lhci,ncase) ->
-      let nlh = List.length lh in
-      let nlhci = List.length lhci in
-      let lh0 = ref [] in
-      for i=1 to (nlh-nlhci) do
-         lh0:=(!lh0)@[List.nth lh (i-1)];
-      done;
-      let lh=nrem lh (nlh-nlhci) in
-      let s=ref c in
-      let lh1=ref [] in
-      for i=1 to nlhci do
-        let targ=(List.nth lhci (i-1))in
-        let nh=(List.nth lh (i-1)) in
-        if targ="arg" || targ="argrec" 
-        then
-            (s:=(!s)^" "^(string_of_id nh.hyp_name);
-	     lh0:=(!lh0)@[nh])
-        else lh1:=(!lh1)@[nh];
-      done;
-      let introhyprec=
-          (if (!lh1)=[] then spe 
-           else   par_hypothese_de_recurrence () )
-      in          
-      if a>0 then s:="("^(!s)^")";
-      spv [sphv [(if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb]
-                     else spe);
-                     sps !s; sps ":"]; 
-           prnatural_ghyp (group_lhyp !lh0) (supposons ());
-           introhyprec;
-           prl (natural_hyp) !lh1]
-  |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) ->
-      sphv [  (if ncase>1
-                     then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c);
-                             sps ":";spb]
-                     else spe);
-           (prphrases (natural_hyp) lh )]
-
-;;
-
-(*****************************************************************************)
-(*
-    Analyse des tactiques.
-*)
-
-let name_tactic = function
-  | TacIntroPattern _ -> "Intro"
-  | TacAssumption -> "Assumption"
-  | _ -> failwith "TODO"
-;;
-
-(*
-let arg1_tactic tac =
-  match tac with
-    (Node(_,"Interp",
-		(Node(_,_,
-		      (Node(_,_,x::_))::_))::_))::_ ->x
-  | (Node(_,_,x::_))::_ -> x
-  | x::_ -> x
-  | _ -> assert false
-;;
-*)
-
-let arg1_tactic tac = failwith "TODO";;
-
-type type_info_subgoals =
-    {ihsg: type_info_subgoals_hyp;
-     isgintro : string}
-;;
-
-let rec show_goal lh ig g gs =
-  match ig with
-    "intros" ->
-      if lh = []
-      then spe
-      else show_goal lh "standard" g gs 
-  |"standard" ->
-      (match (sort_of_type g gs) with
-        Nprop -> donnons_une_proposition ()
-      | Nformula -> montrons g
-      | Ntype -> calculons_un_element_de g
-      | Nfunction ->calculons_une_fonction_de_type g)
-  | "apply" -> show_goal lh "" g gs
-  | "simpl" ->en_simplifiant_on_obtient g
-  | "rewrite" -> on_obtient g 
-  | "equality" -> reste_a_montrer g
-  | "trivial_equality" -> reste_a_montrer g
-  | "" -> spe
-  |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ]
-;;
-
-let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s =
-  if ig="" && lh = []
-  then spe
-  else sphv [  show_goal lh ig g gs; sps s]
-;;
-
-let imaginez_une_preuve_de () =  match !natural_language with
-    French -> "Imaginez une preuve de"
-| English -> "Imagine a proof of"
-;;
-
-let donnez_un_element_de () =  match !natural_language with
-    French -> "Donnez un element de"
-| English -> "Give an element of";;
-
-let intro_not_proved_goal gs =
-   match gs with
-     Prop(Null) -> imaginez_une_preuve_de ()
-    |_ -> donnez_un_element_de ()
-;;
-
-let first_name_hyp_of_ntree {t_goal={newhyp=lh}}=
-  match lh with
-   {hyp_name=n}::_ -> n
-  | _ -> assert false
-;;
-
-let rec find_type x t=
-    match (kind_of_term (strip_outer_cast t)) with 
-      Prod(y,ty,t) ->
-	(match y with
-	  Name y -> 
-            if x=(string_of_id y) then ty
-            else find_type x t
-	| _ -> find_type x t)
-     |_-> assert false 
-;;
-
-(***********************************************************************
-Traitement des égalités
-*)
-(*
-let is_equality e =
-   match  (kind_of_term e) with
-     AppL args ->
-       (match (kind_of_term args.(0)) with
-	 Const (c,_) ->
-	   (match (string_of_sp c) with
-	     "Equal" -> true
-           | "eq" -> true
-	   | "eqT" -> true
-	   | "identityT" -> true
-	   | _ -> false)
-       | _ -> false)
-   | _ -> false
-;;
-*)
-
-let is_equality e =
-  let e= (strip_outer_cast e) in
-   match  (kind_of_term e) with
-     App (f,args) -> (Array.length args) >= 3
-   | _ -> false
-;;
-
-let terms_of_equality e =
-  let e= (strip_outer_cast e) in
-  match  (kind_of_term e) with
-     App (f,args) -> (args.(1) , args.(2))
-    | _ -> assert false
-;;
-
-let eq_term = eq_constr;;
-
-let is_equality_tac = function
-  | TacAtom (_,
-      (TacExtend
-	(_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc"
-	 |"ERewriteParallel"|"ERewriteNormal"
-	 |"RewriteLR"|"RewriteRL"|"Replace"),_)
-      | TacReduce _
-      | TacSymmetry _ | TacReflexivity
-      | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true
-  | _ -> false
-
-let equalities_ntree ig ntree =
-  let rec equalities_ntree ig ntree =
-  if not (is_equality (concl ntree)) 
-  then []
-  else
-    match (proof ntree) with
-      Notproved ->  [(ig,ntree)]
-    | Proof (tac,ltree) ->
-	if is_equality_tac tac
-      	then (match ltree with
-          [] ->  [(ig,ntree)]
-	| t::_ -> let res=(equalities_ntree ig t) in
-	          if eq_term (concl ntree) (concl t)
-		  then res
-		  else (ig,ntree)::res)
-	else  [(ig,ntree)]
-  in 
-  equalities_ntree ig ntree 
-;;
-
-let remove_seq_of_terms l =
-  let rec remove_seq_of_terms l =    match l with
-    a::b::l -> if (eq_term (fst a) (fst b))
-    then remove_seq_of_terms (b::l)
-    else a::(remove_seq_of_terms (b::l))
-  | _ -> l
-  in remove_seq_of_terms l
-;;
-
-let  list_to_eq l o=
-  let switch = fun h h' -> (if o then h else h') in
-   match l with
-      [a] -> spt (fst a) 
-   |  (a,h)::(b,h')::l ->
-       let rec list_to_eq h l =
-	 match l with
-	   [] -> []
-	 |  (b,h')::l ->
-	     (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe])
-             :: (list_to_eq (switch h' h) l)
-       in sph [spt a;  spb;
-		 spv ((sph [sps "="; spb; spt b; spb; 
-			     tag_uselemma (switch h h') spe])
-		      ::(list_to_eq (switch h' h) l))]
-  | _ -> assert false
-;;
-
-let stde = Global.env;;
-
-let dbize env = Constrintern.interp_constr Evd.empty env;;
-
-(**********************************************************************)
-let rec natural_ntree ig ntree =
-  let  {t_info=info;
-	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	 t_proof=p} = ntree in
-    let leq = List.rev (equalities_ntree ig ntree)  in
-    if List.length leq > 1
-    then (* Several equalities to treate ... *)
-      (
-       print_string("Several equalities to treate ...\n");
-      let l1 = ref [] in
-      let l2 = ref [] in
-      List.iter
-	(fun (_,ntree) ->
-	 let lemma =  match (proof ntree) with
-	   Proof (tac,ltree) ->
-	     (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *)
-			  (match ltree with
-			    [] ->spe
-			  | [_] -> spe
-			  | _::l -> sphv[sps ": ";
-					  prli (natural_ntree 
-					    {ihsg=All_subgoals_hyp;
-					      isgintro="standard"})
-                            		    l])])
-	      with _ -> sps "simplification"  )
-	 | Notproved -> spe
-	 in
- 	  let (t1,t2)= terms_of_equality (concl ntree) in
-	  l2:=(t2,lemma)::(!l2);
-	  l1:=(t1,lemma)::(!l1))
-	leq;
-      l1:=remove_seq_of_terms !l1;
-      l2:=remove_seq_of_terms !l2;
-      l2:=List.rev !l2;
-      let ltext=ref [] in
-      if List.length !l1 > 1
-      then (ltext:=(!ltext)@[list_to_eq !l1 true];
-	    if List.length !l2 > 1 then
-	      (ltext:=(!ltext)@[_et()];
-	       ltext:=(!ltext)@[list_to_eq !l2 false]))
-      else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false];
-      if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext];
-      let (ig,ntree)=(List.hd leq) in
-      spv [(natural_lhyp lh ig.ihsg);
-	    (show_goal2 lh ig g (nsort gf) "");
-	    sph !ltext;
-	    
-	    natural_ntree {ihsg=All_subgoals_hyp;
-                            isgintro=
-			    let  (t1,t2)= terms_of_equality (concl ntree) in
-			    if eq_term t1 t2
-			    then "trivial_equality"
-			    else "equality"}
-	      ntree]
-      	)
-    else
-    let ntext =
-      let gs=nsort gf in
-      match p with
-   	Notproved ->  spv [ (natural_lhyp lh ig.ihsg);
-                            sph [spi; sps (intro_not_proved_goal gs); spb; 
-                                  tag_toprove g  ]
-			  ]
-
-      | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree)
-      | Proof (TacAtom (_,tac),ltree) -> 
-	 (let ntext = 
-	  match tac with
-(* Pas besoin de l'argument éventuel de la tactique *)
-	    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 (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
-	  | (* "Simpl" *)TacReduce (r,cl)  ->
-	      natural_reduce ig lh g gs ge r cl ltree
-	  | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree
-	  | TacAuto _ -> natural_auto ig lh g gs ltree
-	  | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree
-	  | TacTrivial _ -> natural_trivial ig lh g gs ltree
-	  | TacAssumption -> natural_trivial ig lh g gs ltree
-	  | TacClear _ -> natural_clear ig lh g gs ltree
-(* Besoin de l'argument de la tactique *)
-	  | TacSimpleInductionDestruct (true,NamedHyp id) -> 
-              natural_induction ig lh g gs ge id ltree false
-	  | TacExtend (_,"InductionIntro",[a]) -> 
-              let id=(out_gen wit_ident a) in
-              natural_induction ig lh g gs ge id ltree true
-	  | TacApply (_,false,[c,_],None) ->
-              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 (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 (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
-	  | TacExtend (_,"Rewrite",[_;a]) ->
-	      let (c,_) = out_gen wit_constr_with_bindings a in
-	      natural_rewrite ig lh g gs c ltree
-	  | TacExtend (_,"ERewriteRL",[a]) ->
-	      let c = out_gen wit_constr a in (* TODO *)
-	      natural_rewrite ig lh g gs c ltree
-	  | TacExtend (_,"ERewriteLR",[a]) ->
-	      let c = out_gen wit_constr a in (* TODO *)
-	      natural_rewrite ig lh g gs c ltree
-	  |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree
-         in
-          ntext (* spwithtac ntext tactic*)
-          )
-      | Proof _ -> failwith "Don't know what to do with that"
-    in   
-         if info<>"not_proved"
-         then spshrink info ntext
-         else ntext
-and  natural_generic  ig lh g gs tactic tac ltree =
-  spv
-    [ (natural_lhyp lh ig.ihsg);
-      (show_goal2 lh ig g gs "");
-      on_applique_la_tactique tactic tac ;
-      (prli(natural_ntree  
-	      {ihsg=All_subgoals_hyp;
-		isgintro="standard"})
-         ltree)
-    ]
-and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree)
-(*
-    spv
-    [ (natural_lhyp lh ig.ihsg);
-      (show_goal2 lh ig g gs "");
-      (prl (natural_ntree ig) ltree)
-    ]
-*)
-and natural_intros ig lh g gs ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-            (show_goal2 lh ig g gs "");
-            (prl (natural_ntree  
-                {ihsg=All_subgoals_hyp;
-                 isgintro="intros"})
-                            ltree)
-        ]
-and natural_apply ig lh g gs arg ltree =
-  let lg = List.map concl ltree in
-  match lg with
-    [] ->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-	  de_A_il_vient_B arg g  
-        ]
-  | [sg]->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh
-	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
-	                              then "standard"
-	                              else ""}
-	     g gs "");
-          grace_a_A_il_suffit_de_montrer_LA arg [spt sg];
-	  sph [spi ; natural_ntree 
-		  {ihsg=All_subgoals_hyp;
-		    isgintro="apply"} (List.hd ltree)]
-	]       
-  | _ ->
-      let ln = List.map (fun _ -> new_name()) lg in
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh
-	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
-	                              then "standard"
-			              else ""}
-	     g gs "");
-          grace_a_A_il_suffit_de_montrer_LA arg
-	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
-	       lg ln);
-	  sph [spi; spv (List.map2
-			   (fun x n -> sph [sps ("("^n^"):"); spb;
-					     natural_ntree 
-					       {ihsg=All_subgoals_hyp;
-						 isgintro="apply"} x])
-			   ltree ln)]
-        ]
-and natural_rem_goals ltree =
-  let lg = List.map concl ltree in
-  match lg with
-    [] -> spe
-  | [sg]->
-      spv
-        [ reste_a_montrer_LA [spt sg];
-	  sph [spi ; natural_ntree 
-		  {ihsg=All_subgoals_hyp;
-		    isgintro="apply"} (List.hd ltree)]
-	]       
-  | _ ->
-      let ln = List.map (fun _ -> new_name()) lg in
-      spv
-        [   reste_a_montrer_LA 
-	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
-	       lg ln);
-	  sph [spi; spv (List.map2
-			   (fun x n -> sph [sps ("("^n^"):"); spb;
-					     natural_ntree 
-					       {ihsg=All_subgoals_hyp;
-						 isgintro="apply"} x])
-			   ltree ln)]
-        ]
-and natural_exact ig lh g gs arg ltree =
-spv
-         [  
-             (natural_lhyp lh ig.ihsg);
-             (let {ihsg=pi;isgintro=ig}= ig in
-               (show_goal2 lh {ihsg=pi;isgintro=""}
-                   g gs ""));
-             (match gs with
-               Prop(Null) -> _A_est_immediat_par_B g arg
-              |_ -> le_resultat_est arg)
-
-        ]
-and natural_cut ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (prli(natural_ntree  
-                    {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            (List.rev ltree));
-             de_A_on_deduit_donc_B arg g
-        ]
-and natural_cutintro ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             sph [spi;
-                    (natural_ntree  
-                       {ihsg=All_subgoals_hyp;isgintro=""}
-                       (List.nth ltree 1))];
-             sph [spi;
-                    (natural_ntree  
-                       {ihsg=No_subgoals_hyp;isgintro=""}
-                       (List.nth ltree 0))]
-        ]
-and whd_betadeltaiota x = whd_betaiota Evd.empty x
-and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c)
-and prod_head t =
-  match (kind_of_term (strip_outer_cast t)) with 
-     Prod(_,_,c) -> prod_head c
-(*    |App(f,a) -> f *)
-    | _ -> t
-and string_of_sp sp = string_of_id (basename sp)
-and constr_of_mind mip i =
-  (string_of_id mip.mind_consnames.(i-1))
-and arity_of_constr_of_mind env indf i =
-     (get_constructors env indf).(i-1).cs_nargs
-and gLOB ge = Global.env_of_context ge  (* (Global.env()) *)
-
-and natural_case ig lh g gs ge arg1 ltree with_intros =
- let env= (gLOB ge) in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let ti =(string_of_id mip.mind_typename) in
- let type_arg= targ1 (* List.nth targ (mis_index dmi)*)  in
- if  ncti<>1
-(* Zéro ou Plusieurs constructeurs *)
- then (   
-   spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (match (nsort targ1) with
-               Prop(Null) ->
-		 (match ti with
-		   "or" ->  discutons_avec_A type_arg
-                 | _ -> utilisons_A arg1)
-             |_ -> selon_les_valeurs_de_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=if with_intros
-			      then (arity_of_constr_of_mind env indf !ci)
-		              else 0 in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Case_prop_subgoals_hyp (supposons (),arg1,ici,aci,
-                                     (List.length ltree))
-                               |_-> Case_subgoals_hyp ("",arg1,nci,aci,
-                                                (List.length ltree)));
-                           isgintro= if with_intros then "" else "standard"}
-                          treearg)
-                    ])
-                  (nrem ltree ((List.length ltree)- ncti))));
-	    (sph [spi; (natural_rem_goals
-			  (nhd ltree ((List.length ltree)- ncti)))])
-         ] )
-(* Cas d'un seul constructeur *)
-     else (  
-
-     spv
-     [ (natural_lhyp lh ig.ihsg);
-       (show_goal2 lh ig g gs "");
-       de_A_on_a arg1;
-       (let treearg=List.hd ltree in
-       let nci=(constr_of_mind mip 1) in
-       let aci=
-	 if with_intros
-         then (arity_of_constr_of_mind env indf 1)
-	 else 0 in
-       let _ici= 1 in
-       sph[ (natural_ntree  
-               {ihsg=
-                 (match (nsort targ1) with
-                   Prop(Null) ->
-                     Case_prop_subgoals_hyp ("",arg1,1,aci,
-					     (List.length ltree))
-                 |_-> Case_subgoals_hyp ("",arg1,nci,aci,
-                                         (List.length ltree)));
-                 isgintro=""}
-               treearg)
-          ]);
-       (sph [spi; (natural_rem_goals
-		     (nhd ltree ((List.length ltree)- 1)))])
-     ] 
-     )
-(*    with _ ->natural_generic ig lh g gs (sps "Case")  (spt arg1) ltree *)
-
-(*****************************************************************************)
-(*
-   Elim
-*)
-and prod_list_var t =
-   match (kind_of_term (strip_outer_cast t)) with 
-      Prod(_,t,c) -> t::(prod_list_var c)
-     |_ -> []
-and  hd_is_mind t ti =
-    try (let env = Global.env() in
-         let IndType (indf,targ) = find_rectype env Evd.empty t in
-	 let _ncti= Array.length(get_constructors env indf) in
-	 let (ind,_) = dest_ind_family indf in
-         let (mib,mip) = lookup_mind_specif env ind in
-	 (string_of_id mip.mind_typename) = ti)
-    with _ -> false
-and mind_ind_info_hyp_constr indf c =
-  let env = Global.env() in
-  let (ind,_) = dest_ind_family indf in
-  let (mib,mip) = lookup_mind_specif env ind in
-  let _p = mib.mind_nparams in
-  let a = arity_of_constr_of_mind env indf c in
-  let lp=ref (get_constructors env indf).(c).cs_args in
-  let lr=ref [] in
-  let ti = (string_of_id mip.mind_typename) in
-  for i=1 to a do
-     match !lp with
-     ((_,_,t)::lp1)->
-       if hd_is_mind t ti
-       then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1)
-       else (lr:=(!lr)@["arg"];lp:=lp1)
-     |  _ -> raise (Failure "mind_ind_info_hyp_constr")
-  done;
-  !lr
-(*
- mind_ind_info_hyp_constr "le" 2;;
-donne  ["arg"; "argrec"] 
-mind_ind_info_hyp_constr "le" 1;;
-donne []
- mind_ind_info_hyp_constr "nat" 2;;
-donne ["argrec"]
-*)
-
-and natural_elim ig lh g gs ge arg1 ltree with_intros=
- let env= (gLOB ge) in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let _ti =(string_of_id mip.mind_typename) in
- let _type_arg=targ1 (* List.nth targ (mis_index dmi) *) in
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             (match (nsort targ1) with
-               Prop(Null) -> utilisons_A arg1
-	     |_ ->procedons_par_recurrence_sur_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=(arity_of_constr_of_mind env indf !ci) in
-                      let hci=
-			if with_intros
-			then mind_ind_info_hyp_constr indf  !ci
-		      	else [] in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
-                                     (List.length ltree))
-                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
-                                                (List.length ltree)));
-                           isgintro= ""}
-                          treearg)
-                    ])
-                  (nhd ltree ncti)));
-	    (sph [spi; (natural_rem_goals (nrem ltree ncti))])
-        ]
-(* )
-  with _ ->natural_generic ig lh g gs (sps "Elim")  (spt arg1) ltree *)
-
-(*****************************************************************************)
-(*
-   InductionIntro n
-*) 
-and natural_induction ig lh g gs ge arg2 ltree with_intros=
- let env = (gLOB (g_env (List.hd ltree))) in
- let arg1= mkVar arg2 in
- let targ1 = prod_head (type_of env Evd.empty arg1) in
- let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let _ncti= Array.length(get_constructors env indf) in
- let (ind,_) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let _ti =(string_of_id mip.mind_typename) in
- let _type_arg= targ1(*List.nth targ (mis_index dmi)*) in
-
- let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *)
- (* on les enleve des hypotheses des sous-buts *)
- let ltree = List.map
-     (fun {t_info=info;
-	    t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
-	    t_proof=p} ->
-	  {t_info=info;
-	    t_goal={newhyp=(nrem lh (List.length lh1));
-		     t_concl=g;t_full_concl=gf;t_full_env=ge};
-	    t_proof=p}) ltree in
- spv
-   [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-	   (natural_lhyp lh1 All_subgoals_hyp);
-             (match (print_string "targ1------------\n";(nsort targ1)) with
-               Prop(Null) -> utilisons_A arg1
-	     |_ -> procedons_par_recurrence_sur_A arg1);
-            (let ci=ref 0 in
-             (prli
-                 (fun treearg -> ci:=!ci+1;
-                      let nci=(constr_of_mind mip !ci) in
-                      let aci=(arity_of_constr_of_mind env indf !ci) in
-                      let hci= 
-			if with_intros
-			then mind_ind_info_hyp_constr indf  !ci
-		      	else [] in
-                      let ici= (!ci) in
-                    sph[ (natural_ntree  
-                          {ihsg=
-                             (match (nsort targ1) with
-                                Prop(Null) ->
-                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
-                                     (List.length ltree))
-                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
-                                                (List.length ltree)));
-                           isgintro= "standard"}
-                          treearg)
-                    ])
-                  ltree))
-        ]
-(************************************************************************)
-(* Points fixes *)
-
-and natural_fix ig lh g gs narg ltree =
-  let {t_info=info;
-	t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1;
-                   t_full_env=ge1};t_proof=p1}=(List.hd ltree) in
-  match lh1 with
-     {hyp_name=nfun;hyp_type=tfun}::lh2 ->
-  let ltree=[{t_info=info;
-	       t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1;
-                          t_full_env=ge1};
-	       t_proof=p1}] in
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A  nfun tfun narg;
-             (prli(natural_ntree  
-                   {ihsg=All_subgoals_hyp;isgintro=""})
-                            ltree)
-        ]
-   | _ -> assert false
-and natural_reduce ig lh g gs ge mode la ltree =
-  match la with
-    {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> 
-      spv
-        [  (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro="simpl"})
-             ltree)
-        ]
-  | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr ->
-      spv
-        [  (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-          (prl (natural_ntree 
-		  {ihsg=Reduce_hyp;isgintro=""})
-             ltree)
-        ]
-  | _ -> assert false
-and natural_split ig lh g gs ge la ltree =
-  match la with
-    [arg] -> 
-      let _env= (gLOB ge) in
-      let arg1= (*dbize _env*) arg in
-      spv
-      	[ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-	  pour_montrer_G_la_valeur_recherchee_est_A  g arg1;
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro="standard"})
-             ltree)
-        ]
-  | [] ->
-      spv
-        [ (natural_lhyp lh ig.ihsg);
-          (prli(natural_ntree  
-                  {ihsg=All_subgoals_hyp;isgintro="standard"})
-             ltree)
-        ]
-  | _ -> assert false
-and natural_generalize ig lh g gs ge la ltree =
-  match la with
-    [(_,(_,arg)),_] ->
-      let _env= (gLOB ge) in
-      let arg1= (*dbize env*) arg in
-      let _type_arg=type_of (Global.env()) Evd.empty arg in
-(*      let type_arg=type_of_ast ge arg in*)
-      spv
-      	[ (natural_lhyp lh ig.ihsg);
-          (show_goal2 lh ig g gs ""); 
-	  on_se_sert_de_A   arg1;
-          (prl (natural_ntree 
-		  {ihsg=All_subgoals_hyp;isgintro=""})
-             ltree)
-        ]
-    | _ -> assert false
-and natural_right ig lh g gs ltree =
-  spv
-         [ (natural_lhyp lh ig.ihsg);
-            (prli(natural_ntree  
-                {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree); 
-            d_ou_A g  
-        ]
-and natural_left ig lh g gs ltree =
-  spv
-         [ (natural_lhyp lh ig.ihsg);
-            (prli(natural_ntree  
-                {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree); 
-             d_ou_A g  
-        ]
-and natural_auto ig lh g gs ltree =
-  match ig.isgintro with
-   "trivial_equality" -> spe
-  | _ -> 
-      if ltree=[]
-      then sphv [(natural_lhyp lh ig.ihsg);
-		  (show_goal2 lh ig g gs "");
-		  coq_le_demontre_seul ()]
-      else spv [(natural_lhyp lh ig.ihsg);
-		 (show_goal2 lh ig g gs "");
-		 (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}
-			  )
-                    ltree)]
-and natural_infoauto ig lh g gs ltree =
- match ig.isgintro with
-   "trivial_equality" ->
-     spshrink "trivial_equality"
-       (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}
-		 (List.hd ltree))
-  | _ ->   sphv [(natural_lhyp lh ig.ihsg);
-	 (show_goal2 lh ig g gs "");
-	 coq_le_demontre_seul ();
-       spshrink "auto"
-		    (sph [spi;
-		       (natural_ntree
-			  {ihsg=All_subgoals_hyp;isgintro=""}
-			  (List.hd ltree))])]
-and natural_trivial ig lh g gs ltree =
-  if ltree=[]
-  then sphv [(natural_lhyp lh ig.ihsg);
-	      (show_goal2 lh ig g gs "");
-	      ce_qui_est_trivial () ]
-  else spv [(natural_lhyp lh ig.ihsg);
-	     (show_goal2 lh ig g gs ". ");
-            (prli(natural_ntree  
-                      {ihsg=All_subgoals_hyp;isgintro="standard"})
-                            ltree)]
-and natural_rewrite ig lh g gs arg ltree =
-  spv
-         [  (natural_lhyp lh ig.ihsg);
-             (show_goal2 lh ig g gs "");
-             en_utilisant_l_egalite_A arg;
-            (prli(natural_ntree  
-                 {ihsg=All_subgoals_hyp;isgintro="rewrite"})
-                            ltree)
-        ]
-;;
-
-let natural_ntree_path ig g =
-  Random.init(0);
-        natural_ntree ig g
-;;
-
-let show_proof lang gpath =
-  (match lang with
-     "fr" -> natural_language:=French
-    |"en" -> natural_language:=English
-    | _ -> natural_language:=English);
-  path:=List.rev gpath;
-  name_count:=0;
-  let ntree=(get_nproof ()) in
-  let {t_info=i;t_goal=g;t_proof=p} =ntree in
-  root_of_text_proof
-    (sph [(natural_ntree_path {ihsg=All_subgoals_hyp;
-				isgintro="standard"}
-	                      {t_info="not_proved";t_goal=g;t_proof=p});
-           spr])
-    ;;
-
-let show_nproof path =
-  pp (sp_print (sph [spi; show_proof "fr" path]));;
-
-vinterp_add "ShowNaturalProof"
-	    (fun _ ->
-		 (fun () ->show_nproof[];()));;
-
-(***********************************************************************
-debug sous cygwin:
-
-PATH=/usr/local/bin:/usr/bin:$PATH
-COQTOP=d:/Tools/coq-7avril
-CAMLLIB=/usr/local/lib/ocaml
-CAMLP4LIB=/usr/local/lib/camlp4
-export CAMLLIB
-export COQTOP
-export CAMLP4LIB 
-cd d:/Tools/pcoq/src/text
-d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax  -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history
-
- 
- 
-Lemma l1: (A, B : Prop) A \/ B -> B ->  A.
-Intros.
-Elim H.
-Auto.
-Qed.
- 
-
-Drop.
-
-#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
-#load "xlate.cmo";;
-#load "translate.cmo";;
-#load "showproof_ct.cmo";;
-#load "showproof.cmo";;
-#load "pbp.cmo";;
-#load "debug_tac.cmo";;
-#load "name_to_ast.cmo";;
-#load "paths.cmo";;
-#load "dad.cmo";;
-#load "vtp.cmo";;
-#load "history.cmo";;
-#load "centaur.cmo";;
-Xlate.set_xlate_mut_stuff Centaur.globcv;;
-Xlate.declare_in_coq();;
-
-#use "showproof.ml";;
-
-let pproof x = pP (sp_print x);;
-Pp_control.set_depth_boxes 100;;
-#install_printer  pproof;;
-
-ep();;
-let bidon = ref (constr_of_string "O");; 
-
-#trace to_nproof;;
-***********************************************************************)
-let ep()=show_proof "fr" [];;
diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli
deleted file mode 100755
index 9b6787b7..00000000
--- a/contrib/interface/showproof.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-open Environ
-open Evd
-open Names
-open Term
-open Util
-open Proof_type
-open Pfedit
-open Term
-open Reduction
-open Clenv
-open Typing
-open Inductive
-open Vernacinterp
-open Declarations
-open Showproof_ct
-open Proof_trees
-open Sign
-open Pp
-open Printer
-
-val show_proof : string -> int list -> Ascent.ct_TEXT;;
diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml
deleted file mode 100644
index dd7f455d..00000000
--- a/contrib/interface/showproof_ct.ml
+++ /dev/null
@@ -1,184 +0,0 @@
-(*****************************************************************************)
-(*
-   Vers Ctcoq
-*)
-
-open Metasyntax
-open Printer
-open Pp
-open Translate
-open Ascent
-open Vtp
-open Xlate
-
-let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);;
-
-let sps s =
-  ct_text s
-    ;;
-
-
-let sphs s =
-  ct_text s
-    ;;
-
-let spe = sphs "";;
-let spb = sps " ";;
-let spr = sps "Retour chariot pour Show proof";;
-
-let spnb n = 
-   let s = ref "" in
-   for i=1 to n do s:=(!s)^" "; done; sps !s
-;;
-
-
-let rec spclean l =
-  match l with 
-    [] -> []
-   |x::l -> if x=spe then (spclean l) else x::(spclean l)
-;;
-
-
-let spnb n = 
-   let s = ref "" in
-   for i=1 to n do s:=(!s)^" "; done; sps !s
-;;
-
-let ct_FORMULA_constr = Hashtbl.create 50;;
-
-let stde()  = (Global.env())
-
-;;
-
-let spt t =
-   let f = (translate_constr true (stde()) t) in
-   Hashtbl.add ct_FORMULA_constr f t;
-   CT_text_formula f
-;;
-
-
-
-let root_of_text_proof t=
-  CT_text_op [ct_text "root_of_text_proof";
-              t]
-    ;;
-    
-let spshrink info t =
-  CT_text_op [ct_text "shrink";
-	      CT_text_op [ct_text info;
-                          t]]
-;;
-			 
-let spuselemma intro x y =
-  CT_text_op [ct_text "uselemma";
-              ct_text intro;
-	      x;y]
-;;
-
-let sptoprove p t =
-  CT_text_op [ct_text "to_prove";
-	      CT_text_path p;
-              ct_text "goal";
-	      (spt t)]
-;;
-let sphyp p h t =
-  CT_text_op [ct_text "hyp";
-	      CT_text_path p;
-	      ct_text h;
-              (spt t)]
-;;
-let sphypt p h t =
-  CT_text_op [ct_text "hyp_with_type";
-	      CT_text_path p;
-	      ct_text h;
-              (spt t)]
-;;
-
-let spwithtac x t =
-    CT_text_op [ct_text "with_tactic";
-                ct_text t;
-                x]
-;;
-
-
-let spv l =
-   let l= spclean l in
-   CT_text_v l
-;;
-     
-let sph l =
-   let l= spclean l in
-   CT_text_h l
-;;
-
-
-let sphv l =
-   let l= spclean l in
-   CT_text_hv l
-;;
-
-let rec prlist_with_sep f g l =
-    match l with 
-      [] -> hov 0 (mt ())
-     |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1))
-;;
-   
-let rec sp_print x = 
-   match x with
-     | CT_coerce_ID_to_TEXT (CT_ident s)
-       -> (match s with
-	     | "\n" -> fnl ()
-	     | "Retour chariot pour Show proof" -> fnl ()
-	     |_ -> str s)
-     | CT_text_formula  f -> pr_lconstr (Hashtbl.find ct_FORMULA_constr f)
-     | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove");
-		   CT_text_path (CT_signed_int_list p);
-		   CT_coerce_ID_to_TEXT (CT_ident "goal");
-		   g] ->
-      let _p=(List.map (fun y -> match y with
-	                 (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-      h 0 (str "<b>" ++ sp_print g ++ str "</b>")
- |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma");
-              CT_coerce_ID_to_TEXT (CT_ident intro);
-	      l;g] ->
-      h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g)
- |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp");
-	      CT_text_path (CT_signed_int_list p);
-	      CT_coerce_ID_to_TEXT (CT_ident hyp);
-              g]  ->
-      let _p=(List.map (fun y -> match y with
-	                  (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-            h 0 (str hyp)
-
-  |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type");
-	      CT_text_path (CT_signed_int_list p);
-	      CT_coerce_ID_to_TEXT (CT_ident hyp);
-              g]  ->
-      let _p=(List.map (fun y -> match y with
-                         (CT_coerce_INT_to_SIGNED_INT
-			      (CT_int x)) -> x
-		       | _ -> raise (Failure "sp_print")) p) in
-      h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>")   
-
-  | CT_text_h l ->
-      h 0 (prlist_with_sep (fun () -> mt ())
-	     (fun y -> sp_print y) l)
-  | CT_text_v l ->
-      v 0 (prlist_with_sep (fun () -> mt ())
-		(fun y -> sp_print y) l)
-  | CT_text_hv l ->
-      h 0 (prlist_with_sep (fun () -> mt ())
-	     (fun y -> sp_print y) l)
-  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink");
-	      CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]]  ->
-                   h 0 (str ("("^info^": ") ++ sp_print t ++ str ")")
-  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof");
-              t]->
-                    sp_print t 
-  | _ -> str "..."
-;;
-  
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
deleted file mode 100644
index 559860b2..00000000
--- a/contrib/interface/translate.ml
+++ /dev/null
@@ -1,80 +0,0 @@
-open Names;;
-open Sign;;
-open Util;;
-open Term;;
-open Pp;;
-open Libobject;;
-open Library;;
-open Vernacinterp;;
-open Tacmach;;
-open Pfedit;;
-open Parsing;;
-open Evd;;
-open Evarutil;;
-
-open Xlate;;
-open Vtp;;
-open Ascent;;
-open Environ;;
-open Proof_type;;
-
-(*translates a formula into a centaur-tree --> FORMULA *)
-let translate_constr at_top env c =
-  xlate_formula (Constrextern.extern_constr at_top env c);;
-
-(*translates a named_context into a centaur-tree --> PREMISES_LIST *)
-(* this code is inspired from printer.ml (function pr_named_context_of) *)
-let translate_sign env =
-  let l = 
-    Environ.fold_named_context
-      (fun env (id,v,c) l -> 
-	 (match v with
-	      None ->
-	       	CT_premise(CT_ident(string_of_id id), translate_constr false env c)
-	    | Some v1 ->
-		CT_eval_result
-		  (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)),
-		   translate_constr false env v1,
-		   translate_constr false env c))::l)
-      env ~init:[] 
-  in
-  CT_premises_list l;;
-       
-(* the function rev_and_compact performs two operations:
-   1- it reverses the list of integers given as argument
-   2- it replaces sequences of "1" by a negative number that is
-      the length of the sequence. *)
-let rec rev_and_compact l = function
-    [] -> l
-  | 1::tl -> 
-      (match l with
-              n::tl' -> 
-        if n < 0 then
-          rev_and_compact ((n - 1)::tl') tl
-        else
-          rev_and_compact ((-1)::l) tl
-      |       [] -> rev_and_compact [-1] tl)
-  | a::tl ->
-      if a < 0 then
-      (match l with
-        n::tl' ->
-          if n < 0 then
-            rev_and_compact ((n + a)::tl') tl
-          else
-            rev_and_compact (a::l) tl
-      | [] -> rev_and_compact (a::l) tl)
-      else
-      rev_and_compact (a::l) tl;;
-
-(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *)
-let translate_path l =
- CT_signed_int_list
- (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n))
-    (rev_and_compact [] 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
deleted file mode 100644
index 34841fc4..00000000
--- a/contrib/interface/translate.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-open Ascent;;
-open Evd;;
-open Proof_type;;
-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;;
-val translate_path : int list -> ct_SIGNED_INT_LIST;;
diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc
deleted file mode 100644
index 4d3dc558..00000000
--- a/contrib/interface/vernacrc
+++ /dev/null
@@ -1,12 +0,0 @@
-# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $
-
-# This file is loaded initially by ./vernacparser.
-
-load_syntax_file 1 Notations
-load_syntax_file 2 Logic
-load_syntax_file 34 Omega
-load_syntax_file 27 Ring
-quiet_parse_string
-Goal a.
-&& END--OF--DATA
-print_version
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
deleted file mode 100644
index 94609009..00000000
--- a/contrib/interface/vtp.ml
+++ /dev/null
@@ -1,1945 +0,0 @@
-open Ascent;;
-open Pp;;
-
-(* LEM: This is actually generated automatically *)
-
-let fNODE s n =
-    (str "n\n") ++
-    (str ("vernac$" ^ s)) ++
-    (str "\n") ++
-    (int n) ++
-    (str "\n");;
-
-let fATOM s1 =
-    (str "a\n") ++
-    (str ("vernac$" ^ s1)) ++
-    (str "\n");;
-
-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 ++
-   fNODE "astnode" 2
-| CT_astpath(x1) ->
-   fID_LIST x1 ++
-   fNODE "astpath" 1
-| CT_astslam(x1, x2) ->
-   fID_OPT x1 ++
-   fAST x2 ++
-   fNODE "astslam" 2
-and fAST_LIST = function
-| CT_ast_list 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) ++
-   str "\n"
-and fBINDER = function
-| CT_coerce_DEF_to_BINDER x -> fDEF x
-| CT_binder(x1, x2) ->
-   fID_OPT_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "binder" 2
-| CT_binder_coercion(x1, x2) ->
-   fID_OPT_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "binder_coercion" 2
-and fBINDER_LIST = function
-| CT_binder_list 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.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 ++
-   fNODE "binding" 2
-and fBINDING_LIST = function
-| CT_binding_list 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) ++
-   str "\n"
-and fCLAUSE = function
-| CT_clause(x1, 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 ++
-   fNODE "cofixtac" 2
-and fCOFIX_REC = function
-| CT_cofix_rec(x1, x2, x3, 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.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.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
-| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x
-| 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 ++
-   fNODE "abort" 1
-| CT_abstraction(x1, x2, 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 ++
-   fNODE "add_field" 4
-| CT_add_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1 ++
-   fID x2 ++
-   fNODE "add_natural_feature" 2
-| CT_addpath(x1, x2) ->
-   fSTRING x1 ++
-   fID_OPT x2 ++
-   fNODE "addpath" 2
-| CT_arguments_scope(x1, x2) ->
-   fID x1 ++
-   fID_OPT_LIST x2 ++
-   fNODE "arguments_scope" 2
-| CT_bind_scope(x1, x2) ->
-   fID x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "bind_scope" 2
-| CT_cd(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "cd" 1
-| CT_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "check" 1
-| CT_class(x1) ->
-   fID x1 ++
-   fNODE "class" 1
-| CT_close_scope(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 ++
-   fNODE "coercion" 5
-| CT_cofix_decl(x1) ->
-   fCOFIX_REC_LIST x1 ++
-   fNODE "cofix_decl" 1
-| CT_compile_module(x1, x2, 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 ++
-   fNODE "declare_module" 4
-| CT_define_notation(x1, x2, x3, 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 ++
-   fNODE "definition" 5
-| CT_delim_scope(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "delim_scope" 2
-| CT_delpath(x1) ->
-   fSTRING x1 ++
-   fNODE "delpath" 1
-| CT_derive_depinversion(x1, x2, x3, 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 ++
-   fNODE "derive_inversion" 4
-| CT_derive_inversion_with(x1, x2, x3, x4) ->
-   fINV_TYPE x1 ++
-   fID x2 ++
-   fFORMULA x3 ++
-   fSORT_TYPE x4 ++
-   fNODE "derive_inversion_with" 4
-| CT_explain_proof(x1) ->
-   fINT_LIST x1 ++
-   fNODE "explain_proof" 1
-| CT_explain_prooftree(x1) ->
-   fINT_LIST x1 ++
-   fNODE "explain_prooftree" 1
-| CT_export_id(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "export_id" 1
-| CT_extract_to_file(x1, x2) ->
-   fSTRING x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "extract_to_file" 2
-| CT_extraction(x1) ->
-   fID_OPT x1 ++
-   fNODE "extraction" 1
-| CT_fix_decl(x1) ->
-   fFIX_REC_LIST x1 ++
-   fNODE "fix_decl" 1
-| CT_focus(x1) ->
-   fINT_OPT x1 ++
-   fNODE "focus" 1
-| CT_go(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 ++
-   fNODE "hint_destruct" 6
-| CT_hint_extern(x1, x2, x3, x4) ->
-   fINT x1 ++
-   fFORMULA_OPT 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 ++
-   fNODE "hintrewrite" 4
-| CT_hints(x1, x2, 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 ++
-   fNODE "hints_immediate" 2
-| CT_hints_resolve(x1, 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 ++
-   fNODE "hyp_search_pattern" 2
-| CT_implicits(x1, x2) ->
-   fID x1 ++
-   fID_LIST_OPT x2 ++
-   fNODE "implicits" 2
-| CT_import_id(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "import_id" 1
-| CT_ind_scheme(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 ++
-   fNODE "infix" 4
-| CT_inline(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "inline" 1
-| CT_inspect(x1) ->
-   fINT x1 ++
-   fNODE "inspect" 1
-| CT_kill_node(x1) ->
-   fINT x1 ++
-   fNODE "kill_node" 1
-| CT_load(x1, x2) ->
-   fVERBOSE_OPT x1 ++
-   fID_OR_STRING x2 ++
-   fNODE "load" 2
-| CT_local_close_scope(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 ++
-   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 ++
-   fNODE "local_hint_destruct" 6
-| CT_local_hint_extern(x1, x2, x3, 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 ++
-   fNODE "local_hints" 3
-| CT_local_hints_immediate(x1, 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 ++
-   fNODE "local_hints_resolve" 2
-| CT_local_infix(x1, x2, x3, x4) ->
-   fSTRING x1 ++
-   fID x2 ++
-   fMODIFIER_LIST x3 ++
-   fID_OPT x4 ++
-   fNODE "local_infix" 4
-| CT_local_open_scope(x1) ->
-   fID x1 ++
-   fNODE "local_open_scope" 1
-| CT_local_reserve_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMODIFIER_LIST x2 ++
-   fNODE "local_reserve_notation" 2
-| CT_locate(x1) ->
-   fID x1 ++
-   fNODE "locate" 1
-| CT_locate_file(x1) ->
-   fSTRING x1 ++
-   fNODE "locate_file" 1
-| CT_locate_lib(x1) ->
-   fID x1 ++
-   fNODE "locate_lib" 1
-| CT_locate_notation(x1) ->
-   fSTRING x1 ++
-   fNODE "locate_notation" 1
-| CT_mind_decl(x1, x2) ->
-   fCO_IND x1 ++
-   fIND_SPEC_LIST x2 ++
-   fNODE "mind_decl" 2
-| CT_ml_add_path(x1) ->
-   fSTRING x1 ++
-   fNODE "ml_add_path" 1
-| CT_ml_declare_modules(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 ++
-   fNODE "module" 4
-| CT_module_type_decl(x1, x2, x3) ->
-   fID x1 ++
-   fMODULE_BINDER_LIST x2 ++
-   fMODULE_TYPE_OPT x3 ++
-   fNODE "module_type_decl" 3
-| CT_no_inline(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "no_inline" 1
-| CT_omega_flag(x1, x2) ->
-   fOMEGA_MODE x1 ++
-   fOMEGA_FEATURE x2 ++
-   fNODE "omega_flag" 2
-| CT_open_scope(x1) ->
-   fID x1 ++
-   fNODE "open_scope" 1
-| CT_print -> fNODE "print" 0
-| CT_print_about(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 ++
-   fNODE "print_ltac" 1
-| CT_print_coercions -> fNODE "print_coercions" 0
-| CT_print_grammar(x1) ->
-   fGRAMMAR x1 ++
-   fNODE "print_grammar" 1
-| CT_print_graph -> fNODE "print_graph" 0
-| CT_print_hint(x1) ->
-   fID_OPT x1 ++
-   fNODE "print_hint" 1
-| CT_print_hintdb(x1) ->
-   fID_OR_STAR x1 ++
-   fNODE "print_hintdb" 1
-| CT_print_rewrite_hintdb(x1) ->
-   fID x1 ++
-   fNODE "print_rewrite_hintdb" 1
-| CT_print_id(x1) ->
-   fID x1 ++
-   fNODE "print_id" 1
-| CT_print_implicit(x1) ->
-   fID x1 ++
-   fNODE "print_implicit" 1
-| CT_print_loadpath -> fNODE "print_loadpath" 0
-| CT_print_module(x1) ->
-   fID x1 ++
-   fNODE "print_module" 1
-| CT_print_module_type(x1) ->
-   fID x1 ++
-   fNODE "print_module_type" 1
-| CT_print_modules -> fNODE "print_modules" 0
-| CT_print_natural(x1) ->
-   fID x1 ++
-   fNODE "print_natural" 1
-| CT_print_natural_feature(x1) ->
-   fNATURAL_FEATURE x1 ++
-   fNODE "print_natural_feature" 1
-| CT_print_opaqueid(x1) ->
-   fID x1 ++
-   fNODE "print_opaqueid" 1
-| CT_print_path(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "print_path" 2
-| CT_print_proof(x1) ->
-   fID x1 ++
-   fNODE "print_proof" 1
-| CT_print_scope(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 ++
-   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 ++
-   fNODE "print_universes" 1
-| CT_print_visibility(x1) ->
-   fID_OPT x1 ++
-   fNODE "print_visibility" 1
-| CT_proof(x1) ->
-   fFORMULA x1 ++
-   fNODE "proof" 1
-| CT_proof_no_op -> fNODE "proof_no_op" 0
-| CT_proof_with(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "proof_with" 1
-| CT_pwd -> fNODE "pwd" 0
-| CT_quit -> fNODE "quit" 0
-| CT_read_module(x1) ->
-   fID x1 ++
-   fNODE "read_module" 1
-| CT_rec_ml_add_path(x1) ->
-   fSTRING x1 ++
-   fNODE "rec_ml_add_path" 1
-| CT_recaddpath(x1, 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 ++
-   fNODE "record" 6
-| CT_remove_natural_feature(x1, 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 ++
-   fNODE "require" 3
-| CT_reserve(x1, x2) ->
-   fID_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "reserve" 2
-| CT_reserve_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMODIFIER_LIST x2 ++
-   fNODE "reserve_notation" 2
-| CT_reset(x1) ->
-   fID x1 ++
-   fNODE "reset" 1
-| CT_reset_section(x1) ->
-   fID x1 ++
-   fNODE "reset_section" 1
-| CT_restart -> fNODE "restart" 0
-| CT_restore_state(x1) ->
-   fID x1 ++
-   fNODE "restore_state" 1
-| CT_resume(x1) ->
-   fID_OPT x1 ++
-   fNODE "resume" 1
-| CT_save(x1, x2) ->
-   fTHM_OPT x1 ++
-   fID_OPT x2 ++
-   fNODE "save" 2
-| CT_scomments(x1) ->
-   fSCOMMENT_CONTENT_LIST x1 ++
-   fNODE "scomments" 1
-| CT_search(x1, 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 ++
-   fNODE "search_about" 2
-| CT_search_pattern(x1, x2) ->
-   fFORMULA x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search_pattern" 2
-| CT_search_rewrite(x1, x2) ->
-   fFORMULA x1 ++
-   fIN_OR_OUT_MODULES x2 ++
-   fNODE "search_rewrite" 2
-| CT_section_end(x1) ->
-   fID x1 ++
-   fNODE "section_end" 1
-| CT_section_struct(x1, x2, x3) ->
-   fSECTION_BEGIN x1 ++
-   fSECTION_BODY x2 ++
-   fCOMMAND x3 ++
-   fNODE "section_struct" 3
-| CT_set_natural(x1) ->
-   fID x1 ++
-   fNODE "set_natural" 1
-| CT_set_natural_default -> fNODE "set_natural_default" 0
-| CT_set_option(x1) ->
-   fTABLE x1 ++
-   fNODE "set_option" 1
-| CT_set_option_value(x1, 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 ++
-   fNODE "set_option_value2" 2
-| CT_sethyp(x1) ->
-   fINT x1 ++
-   fNODE "sethyp" 1
-| CT_setundo(x1) ->
-   fINT x1 ++
-   fNODE "setundo" 1
-| CT_show_existentials -> fNODE "show_existentials" 0
-| CT_show_goal(x1) ->
-   fINT_OPT x1 ++
-   fNODE "show_goal" 1
-| CT_show_implicit(x1) ->
-   fINT x1 ++
-   fNODE "show_implicit" 1
-| CT_show_intro -> fNODE "show_intro" 0
-| CT_show_intros -> fNODE "show_intros" 0
-| CT_show_node -> fNODE "show_node" 0
-| CT_show_proof -> fNODE "show_proof" 0
-| CT_show_proofs -> fNODE "show_proofs" 0
-| 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 ++
-   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 ++
-   fNODE "syntax_macro" 3
-| CT_tactic_definition(x1) ->
-   fTAC_DEF_NE_LIST x1 ++
-   fNODE "tactic_definition" 1
-| CT_test_natural_feature(x1, x2) ->
-   fNATURAL_FEATURE x1 ++
-   fID x2 ++
-   fNODE "test_natural_feature" 2
-| CT_theorem_struct(x1, x2) ->
-   fTHEOREM_GOAL x1 ++
-   fPROOF_SCRIPT x2 ++
-   fNODE "theorem_struct" 2
-| CT_time(x1) ->
-   fCOMMAND x1 ++
-   fNODE "time" 1
-| CT_undo(x1) ->
-   fINT_OPT x1 ++
-   fNODE "undo" 1
-| CT_unfocus -> fNODE "unfocus" 0
-| CT_unset_option(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 ++
-   fNODE "user_vernac" 2
-| CT_variable(x1, x2) ->
-   fVAR x1 ++
-   fBINDER_NE_LIST x2 ++
-   fNODE "variable" 2
-| CT_write_module(x1, 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.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) ++
-   str "\n"
-and fCOMMENT_S = function
-| CT_comment_s 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 ++
-   fNODE "constr" 2
-| CT_constr_coercion(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "constr_coercion" 2
-and fCONSTR_LIST = function
-| CT_constr_list 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.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 ++
-   fNODE "context" 2
-and fCONTEXT_RULE = function
-| CT_context_rule(x1, x2, x3) ->
-   fCONTEXT_HYP_LIST x1 ++
-   fCONTEXT_PATTERN x2 ++
-   fTACTIC_COM x3 ++
-   fNODE "context_rule" 3
-| CT_def_context_rule(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "def_context_rule" 1
-and fCONVERSION_FLAG = function
-| CT_beta -> fNODE "beta" 0
-| CT_delta -> fNODE "delta" 0
-| CT_evar -> fNODE "evar" 0
-| CT_iota -> fNODE "iota" 0
-| CT_zeta -> fNODE "zeta" 0
-and fCONVERSION_FLAG_LIST = function
-| CT_conversion_flag_list 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.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "unf" (List.length l)
-| CT_unfbut 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) ++
-   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 ++
-   fNODE "decl_notation" 3
-and fDEF = function
-| CT_def(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "def" 2
-and fDEFN = 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 ++
-   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) ++
-   str "\n"
-and fDESTRUCTING = function
-| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x
-| CT_destructing -> fNODE "destructing" 0
-and fDESTRUCT_LOCATION = function
-| CT_conclusion_location -> fNODE "conclusion_location" 0
-| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0
-| CT_hypothesis_location -> fNODE "hypothesis_location" 0
-and fDOTDOT_OPT = function
-| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x
-| CT_dotdot -> fNODE "dotdot" 0
-and fEQN = function
-| CT_eqn(x1, x2) ->
-   fMATCH_PATTERN_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "eqn" 2
-and fEQN_LIST = function
-| CT_eqn_list 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 ++
-   fNODE "eval" 3
-and fFIXTAC = function
-| CT_fixtac(x1, x2, 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 ++
-   fNODE "fix_binder" 4
-and fFIX_BINDER_LIST = function
-| CT_fix_binder_list(x,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 ++
-   fNODE "fix_rec" 5
-and fFIX_REC_LIST = function
-| CT_fix_rec_list(x,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.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
-| CT_coerce_ID_to_FORMULA x -> fID x
-| CT_coerce_NUM_to_FORMULA x -> fNUM x
-| 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 ++
-   fNODE "appc" 2
-| CT_arrowc(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA x2 ++
-   fNODE "arrowc" 2
-| CT_bang(x1) ->
-   fFORMULA x1 ++
-   fNODE "bang" 1
-| CT_cases(x1, x2, 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 ++
-   fNODE "cofixc" 2
-| CT_elimc(x1, x2, x3, 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 ++
-   fNODE "fixc" 2
-| CT_if(x1, x2, x3, 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 ++
-   fNODE "inductive_let" 4
-| CT_labelled_arg(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "labelled_arg" 2
-| CT_lambdac(x1, 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 ++
-   fNODE "let_tuple" 4
-| CT_letin(x1, x2) ->
-   fDEF x1 ++
-   fFORMULA x2 ++
-   fNODE "letin" 2
-| CT_notation(x1, x2) ->
-   fSTRING x1 ++
-   fFORMULA_LIST x2 ++
-   fNODE "notation" 2
-| CT_num_encapsulator(x1, x2) ->
-   fNUM_TYPE x1 ++
-   fFORMULA x2 ++
-   fNODE "num_encapsulator" 2
-| CT_prodc(x1, x2) ->
-   fBINDER_NE_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "prodc" 2
-| CT_proj(x1, x2) ->
-   fFORMULA x1 ++
-   fFORMULA_NE_LIST x2 ++
-   fNODE "proj" 2
-and fFORMULA_LIST = function
-| CT_formula_list 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.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
-| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x
-and fFORMULA_OR_INT = function
-| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x
-| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x
-and fGRAMMAR = function
-| CT_grammar_none -> fNODE "grammar_none" 0
-and fHYP_LOCATION = function
-| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x
-| CT_intype(x1, x2) ->
-   fID x1 ++
-   fINT_LIST x2 ++
-   fNODE "intype" 2
-| CT_invalue(x1, 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.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) ++
-   str "\n"
-| CT_metac(x1) ->
-   fINT x1 ++
-   fNODE "metac" 1
-| 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.fold_left (++) (mt()) (List.map fID l)) ++
-   fNODE "id_list" (List.length l)
-and fID_LIST_LIST = function
-| CT_id_list_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.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
-| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x
-and fID_NE_LIST_OR_STRING = function
-| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x
-| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x
-and fID_OPT = function
-| CT_coerce_ID_to_ID_OPT x -> fID x
-| CT_coerce_NONE_to_ID_OPT x -> fNONE x
-and fID_OPT_LIST = function
-| CT_id_opt_list 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.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
-| CT_all -> fNODE "all" 0
-and fID_OR_INT = function
-| CT_coerce_ID_to_ID_OR_INT x -> fID x
-| CT_coerce_INT_to_ID_OR_INT x -> fINT x
-and fID_OR_INT_OPT = function
-| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x
-| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x
-| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x
-and fID_OR_STAR = function
-| CT_coerce_ID_to_ID_OR_STAR x -> fID x
-| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x
-and fID_OR_STRING = function
-| CT_coerce_ID_to_ID_OR_STRING x -> fID x
-| 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.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
-| CT_export -> fNODE "export" 0
-| 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 ++
-   fNODE "ind_spec" 5
-and fIND_SPEC_LIST = function
-| CT_ind_spec_list 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) ++
-   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.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.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.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.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
-| CT_coerce_NONE_to_INT_OPT x -> fNONE x
-and fINT_OR_LOCN = function
-| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x
-| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x
-and fINT_OR_NEXT = function
-| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x
-| CT_next_level -> fNODE "next_level" 0
-and fINV_TYPE = function
-| CT_inv_clear -> fNODE "inv_clear" 0
-| CT_inv_regular -> fNODE "inv_regular" 0
-| CT_inv_simple -> fNODE "inv_simple" 0
-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 ++
-   fNODE "in_modules" 1
-| CT_out_modules(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 ++
-   fNODE "let_clause" 3
-and fLET_CLAUSES = function
-| CT_let_clauses(x,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
-| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x
-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) ++
-   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 ++
-   fNODE "formula_as" 2
-| CT_formula_as_in(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fFORMULA x3 ++
-   fNODE "formula_as_in" 3
-| CT_formula_in(x1, 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.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 ++
-   fNODE "pattern_app" 2
-| CT_pattern_as(x1, x2) ->
-   fMATCH_PATTERN x1 ++
-   fID_OPT x2 ++
-   fNODE "pattern_as" 2
-| CT_pattern_delimitors(x1, x2) ->
-   fNUM_TYPE x1 ++
-   fMATCH_PATTERN x2 ++
-   fNODE "pattern_delimitors" 2
-| CT_pattern_notation(x1, x2) ->
-   fSTRING x1 ++
-   fMATCH_PATTERN_LIST x2 ++
-   fNODE "pattern_notation" 2
-and fMATCH_PATTERN_LIST = function
-| CT_match_pattern_list 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.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 ++
-   fNODE "match_tac_rule" 2
-and fMATCH_TAC_RULES = function
-| CT_match_tac_rules(x,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 ++
-   fNODE "entry_type" 2
-| CT_format(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 ++
-   fNODE "set_item_level" 2
-| CT_set_level(x1) ->
-   fINT x1 ++
-   fNODE "set_level" 1
-and fMODIFIER_LIST = function
-| CT_modifier_list 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 ++
-   fNODE "module_binder" 2
-and fMODULE_BINDER_LIST = function
-| CT_module_binder_list 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 ++
-   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 ++
-   fNODE "module_type_with_def" 3
-| CT_module_type_with_mod(x1, x2, 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 ++
-   fNODE "only_check" 1
-and fMODULE_TYPE_OPT = function
-| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x
-| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x
-and fNATURAL_FEATURE = function
-| CT_contractible -> fNODE "contractible" 0
-| CT_implicit -> fNODE "implicit" 0
-| CT_nat_transparent -> fNODE "nat_transparent" 0
-and fNONE = function
-| CT_none -> fNODE "none" 0
-and fNUM = 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
-| CT_flag_time -> fNODE "flag_time" 0
-and fOMEGA_MODE = function
-| CT_set -> fNODE "set" 0
-| CT_switch -> fNODE "switch" 0
-| CT_unset -> fNODE "unset" 0
-and fORIENTATION = function
-| CT_lr -> fNODE "lr" 0
-| CT_rl -> fNODE "rl" 0
-and fPATTERN = function
-| CT_pattern_occ(x1, x2) ->
-   fINT_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "pattern_occ" 2
-and fPATTERN_NE_LIST = function
-| CT_pattern_ne_list(x,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
-| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x
-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 ++
-   fNODE "eval_result" 3
-| CT_premise(x1, x2) ->
-   fID x1 ++
-   fFORMULA x2 ++
-   fNODE "premise" 2
-and fPREMISES_LIST = function
-| CT_premises_list 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 ++
-   fNODE "premise_pattern" 2
-and fPROOF_SCRIPT = function
-| CT_proof_script 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 ++
-   fNODE "defrecconstr" 3
-| CT_defrecconstr_coercion(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fFORMULA_OPT x3 ++
-   fNODE "defrecconstr_coercion" 3
-| CT_recconstr(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "recconstr" 2
-| CT_recconstr_coercion(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "recconstr_coercion" 2
-and fRECCONSTR_LIST = function
-| CT_recconstr_list 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 ++
-   fNODE "rec_tactic_fun" 3
-and fREC_TACTIC_FUN_LIST = function
-| CT_rec_tactic_fun_list(x,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 ++
-   fNODE "cbv" 2
-| CT_fold(x1) ->
-   fFORMULA_LIST x1 ++
-   fNODE "fold" 1
-| CT_hnf -> fNODE "hnf" 0
-| CT_lazy(x1, x2) ->
-   fCONVERSION_FLAG_LIST x1 ++
-   fCONV_SET x2 ++
-   fNODE "lazy" 2
-| CT_pattern(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 ++
-   fNODE "simpl" 1
-| CT_unfold(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 ++
-   fNODE "as_and_return" 2
-| CT_return(x1) ->
-   fFORMULA x1 ++
-   fNODE "return" 1
-and fRULE = function
-| CT_rule(x1, x2) ->
-   fPREMISES_LIST x1 ++
-   fFORMULA x2 ++
-   fNODE "rule" 2
-and fRULE_LIST = function
-| CT_rule_list 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 ++
-   fNODE "scheme_spec" 4
-and fSCHEME_SPEC_LIST = function
-| CT_scheme_spec_list(x,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.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++
-   fNODE "scomment_content_list" (List.length l)
-and fSECTION_BEGIN = function
-| CT_section(x1) ->
-   fID x1 ++
-   fNODE "section" 1
-and fSECTION_BODY = function
-| CT_section_body 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 ++
-   fNODE "minus" 1
-and fSIGNED_INT_LIST = function
-| CT_signed_int_list 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) ++
-   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
-| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x
-| CT_spec -> fNODE "spec" 0
-and fSTAR = function
-| CT_star -> fNODE "star" 0
-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) ++
-   str "\n"
-and fSTRING_NE_LIST = function
-| CT_string_ne_list(x,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
-| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x
-and fTABLE = function
-| CT_coerce_ID_to_TABLE x -> fID x
-| CT_table(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "table" 2
-and fTACTIC_ARG = function
-| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x
-| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x
-| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x
-| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x
-| CT_void -> fNODE "void" 0
-and fTACTIC_ARG_LIST = function
-| CT_tactic_arg_list(x,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 ++
-   fNODE "abstract" 2
-| CT_absurd(x1) ->
-   fFORMULA x1 ++
-   fNODE "absurd" 1
-| CT_any_constructor(x1) ->
-   fTACTIC_OPT x1 ++
-   fNODE "any_constructor" 1
-| CT_apply(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "apply" 2
-| CT_assert(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "assert" 2
-| CT_assumption -> fNODE "assumption" 0
-| CT_auto(x1) ->
-   fINT_OPT x1 ++
-   fNODE "auto" 1
-| CT_auto_with(x1, 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 ++
-   fNODE "autorewrite" 2
-| CT_autotdb(x1) ->
-   fINT_OPT x1 ++
-   fNODE "autotdb" 1
-| CT_case_type(x1) ->
-   fFORMULA x1 ++
-   fNODE "case_type" 1
-| CT_casetac(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "casetac" 2
-| CT_cdhyp(x1) ->
-   fID x1 ++
-   fNODE "cdhyp" 1
-| CT_change(x1, x2) ->
-   fFORMULA x1 ++
-   fCLAUSE x2 ++
-   fNODE "change" 2
-| CT_change_local(x1, x2, x3) ->
-   fPATTERN x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "change_local" 3
-| CT_clear(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "clear" 1
-| CT_clear_body(x1) ->
-   fID_NE_LIST x1 ++
-   fNODE "clear_body" 1
-| CT_cofixtactic(x1, 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 ++
-   fNODE "condrewrite_lr" 4
-| CT_condrewrite_rl(x1, x2, x3, 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 ++
-   fNODE "constructor" 2
-| CT_contradiction -> fNODE "contradiction" 0
-| CT_contradiction_thm(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "contradiction_thm" 2
-| CT_cut(x1) ->
-   fFORMULA x1 ++
-   fNODE "cut" 1
-| CT_cutrewrite_lr(x1, x2) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fNODE "cutrewrite_lr" 2
-| CT_cutrewrite_rl(x1, x2) ->
-   fFORMULA x1 ++
-   fID_OPT x2 ++
-   fNODE "cutrewrite_rl" 2
-| CT_dauto(x1, 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 ++
-   fNODE "decompose_list" 2
-| CT_decompose_record(x1) ->
-   fFORMULA x1 ++
-   fNODE "decompose_record" 1
-| CT_decompose_sum(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 ++
-   fNODE "depinversion" 4
-| CT_deprewrite_lr(x1) ->
-   fID x1 ++
-   fNODE "deprewrite_lr" 1
-| CT_deprewrite_rl(x1) ->
-   fID x1 ++
-   fNODE "deprewrite_rl" 1
-| CT_destruct(x1) ->
-   fID_OR_INT x1 ++
-   fNODE "destruct" 1
-| CT_dhyp(x1) ->
-   fID x1 ++
-   fNODE "dhyp" 1
-| CT_discriminate_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "discriminate_eq" 1
-| CT_do(x1, x2) ->
-   fID_OR_INT x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "do" 2
-| CT_eapply(x1, x2) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fNODE "eapply" 2
-| CT_eauto(x1, 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 ++
-   fNODE "eauto_with" 3
-| CT_elim(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fUSING x3 ++
-   fNODE "elim" 3
-| CT_elim_type(x1) ->
-   fFORMULA x1 ++
-   fNODE "elim_type" 1
-| CT_exact(x1) ->
-   fFORMULA x1 ++
-   fNODE "exact" 1
-| CT_exact_no_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "exact_no_check" 1
-| CT_vm_cast_no_check(x1) ->
-   fFORMULA x1 ++
-   fNODE "vm_cast_no_check" 1
-| CT_exists(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "exists" 1
-| CT_fail(x1, x2) ->
-   fID_OR_INT x1 ++
-   fSTRING_OPT x2 ++
-   fNODE "fail" 2
-| CT_first(x,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 ++
-   fNODE "firstorder" 1
-| CT_firstorder_using(x1, x2) ->
-   fTACTIC_OPT x1 ++
-   fID_NE_LIST x2 ++
-   fNODE "firstorder_using" 2
-| CT_firstorder_with(x1, 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 ++
-   fNODE "fixtactic" 3
-| CT_formula_marker(x1) ->
-   fFORMULA x1 ++
-   fNODE "formula_marker" 1
-| CT_fresh(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "fresh" 1
-| CT_generalize(x1) ->
-   fFORMULA_NE_LIST x1 ++
-   fNODE "generalize" 1
-| CT_generalize_dependent(x1) ->
-   fFORMULA x1 ++
-   fNODE "generalize_dependent" 1
-| CT_idtac(x1) ->
-   fSTRING_OPT x1 ++
-   fNODE "idtac" 1
-| CT_induction(x1) ->
-   fID_OR_INT x1 ++
-   fNODE "induction" 1
-| CT_info(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "info" 1
-| CT_injection_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "injection_eq" 1
-| CT_instantiate(x1, x2, x3) ->
-   fINT x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "instantiate" 3
-| CT_intro(x1) ->
-   fID_OPT x1 ++
-   fNODE "intro" 1
-| CT_intro_after(x1, x2) ->
-   fID_OPT x1 ++
-   fID x2 ++
-   fNODE "intro_after" 2
-| CT_intros(x1) ->
-   fINTRO_PATT_LIST x1 ++
-   fNODE "intros" 1
-| CT_intros_until(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 ++
-   fNODE "inversion" 4
-| CT_left(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "left" 1
-| CT_let_ltac(x1, x2) ->
-   fLET_CLAUSES x1 ++
-   fLET_VALUE x2 ++
-   fNODE "let_ltac" 2
-| CT_lettac(x1, x2, x3) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fCLAUSE x3 ++
-   fNODE "lettac" 3
-| CT_match_context(x,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.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 ++
-   fNODE "match_tac" 2
-| CT_move_after(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "move_after" 2
-| CT_new_destruct(x1, x2, 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.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 ++
-   fNODE "orelse" 2
-| CT_parallel(x,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 ++
-   fNODE "pose" 2
-| CT_progress(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "progress" 1
-| CT_prolog(x1, x2) ->
-   fFORMULA_LIST x1 ++
-   fINT x2 ++
-   fNODE "prolog" 2
-| CT_rec_tactic_in(x1, x2) ->
-   fREC_TACTIC_FUN_LIST x1 ++
-   fTACTIC_COM x2 ++
-   fNODE "rec_tactic_in" 2
-| CT_reduce(x1, x2) ->
-   fRED_COM x1 ++
-   fCLAUSE x2 ++
-   fNODE "reduce" 2
-| CT_refine(x1) ->
-   fFORMULA x1 ++
-   fNODE "refine" 1
-| CT_reflexivity -> fNODE "reflexivity" 0
-| CT_rename(x1, x2) ->
-   fID x1 ++
-   fID x2 ++
-   fNODE "rename" 2
-| CT_repeat(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "repeat" 1
-| CT_replace_with(x1, x2,x3,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 ++
-   fNODE "rewrite_lr" 3
-| CT_rewrite_rl(x1, x2, x3) ->
-   fFORMULA x1 ++
-   fSPEC_LIST x2 ++
-   fCLAUSE x3 ++
-   fNODE "rewrite_rl" 3
-| CT_right(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "right" 1
-| CT_ring(x1) ->
-   fFORMULA_LIST x1 ++
-   fNODE "ring" 1
-| CT_simple_user_tac(x1, x2) ->
-   fID x1 ++
-   fTACTIC_ARG_LIST x2 ++
-   fNODE "simple_user_tac" 2
-| CT_simplify_eq(x1) ->
-   fID_OR_INT_OPT x1 ++
-   fNODE "simplify_eq" 1
-| CT_specialize(x1, x2, x3) ->
-   fINT_OPT x1 ++
-   fFORMULA x2 ++
-   fSPEC_LIST x3 ++
-   fNODE "specialize" 3
-| CT_split(x1) ->
-   fSPEC_LIST x1 ++
-   fNODE "split" 1
-| CT_subst(x1) ->
-   fID_LIST x1 ++
-   fNODE "subst" 1
-| CT_superauto(x1, x2, x3, x4) ->
-   fINT_OPT x1 ++
-   fID_LIST x2 ++
-   fDESTRUCTING x3 ++
-   fUSINGTDB x4 ++
-   fNODE "superauto" 4
-| CT_symmetry(x1) ->
-   fCLAUSE x1 ++
-   fNODE "symmetry" 1
-| CT_tac_double(x1, x2) ->
-   fID_OR_INT x1 ++
-   fID_OR_INT x2 ++
-   fNODE "tac_double" 2
-| CT_tacsolve(x,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 ++
-   fNODE "tactic_fun" 2
-| CT_then(x,l) ->
-   fTACTIC_COM x ++
-   (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
-   fNODE "then" (1 + (List.length l))
-| CT_transitivity(x1) ->
-   fFORMULA x1 ++
-   fNODE "transitivity" 1
-| CT_trivial -> fNODE "trivial" 0
-| CT_trivial_with(x1) ->
-   fID_NE_LIST_OR_STAR x1 ++
-   fNODE "trivial_with" 1
-| CT_truecut(x1, x2) ->
-   fID_OPT x1 ++
-   fFORMULA x2 ++
-   fNODE "truecut" 2
-| CT_try(x1) ->
-   fTACTIC_COM x1 ++
-   fNODE "try" 1
-| CT_use(x1) ->
-   fFORMULA x1 ++
-   fNODE "use" 1
-| CT_use_inversion(x1, x2, x3) ->
-   fID_OR_INT x1 ++
-   fFORMULA x2 ++
-   fID_LIST x3 ++
-   fNODE "use_inversion" 3
-| CT_user_tac(x1, 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 ++
-   fNODE "tac_def" 2
-and fTAC_DEF_NE_LIST = function
-| CT_tac_def_ne_list(x,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
-| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x
-| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x
-| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x
-| CT_coerce_PATTERN_to_TARG x -> fPATTERN x
-| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x
-| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x
-| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x
-| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x
-| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x
-| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x
-| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x
-| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x
-and fTARG_LIST = function
-| CT_targ_list 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 ++
-   fNODE "check_term" 1
-| CT_inst_term(x1, 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 ++
-   fNODE "text_formula" 1
-| CT_text_h l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_h" (List.length l)
-| CT_text_hv l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_hv" (List.length l)
-| CT_text_op l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_op" (List.length l)
-| CT_text_path(x1) ->
-   fSIGNED_INT_LIST x1 ++
-   fNODE "text_path" 1
-| CT_text_v l ->
-   (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
-   fNODE "text_v" (List.length l)
-and fTHEOREM_GOAL = function
-| CT_goal(x1) ->
-   fFORMULA x1 ++
-   fNODE "goal" 1
-| CT_theorem_goal(x1, x2, x3, 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) ++
-   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 ++
-   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 ++
-   fNODE "unfold_occ" 2
-and fUNFOLD_NE_LIST = function
-| CT_unfold_ne_list(x,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 ++
-   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) ++
-   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
-| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x
-| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x
-| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x
-| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x
-| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x
-| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x
-| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x
-| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x
-| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x
-| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x
-| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x
-| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x
-and fVARG_LIST = function
-| CT_varg_list 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
-| CT_verbose -> fNODE "verbose" 0
-;;
diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli
deleted file mode 100644
index d7bd8db5..00000000
--- a/contrib/interface/vtp.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-open Ascent;;
-open Pp;;
-
-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
deleted file mode 100644
index e3cd56a0..00000000
--- a/contrib/interface/xlate.ml
+++ /dev/null
@@ -1,2267 +0,0 @@
-(** Translation from coq abstract syntax trees to centaur vernac
-   *)
-open String;;
-open Char;;
-open Util;;
-open Names;;
-open Ascent;;
-open Genarg;;
-open Rawterm;;
-open Termops;;
-open Tacexpr;;
-open Vernacexpr;;
-open Decl_kinds;;
-open Topconstr;;
-open Libnames;;
-open Goptions;;
-
-
-(* // 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
-problem is that now grammar rules will refer to identifiers by giving
-their absolute name, using the mutconstruct when needed.  Unfortunately,
-when you have a mutconstruct structure, you don't have a way to guess
-the corresponding identifier without an environment, and the parser
-does not have an environment.  We add one, only for the constructs
-that are always loaded. *)
-let type_table = ((Hashtbl.create 17) :
-      (string, ((string array) array)) Hashtbl.t);;
-
-Hashtbl.add type_table "Coq.Init.Logic.and"
-  [|[|"dummy";"conj"|]|];;
-
-Hashtbl.add type_table "Coq.Init.Datatypes.prod"
-  [|[|"dummy";"pair"|]|];;
-
-Hashtbl.add type_table "Coq.Init.Datatypes.nat"
-  [|[|"";"O"; "S"|]|];;
-
-Hashtbl.add type_table "Coq.ZArith.fast_integer.Z"
-[|[|"";"ZERO";"POS";"NEG"|]|];;
-
-
-Hashtbl.add type_table "Coq.ZArith.fast_integer.positive"
-[|[|"";"xI";"xO";"xH"|]|];;
-
-(*The following two codes are added to cope with the distinction
-  between ocaml and caml-light syntax while using ctcaml to
-  manipulate the program *)
-let code_plus = code (get "+" 0);;
-
-let code_minus = code (get "-" 0);;
-
-let coercion_description_holder = ref (function _ -> None : t -> int option);;
-
-let coercion_description t = !coercion_description_holder t;;
-
-let set_coercion_description f =
- coercion_description_holder:=f; ();;
-
-let xlate_error s = print_endline ("xlate_error : "^s);failwith ("Translation error: " ^ s);;
-
-let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;;
-
-let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;;
-
-let ctf_STRING_OPT = function
-  | None -> ctf_STRING_OPT_NONE
-  | Some s -> ctf_STRING_OPT_SOME (CT_string s)
-
-let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;;
-
-let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;;
-
-let ctv_ID_OPT_OR_ALL_NONE =
- CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);;
-
-let ctv_FORMULA_OPT_NONE =
-  CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);;
-
-let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;;
-
-let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT 
-			      ctv_FORMULA_OPT_NONE;;
-
-let ctf_ID_OPT_OR_ALL_SOME s =
- CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);;
-
-let ctv_ID_OPT_OR_ALL_ALL = CT_all;;
-
-let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;;
-
-let ct_coerce_FORMULA_to_DEF_BODY x =
-    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
-    (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);;
-
-let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;;
-
-let varc x = CT_coerce_ID_to_FORMULA x;;
-
-let xlate_ident id = CT_ident (string_of_id id)
-
-let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);;
-
-let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);;
-
-let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;;
-
-let nums_to_int_list l =  CT_int_list(nums_to_int_list_aux l);;
-
-let num_or_var_to_int = function
-  | ArgArg x -> CT_int x
-  | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";;
-
-let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;;
-
-let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);;
-
-let nums_or_var_to_int_ne_list n l =
-  CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);;
-
-type iTARG =   Targ_command of ct_FORMULA
-             | Targ_intropatt of ct_INTRO_PATT_LIST
-             | Targ_id_list of ct_ID_LIST
-             | Targ_spec_list of ct_SPEC_LIST
-             | Targ_binding_com of ct_FORMULA
-             | Targ_ident of ct_ID
-             | Targ_int of ct_INT
-             | Targ_binding of ct_BINDING
-             | Targ_pattern of ct_PATTERN
-             | Targ_unfold of ct_UNFOLD
-	     | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST
-             | Targ_string of ct_STRING
-             | Targ_fixtac of ct_FIXTAC
-             | Targ_cofixtac of ct_COFIXTAC
-             | Targ_tacexp of ct_TACTIC_COM
-             | Targ_redexp of ct_RED_COM;;
-
-type iVARG =   Varg_binder of ct_BINDER
-             | Varg_binderlist of ct_BINDER_LIST
-             | Varg_bindernelist of ct_BINDER_NE_LIST
-             | Varg_call of ct_ID * iVARG list
-             | Varg_constr of ct_FORMULA
-             | Varg_sorttype of ct_SORT_TYPE
-             | Varg_constrlist of ct_FORMULA list
-             | Varg_ident of ct_ID
-             | Varg_int of ct_INT
-             | Varg_intlist of ct_INT_LIST
-             | Varg_none
-             | Varg_string of ct_STRING
-             | Varg_tactic of ct_TACTIC_COM
-             | Varg_ast of ct_AST
-             | Varg_astlist of ct_AST_LIST
-             | Varg_tactic_arg of iTARG
-             | Varg_varglist of iVARG list;;
-
-
-let coerce_iVARG_to_FORMULA =
- function
-    | Varg_constr x -> x
-    | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x
-    | Varg_ident id -> CT_coerce_ID_to_FORMULA id
-    | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";;
-
-let coerce_iVARG_to_ID =
- function Varg_ident id -> id
-    | _ -> xlate_error "coerce_iVARG_to_ID";;
-
-let coerce_VARG_to_ID =
- function
-    | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) ->
-     x
-    | _ -> xlate_error "coerce_VARG_to_ID";;
-
-let xlate_ident_opt =
-  function
-    | None -> ctv_ID_OPT_NONE
-    | Some id -> ctf_ID_OPT_SOME (xlate_ident id)
-
-let xlate_id_to_id_or_int_opt s =
-   CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));;
-
-let xlate_int_to_id_or_int_opt n =
-   CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
-     (CT_coerce_INT_to_ID_OR_INT (CT_int n));;
-
-let none_in_id_or_int_opt =
-  CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-    (CT_coerce_NONE_to_ID_OPT(CT_none));;
-
-let xlate_int_opt = function
-  | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n)
-  | None ->  CT_coerce_NONE_to_INT_OPT CT_none
-
-let xlate_int_or_var_opt_to_int_opt = function
-  | Some (ArgArg n) -> CT_coerce_INT_to_INT_OPT (CT_int n)
-  | 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)))
-
-let loc_qualid_to_ct_ID ref =
-  CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
-
-let int_of_meta n = int_of_string (string_of_id n)
-let is_int_meta n = try let _ = int_of_meta n in true with _ -> false
-
-let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l)
-
-let reference_to_ct_ID = function
-  | Ident (_,id) -> CT_ident (Names.string_of_id id)
-  | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid)
-
-let xlate_class = function
-  | FunClass -> CT_ident "FUNCLASS"
-  | SortClass -> CT_ident "SORTCLASS"
-  | RefClass qid -> loc_qualid_to_ct_ID qid
-
-let id_to_pattern_var ctid =
- match ctid with
- | CT_metaid _ -> xlate_error "metaid not expected in pattern_var"
- | CT_ident "_" -> 
-     CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none)
- | CT_ident id_string ->
-     CT_coerce_ID_OPT_to_MATCH_PATTERN 
-       (CT_coerce_ID_to_ID_OPT (CT_ident id_string))
- | CT_metac _ -> assert false;;
-
-exception Not_natural;;
-
-let xlate_sort =
-  function
-    | RProp Term.Pos -> CT_sortc "Set"
-    | RProp Term.Null -> CT_sortc "Prop"
-    | RType None -> CT_sortc "Type"
-    | RType (Some u) -> xlate_error "xlate_sort";;
-
-
-let xlate_qualid a =
-  let d,i = Libnames.repr_qualid a in
-  let l = Names.repr_dirpath d in
-  List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;;
-   
-(* // The next two functions should be modified to make direct reference
-  to a notation operator *)
-let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);;
-
-let xlate_reference = function
-    Ident(_,i) -> CT_ident (string_of_id i)
-  | Qualid(_, q) -> CT_ident (xlate_qualid q);;
-let rec xlate_match_pattern =
- function
-   | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference  s)
-   | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_")
-   | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f)
-   | CPatCstr (_, f1 , (arg1 :: args)) ->
-     CT_pattern_app
-      (id_to_pattern_var (xlate_reference  f1),
-      CT_match_pattern_ne_list
-       (xlate_match_pattern arg1, 
-	List.map xlate_match_pattern args))
-    | CPatAlias  (_,  pattern, id) ->
-     CT_pattern_as
-      (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id))
-    | CPatOr (_,l) -> xlate_error "CPatOr: TODO"
-    | CPatDelimiters(_, key, p) -> 
-	CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p)
-    | CPatPrim (_,Numeral n) ->
- 	CT_coerce_NUM_to_MATCH_PATTERN
-	  (CT_int_encapsulator(Bigint.to_string n))
-    | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO"
-    | CPatNotation(_, s, (l,[])) -> 
-	CT_pattern_notation(CT_string s,
-			    CT_match_pattern_list(List.map xlate_match_pattern l))
-    | CPatNotation(_, s, (l,_)) ->
-	 xlate_error "CPatNotation (recursive notation): TODO"
-;;
-
-
-let xlate_id_opt_aux = function
-    Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id))
-  | Anonymous -> ctv_ID_OPT_NONE;;
-
-let xlate_id_opt (_, v) = xlate_id_opt_aux v;;
-
-let xlate_id_opt_ne_list = function
-    [] -> assert false
-  | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);;
-
-
-let rec last = function
-    [] -> assert false
-  | [a] -> a
-  | a::tl -> last tl;;
-
-let rec decompose_last = function
-    [] -> assert false
-  | [a] -> [], a
-  | a::tl -> let rl, b = decompose_last tl in (a::rl), b;;
-
-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 ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));;
-
-let rec xlate_binder = function
-    (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
-| (None, Some t) -> CT_return(xlate_formula t)
-| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t)
-| (Some _, None) -> assert false
-and xlate_formula_opt =
-  function
-    | None -> ctv_FORMULA_OPT_NONE
-    | 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)
-  | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n,
-						       xlate_formula v))
-and 
-  xlate_match_pattern_ne_list = function
-    [] -> assert false
-  | 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)
-  | _ -> xlate_error "TODO: disjunctive multiple patterns"
-and 
-  xlate_binder_ne_list = function
-    [] -> assert false
-  | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l)
-and 
-  xlate_binder_list = function
-  l -> CT_binder_list( List.map xlate_binder_l l)
-and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
-
-     CRef r -> varc (xlate_reference r)
-   | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b)
-   | CProdN(_,ll,b) as whole_term -> 
-       let rec gather_binders = function
-	   CProdN(_, ll, b) ->
-	     ll@(gather_binders b)
-	 | _ -> [] in
-       let rec fetch_ultimate_body = function
-	   CProdN(_, _, b) -> fetch_ultimate_body b
-	 | a -> a in
-	 CT_prodc(xlate_binder_ne_list (gather_binders whole_term), 
-		  xlate_formula (fetch_ultimate_body b))
-   | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b)
-   | CLetIn(_, v, a, b) -> 
-       CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b)
-   | CAppExpl(_, (Some n, r), l) -> 
-       let l', last = decompose_last l in
-	 CT_proj(xlate_formula last,
-		 CT_formula_ne_list
-		   (CT_bang(varc (xlate_reference r)),
-		    List.map xlate_formula l'))
-   | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r))
-   | CAppExpl(_, (None, r), l) -> 
-       CT_appc(CT_bang(varc (xlate_reference r)),
-	       xlate_formula_ne_list l)
-   | CApp(_, (Some n,f), l) -> 
-       let l', last = decompose_last l in
-       CT_proj(xlate_formula_expl last, 
-	       CT_formula_ne_list
-		 (xlate_formula f, List.map xlate_formula_expl l'))
-   | CApp(_, (_,f), l) -> 
-       CT_appc(xlate_formula f, xlate_formula_expl_ne_list l)
-   | CRecord (_,_,_) -> xlate_error "CRecord: TODO"
-   | 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,
-                CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns))
-   | CLetTuple (_,a::l, ret_info, c, b) -> 
-      CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a,
-				     List.map xlate_id_opt_aux l),
-		   xlate_return_info ret_info,
-		   xlate_formula c,
-		   xlate_formula b)
-   | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()"
-   | CIf (_,c, ret_info, b1, b2) -> 
-       CT_if
-	 (xlate_formula c, xlate_return_info ret_info,
-	  xlate_formula b1, xlate_formula b2)
-
-   | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s)
-   | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l)
-   | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO"
-   | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO"
-   | CPrim (_, Numeral i) -> 
-       CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i))
-   | CPrim (_, String _) -> xlate_error "CPrim (String): TODO"
-   | CHole _ -> CT_existvarc 
-(* I assume CDynamic has been inserted to make free form extension of
-   the language possible, but this would go agains the logic of pcoq anyway. *)
-   | CDynamic (_, _) -> assert false
-   | CDelimiters (_, key, num) -> 
-	 CT_num_encapsulator(CT_num_type key , xlate_formula  num)
-   | CCast (_, e, CastConv (_, t)) -> 
-       CT_coerce_TYPED_FORMULA_to_FORMULA
-	 (CT_typed_formula(xlate_formula e, xlate_formula t))
-   | CCast (_, e, CastCoerce) -> assert false
-   | CPatVar (_, (_,i)) when is_int_meta i ->
-       CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i)))
-   | CPatVar (_, (false, s)) ->
-       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"
-   | CCoFix (_, (_, id), lm::lmi) -> 
-     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 = make_fix_struct (n, bl) in
-        let arf = xlate_formula arf in
-        let ardef = xlate_formula ardef in
-	match xlate_binder_list bl with
-	  | CT_binder_list (b :: bl) ->
-	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl),
-			  struct_arg, arf, ardef)
-          | _ -> xlate_error "mutual recursive" in
-       CT_fixc (xlate_ident id, 
-         	CT_fix_binder_list
-		  (CT_coerce_FIX_REC_to_FIX_BINDER 
-		     (strip_mutrec lm), List.map 
-		       (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x))
-		       lmi)) 
-   | CCoFix _ -> assert false
-   | CFix _ -> assert false
-and xlate_matched_formula = function
-    (f, (Some x, Some y)) ->
-      CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y)
-  | (f, (None, Some y)) ->
-      CT_formula_in(xlate_formula f, xlate_formula y)
-  | (f, (Some x, None)) ->
-      CT_formula_as(xlate_formula f, xlate_id_opt_aux x)
-  | (f, (None, None)) -> 
-      CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f)
-and xlate_formula_expl = function
-    (a, None) -> xlate_formula a
-  | (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)
-and xlate_formula_expl_ne_list = function
-    [] -> assert false
-  | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l)
-and xlate_formula_ne_list = function 
-    [] -> assert false
-  | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);;
-
-let (xlate_ident_or_metaid:
-      Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function
-    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
-  | (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 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)"
-
-
-
-let xlate_clause cls =
-  let hyps_info =
-    match cls.onhyps with
-    	None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star
-      | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in
-  CT_clause
-    (hyps_info, 
-     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)
-
-(** Tactics
-   *)
-let strip_targ_spec_list =
- function
-    | Targ_spec_list x -> x
-    | _ -> xlate_error "strip tactic: non binding-list argument";;
-
-let strip_targ_binding =
- function
-    | Targ_binding x -> x
-    | _ -> xlate_error "strip tactic: non-binding argument";;
-
-let strip_targ_command =
- function
-    | Targ_command x -> x
-    | Targ_binding_com x -> x
-    | _ -> xlate_error "strip tactic: non-command argument";;
-
-let strip_targ_ident =
- function
-    | Targ_ident x -> x
-    | _ -> xlate_error "strip tactic: non-ident argument";;
-
-let strip_targ_int =
- function
-    | Targ_int x -> x
-    | _ -> xlate_error "strip tactic: non-int argument";;
-
-let strip_targ_pattern =
- function
-    | Targ_pattern x -> x
-    | _ -> xlate_error "strip tactic: non-pattern argument";;
-
-let strip_targ_unfold =
- function
-    | Targ_unfold x -> x
-    | _ -> xlate_error "strip tactic: non-unfold argument";;
-
-let strip_targ_fixtac =
- function
-    | Targ_fixtac x -> x
-    | _ -> xlate_error "strip tactic: non-fixtac argument";;
-
-let strip_targ_cofixtac =
- function
-    | Targ_cofixtac x -> x
-    | _ -> xlate_error "strip tactic: non-cofixtac argument";;
-
-(*Need to transform formula to id for "Prolog" tactic problem *)
-let make_ID_from_FORMULA =
- function
-    | CT_coerce_ID_to_FORMULA id -> id
-    | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";;
-
-let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);;
-
-let xlate_quantified_hypothesis = function
-  | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
-  | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id)
-
-let xlate_quantified_hypothesis_opt = function
-  | None -> 
-      CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE
-  | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n
-  | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;;
-
-let xlate_id_or_int = function
-    ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n)
-  | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);;
-
-let xlate_explicit_binding (loc,h,c) = 
-  CT_binding (xlate_quantified_hypothesis h, xlate_formula c)
-
-let xlate_bindings = function
-  | ImplicitBindings l ->
-      CT_coerce_FORMULA_LIST_to_SPEC_LIST
-        (CT_formula_list (List.map xlate_formula l))
-  | ExplicitBindings l ->
-      CT_coerce_BINDING_LIST_to_SPEC_LIST
-        (CT_binding_list (List.map xlate_explicit_binding l))
-  | NoBindings ->
-      CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list [])
-
-let strip_targ_spec_list =
- function
-    | Targ_spec_list x -> x
-    | _ -> xlate_error "strip_tar_spec_list";;
-
-let strip_targ_intropatt =
- function
-    | Targ_intropatt x -> x
-    | _ -> xlate_error "strip_targ_intropatt";;
-
-let get_flag r =
-  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 csts
-    else
-      (if r.rConst = []
-      then (* probably useless: just for compatibility *) []
-      else [CT_delta]),
-      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
-  (* Rem: EVAR flag obsolète *)
-  conv_flags, red_ids
-
-let rec xlate_intro_pattern (loc,pat) = match pat with
-  | IntroOrAndPattern [] -> assert false
-  | IntroOrAndPattern (fp::ll) ->
-      CT_disj_pattern
-      	(CT_intro_patt_list(List.map xlate_intro_pattern fp),
-	 List.map 
-	   (fun l ->
-	      CT_intro_patt_list(List.map xlate_intro_pattern l))
-	   ll)
-  | 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
- | SimpleInversion -> CT_inv_simple
- | FullInversion -> CT_inv_regular
-
-let is_tactic_special_case = function
-    "AutoRewrite" -> true
-  | _ -> false;;
-
-let xlate_context_pattern = function
-  | Term v -> 
-      CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v)
-  | Subterm (b, idopt, v) -> (* TODO: application pattern *)
-      CT_context(xlate_ident_opt idopt, xlate_formula v)
-
-
-let xlate_match_context_hyps = function
-  | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b)
-  | Def (na,b,t) -> xlate_error "TODO: Let hyps"
-      (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *)
-
-let xlate_arg_to_id_opt = function
-    Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id))
-  | None -> ctv_ID_OPT_NONE;;
-
-let xlate_largs_to_id_opt largs =
-  match List.map xlate_arg_to_id_opt largs with
-      fst::rest -> fst, rest
-    | _ -> assert false;;
-
-let xlate_int_or_constr = function
-    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))
-  | ElimOnAnonHyp i -> 
-      CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	(CT_coerce_INT_to_ID_OR_INT(CT_int i));;
-
-let xlate_using = function
-    None -> CT_coerce_NONE_to_USING(CT_none)
-  | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);;
-
-let xlate_one_unfold_block = function
-    ((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
-    None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE
-  | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp)
-
-let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
-
-let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) =
-  function
-    | TacVoid ->
-	CT_void
-    | Tacexp t -> 
-	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t)
-    | Integer n ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
-    | Reference r ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r)))
-    | TacDynamic _ ->
-	failwith "Dynamics not treated in xlate_ast"
-    | ConstrMayEval (ConstrTerm c) ->
-	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
-	  (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c))
-    | ConstrMayEval(ConstrEval(r,c)) ->
-	CT_coerce_EVAL_CMD_to_TACTIC_ARG
-	  (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r,
-		   xlate_formula c))
-    | ConstrMayEval(ConstrTypeOf(c)) -> 
-	CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c))
-    | MetaIdArg _ ->
-	xlate_error "MetaIdArg should only be used in quotations"
-    | t ->
-	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t)
-
-and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) =
- function
-   (* Moved from xlate_tactic *)
-    | TacCall (_, r, a::l) ->
-	CT_simple_user_tac
-	  (reference_to_ct_ID r,
-	    CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l))
-    | Reference (Ident (_,s)) -> ident_tac s
-    | ConstrMayEval(ConstrTerm a) ->
-	CT_formula_marker(xlate_formula a)
-    | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None)
-    | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s))
-    | TacFreshId _ -> xlate_error "TODO: fresh with many args"
-    | t -> xlate_error "TODO LATER: result other than tactic or constr"
-
-and xlate_red_tactic =
- function
-  | Red true -> xlate_error ""
-  | Red false -> CT_red
-  | CbvVm -> CT_cbvvm
-  | Hnf -> CT_hnf
-  | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE
-  | Simpl (Some (occs,c)) -> 
-      let l = nums_of_occs occs in
-      CT_simpl 
-	(CT_coerce_PATTERN_to_PATTERN_OPT
-	   (CT_pattern_occ
-	      (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c)))
-  | Cbv flag_list ->
-     let conv_flags, red_ids = get_flag flag_list in
-     CT_cbv (CT_conversion_flag_list conv_flags, red_ids)
-  | Lazy flag_list ->
-     let conv_flags, red_ids = get_flag flag_list in
-     CT_lazy (CT_conversion_flag_list conv_flags, red_ids)
-  | Unfold unf_list ->
-     let ct_unf_list = List.map xlate_one_unfold_block unf_list in
-     (match ct_unf_list with
-      | first :: others -> CT_unfold (CT_unfold_ne_list (first, others))
-      | [] -> error "there should be at least one thing to unfold")
-  | Fold formula_list -> 
-      CT_fold(CT_formula_list(List.map xlate_formula formula_list))
-  | Pattern l ->
-     let pat_list = List.map (fun (occs,c) ->
-          CT_pattern_occ
-           (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))
-      | [] -> error "Expecting at least one pattern in a Pattern command")
-  | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)"
-
-and xlate_local_rec_tac = function 
- (* TODO LATER: local recursive tactics and global ones should be handled in
-    the same manner *)
-  | ((_,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,[||]) -> 
-       (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
-       let cl = List.map xlate_tactic l in
-       (match xlate_tactic t1 with
-	    CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)])
-	  | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)]))
-   | TacFirst([]) -> assert false
-   | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l)
-   | TacSolve([]) -> assert false
-   | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l)
-   | TacComplete _ -> xlate_error "TODO: tactical complete"
-   | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t)
-   | TacTry t -> CT_try (xlate_tactic t)
-   | TacRepeat t -> CT_repeat(xlate_tactic t)
-   | TacAbstract(t,id_opt) -> 
-       CT_abstract((match id_opt with
-		       	None -> ctv_ID_OPT_NONE
-		      | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))),
-		   xlate_tactic t)
-   | TacProgress t -> CT_progress(xlate_tactic t)
-   | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2)
-   | TacMatch (true,_,_) -> failwith "TODO: lazy match"
-   | TacMatch (false, exp, rules) ->
-        CT_match_tac(xlate_tactic exp,
-                     match List.map 
-                       (function 
-                          | Pat ([],p,tac) ->
-                              CT_match_tac_rule(xlate_context_pattern p,
-                                                mk_let_value tac)
-                          | Pat (_,p,tac) -> xlate_error"No hyps in pure Match"
-                          | All tac ->
-                              CT_match_tac_rule
-                                (CT_coerce_FORMULA_to_CONTEXT_PATTERN
-                                   CT_existvarc, 
-                                   mk_let_value tac)) rules with
-                         | [] -> assert false
-                         | fst::others ->
-                             CT_match_tac_rules(fst, others))
-   | TacMatchGoal (_,_,[]) | TacMatchGoal (true,_,_) -> failwith ""
-   | TacMatchGoal (false,false,rule1::rules) ->
-         CT_match_context(xlate_context_rule rule1,
-                          List.map xlate_context_rule rules)
-   | TacMatchGoal (false,true,rule1::rules) ->
-         CT_match_context_reverse(xlate_context_rule rule1,
-                          List.map xlate_context_rule rules)
-   | TacLetIn (false, l, t) ->
-       let cvt_clause =
-         function
-             ((_,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),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),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)) 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))
-   | 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)
-   | TacAtom (_, t) -> xlate_tac t 
-   | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE)
-   | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count,
-				   ctf_STRING_OPT_SOME (CT_string s))
-   | TacFail (count, _) -> xlate_error "TODO: generic fail message"
-   | TacId [] -> CT_idtac ctf_STRING_OPT_NONE
-   | TacId [MsgString s] -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s))
-   | TacId _ -> xlate_error "TODO: generic idtac message"
-   | TacInfo t -> CT_info(xlate_tactic t)
-   | TacArg a -> xlate_call_or_tacarg a
-
-and xlate_tac =
-  function
-    | TacExtend (_, "firstorder", tac_opt::l) ->
-       let t1 =
-	 match
-	   out_gen (wit_opt rawwit_main_tactic) tac_opt
-	 with
-	 | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none
-	 | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in
-	 (match l with
-	      [] -> CT_firstorder t1
-	    | [l1] -> 
-		(match genarg_tag l1 with
-		     List1ArgType PreIdentArgType -> 
-		       let l2 = List.map 
-				  (fun x -> CT_ident x)
-				  (out_gen (wit_list1 rawwit_pre_ident) l1) in
-		       let fst,l3 = 
-			 match l2 with fst::l3 -> fst,l3 | [] -> assert false in
-		      	 CT_firstorder_using(t1, CT_id_ne_list(fst, l3))
-		   | List1ArgType RefArgType ->
-		       let l2 = List.map reference_to_ct_ID 
-				  (out_gen (wit_list1 rawwit_ref) l1) in
-		       let fst,l3 =
-			 match  l2 with fst::l3 -> fst, l3 | [] -> assert false in
-			 CT_firstorder_with(t1, CT_id_ne_list(fst, l3))
-		   | _ -> assert false)
-	    | _ -> assert false)
-    | TacExtend (_, "refine", [c]) ->
-       CT_refine (xlate_formula (snd (out_gen rawwit_casted_open_constr c)))
-    | TacExtend (_,"absurd",[c]) ->
-       CT_absurd (xlate_formula (out_gen rawwit_constr c))
-    | TacExtend (_,"contradiction",[opt_c]) ->
-	(match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with
-	     None -> CT_contradiction
-	   | Some(c, b) ->
-	       let c1 = xlate_formula c in
-	       let bindings = xlate_bindings b in
-		 CT_contradiction_thm(c1, bindings))
-    | 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),
-	  xlate_formula f,
-	  xlate_clause b)
-    | TacExtend (_,"contradiction",[]) -> CT_contradiction
-    | TacDoubleInduction (n1, n2) ->
-	CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2)
-    | TacExtend (_,"discriminate", []) ->
-     CT_discriminate_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE)
-    | TacExtend (_,"discriminate", [id]) ->
-     CT_discriminate_eq
-         (xlate_quantified_hypothesis_opt
-	    (Some (out_gen rawwit_quant_hyp id)))
-    | TacExtend (_,"simplify_eq", []) ->
-	  CT_simplify_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT
-		(CT_coerce_NONE_to_ID_OPT CT_none))
-    | TacExtend (_,"simplify_eq", [id]) ->
-	let id1 = out_gen rawwit_quant_hyp id in
-	let id2 = CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
-	      	(xlate_quantified_hypothesis id1) in
-	  CT_simplify_eq id2
-    | TacExtend (_,"injection", []) ->
-     CT_injection_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE)
-    | TacExtend (_,"injection", [id]) ->
-     CT_injection_eq
-         (xlate_quantified_hypothesis_opt
-	    (Some (out_gen rawwit_quant_hyp id)))
-    | TacExtend (_,"injection_as", [idopt;ipat]) ->
-	xlate_error "TODO: injection as"
-    | TacFix (idopt, n) ->
-     CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
-    | TacMutualFix (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 (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) -> 
-	CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n))
-    | TacIntroMove (Some id1, MoveAfter id2) ->
-     CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2)
-    | TacIntroMove (None, MoveAfter id2) ->
-	CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_hyp id2)
-    | TacMove (true, id1, MoveAfter id2) ->
-	CT_move_after(xlate_hyp id1, xlate_hyp id2)
-    | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal"
-    | TacMove _ -> xlate_error "TODO: move before, at top, at bottom"
-    | TacIntroPattern patt_list ->
-	CT_intros
-	  (CT_intro_patt_list (List.map xlate_intro_pattern patt_list))
-    | TacIntroMove (Some id, MoveToEnd true) ->
-     CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)])
-    | TacIntroMove (None, MoveToEnd true) ->
-	CT_intro (CT_coerce_NONE_to_ID_OPT CT_none)
-    | TacIntroMove _ -> xlate_error "TODO"
-    | 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
-	let cl = 
-	  (* J.F. : 18/08/2006 
-	     Hack to coerce the "clause" argument of replace to a real clause 
-	     To be remove if we can reuse the clause grammar entrie defined in g_tactic
-	  *)
-	  let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in 
-	  let cl_as_xlate_arg = 
-	    {cl_as_clause with 
-	       Tacexpr.onhyps = 
-		Option.map 
-		  (fun l -> 
-		     List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
-		  )
-		  cl_as_clause.Tacexpr.onhyps
-	    }
-	  in
-	  cl_as_xlate_arg
-	in 
-	let cl = xlate_clause cl in 
-	let tac_opt = 
-	  match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with
-	    | None -> CT_coerce_NONE_to_TACTIC_OPT  CT_none
-	    | Some tac ->
-		let tac =  xlate_tactic tac in
-		CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
-	in 
-	CT_replace_with (c1, c2,cl,tac_opt)
-    | 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
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
-     else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
-    | TacExtend (_,"conditional_rewrite", [t; b; cbindl; id]) ->
-     let t = out_gen rawwit_main_tactic t in
-     let b = out_gen Extraargs.rawwit_orient b in
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in
-     if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id)
-     else CT_condrewrite_rl (xlate_tactic t, c, bindl, id)
-    | TacExtend (_,"dependent_rewrite", [b; c]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      (match c with
-	| CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> 
-	    if b then CT_deprewrite_lr id else CT_deprewrite_rl id
-	| _ -> xlate_error "dependent rewrite on term: not supported")
-    | TacExtend (_,"dependent_rewrite", [b; c; id]) ->
-	xlate_error "dependent rewrite on terms in hypothesis: not supported"
-    | TacExtend (_,"cut_rewrite", [b; c]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
-      else CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
-    | TacExtend (_,"cut_rewrite", [b; c; id]) ->
-      let b = out_gen Extraargs.rawwit_orient b in
-      let c = xlate_formula (out_gen rawwit_constr c) in
-      let id = xlate_ident (snd (out_gen rawwit_var id)) in
-      if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
-      else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
-    | TacExtend(_, "subst", [l]) ->
-	CT_subst
-	  (CT_id_list
-	     (List.map (fun x -> CT_ident (string_of_id x))
-		(out_gen (wit_list1 rawwit_ident) l)))
-    | TacReflexivity -> CT_reflexivity
-    | TacSymmetry cls -> CT_symmetry(xlate_clause cls)
-    | TacTransitivity c -> CT_transitivity (xlate_formula c)
-    | TacAssumption -> CT_assumption
-    | TacExact c -> CT_exact (xlate_formula c)
-    | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c)
-    | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c)
-    | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id)
-    | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id)
-    | TacDestructConcl -> CT_dconcl
-    | TacSuperAuto (nopt,l,a3,a4) ->
-      CT_superauto(
-        xlate_int_opt nopt,
-        xlate_qualid_list l,
-        (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none),
-        (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none))
-    | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt)
-    | TacAuto (nopt, [], Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt)
-    | TacAuto (nopt, [], None) ->
- 	CT_auto_with (xlate_int_or_var_opt_to_int_opt nopt,
-		      CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-    | TacAuto (nopt, [], Some (id1::idl)) ->
-	CT_auto_with(xlate_int_or_var_opt_to_int_opt nopt,
-             CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
-             CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl)))
-    | TacAuto (nopt, _::_, _) ->
-	xlate_error "TODO: auto using"
-    |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) ->
-       let (id_list:ct_ID list) =
-	 List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in
-       let fst, (id_list1: ct_ID list) =
-	 match id_list with [] -> assert false | a::tl -> a,tl in
-       let t1 =
-	 match t with
-	     [t0] -> 
-	       CT_coerce_TACTIC_COM_to_TACTIC_OPT
-	       (xlate_tactic(out_gen rawwit_main_tactic t0))
-	   | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none
-	   | _ -> assert false in
-	 CT_autorewrite (CT_id_ne_list(fst, id_list1), t1)
-    | TacExtend (_,"eauto", [nopt; popt; lems; idl]) ->
-	let first_n =
-	  match out_gen (wit_opt rawwit_int_or_var) nopt with
-	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
-	    | None -> none_in_id_or_int_opt in
-	let second_n =
-	  match out_gen (wit_opt rawwit_int_or_var) popt with
-	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
-	    | None -> none_in_id_or_int_opt in
-	let _lems =
-	  match out_gen Eauto.rawwit_auto_using lems with
-	    | [] -> []
-	    | _ -> xlate_error "TODO: eauto using" in
-	let idl = out_gen Eauto.rawwit_hintbases idl in
-          (match idl with
-	    None -> CT_eauto_with(first_n,
-				  second_n,
-				  CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-	  | Some [] -> CT_eauto(first_n, second_n)
-	  | Some (a::l) -> 
-	      CT_eauto_with(first_n, second_n,
-			    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR
-			      (CT_id_ne_list
-				 (CT_ident a,
-				  List.map (fun x -> CT_ident x) l))))
-    | TacExtend (_,"prolog", [cl; n]) ->
-      let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in
-      (match out_gen rawwit_int_or_var n with
-	| ArgVar _ -> xlate_error ""
-	| ArgArg n -> CT_prolog (CT_formula_list cl, CT_int  n))
-    (* 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)
-    | TacTrivial ([],Some (id1::idl)) ->
-	 CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
-            (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl))))
-    | TacTrivial (_::_,_) ->
-	xlate_error "TODO: trivial using"
-    | TacReduce (red, l) ->
-     CT_reduce (xlate_red_tactic red, xlate_clause l)
-    | TacApply (true,false,[c,bindl],None) ->
-     CT_apply (xlate_formula c, xlate_bindings bindl)
-    | TacApply (true,true,[c,bindl],None) ->
-     CT_eapply (xlate_formula c, xlate_bindings bindl)
-    | TacApply (_,_,_,_) ->
-	xlate_error "TODO: simple (e)apply and iterated apply and apply in"
-    | 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 ((((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 (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 (false,(c1,sl), u) ->
-     CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u)
-    | TacCase (false,(c1,sl)) ->
-     CT_casetac (xlate_formula c1, xlate_bindings sl)
-    | TacElim (true,_,_) | TacCase (true,_)
-    | TacInductionDestruct (_,true,_) ->
-	xlate_error "TODO: eelim, ecase, edestruct, einduction"
-    | TacSimpleInductionDestruct (true,h) ->
-	CT_induction (xlate_quantified_hypothesis h)
-    | TacSimpleInductionDestruct (false,h) ->
-	CT_destruct (xlate_quantified_hypothesis h)
-    | TacCut c -> CT_cut (xlate_formula c)
-    | TacLApply c -> CT_use (xlate_formula c)
-    | TacDecompose ([],c) ->
-	xlate_error "Decompose : empty list of identifiers?"
-    | TacDecompose (id::l,c) ->
-	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)
-    | TacClear (false,[]) ->
-	xlate_error "Clear expects a non empty list of identifiers"
-    | TacClear (false,id::idl) ->
-       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,
-		     xlate_with_names l,
-	             CT_id_list (List.map xlate_hyp idl))
-    | TacInversion (DepInversion (k,copt,l),quant_hyp) ->
-	let id = xlate_quantified_hypothesis quant_hyp in
-	CT_depinversion (compute_INV_TYPE k, id, 
-			 xlate_with_names l, xlate_formula_opt copt)
-    | TacInversion (InversionUsing (c,idlist), id) ->
-	let id = xlate_quantified_hypothesis id in
-	  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 _ -> 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, []) ->
-	CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b)
-    | TacDAuto (a, b, _) ->
-	xlate_error "TODO: dauto using"
-    | TacInductionDestruct(true,false,[a,b,(None,c),None]) ->
-	CT_new_destruct
-	  (List.map  xlate_int_or_constr a, xlate_using b, 
-	   xlate_with_names c)
-    | TacInductionDestruct(false,false,[a,b,(None,c),None]) ->
-	CT_new_induction
-	  (List.map xlate_int_or_constr a, xlate_using b,
-	   xlate_with_names c)
-    | TacInductionDestruct(_,false,_) -> 
-	xlate_error "TODO: clause 'in' and full 'as' of destruct/induction"
-    | TacLetTac (na, c, cl, true) when cl = nowhere -> 
-        CT_pose(xlate_id_opt_aux na, xlate_formula c)
-    | 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, Some (_,IntroIdentifier id), c) -> 
-        CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c)
-    | TacAssert (None, None, c) -> 
-        CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
-    | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> 
-        CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c)
-    | TacAssert (Some (TacId []), None, c) -> 
-        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(false,Some tac) -> 
-	CT_any_constructor
-	(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
-    | 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))
-    | TacAlias _ -> xlate_error "Alias not supported"
-
-and coerce_genarg_to_TARG x =
- match Genarg.genarg_tag x with
-  (* Basic types *)
-  | BoolArgType -> xlate_error "TODO: generic boolean argument"
-  | IntArgType ->
-      let n = out_gen rawwit_int x in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
-  | IntOrVarArgType ->
-      let x = match out_gen rawwit_int_or_var x with
-	| ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
-	| ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x)
-  | StringArgType ->
-     let s = CT_string (out_gen rawwit_string x) in
-       CT_coerce_SCOMMENT_CONTENT_to_TARG
-	 (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
-	    (CT_coerce_STRING_to_ID_OR_STRING s))
-  | PreIdentArgType ->
-      let id = CT_ident (out_gen rawwit_pre_ident x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | IntroPatternArgType ->
-      xlate_error "TODO"
-  | IdentArgType true ->
-      let id = xlate_ident (out_gen rawwit_ident x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | IdentArgType false ->
-      xlate_error "TODO"
-  | VarArgType ->
-      let id = xlate_ident (snd (out_gen rawwit_var x)) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  | RefArgType ->
-      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
-	CT_coerce_FORMULA_OR_INT_to_TARG
-	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
-	     (CT_coerce_ID_to_ID_OR_INT id))
-  (* Specific types *)
-  | SortArgType ->
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      (CT_coerce_FORMULA_to_SCOMMENT_CONTENT
-        (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
-  | ConstrArgType ->
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x)))
-  | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
-  | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
-  | OpenConstrArgType b -> 
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      	(CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula
-					 (snd (out_gen
-					    (rawwit_open_constr_gen b) x))))
-  | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
-      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"
-  | BindingsArgType -> xlate_error "TODO: generic with bindings"
-  | RedExprArgType -> xlate_error "TODO: generic red expr"
-  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
-  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
-  | OptArgType x -> xlate_error "TODO: optional generic arguments"
-  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
-  | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
-and xlate_context_rule =
-  function
-    | Pat (hyps, concl_pat, tactic) ->
-	CT_context_rule
-	  (CT_context_hyp_list (List.map xlate_match_context_hyps hyps),
-	   xlate_context_pattern concl_pat, xlate_tactic tactic)
-    | All tactic ->
-        CT_def_context_rule (xlate_tactic tactic)
-and formula_to_def_body =
-  function
-    | ConstrEval (red, f) ->
-        CT_coerce_EVAL_CMD_to_DEF_BODY(
-	CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
-                xlate_red_tactic red, xlate_formula f))
-    | ConstrContext((_, id), f) ->
-       	CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
-	  (CT_context
-	     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)),
-	      xlate_formula f))
-    | ConstrTypeOf f -> CT_type_of (xlate_formula f)
-    | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c)
-
-and mk_let_value = function 
-    TacArg (ConstrMayEval v) ->
-      CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v)
-  | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);;
-
-let coerce_genarg_to_VARG x =
- match Genarg.genarg_tag x with
-  (* Basic types *)
-  | BoolArgType -> xlate_error "TODO: generic boolean argument"
-  | IntArgType ->
-      let n = out_gen rawwit_int x in
-      CT_coerce_ID_OR_INT_OPT_to_VARG
-	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
-	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
-  | IntOrVarArgType ->
-      (match out_gen rawwit_int_or_var x with
-	| ArgArg n -> 
-      CT_coerce_ID_OR_INT_OPT_to_VARG
-	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
-	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
-	| ArgVar (_,id) ->
-	    CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT (xlate_ident id))))
-  | StringArgType ->
-     let s = CT_string (out_gen rawwit_string x) in
-     CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s)
-  | PreIdentArgType ->
-      let id = CT_ident (out_gen rawwit_pre_ident x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | IntroPatternArgType ->
-      xlate_error "TODO"
-  | IdentArgType true ->
-      let id = xlate_ident (out_gen rawwit_ident x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | IdentArgType false ->
-      xlate_error "TODO"
-  | VarArgType ->
-      let id = xlate_ident (snd (out_gen rawwit_var x)) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  | RefArgType ->
-      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
-      CT_coerce_ID_OPT_OR_ALL_to_VARG
-	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
-	        (CT_coerce_ID_to_ID_OPT id))
-  (* Specific types *)
-  | SortArgType ->
-     CT_coerce_FORMULA_OPT_to_VARG 
-      (CT_coerce_FORMULA_to_FORMULA_OPT
-	(CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
-  | ConstrArgType ->
-     CT_coerce_FORMULA_OPT_to_VARG 
-      (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr 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 = 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"
-  | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
-  | BindingsArgType -> xlate_error "TODO: generic with bindings"
-  | RedExprArgType -> xlate_error "TODO: red expr as generic argument"
-  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
-  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
-  | OptArgType x -> xlate_error "TODO: optional generic arguments"
-  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
-  | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
-
-
-let xlate_thm x = CT_thm (string_of_theorem_kind x)
-
-let xlate_defn k = CT_defn (string_of_definition_kind k)
-
-let xlate_var x = CT_var (match x with
- | (Global,Definitional) -> "Parameter"
- | (Global,Logical) -> "Axiom"
- | (Local,Definitional) -> "Variable"
- | (Local,Logical) -> "Hypothesis"
- | (Global,Conjectural) -> "Conjecture"
- | (Local,Conjectural) -> xlate_error "No local conjecture");;
-
-
-let xlate_dep =
- function
-    | true -> CT_dep "Induction for"
-    | false -> CT_dep "Minimality for";;
-
-let xlate_locn =
- function
-    | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n)
-    | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top")
-    | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev")
-    | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next")
-
-let xlate_search_restr =
-  function
-    | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none
-    | SearchInside (m1::l1) ->
-	CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
-	List.map loc_qualid_to_ct_ID l1))
-    | SearchOutside (m1::l1) ->
-	CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
-	List.map loc_qualid_to_ct_ID l1))
-    | SearchInside [] -> xlate_error "bad extra argument for Search"
-
-let xlate_check =
- function
-    | "CHECK" -> "Check"
-    | "PRINTTYPE" -> "Type"
-    | _ -> xlate_error "xlate_check";;
-
-let build_constructors l =
- let f (coe,((_,id),c)) =
-   if coe then CT_constr_coercion (xlate_ident id, xlate_formula c)
-   else CT_constr (xlate_ident id, xlate_formula c) in
- CT_constr_list (List.map f l)
-
-let build_record_field_list l =
- let build_record_field ((coe,d),not) = match d with
-  | AssumExpr (id,c) ->
-      if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c)
-      else
-	CT_recconstr(xlate_id_opt id, xlate_formula c)
-  | DefExpr (id,c,topt) ->
-      if coe then
- 	CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c,
-			      xlate_formula_opt topt)
-      else
- 	CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in
- CT_recconstr_list (List.map build_record_field l);;
-
-let get_require_flags impexp spec =
- let ct_impexp =
-  match impexp with
-  | None -> CT_coerce_NONE_to_IMPEXP CT_none
-  | Some false -> CT_import
-  | Some true -> CT_export in
- let ct_spec =
-  match spec with
-  | None -> ctv_SPEC_OPT_NONE
-  | Some true -> CT_spec
-  | Some false -> ctv_SPEC_OPT_NONE in
- ct_impexp, ct_spec;;
-
-let cvt_optional_eval_for_definition c1 optional_eval =
-  match optional_eval with
-    None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1)
-  | Some red ->
-      CT_coerce_EVAL_CMD_to_DEF_BODY(
-      CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
-	      xlate_red_tactic red,
-	      xlate_formula c1))
-
-let cvt_vernac_binder = function
-  | b,(id::idl,c) ->
-      let l,t = 
-	CT_id_opt_ne_list 
-          (xlate_ident_opt (Some (snd id)),
-           List.map (fun id -> xlate_ident_opt (Some (snd id))) idl),
-          xlate_formula c in
-	if b then
-	  CT_binder_coercion(l,t)
-	else
-	  CT_binder(l,t)
-  | _, _ -> xlate_error "binder with no left part, rejected";;
-
-let cvt_vernac_binders = function
-    a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args)
-  | [] -> assert false;;
-
-
-let xlate_comment = function
-    CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c)
-  | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
-      (CT_coerce_STRING_to_ID_OR_STRING(CT_string s))
-  | CommentInt n ->
-      CT_coerce_FORMULA_to_SCOMMENT_CONTENT
-	(CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));;
-
-let translate_opt_notation_decl = function
-    None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none)
-  |  Some(s, f, sc) ->
-       let tr_sc = 
-	 match sc with 
-	     None -> ctv_ID_OPT_NONE
-	   | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in
-       CT_decl_notation(CT_string s, xlate_formula f, tr_sc);;
-
-let xlate_level = function
-    Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n)
-  | Extend.NextLevel -> CT_next_level;;
-
-let xlate_syntax_modifier = function
-    Extend.SetItemLevel((s::sl), level) ->
-      CT_set_item_level
-	(CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl),
-	 xlate_level level)
-  | Extend.SetItemLevel([], _) -> assert false
-  | Extend.SetLevel level -> CT_set_level (CT_int level)
-  | Extend.SetAssoc Gramext.LeftA -> CT_lefta
-  | Extend.SetAssoc Gramext.RightA -> CT_righta
-  | Extend.SetAssoc Gramext.NonA -> CT_nona
-  | Extend.SetEntryType(x,typ) ->
-      CT_entry_type(CT_ident x,
-		 match typ with
-		     Extend.ETIdent -> CT_ident "ident"
-		   | Extend.ETReference -> CT_ident "global"
-		   | Extend.ETBigint -> CT_ident "bigint"
-		   | _ -> xlate_error "syntax_type not parsed")
-  | Extend.SetOnlyParsing -> CT_only_parsing
-  | Extend.SetFormat(_,s) -> CT_format(CT_string s);;
-
-
-let rec xlate_module_type = function
-  | CMTEident(_, qid) -> 
-      CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid))
-  | CMTEwith(mty, decl) ->
-      let mty1 = xlate_module_type mty in
-	(match decl with
-	     CWith_Definition((_, idl), c) ->
-	       CT_module_type_with_def(mty1, 
-				       CT_id_list (List.map xlate_ident idl),
-                                       xlate_formula c)
-	   | CWith_Module((_, idl), (_, qid)) ->
-	       CT_module_type_with_mod(mty1,
-				       CT_id_list (List.map xlate_ident idl), 
-				       CT_ident (xlate_qualid qid)))
-  | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";;
-
-
-let xlate_module_binder_list (l:module_binder list) =
-  CT_module_binder_list
-    (List.map (fun (_, idl, mty) ->
-		 let idl1 = 
-		   List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in
-		 let fst,idl2 = match idl1 with
-		     [] -> assert false
-		   | fst::idl2 -> fst,idl2 in
-		 CT_module_binder
-		   (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);;
-
-let xlate_module_type_check_opt = function
-    None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
- 	(CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE)
-  | Some(mty, true) -> CT_only_check(xlate_module_type mty)
-  | Some(mty, false) -> 
-      CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
-	(CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
-	   (xlate_module_type mty));;
-
-let rec xlate_module_expr = function
-    CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR
-	(CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid)))
-  | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1,
-					 xlate_module_expr me2)
-
-let rec xlate_vernac =
- function
-   | VernacDeclareTacticDefinition (true, tacs) ->
-       (match List.map 
-	 (function
-	      (id, _, body) ->
-		CT_tac_def(reference_to_ct_ID id, xlate_tactic body))
-	 tacs with
-	     [] -> assert false
-	   | fst::tacs1 ->
-	       CT_tactic_definition
-		 (CT_tac_def_ne_list(fst, tacs1)))
-   | VernacDeclareTacticDefinition(false, _) -> 
-       xlate_error "obsolete tactic definition not handled"
-    | VernacLoad (verbose,s) ->
-      CT_load (
-       (match verbose with
-        | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none
-        | true -> CT_verbose),
-       CT_coerce_STRING_to_ID_OR_STRING (CT_string s))
-    | VernacCheckMayEval (Some red, numopt, f) ->
-      let red = xlate_red_tactic red in
-      CT_coerce_EVAL_CMD_to_COMMAND
-       (CT_eval (xlate_int_opt numopt, red, xlate_formula f))
-    |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s)
-    | VernacAddLoadPath (false,str,None) ->
- 	CT_addpath (CT_string str, ctv_ID_OPT_NONE)
-    | VernacAddLoadPath (false,str,Some x) ->
- 	CT_addpath (CT_string str,
-		    CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
-    | VernacAddLoadPath (true,str,None) ->
- 	CT_recaddpath (CT_string str, ctv_ID_OPT_NONE)
-    | VernacAddLoadPath (_,str, Some x) ->
-	CT_recaddpath (CT_string str,
-		       CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
-    | VernacRemoveLoadPath str -> CT_delpath (CT_string str)
-    | VernacToplevelControl Quit -> CT_quit
-    | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported"
-      (*ML commands *)
-    | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str)
-    | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str)
-    | VernacDeclareMLModule [] -> failwith ""
-    | VernacDeclareMLModule (str :: l) ->
-      CT_ml_declare_modules
-       (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l))
-    | VernacGoal c ->
-	CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c))
-    | VernacAbort (Some (_,id)) ->
-	CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id))
-    | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE
-    | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL
-    | VernacRestart -> CT_restart
-    | VernacSolve (n, tac, b) -> 
-	CT_solve (CT_int n, xlate_tactic tac,
-		  if b then CT_dotdot
-                  else CT_coerce_NONE_to_DOTDOT_OPT CT_none)
-
-(* MMode *)
-
-    | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> 
-	anomaly "No MMode in CTcoq"
-
-
-(* /MMode *)
-
-    | VernacFocus nopt -> CT_focus (xlate_int_opt nopt)
-    | VernacUnfocus -> CT_unfocus
-    |VernacExtend("Extraction", [f;l]) ->
-       let file = out_gen rawwit_string f in
-       let l1 = out_gen (wit_list1 rawwit_ref) l in
-       let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in
-	 CT_extract_to_file(CT_string file, 
-		       CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				     List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("ExtractionInline", [l]) ->
-	let l1 = out_gen (wit_list1 rawwit_ref) l in
-	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
-	CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("ExtractionNoInline", [l]) ->
-	let l1 = out_gen (wit_list1 rawwit_ref) l in
-	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
-	CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
-				List.map loc_qualid_to_ct_ID l2))
-    | VernacExtend("Field", 
-		   [fth;ainv;ainvl;div]) ->
-	(match List.map (fun v -> xlate_formula(out_gen rawwit_constr v))
-                   [fth;ainv;ainvl]
- 	 with
-             [fth1;ainv1;ainvl1] ->
-	       let adiv1 =
-                 xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in
-	       CT_add_field(fth1, ainv1, ainvl1, adiv1)
-	   |_ -> assert false)
-  | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) ->
-      let orient = out_gen Extraargs.rawwit_orient o in
-      let formula_list = out_gen (wit_list1 rawwit_constr) f in
-      let base = out_gen rawwit_pre_ident b in
-      let t = 
-	match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId []
-      in
-      let ct_orient = match orient with
-	| true  -> CT_lr
-	| false -> CT_rl in
-      let f_ne_list = match List.map xlate_formula formula_list with
-	  (fst::rest) -> CT_formula_ne_list(fst,rest)
-	| _ -> assert false in
-      CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t)
-  | VernacCreateHintDb (local,dbname,b) ->
-      xlate_error "TODO: VernacCreateHintDb"
-  | VernacHints (local,dbnames,h) ->
-      let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in
-      (match h with
-	| HintsConstructors l ->
-	 let n1, names = match List.map tac_qualid_to_ct_ID l with
-	     n1 :: names -> n1, names
-	   | _  -> failwith "" in
-	   if local then
-	     CT_local_hints(CT_ident "Constructors",
-			    CT_id_ne_list(n1, names), dblist)
-	   else
-	     CT_hints(CT_ident "Constructors",
-		      CT_id_ne_list(n1, names), dblist)
-	| HintsExtern (n, c, t) ->
-	    let pat = match c with 
-	      | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none)
-	      | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) 
-	    in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist)
-        | HintsImmediate l -> 
-	 let f1, formulas = match List.map xlate_formula 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)
-        | HintsResolve l -> 
-	 let f1, formulas = match List.map xlate_formula (List.map pi3 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
-	   | _  -> failwith "" in
-	   if local then
-             CT_local_hints(CT_ident "Unfold",
-			    CT_id_ne_list(n1, names), dblist)
-	   else	     
-             CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist)
-        | HintsTransparency (l,b) -> 
-	 let n1, names = match List.map loc_qualid_to_ct_ID l with
-	     n1 :: names -> n1, names
-	   | _  -> failwith "" in
-	 let ty = if b then "Transparent" else "Opaque" in
-	   if local then
-             CT_local_hints(CT_ident ty,
-			    CT_id_ne_list(n1, names), dblist)
-	   else	     
-             CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist)
-       	| HintsDestruct(id, n, loc, f, t) ->
-	    let dl = match loc with
-		ConclLocation() -> CT_conclusion_location
-	      | HypLocation true -> CT_discardable_hypothesis
-	      | HypLocation false -> CT_hypothesis_location in
-	     if local then
-               CT_local_hint_destruct
-		 (xlate_ident id, CT_int n,
-		  dl, xlate_formula f, xlate_tactic t, dblist)
-	     else
-	       CT_hint_destruct
-		 (xlate_ident id, CT_int n, dl, xlate_formula f,
-		  xlate_tactic t, dblist)
-)
-  | VernacEndProof (Proved (true,None)) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE)
-  | VernacEndProof (Proved (false,None)) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE)
-  | VernacEndProof (Proved (b,Some ((_,s), Some kind))) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind),
-       ctf_ID_OPT_SOME (xlate_ident s))
-  | VernacEndProof (Proved (b,Some ((_,s),None))) ->
-      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"),
-       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 (_,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
-  | VernacShow ShowProof -> CT_show_proof
-  | VernacShow ShowTree -> CT_show_tree
-  | VernacShow ShowProofNames -> CT_show_proofs
-  | VernacShow (ShowIntros true) -> CT_show_intros
-  | VernacShow (ShowIntros false) -> CT_show_intro
-  | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1)
-  | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n)
-  | VernacShow ShowExistentials -> CT_show_existentials
-  | VernacShow ShowScript -> CT_show_script
-  | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)"
-  | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)"
-  | VernacGo arg -> CT_go (xlate_locn arg)
-  | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l)
-  | VernacShow (ExplainTree l) ->
-      CT_explain_prooftree (nums_to_int_list l)
-  | VernacCheckGuard -> CT_guarded
-  | VernacPrint p ->
-      (match p with
-	  PrintFullContext -> CT_print_all
-	| PrintName id -> CT_print_id (loc_qualid_to_ct_ID id)
-	| 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 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))
-	| PrintRewriteHintDbName id -> 
-	    CT_print_rewrite_hintdb (CT_ident id)
-	| PrintHint id ->
-	    CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id))
-	| PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE
-	| PrintLoadPath None -> CT_print_loadpath
-	| PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir"
-	| PrintMLLoadPath -> CT_ml_print_path
-	| PrintMLModules -> CT_ml_print_modules
-	| PrintGraph -> CT_print_graph
-	| PrintClasses -> CT_print_classes
-	| PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid)
-	| PrintCoercions -> CT_print_coercions
-	| PrintCoercionPaths (id1, id2) -> 
-	    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)
-	| PrintTables -> CT_print_tables
-        | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a)
-        | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a)
-        | PrintScopes -> CT_print_scopes
-        | PrintScope id -> CT_print_scope (CT_ident id)
-	| PrintVisibility id_opt ->
-	    CT_print_visibility 
-	      (match id_opt with
-		   Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id)
-		 | None -> ctv_ID_OPT_NONE)
-        | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid)
-	| PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid))
-  | VernacBeginSection (_,id) ->
-      CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id))
-  | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id)
-  | 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))
-  | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
-      CT_coerce_THEOREM_GOAL_to_COMMAND
-	(CT_theorem_goal
-	   (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k),
-	    xlate_ident s, xlate_binder_list bl, xlate_formula typ))
-  | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) ->
-      CT_definition
-	(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,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) ->
-      let translated_restriction = xlate_search_restr x in
-      (match s with
-	| SearchPattern c ->
-	    CT_search_pattern(xlate_formula c, translated_restriction)
-	| SearchHead id ->
-	    CT_search(loc_qualid_to_ct_ID id, translated_restriction)
-	| SearchRewrite c ->
-	    CT_search_rewrite(xlate_formula c, translated_restriction)
-	| SearchAbout (a::l) ->
-	    let xlate_search_about_item (b,it) =
-              if not b then xlate_error "TODO: negative searchabout constraint";
-	      match it with
-		  SearchSubPattern (CRef x) -> 
-		    CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
-		| SearchString (s,None) -> 
-		    CT_coerce_STRING_to_ID_OR_STRING(CT_string s)
-		| SearchString _ | SearchSubPattern _ ->
-                    xlate_error
-		    "TODO: search subpatterns or notation with explicit scope"
-	    in
-	    CT_search_about
-	      (CT_id_or_string_ne_list(xlate_search_about_item a,
-				       List.map xlate_search_about_item l),
-	       translated_restriction)
-  	| SearchAbout [] -> assert false)
-
-(*   | (\*Record from tactics/Record.v *\) *)
-(*     VernacRecord  *)
-(*       (_, (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 *)
-(*       CT_record *)
-(*        ((if add_coercion then CT_coercion_atm else *)
-(*           CT_coerce_NONE_to_COERCION_OPT(CT_none)), *)
-(*         xlate_ident s, xlate_binder_list binders,  *)
-(* 	xlate_formula (Option.get c1), record_constructor, *)
-(*          build_record_field_list field_list) *)
-   | VernacInductive (isind, lmi) ->
-      let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in
-      let strip_mutind = function
-          (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) ->
-          CT_ind_spec
-            (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c),
-             build_constructors constructors,
-	     translate_opt_notation_decl notopt) 
-	| _ -> xlate_error "TODO: Record notation in (Co)Inductive" in
-        CT_mind_decl
-	  (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 = make_fix_struct (n, bl) in
-        let arf = xlate_formula arf in
-        let ardef = xlate_formula ardef in
-	match xlate_binder_list bl with
-	  | CT_binder_list (b :: bl) ->
-	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), 
-			  struct_arg, arf, ardef)
-          | _ -> xlate_error "mutual recursive" in
-        CT_fix_decl
-	  (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) =
-	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 = 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)
-      | (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))
-   | 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), _, _, _) ->
-       xlate_error"TODO: Local abbreviations and abbreviations with parameters"
-  (* Modules and Module Types *)
-   | 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
-			      None ->
-				CT_coerce_ID_OPT_to_MODULE_TYPE_OPT
-				  ctv_ID_OPT_NONE
-			    | Some mty1 ->
-				CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
-				  (xlate_module_type mty1))
-   | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) ->
-       CT_module(xlate_ident id, 
-		 xlate_module_binder_list bl,
-		 xlate_module_type_check_opt mty_o,
-		 match mexpr_o with
-		     None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE
-		   | Some m -> xlate_module_expr m)
-  | VernacDeclareModule(_,(_, id), bl, mty_o) -> 
-       CT_declare_module(xlate_ident id, 
-		 xlate_module_binder_list bl,
-		 xlate_module_type_check_opt (Some mty_o),
-		 CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE)
-   | VernacRequire (impexp, spec, id::idl) ->
-      let ct_impexp, ct_spec = get_require_flags impexp spec in
-      CT_require (ct_impexp, ct_spec, 
-		  CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING(
-		  CT_id_ne_list(loc_qualid_to_ct_ID id,
-				List.map loc_qualid_to_ct_ID idl)))
-   | VernacRequire (_,_,[]) ->
-       xlate_error "Require should have at least one id argument"
-   | VernacRequireFrom (impexp, spec, filename) ->
-      let ct_impexp, ct_spec = get_require_flags impexp spec in
-      CT_require(ct_impexp, ct_spec, 
-		 CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename))
-
-   | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s)
-   | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s)
-   | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s)
-   | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s)
-   | VernacArgumentsScope(true, qid, l) -> 
-       CT_arguments_scope(loc_qualid_to_ct_ID qid,
-		       CT_id_opt_list
-		       (List.map
-			  (fun x ->
-				  match x with
-				      None -> ctv_ID_OPT_NONE
-				    | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l))
-   | VernacArgumentsScope(false, qid, l) -> 
-       xlate_error "TODO: Arguments Scope Global"
-   | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2)
-   | VernacBindScope(id, a::l) -> 
-       let xlate_class_rawexpr = function
-	   FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass"
-	 | RefClass qid -> loc_qualid_to_ct_ID qid in
-       CT_bind_scope(CT_ident id,
-		     CT_id_ne_list(xlate_class_rawexpr a,
-				   List.map xlate_class_rawexpr l))
-   | VernacBindScope(id, []) -> assert false
-   | VernacNotation(b, c, (s,modif_list), opt_scope) -> 
-       let translated_s = CT_string s in
-       let formula = xlate_formula c in
-       let translated_modif_list = 
-	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
-       let translated_scope = match opt_scope with
-	   None -> ctv_ID_OPT_NONE
-	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
-       if b then
-       CT_local_define_notation
-	 (translated_s, formula, translated_modif_list, translated_scope)
-       else
-	 CT_define_notation(translated_s, formula, 
-			    translated_modif_list, translated_scope)
-   | VernacSyntaxExtension(b,(s,modif_list)) -> 
-       let translated_s = CT_string s in
-       let translated_modif_list = 
-	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
-       if b then
-	 CT_local_reserve_notation(translated_s, translated_modif_list)
-       else
-	 CT_reserve_notation(translated_s, translated_modif_list)
-   | VernacInfix (b,(str,modl),id, opt_scope) ->
-       let id1 = loc_qualid_to_ct_ID id in
-       let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in
-       let s = CT_string str in
-       let translated_scope = match opt_scope with
-	   None -> ctv_ID_OPT_NONE
-	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
-	 if b then
-	   CT_local_infix(s, id1,modl1, translated_scope)
-	 else
-	   CT_infix(s, id1,modl1, translated_scope)
-   | VernacCoercion (s, id1, id2, id3) ->
-      let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in
-      let local_opt =
-       match s with
-       (* Cannot decide whether it is a global or a Local but at toplevel *)
-       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
-       | Local -> CT_local in
-      CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1,
-        xlate_class id2, xlate_class id3)
-
-   | VernacIdentityCoercion (s, (_,id1), id2, id3) ->
-      let id_opt = CT_identity in
-      let local_opt =
-       match s with
-       (* Cannot decide whether it is a global or a Local but at toplevel *)
-       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
-       | Local -> CT_local in
-      CT_coercion (local_opt, id_opt, xlate_ident id1,
-        xlate_class id2, xlate_class id3)
-
-    (* Type Classes *) 
-   | VernacDeclareInstance _|VernacContext _|
-	 VernacInstance (_, _, _, _, _) ->
-	   xlate_error "TODO: Type Classes commands"
-
-  | VernacResetName id -> CT_reset (xlate_ident (snd id))
-  | VernacResetInitial -> CT_restore_state (CT_ident "Initial")
-  | VernacExtend (s, l) ->
-      CT_user_vernac
-       (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l))
-  | VernacList((_, a)::l) -> 
-      CT_coerce_COMMAND_LIST_to_COMMAND
-	(CT_command_list(xlate_vernac a, 
-			 List.map (fun (_, x) -> xlate_vernac x) l))
-  | VernacList([]) -> assert false
-  | VernacNop -> CT_proof_no_op
-  | VernacComments l -> 
-      CT_scomments(CT_scomment_content_list (List.map xlate_comment l))
-  | VernacDeclareImplicits(true, id, opt_positions) ->
-      CT_implicits
-	(reference_to_ct_ID id,
-	 match opt_positions with
-	     None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none
-	   | Some l -> 
-	       CT_coerce_ID_LIST_to_ID_LIST_OPT
-	       (CT_id_list
-	       (List.map
-		  (function ExplByPos (x,_), _, _
-		       -> xlate_error
-			   "explication argument by rank is obsolete"
-		     | ExplByName id, _, _ -> CT_ident (string_of_id id)) l)))
-  | VernacDeclareImplicits(false, id, opt_positions) ->
-      xlate_error "TODO: Implicit Arguments Global"
-  | VernacReserve((_,a)::l, f) ->
-      CT_reserve(CT_id_ne_list(xlate_ident a, 
-			       List.map (fun (_,x) -> xlate_ident x) l),
-		 xlate_formula f)
-  | VernacReserve([], _) -> assert false
-  | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id)
-  | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id)
-  | VernacLocate(LocateModule _) -> xlate_error "TODO: Locate Module"
-  | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s)
-  | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s)
-  | VernacTime(v) -> CT_time(xlate_vernac v)
-  | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[])
-  |VernacExactProof f -> CT_proof(xlate_formula f)
-  | VernacSetOption (table, BoolValue true) -> 
-      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)
-	  | 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)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-      let value =
-	match v with
-	  | BoolValue _ -> assert false
-	  | StringValue s ->
-	      CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s)
-	  | IntValue n ->
-	      CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in
-	CT_set_option_value(table1, value)
-  | VernacUnsetOption(table) ->
-      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)
-	  | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
-	CT_unset_option(table1)
-  | VernacAddOption (table, l) ->
-      let values =
-	List.map
-	  (function
-	     | QualidRefValue x -> 
-		 CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
-	     | StringRefValue x -> 
-		 CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in
-      let fst, values1 = 
-	match values with [] -> assert false | a::b -> (a,b) in
-      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)
-	  | 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,
-				 List.map reference_to_ct_ID l))
-  | VernacImport(false, a::l) ->
-      CT_import_id(CT_id_ne_list(reference_to_ct_ID a,
-				 List.map reference_to_ct_ID l))
-  | VernacImport(_, []) -> assert false
-  | VernacProof t -> CT_proof_with(xlate_tactic t)
-  | (VernacGlobalCheck _|VernacPrintOption _|
-     VernacMemOption (_, _)|VernacRemoveOption (_, _)
-  | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _|
-    VernacSolveExistential (_, _)|VernacCanonical _ |
-     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
-   | VernacList (v::l) ->
-       CT_command_list
-         (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l)
-   | VernacList [] -> xlate_error "xlate_command_list"
-   | _ -> xlate_error "Not a list of commands";;
diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli
deleted file mode 100644
index 2e2b95fe..00000000
--- a/contrib/interface/xlate.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-open Ascent;;
-
-val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;;
-val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;;
-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;;
-
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v
deleted file mode 100644
index 93b4d213..00000000
--- a/contrib/micromega/CheckerMaker.v
+++ /dev/null
@@ -1,129 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index 40db9e46..00000000
--- a/contrib/micromega/Env.v
+++ /dev/null
@@ -1,182 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index 04e68272..00000000
--- a/contrib/micromega/EnvRing.v
+++ /dev/null
@@ -1,1403 +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        *)
-(************************************************************************)
-(* 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
deleted file mode 100644
index 5aadfa2a..00000000
--- a/contrib/micromega/LICENSE.sos
+++ /dev/null
@@ -1,29 +0,0 @@
-            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
deleted file mode 100644
index a5ac92db..00000000
--- a/contrib/micromega/MExtraction.v
+++ /dev/null
@@ -1,23 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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/OrderedRing.v b/contrib/micromega/OrderedRing.v
deleted file mode 100644
index 149b7731..00000000
--- a/contrib/micromega/OrderedRing.v
+++ /dev/null
@@ -1,458 +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        *)
-(************************************************************************)
-(*                      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/Psatz.v b/contrib/micromega/Psatz.v
deleted file mode 100644
index b2dd9910..00000000
--- a/contrib/micromega/Psatz.v
+++ /dev/null
@@ -1,75 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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 xpsatz dom d :=
-  let tac := lazymatch dom with
-  | Z => 
-    (sos_Z || psatz_Z 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 =>
-    (sos_R || psatz_R 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
-  | Q =>
-      (sos_Q || psatz_Q d) ;
-    intros __wit __varmap __ff ; 
-    change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; 
-    apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
-  | _ => fail "Unsupported domain"
-  end in tac.
-
-Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
-Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
-
-Ltac psatzl dom :=
-  let tac := lazymatch dom with
-  | Z =>
-    psatzl_Z ;
-    intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
-    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
-  | Q =>
-    psatzl_Q ; 
-    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 => 
-    psatzl_R ;
-    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 lia := 
-  xlia ;
-  intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; 
-      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v
deleted file mode 100644
index c054f218..00000000
--- a/contrib/micromega/QMicromega.v
+++ /dev/null
@@ -1,199 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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 Qfield.
-
-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_0_l.
-  auto.
-  compute in H.
-  discriminate.
-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_eq; 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 => fun x y => Qle y x
-| OpLt => Qlt
-| OpGt => fun x y => Qlt y x
-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
deleted file mode 100644
index 7c6969c2..00000000
--- a/contrib/micromega/RMicromega.v
+++ /dev/null
@@ -1,174 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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 Zeq_bool_eq ; auto.
-  apply R_power_theory.
-  intros x y.
-  intro.
-  apply IZR_neq.
-  apply 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_op2 (o:Op2) : R -> R -> Prop :=
-    match o with
-      | OpEq =>  @eq R
-      | OpNEq => fun x y  => ~ x = y
-      | OpLe => Rle
-      | OpGe => Rge
-      | OpLt => Rlt
-      | OpGt => Rgt
-    end.
-
-
-Definition Reval_formula (e: PolEnv R) (ff : Formula Z) :=
-  let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).
-
-Definition Reval_formula' :=
-  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
-
-Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
-Proof.
-  intros.
-  unfold Reval_formula.
-  destruct f.
-  unfold Reval_formula'.
-  unfold Reval_expr.
-  split ; destruct Fop ; simpl ; auto.
-  apply Rge_le.
-  apply Rle_ge.
-Qed.
-
-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. rewrite Reval_formula_compat.
-  unfold Reval_formula'. now apply (cnf_normalise_correct Rsor).
-  intros. rewrite Reval_formula_compat. 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
deleted file mode 100644
index 801d8b21..00000000
--- a/contrib/micromega/Refl.v
+++ /dev/null
@@ -1,129 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index 6885b82c..00000000
--- a/contrib/micromega/RingMicromega.v
+++ /dev/null
@@ -1,779 +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        *)
-(************************************************************************)
-(*                      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
deleted file mode 100644
index ef48efa6..00000000
--- a/contrib/micromega/Tauto.v
+++ /dev/null
@@ -1,324 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index 240c0fb7..00000000
--- a/contrib/micromega/VarMap.v
+++ /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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index ced67e39..00000000
--- a/contrib/micromega/ZCoeff.v
+++ /dev/null
@@ -1,173 +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        *)
-(************************************************************************)
-(*                      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
deleted file mode 100644
index 0855925a..00000000
--- a/contrib/micromega/ZMicromega.v
+++ /dev/null
@@ -1,705 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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 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 Zeq_bool_eq ; 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
deleted file mode 100644
index f4efcd08..00000000
--- a/contrib/micromega/certificate.ml
+++ /dev/null
@@ -1,740 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
-
-let  remove e  l  = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
-
-
-(* The prover is (probably) incomplete --
-   only searching for naive cutting planes *)
-
-let candidates sys = 
- let ll = List.fold_right (
-  fun (Mc.Pair(e,k)) r -> 
-   match k with 
-    | Mc.NonStrict -> (dev_form z_spec e , Ge)::r
-    | Mc.Equal     ->  (dev_form z_spec e , Eq)::r 
-       (* we already know the bound -- don't compute it again *)
-    | _     -> failwith "Cannot happen candidates") sys [] in
-
- let (sys,var_mn) = make_linear_system ll in
- let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in
-  (List.fold_left (fun l cstr ->   
-   let gcd = Big_int (Vect.gcd cstr.coeffs) in
-    if gcd =/ (Int 1) && cstr.op = Eq 
-    then l 
-    else  (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars
-
-
-let rec xzlinear_prover planes sys = 
- match linear_prover z_spec sys with
-  | Some prf -> Some (Mc.RatProof prf)
-  | None     -> (* find the candidate with the smallest range *)
-     (* Grrr - linear_prover is also calling 'make_linear_system' *)
-     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.NonStrict -> Ge 
-              | Mc.Equal              -> Eq
-              | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in
-     let (ll,var) = make_linear_system ll in
-     let candidates = List.fold_left (fun  acc vect -> 
-      match Fourier.optimise vect ll with
-       | None -> acc
-       | Some i -> 
-(*	  Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *)
-	  flush stdout ; 
-	  (vect,i) ::acc)  [] planes in
-
-     let smallest_interval = 
-      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
-       | (x,Itv(Some i, Some j))  -> Some(i,x,j)
-       | (x,Point n) ->  Some(n,x,n)
-       |   x        ->   None (* This might be a cutting plane *)
-      in
-      match smallest_interval 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) :: sys),
-            (* lb <= x  -> lb > x *)
-            linear_prover z_spec 
-             (Mc.Pair( pplus  (popp (pmult  (pconst lbd) expr)) (pconst lbn) ,  
-                     Mc.NonStrict)::sys) 
-            with
-             | Some cub , Some clb  ->   
-                (match zlinear_enum  (remove e planes)   expr 
-                  (ceiling_num lb)  (floor_num ub) sys 
-                 with
-                  | None -> None
-                  | Some prf -> 
-                     Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
-             | _ -> None
-           )
-       |  _ -> None
-and zlinear_enum  planes 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
-   (*let enum =  *)
-   match xzlinear_prover planes sys' with
-    | None -> if debug then print_string "zlp?"; None
-    | Some prf -> if debug then print_string "zlp!";
-    match zlinear_enum planes expr (clb +/ (Int 1)) cub l with
-     | None -> None
-     | Some prfl -> Some (Mc.Cons(prf,prfl))
-
-let zlinear_prover sys =  
- let candidates = candidates sys in
- (*  Printf.printf "candidates %d" (List.length candidates) ; *) 
- xzlinear_prover candidates sys
-
-open Sos
-
-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 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 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)
-
-
-open Micromega
- let rec term_to_q_expr = function
-  | Const n ->  PEc (Ml2C.q n)
-  | Zero   ->  PEc ( Ml2C.q (Int 0))
-  | Var s   ->  PEX (Ml2C.index 
-		      (int_of_string (String.sub s 1 (String.length s - 1))))
-  | Mul(p1,p2) ->  PEmul(term_to_q_expr p1, term_to_q_expr p2)
-  | Add(p1,p2) ->   PEadd(term_to_q_expr p1, term_to_q_expr p2)
-  | Opp p ->   PEopp (term_to_q_expr p)
-  | Pow(t,n) ->  PEpow (term_to_q_expr t,Ml2C.n n)
-  | Sub(t1,t2) ->  PEsub (term_to_q_expr t1,  term_to_q_expr t2)
-  | _ -> failwith "term_to_q_expr: not implemented"
-
-let  q_cert_of_pos  pos = 
- 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.q   n)
-  | Square t -> Mc.S_Square (term_to_q_expr  t)
-  | Eqmul (t, y) -> Mc.S_Ideal(term_to_q_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
-  simplify_cone q_spec (_cert_of_pos pos)
-
-
- let rec term_to_z_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_z_expr p1, term_to_z_expr p2)
-  | Add(p1,p2) ->   PEadd(term_to_z_expr p1, term_to_z_expr p2)
-  | Opp p ->   PEopp (term_to_z_expr p)
-  | Pow(t,n) ->  PEpow (term_to_z_expr t,Ml2C.n n)
-  | Sub(t1,t2) ->  PEsub (term_to_z_expr t1,  term_to_z_expr t2)
-  | _ -> failwith "term_to_z_expr: not implemented"
-
-let  z_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_z_expr  t)
-  | Eqmul (t, y) -> Mc.S_Ideal(term_to_z_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
-  simplify_cone z_spec (_cert_of_pos pos)
-
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
deleted file mode 100644
index b4863ffc..00000000
--- a/contrib/micromega/coq_micromega.ml
+++ /dev/null
@@ -1,1286 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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"];
-     ["Coq";"Reals" ; "Rpow_def"];
-     ["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_R0    = lazy (constant "R0")
- let coq_R1    = lazy (constant "R1")
-
-
- 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_Zpower = lazy (constant "Zpower")
- let coq_N_of_Z = lazy 
-  (gen_constant_in_modules "ZArithRing" 
-    [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
-
- let coq_Qgt = lazy (constant "Qgt")
- let coq_Qge = lazy (constant "Qge")
- let coq_Qle = lazy (constant "Qle")
- let coq_Qlt = lazy (constant "Qlt")
- let coq_Qeq = lazy (constant "Qeq")
-
-
- let coq_Qplus = lazy (constant "Qplus")
- let coq_Qminus = lazy (constant "Qminus")
- let coq_Qopp = lazy (constant "Qopp")
- let coq_Qmult = lazy (constant "Qmult")
- let coq_Qpower = lazy (constant "Qpower")
-
-
- let coq_Rgt = lazy (constant "Rgt")
- let coq_Rge = lazy (constant "Rge")
- let coq_Rle = lazy (constant "Rle")
- let coq_Rlt = lazy (constant "Rlt")
-
- let coq_Rplus = lazy (constant "Rplus")
- let coq_Rminus = lazy (constant "Rminus")
- let coq_Ropp = lazy (constant "Ropp")
- let coq_Rmult = lazy (constant "Rmult")
- let coq_Rpower = lazy (constant "pow")
-
-
- 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) -> if c = Lazy.force coq_Qmake then
-	{Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
-      else 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 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 assoc_const x l = 
-  try 
-  snd (List.find (fun (x',y) -> x = Lazy.force x') l)
-  with
-    Not_found -> raise ParseError
-
- let zop_table = [ 
-  coq_Zgt, Mc.OpGt ; 
-  coq_Zge, Mc.OpGe ;
-  coq_Zlt, Mc.OpLt ;
-  coq_Zle, Mc.OpLe ]
-
- let rop_table = [ 
-  coq_Rgt, Mc.OpGt ; 
-  coq_Rge, Mc.OpGe ;
-  coq_Rlt, Mc.OpLt ;
-  coq_Rle, Mc.OpLe ]
-
- let qop_table = [ 
-  coq_Qlt, Mc.OpLt ;
-  coq_Qle, Mc.OpLe ;
-  coq_Qeq, Mc.OpEq
- ]
-
-
- let parse_zop (op,args) =
-  match kind_of_term op with
-   | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
-   |  Ind(n,0) -> 
-       if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_Z
-       then (Mc.OpEq, args.(1), args.(2))
-       else raise ParseError
-   |   _ -> failwith "parse_zop"
-
-
- let parse_rop (op,args) =
-   match kind_of_term op with
-    | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
-    |  Ind(n,0) -> 
-       if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_R
-       then (Mc.OpEq, args.(1), args.(2))
-       else raise ParseError
-   |   _ -> failwith "parse_zop"
-
- let parse_qop (op,args) =
-   (assoc_const op qop_table, 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 assoc_ops x l = 
-  try 
-    snd (List.find (fun (x',y) -> x = Lazy.force x') l)
-  with
-    Not_found -> Ukn "Oups"
-
-
-
- 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 assoc_ops t ops_spec  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 = 
-   [ 
-     coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Zmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Zopp   , Opp ; 
-     coq_Zpower , Power]
-
-let qop_spec = 
-  [
-     coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Qmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Qopp   , Opp ; 
-     coq_Qpower , Power]
-
-let rop_spec = 
-  [
-     coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
-     coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
-     coq_Rmult  , Binop  (fun x y -> Mc.PEmul (x,y)) ; 
-     coq_Ropp   , Opp ; 
-     coq_Rpower , Power]
-
-
-
-
-      
-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 ->  
-      if term = Lazy.force coq_R0
-      then Mc.Z0
-      else if term = Lazy.force coq_R1
-      then Mc.Zpos Mc.XH
-      else 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 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
-    
-
-
-
- (* ! 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 = Sos.positivstellensatz option
-type micromega_polys = (Micromega.q 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 =
-    List.fold_left Filename.concat (Envars.coqlib ())
-      ["contrib"; "micromega"; "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 rec z_to_q_expr e = 
- match e with
-  | Mc.PEc z   -> Mc.PEc {Mc.qnum = z ; Mc.qden = Mc.XH}
-  | Mc.PEX x   -> Mc.PEX x
-  | Mc.PEadd(e1,e2) -> Mc.PEadd(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEsub(e1,e2) -> Mc.PEsub(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEmul(e1,e2) -> Mc.PEmul(z_to_q_expr e1, z_to_q_expr e2)
-  | Mc.PEopp(e) -> Mc.PEopp(z_to_q_expr e)
-  | Mc.PEpow(e,n) -> Mc.PEpow(z_to_q_expr e,n)
-
-
-let call_csdpcert_q provername poly = 
- match call_csdpcert provername poly with
-  | None -> None
-  | Some cert -> 
-     let cert = Certificate.q_cert_of_pos cert in
-      match Mc.qWeakChecker (CamlToCoq.list (fun x -> x) poly)  cert with
-       | Mc.True -> Some cert
-       | Mc.False ->  (print_string "buggy certificate" ; flush stdout) ;None
-
-
-let call_csdpcert_z provername poly = 
- let l = List.map (fun (Mc.Pair(e,o)) -> (Mc.Pair(z_to_q_expr e,o))) poly in
-  match call_csdpcert provername l with
-   | None -> None
-   | Some cert -> 
-      let cert = Certificate.z_cert_of_pos cert in
-       match Mc.zWeakChecker (CamlToCoq.list (fun x -> x) poly)  cert with
-	| Mc.True -> Some cert
-	| Mc.False ->  (print_string "buggy certificate" ; flush stdout) ;None
-
-
-
-
-let psatzl_Z gl = 
- micromega_gen parse_zarith  Mc.negate Mc.normalise zz_domain_spec
-  [lift_ratproof 
-    (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
-
-
-let psatzl_Q gl = 
- micromega_gen  parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec 
-  [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ]   gl
-
-let psatz_Q i gl = 
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
-  [ call_csdpcert_q ("real_nonlinear_prover", Some i), "fourier refutation" ]  gl
-
-let psatzl_R gl = 
- micromega_gen  parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec 
-  [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ]   gl
-
-
-let psatz_R i gl = 
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
-  [ call_csdpcert_z  ("real_nonlinear_prover", Some i), "fourier refutation" ]  gl
-
-  
-let psatz_Z i gl = 
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec 
- [lift_ratproof (call_csdpcert_z ("real_nonlinear_prover",Some i)), 
-  "fourier refutation" ] gl
-
-
-let sos_Z gl = 
- micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec 
-  [lift_ratproof (call_csdpcert_z ("pure_sos", None)), "pure sos refutation"]  gl
-
-let sos_Q gl = 
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise  qq_domain_spec 
-  [call_csdpcert_q ("pure_sos", None), "pure sos refutation"]  gl
-
-let sos_R gl = 
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise  rz_domain_spec 
-  [call_csdpcert_z ("pure_sos", None), "pure sos refutation"]  gl
-
-
-
-let xlia 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
deleted file mode 100644
index e451a38f..00000000
--- a/contrib/micromega/csdpcert.ml
+++ /dev/null
@@ -1,197 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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  (C2Ml.q_to_num 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 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 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) 
-
-(* 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
-   Some proof
- 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 proof
- with
-  | Not_found -> (* This is no strict inequality *) None
-  |  x        -> None
-
-
-type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list
-type csdp_certificate = Sos.positivstellensatz 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
deleted file mode 100644
index 50024e78..00000000
--- a/contrib/micromega/g_micromega.ml4
+++ /dev/null
@@ -1,74 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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 11306 2008-08-05 16:51:08Z notin $ *)
-
-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 PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ]
-| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
-END
-
-TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
-   END
-
-TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Coq_micromega.sos_Q]
-   END
-
-TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Coq_micromega.sos_R]
-END
-
-
-TACTIC EXTEND Omicron
-[ "psatzl_Z"  ] -> [ Coq_micromega.psatzl_Z]
-END
-
-TACTIC EXTEND QOmicron
-[ "psatzl_Q"  ] -> [ Coq_micromega.psatzl_Q]
-END
-
-
-TACTIC EXTEND ZOmicron
-[ "xlia"  ] -> [ Coq_micromega.xlia]
-END
-
-TACTIC EXTEND ROmicron
-[ "psatzl_R"  ] -> [ Coq_micromega.psatzl_R]
-END
-
-TACTIC EXTEND RMicromega
-| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ]
-| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
-END
-
-
-TACTIC EXTEND QMicromega
-| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
-| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
-END
-
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
deleted file mode 100644
index 415d3a3e..00000000
--- a/contrib/micromega/mfourier.ml
+++ /dev/null
@@ -1,667 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index e151e4e1..00000000
--- a/contrib/micromega/micromega.ml
+++ /dev/null
@@ -1,1512 +0,0 @@
-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
deleted file mode 100644
index f94f091e..00000000
--- a/contrib/micromega/micromega.mli
+++ /dev/null
@@ -1,398 +0,0 @@
-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
deleted file mode 100644
index 2473608f..00000000
--- a/contrib/micromega/mutils.ml
+++ /dev/null
@@ -1,305 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index e3d72ed9..00000000
--- a/contrib/micromega/sos.ml
+++ /dev/null
@@ -1,1919 +0,0 @@
-(* ========================================================================= *)
-(* - 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
deleted file mode 100644
index 31c9518c..00000000
--- a/contrib/micromega/sos.mli
+++ /dev/null
@@ -1,66 +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        *)
-(************************************************************************)
-
-
-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
deleted file mode 100644
index fee4ebfc..00000000
--- a/contrib/micromega/vector.ml
+++ /dev/null
@@ -1,674 +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        *)
-(************************************************************************)
-(*                                                                      *)
-(* 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
deleted file mode 100644
index ee823502..00000000
--- a/contrib/omega/Omega.v
+++ /dev/null
@@ -1,58 +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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* $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
-  Zmult_plus_distr_r: zarith.
-
-Require Export Zhints.
-
-(*
-(* The constant minus is required in coq_omega.ml *)
-Require Minus.
-*)
-
-Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith.
-Hint Extern 10 (_ <= _) => abstract omega: zarith.
-Hint Extern 10 (_ < _) => abstract omega: zarith.
-Hint Extern 10 (_ >= _) => abstract omega: zarith.
-Hint Extern 10 (_ > _) => abstract omega: zarith.
-
-Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith.
-Hint Extern 10 (~ _ <= _) => abstract omega: zarith.
-Hint Extern 10 (~ _ < _) => abstract omega: zarith.
-Hint Extern 10 (~ _ >= _) => abstract omega: zarith.
-Hint Extern 10 (~ _ > _) => abstract omega: zarith.
-
-Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith.
-Hint Extern 10 (_ <= _)%Z => abstract omega: zarith.
-Hint Extern 10 (_ < _)%Z => abstract omega: zarith.
-Hint Extern 10 (_ >= _)%Z => abstract omega: zarith.
-Hint Extern 10 (_ > _)%Z => abstract omega: zarith.
-
-Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith.
-Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith.
-Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith.
-Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith.
-Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith.
-
-Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file
diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v
deleted file mode 100644
index 5c240553..00000000
--- a/contrib/omega/OmegaLemmas.v
+++ /dev/null
@@ -1,302 +0,0 @@
-(***********************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
-(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
-(*   \VV/  *************************************************************)
-(*    //   *      This file is distributed under the terms of the      *)
-(*         *       GNU Lesser General Public License Version 2.1       *)
-(***********************************************************************)
-
-(*i $Id: OmegaLemmas.v 11739 2009-01-02 19:33:19Z herbelin $ i*)
-
-Require Import ZArith_base.
-Open Local Scope Z_scope.
-
-(** Factorization lemmas *)
-
-Theorem Zred_factor0 : forall n:Z, n = n * 1.
-  intro x; rewrite (Zmult_1_r x); reflexivity.
-Qed.
-
-Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
-Proof.
-  exact Zplus_diag_eq_mult_2.
-Qed.
-
-Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
-Proof.
-  intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; trivial with arith.
-Qed.
-
-Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
-Proof.
-  intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; 
-      trivial with arith.
-Qed.
-
-Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
-Proof.
-  intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
-Qed.
-
-Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
-Proof.
-  intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
-Qed.
-
-Theorem Zred_factor6 : forall n:Z, n = n + 0.
-Proof.
-  intro; rewrite Zplus_0_r; trivial with arith.
-Qed.
-
-(** Other specific variants of theorems dedicated for the Omega tactic *)
-
-Lemma new_var : forall x : Z, exists y : Z, x = y.
-intros x; exists x; trivial with arith. 
-Qed.
-
-Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
-intros x y H; rewrite H; auto with arith.
-Qed.
-
-Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
-exact Zplus_le_0_compat.
-Qed. 
-
-Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.
-
-intros x y k H1 H2 H3; apply (Zmult_integral_l k);
- [ unfold not in |- *; intros H4; absurd (k > 0);
-    [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate
-    | assumption ]
- | rewrite <- H2; assumption ].
-Qed.
-
-Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0.
-
-unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
- [ intros H4; cut (0 <= z * y + x);
-    [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
-       absurd (z * y + x > 0);
-       [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
-       | apply Zle_gt_trans with x;
-          [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
-             apply Zplus_le_compat_r; rewrite Zmult_comm; 
-             generalize H4; unfold Zgt in |- *; case y;
-             [ simpl in |- *; intros H7; discriminate H7
-             | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
-                unfold Zle in |- *; rewrite Zcompare_mult_compat; 
-                exact H6
-             | simpl in |- *; intros p H7; discriminate H7 ]
-          | assumption ] ]
-    | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ]
- | apply Zgt_trans with x; [ assumption | assumption ] ].
-Qed.
-
-Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0.
-
-intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith.
-Qed.
-
-Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z.
-
-intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption.
-Qed.
-
-Lemma OMEGA7 :
- forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
-
-intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat;
- apply Zmult_gt_0_le_0_compat; assumption.
-Qed.
-
-Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.
-
-intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
- [ intros H4; absurd (0 < x);
-    [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
-       rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; 
-       assumption
-    | assumption ]
- | intros H4; rewrite H4; trivial with arith ].
-Qed.
-
-Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0.
-
-intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l;
- rewrite Zplus_0_r; assumption.
-Qed.
-
-Lemma OMEGA10 :
- forall v c1 c2 l1 l2 k1 k2 : Z,
- (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
- v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith.
-Qed.
-
-Lemma OMEGA11 :
- forall v1 c1 l1 l2 k1 : Z,
- (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
- trivial with arith.
-Qed.
-
-Lemma OMEGA12 :
- forall v2 c2 l1 l2 k2 : Z,
- l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
- rewrite Zplus_permute; trivial with arith.
-Qed.
-
-Lemma OMEGA13 :
- forall (v l1 l2 : Z) (x : positive),
- v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.
-
-intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
- rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
- rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x));
- rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
- trivial with arith.
-Qed.
- 
-Lemma OMEGA14 :
- forall (v l1 l2 : Z) (x : positive),
- v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
-
-intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
- rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
- rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r;
- rewrite Zplus_0_r; trivial with arith.
-Qed.
-Lemma OMEGA15 :
- forall v c1 c2 l1 l2 k2 : Z,
- v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith.
-Qed.
-
-Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
- trivial with arith.
-Qed.
-
-Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
-
-unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
- apply Zplus_reg_l with (y * z); rewrite Zplus_comm; 
- rewrite H3; rewrite H2; auto with arith.
-Qed.
-
-Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0.
-
-unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1;
- rewrite H3; auto with arith.
-Qed.
-
-Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
-
-unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
- [ intros H1; elim Zle_lt_or_eq with (1 := H1);
-    [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg;
-       rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
-    | intros H2; absurd (x = 0); auto with arith ]
- | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
-    apply Zle_left; apply Zsucc_le_reg; simpl in |- *; 
-    apply Zlt_le_succ; auto with arith ].
-Qed.
-
-Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
-
-unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3;
- simpl in H3; rewrite Zplus_0_r in H3; trivial with arith.
-Qed.
-
-Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
-  (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y).
-
-Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
-  (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).
-
-Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) 
-  (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).
-
-Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
-  (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p).
-
-Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
-  (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
-  eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2).
-
-Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop)
-  (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) :=
-  eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1).
-Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop)
-  (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) :=
-  eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2).
-
-Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop)
-  (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) :=
-  eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2).
-Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop)
-  (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k).
-
-Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
-  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x).
-
-Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
-  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
-Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) 
-  (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).
-
-Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
-  (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x).
-
-Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
-  (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y).
-
-Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
-  (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y).
-
-Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
-  eq_ind_r P H (Zopp_involutive x).
-
-Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) 
-  (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).
-
-Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
-  (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
-Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) 
-  (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).
-
-Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
-  (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).
-
-Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) 
-  (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).
-
-Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
-  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y).
-
-Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
-  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y).
-
-Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
-  (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).
-
-Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) 
-  (H : P y) := eq_ind_r P H (Zred_factor5 x y).
-
-Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) 
-  (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).
diff --git a/contrib/omega/PreOmega.v b/contrib/omega/PreOmega.v
deleted file mode 100644
index 47e22a97..00000000
--- a/contrib/omega/PreOmega.v
+++ /dev/null
@@ -1,445 +0,0 @@
-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
deleted file mode 100644
index 58873c2d..00000000
--- a/contrib/omega/coq_omega.ml
+++ /dev/null
@@ -1,1824 +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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* $Id: coq_omega.ml 11735 2009-01-02 17:22:31Z herbelin $ *)
-
-open Util
-open Pp
-open Reduction
-open Proof_type
-open Names
-open Nameops
-open Term
-open Termops
-open Declarations
-open Environ
-open Sign
-open Inductive
-open Tacticals
-open Tacmach
-open Evar_refiner
-open Tactics
-open Clenv
-open Logic
-open Libnames
-open Nametab
-open Contradiction
-
-module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
-open OmegaSolver
-
-(* Added by JCF, 09/03/98 *)
-
-let elim_id id gl = simplest_elim (pf_global gl id) gl
-let resolve_id id gl = apply (pf_global gl id) gl
-
-let timing timer_name f arg = f arg
-
-let display_time_flag = ref false
-let display_system_flag = ref false
-let display_action_flag = ref false
-let old_style_flag = ref false
-
-let read f () = !f
-let write f x = f:=x
-
-open Goptions
-
-let _ =
-  declare_bool_option 
-    { optsync  = false;
-      optname  = "Omega system time displaying flag";
-      optkey   = SecondaryTable ("Omega","System");
-      optread  = read display_system_flag;
-      optwrite = write display_system_flag }
-
-let _ =
-  declare_bool_option 
-    { optsync  = false;
-      optname  = "Omega action display flag";
-      optkey   = SecondaryTable ("Omega","Action");
-      optread  = read display_action_flag;
-      optwrite = write display_action_flag }
-
-let _ =
-  declare_bool_option 
-    { optsync  = false;
-      optname  = "Omega old style flag";
-      optkey   = SecondaryTable ("Omega","OldStyle");
-      optread  = read old_style_flag;
-      optwrite = write old_style_flag }
-
-
-let all_time        = timing "Omega     "
-let solver_time     = timing "Solver    "
-let exact_time      = timing "Rewrites  "
-let elim_time       = timing "Elim      "
-let simpl_time      = timing "Simpl     "
-let generalize_time = timing "Generalize"
-
-let new_identifier = 
-  let cpt = ref 0 in 
-  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
-
-let new_identifier_state = 
-  let cpt = ref 0 in 
-  (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s)
-
-let new_identifier_var = 
-  let cpt = ref 0 in 
-  (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
-
-let new_id =
-  let cpt = ref 0 in fun () -> incr cpt; !cpt
-
-let new_var_num =
-  let cpt = ref 1000 in (fun () -> incr cpt; !cpt)
-
-let new_var =
-  let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt)
-
-let display_var i = Printf.sprintf "X%d" i
-
-let intern_id,unintern_id =
-  let cpt = ref 0 in
-  let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
-  (fun (name : identifier) -> 
-     try Hashtbl.find table name with Not_found -> 
-       let idx = !cpt in
-       Hashtbl.add table name idx; 
-       Hashtbl.add co_table idx name;
-       incr cpt; idx),
-  (fun idx -> 
-     try Hashtbl.find co_table idx with Not_found -> 
-       let v = new_var () in
-       Hashtbl.add table v idx; Hashtbl.add co_table idx v; v)
-    
-let mk_then = tclTHENLIST
-
-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 [all_occurrences, Lazy.force s]
- 
-let rev_assoc k =
-  let rec loop = function
-    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l 
-  in
-  loop
-
-let tag_hypothesis,tag_of_hyp, hyp_of_tag =
-  let l = ref ([]:(identifier * int) list) in
-  (fun h id -> l := (h,id):: !l),
-  (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
-  (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis")
-
-let hide_constr,find_constr,clear_tables,dump_tables =
-  let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
-  (fun h id eg b -> l := (h,(id,eg,b)):: !l),
-  (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"),
-  (fun () -> l := []),
-  (fun () -> !l)
-
-(* Lazy evaluation is used for Coq constants, because this code
- is evaluated before the compiled modules are loaded.
- To use the constant Zplus, one must type "Lazy.force coq_Zplus"
- This is the right way to access to Coq constants in tactics ML code *)
-
-open Coqlib
-
-let logic_dir = ["Coq";"Logic";"Decidable"]
-let init_arith_modules = init_modules @ arith_modules
-let coq_modules =
-  init_arith_modules @ [logic_dir] @ zarith_base_modules
-    @ [["Coq"; "omega"; "OmegaLemmas"]]
-
-let init_arith_constant = gen_constant_in_modules "Omega" init_arith_modules
-let constant = gen_constant_in_modules "Omega" coq_modules
-
-(* Zarith *)
-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_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")
-let coq_inj_plus = lazy (constant "inj_plus")
-let coq_inj_mult = lazy (constant "inj_mult")
-let coq_inj_minus1 = lazy (constant "inj_minus1")
-let coq_inj_minus2 = lazy (constant "inj_minus2")
-let coq_inj_S = lazy (constant "inj_S")
-let coq_inj_le = lazy (constant "inj_le")
-let coq_inj_lt = lazy (constant "inj_lt")
-let coq_inj_ge = lazy (constant "inj_ge")
-let coq_inj_gt = lazy (constant "inj_gt")
-let coq_inj_neq = lazy (constant "inj_neq")
-let coq_inj_eq = lazy (constant "inj_eq")
-let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse")
-let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc")
-let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse")
-let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute")
-let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm")
-let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm")
-let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx")
-let coq_OMEGA1 = lazy (constant "OMEGA1")
-let coq_OMEGA2 = lazy (constant "OMEGA2")
-let coq_OMEGA3 = lazy (constant "OMEGA3")
-let coq_OMEGA4 = lazy (constant "OMEGA4")
-let coq_OMEGA5 = lazy (constant "OMEGA5")
-let coq_OMEGA6 = lazy (constant "OMEGA6")
-let coq_OMEGA7 = lazy (constant "OMEGA7")
-let coq_OMEGA8 = lazy (constant "OMEGA8")
-let coq_OMEGA9 = lazy (constant "OMEGA9")
-let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10")
-let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11")
-let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12")
-let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13")
-let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14")
-let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15")
-let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16")
-let coq_OMEGA17 = lazy (constant "OMEGA17")
-let coq_OMEGA18 = lazy (constant "OMEGA18")
-let coq_OMEGA19 = lazy (constant "OMEGA19")
-let coq_OMEGA20 = lazy (constant "OMEGA20")
-let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0")
-let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1")
-let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2")
-let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3")
-let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4")
-let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5")
-let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6")
-let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l")
-let coq_fast_Zmult_opp_comm =  lazy (constant "fast_Zmult_opp_comm")
-let coq_fast_Zopp_plus_distr =   lazy (constant "fast_Zopp_plus_distr")
-let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r")
-let coq_fast_Zopp_eq_mult_neg_1 =  lazy (constant "fast_Zopp_eq_mult_neg_1")
-let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive")
-let coq_Zegal_left = lazy (constant "Zegal_left")
-let coq_Zne_left = lazy (constant "Zne_left")
-let coq_Zlt_left = lazy (constant "Zlt_left")
-let coq_Zge_left = lazy (constant "Zge_left")
-let coq_Zgt_left = lazy (constant "Zgt_left")
-let coq_Zle_left = lazy (constant "Zle_left")
-let coq_new_var = lazy (constant "new_var")
-let coq_intro_Z = lazy (constant "intro_Z")
-
-let coq_dec_eq = lazy (constant "dec_eq")
-let coq_dec_Zne = lazy (constant "dec_Zne")
-let coq_dec_Zle = lazy (constant "dec_Zle")
-let coq_dec_Zlt = lazy (constant "dec_Zlt")
-let coq_dec_Zgt = lazy (constant "dec_Zgt")
-let coq_dec_Zge = lazy (constant "dec_Zge")
-
-let coq_not_Zeq = lazy (constant "not_Zeq")
-let coq_Znot_le_gt = lazy (constant "Znot_le_gt")
-let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge")
-let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt")
-let coq_Znot_gt_le = lazy (constant "Znot_gt_le")
-let coq_neq = lazy (constant "neq")
-let coq_Zne = lazy (constant "Zne")
-let coq_Zle = lazy (constant "Zle")
-let coq_Zgt = lazy (constant "Zgt")
-let coq_Zge = lazy (constant "Zge")
-let coq_Zlt = lazy (constant "Zlt")
-
-(* Peano/Datatypes *)
-let coq_le = lazy (init_arith_constant "le")
-let coq_lt = lazy (init_arith_constant "lt")
-let coq_ge = lazy (init_arith_constant "ge")
-let coq_gt = lazy (init_arith_constant "gt")
-let coq_minus = lazy (init_arith_constant "minus")
-let coq_plus = lazy (init_arith_constant "plus")
-let coq_mult = lazy (init_arith_constant "mult")
-let coq_pred = lazy (init_arith_constant "pred")
-let coq_nat = lazy (init_arith_constant "nat")
-let coq_S = lazy (init_arith_constant "S")
-let coq_O = lazy (init_arith_constant "O")
-
-(* Compare_dec/Peano_dec/Minus *)
-let coq_pred_of_minus = lazy (constant "pred_of_minus")
-let coq_le_gt_dec = lazy (constant "le_gt_dec")
-let coq_dec_eq_nat = lazy (constant "dec_eq_nat")
-let coq_dec_le = lazy (constant "dec_le")
-let coq_dec_lt = lazy (constant "dec_lt")
-let coq_dec_ge = lazy (constant "dec_ge")
-let coq_dec_gt = lazy (constant "dec_gt")
-let coq_not_eq = lazy (constant "not_eq")
-let coq_not_le = lazy (constant "not_le")
-let coq_not_lt = lazy (constant "not_lt")
-let coq_not_ge = lazy (constant "not_ge")
-let coq_not_gt = lazy (constant "not_gt")
-
-(* Logic/Decidable *)
-let coq_eq_ind_r = lazy (constant "eq_ind_r")
-
-let coq_dec_or = lazy (constant "dec_or")
-let coq_dec_and = lazy (constant "dec_and")
-let coq_dec_imp = lazy (constant "dec_imp")
-let coq_dec_iff = lazy (constant "dec_iff")
-let coq_dec_not = lazy (constant "dec_not")
-let coq_dec_False = lazy (constant "dec_False")
-let coq_dec_not_not = lazy (constant "dec_not_not")
-let coq_dec_True = lazy (constant "dec_True")
-
-let coq_not_or = lazy (constant "not_or")
-let coq_not_and = lazy (constant "not_and")
-let coq_not_imp = lazy (constant "not_imp")
-let coq_not_iff = lazy (constant "not_iff")
-let coq_not_not = lazy (constant "not_not")
-let coq_imp_simp = lazy (constant "imp_simp")
-let coq_iff = lazy (constant "iff")
-
-(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *)
-
-(* For unfold *)
-open Closure
-let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
-  | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
-      EvalConstRef kn
-  | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
-
-let sp_Zsucc =     lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc)
-let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus)
-let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle)
-let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt)
-let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge)
-let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt)
-let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
-
-let mk_var v = mkVar (id_of_string v)
-let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |])
-let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
-let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
-let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |])
-let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |])
-let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |])
-let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |])
-let mk_and t1 t2 =  mkApp (build_coq_and (), [| t1; t2 |])
-let mk_or t1 t2 =  mkApp (build_coq_or (), [| t1; t2 |])
-let mk_not t = mkApp (build_coq_not (), [| t |])
-let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
-			      [| Lazy.force coq_comparison; t1; t2 |])
-let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
-
-let mk_integer n =
-  let rec loop n = 
-    if n =? one then Lazy.force coq_xH else 
-    mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI),
-		[| loop (n/two) |])
-  in
-  if n =? zero then Lazy.force coq_Z0 
-  else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg),
-		 [| loop (abs n) |])
-    
-type omega_constant =
-  | Zplus | Zmult | Zminus | Zsucc | Zopp
-  | Plus | Mult | Minus | Pred | S | O
-  | Zpos | Zneg | Z0 | Z_of_nat
-  | Eq | Neq
-  | Zne | Zle | Zlt | Zge | Zgt
-  | Z | Nat
-  | And | Or | False | True | Not | Iff
-  | Le | Lt | Ge | Gt
-  | Other of string
-
-type omega_proposition =
-  | Keq of constr * constr * constr
-  | Kn
-
-type result = 
-  | Kvar of identifier
-  | Kapp of omega_constant * constr list
-  | Kimp of constr * constr
-  | Kufo
-
-let destructurate_prop t =
-  let c, args = decompose_app t in
-  match kind_of_term c, args with
-    | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args)
-    | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args)
-    | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args)
-    | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args)
-    | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args)
-    | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args)
-    | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args)
-    | _, [_;_] when c = build_coq_and () -> Kapp (And,args)
-    | _, [_;_] when c = build_coq_or () -> Kapp (Or,args)
-    | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args)
-    | _, [_] when c = build_coq_not () -> Kapp (Not,args)
-    | _, [] when c = build_coq_False () -> Kapp (False,args)
-    | _, [] when c = build_coq_True () -> Kapp (True,args)
-    | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args)
-    | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args)
-    | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args)
-    | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args)
-    | Const sp, args ->
-	Kapp (Other (string_of_id (id_of_global (ConstRef sp))),args)
-    | Construct csp , args ->
-	Kapp (Other (string_of_id (id_of_global (ConstructRef csp))), args)
-    | Ind isp, args ->
-	Kapp (Other (string_of_id (id_of_global (IndRef isp))),args)
-    | Var id,[] -> Kvar id
-    | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
-    | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal"
-    | _ -> Kufo
-
-let destructurate_type t =
-  let c, args = decompose_app t in
-  match kind_of_term c, args with
-    | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args)
-    | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args)
-    | _ -> Kufo
-
-let destructurate_term t =
-  let c, args = decompose_app t in
-  match kind_of_term c, args with
-    | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args)
-    | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args)
-    | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args)
-    | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args)
-    | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args)
-    | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args)
-    | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args)
-    | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args)
-    | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args)
-    | _, [_] when c = Lazy.force coq_S -> Kapp (S,args)
-    | _, [] when c = Lazy.force coq_O -> Kapp (O,args)
-    | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args)
-    | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args)
-    | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args)
-    | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args)
-    | Var id,[] -> Kvar id
-    | _ -> Kufo
-
-let recognize_number t =
-  let rec loop t =
-    match decompose_app t with
-      | f, [t] when f = Lazy.force coq_xI -> one + two * loop t
-      | f, [t] when f = Lazy.force coq_xO -> two * loop t
-      | f, [] when f = Lazy.force coq_xH -> one
-      | _ -> failwith "not a number" 
-  in
-  match decompose_app t with 
-    | f, [t] when f = Lazy.force coq_Zpos -> loop t
-    | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t)
-    | f, [] when f = Lazy.force coq_Z0 -> zero
-    | _ -> failwith "not a number"
-	  
-type constr_path =
-  | P_APP of int
-  (* Abstraction and product *)
-  | P_BODY 
-  | P_TYPE
-  (* Case *)
-  | P_BRANCH of int
-  | P_ARITY
-  | P_ARG
-
-let context operation path (t : constr) =
-  let rec loop i p0 t = 
-    match (p0,kind_of_term t) with 
-      | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t)
-      | ([], _) -> operation i t
-      | ((P_APP n :: p),  App (f,v)) ->
-	  let v' = Array.copy v in
-	  v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v')
-      | ((P_BRANCH n :: p), Case (ci,q,c,v)) ->
-	  (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *)
-	  let v' = Array.copy v in
-	  v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v'))
-      | ((P_ARITY :: p),  App (f,l)) ->
-	  appvect (loop i p f,l)
-      | ((P_ARG :: p),  App (f,v)) ->
-	  let v' = Array.copy v in
-	  v'.(0) <- loop i p v'.(0); mkApp (f,v')
-      | (p, Fix ((_,n as ln),(tys,lna,v))) ->
-	  let l = Array.length v in
-	  let v' = Array.copy v in
-	  v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v')))
-      | ((P_BODY :: p), Prod (n,t,c)) ->
-	  (mkProd (n,t,loop (succ i) p c))
-      | ((P_BODY :: p), Lambda (n,t,c)) ->
-	  (mkLambda (n,t,loop (succ i) p c))
-      | ((P_BODY :: p), LetIn (n,b,t,c)) ->
-	  (mkLetIn (n,b,t,loop (succ i) p c))
-      | ((P_TYPE :: p), Prod (n,t,c)) ->
-	  (mkProd (n,loop i p t,c))
-      | ((P_TYPE :: p), Lambda (n,t,c)) ->
-	  (mkLambda (n,loop i p t,c))
-      | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
-	  (mkLetIn (n,b,loop i p t,c))
-      | (p, _) -> 
-	  ppnl (Printer.pr_lconstr t);
-	  failwith ("abstract_path " ^ string_of_int(List.length p)) 
-  in
-  loop 1 path t
-
-let occurence path (t : constr) =
-  let rec loop p0 t = match (p0,kind_of_term t) with
-    | (p, Cast (c,_,_)) -> loop p c
-    | ([], _) -> t
-    | ((P_APP n :: p),  App (f,v)) -> loop p v.(pred n)
-    | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n)
-    | ((P_ARITY :: p),  App (f,_)) -> loop p f
-    | ((P_ARG :: p),  App (f,v)) -> loop p v.(0)
-    | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n)
-    | ((P_BODY :: p), Prod (n,t,c)) -> loop p c
-    | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c
-    | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c
-    | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term
-    | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
-    | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
-    | (p, _) -> 
-	ppnl (Printer.pr_lconstr t);
-	failwith ("occurence " ^ string_of_int(List.length p)) 
-  in
-  loop path t
-
-let abstract_path typ path t =
-  let term_occur = ref (mkRel 0) in
-  let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in
-  mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur
-
-let focused_simpl path gl =
-  let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
-  convert_concl_no_check newc DEFAULTcast gl
-
-let focused_simpl path = simpl_time (focused_simpl path)
-
-type oformula =
-  | Oplus of oformula * oformula
-  | Oinv of  oformula
-  | Otimes of oformula * oformula
-  | Oatom of identifier
-  | Oz of bigint
-  | Oufo of constr
-
-let rec oprint = function 
-  | Oplus(t1,t2) -> 
-      print_string "("; oprint t1; print_string "+"; 
-      oprint t2; print_string ")"
-  | Oinv t -> print_string "~"; oprint t
-  | Otimes (t1,t2) -> 
-      print_string "("; oprint t1; print_string "*"; 
-      oprint t2; print_string ")"
-  | Oatom s -> print_string (string_of_id s)
-  | Oz i -> print_string (string_of_bigint i)
-  | Oufo f -> print_string "?"
-
-let rec weight = function
-  | Oatom c -> intern_id c
-  | Oz _ -> -1
-  | Oinv c -> weight c
-  | Otimes(c,_) -> weight c
-  | Oplus _ -> failwith "weight"
-  | Oufo _ -> -1
-
-let rec val_of = function
-  | Oatom c -> mkVar c
-  | Oz c -> mk_integer c
-  | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |])
-  | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |])
-  | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |])
-  | Oufo c -> c
-
-let compile name kind = 
-  let rec loop accu = function
-    | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r
-    | Oz n ->
-	let id = new_id () in
-	tag_hypothesis name id;
-	{kind = kind; body = List.rev accu; constant = n; id = id}
-    | _ -> anomaly "compile_equation" 
-  in
-  loop []
-
-let rec decompile af = 
-  let rec loop = function
-    | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) 
-    | [] -> Oz af.constant 
-  in
-  loop af.body
-
-let mkNewMeta () = mkMeta (Evarutil.new_meta())
-
-let clever_rewrite_base_poly typ p result theorem gl = 
-  let full = pf_concl gl in
-  let (abstracted,occ) = abstract_path typ (List.rev p) full in
-  let t = 
-    applist
-      (mkLambda
-	 (Name (id_of_string "P"), 
-	  mkArrow typ mkProp,
-          mkLambda
-	    (Name (id_of_string "H"),
-	     applist (mkRel 1,[result]),
-	     mkApp (Lazy.force coq_eq_ind_r, 
-		       [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
-       [abstracted]) 
-  in
-  exact (applist(t,[mkNewMeta()])) gl
-
-let clever_rewrite_base p result theorem gl = 
-  clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl
-
-let clever_rewrite_base_nat p result theorem gl = 
-  clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl
-
-let clever_rewrite_gen p result (t,args) = 
-  let theorem = applist(t, args) in 
-  clever_rewrite_base p result theorem
-
-let clever_rewrite_gen_nat p result (t,args) = 
-  let theorem = applist(t, args) in 
-  clever_rewrite_base_nat p result theorem
-
-let clever_rewrite p vpath t gl = 
-  let full = pf_concl gl in
-  let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in
-  let vargs = List.map (fun p -> occurence p occ) vpath in
-  let t' = applist(t, (vargs @ [abstracted])) in
-  exact (applist(t',[mkNewMeta()])) gl
-
-let rec shuffle p (t1,t2) = 
-  match t1,t2 with
-    | Oplus(l1,r1), Oplus(l2,r2) ->
-	if weight l1 > weight l2 then 
-          let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
-          (clever_rewrite p [[P_APP 1;P_APP 1]; 
-			     [P_APP 1; P_APP 2];[P_APP 2]]
-             (Lazy.force coq_fast_Zplus_assoc_reverse)
-           :: tac,
-           Oplus(l1,t'))
-	else 
-	  let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
-          (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
-             (Lazy.force coq_fast_Zplus_permute)
-           :: tac,
-           Oplus(l2,t'))
-    | Oplus(l1,r1), t2 -> 
-	if weight l1 > weight t2 then
-          let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
-          clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc_reverse)
-          :: tac, 
-          Oplus(l1, t')
-	else 
-          [clever_rewrite p [[P_APP 1];[P_APP 2]] 
-	     (Lazy.force coq_fast_Zplus_comm)],
-          Oplus(t2,t1)
-    | t1,Oplus(l2,r2) -> 
-	if weight l2 > weight t1 then
-          let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
-          clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
-            (Lazy.force coq_fast_Zplus_permute)
-          :: tac,
-          Oplus(l2,t')
-	else [],Oplus(t1,t2)
-    | Oz t1,Oz t2 ->
-	[focused_simpl p], Oz(Bigint.add t1 t2)
-    | t1,t2 ->
-	if weight t1 < weight t2 then
-          [clever_rewrite p [[P_APP 1];[P_APP 2]] 
-	     (Lazy.force coq_fast_Zplus_comm)],
-	  Oplus(t2,t1)
-	else [],Oplus(t1,t2)
-	  
-let rec shuffle_mult p_init k1 e1 k2 e2 =
-  let rec loop p = function
-    | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
-          let tac =
-            clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
-                              [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
-                              [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-                              [P_APP 1; P_APP 1; P_APP 2];
-                              [P_APP 2; P_APP 1; P_APP 2];
-                              [P_APP 1; P_APP 2];
-                              [P_APP 2; P_APP 2]]
-              (Lazy.force coq_fast_OMEGA10) 
-	  in
-          if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then 
-            let tac' = 
-	      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
-                (Lazy.force coq_fast_Zred_factor5) in
-	    tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
-	    loop p (l1,l2)
-          else tac :: loop (P_APP 2 :: p) (l1,l2)
-	else if v1 > v2 then
-          clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
-                            [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
-                            [P_APP 1; P_APP 1; P_APP 2];
-                            [P_APP 2];
-                            [P_APP 1; P_APP 2]]
-            (Lazy.force coq_fast_OMEGA11) ::
-          loop (P_APP 2 :: p) (l1,l2')
-	else
-          clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
-                            [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-                            [P_APP 1];
-                            [P_APP 2; P_APP 1; P_APP 2];
-                            [P_APP 2; P_APP 2]]
-            (Lazy.force coq_fast_OMEGA12) ::
-          loop (P_APP 2 :: p) (l1',l2)
-    | ({c=c1;v=v1}::l1), [] -> 
-        clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
-                          [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
-                          [P_APP 1; P_APP 1; P_APP 2];
-                          [P_APP 2];
-                          [P_APP 1; P_APP 2]]
-          (Lazy.force coq_fast_OMEGA11) ::
-        loop (P_APP 2 :: p) (l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
-        clever_rewrite p  [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
-                           [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-                           [P_APP 1];
-                           [P_APP 2; P_APP 1; P_APP 2];
-                           [P_APP 2; P_APP 2]]
-          (Lazy.force coq_fast_OMEGA12) ::
-        loop (P_APP 2 :: p) ([],l2)
-    | [],[] -> [focused_simpl p_init] 
-  in
-  loop p_init (e1,e2)
-    
-let rec shuffle_mult_right p_init e1 k2 e2 =
-  let rec loop p = function
-    | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
-          let tac =
-            clever_rewrite p
-              [[P_APP 1; P_APP 1; P_APP 1];
-               [P_APP 1; P_APP 1; P_APP 2];
-               [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-               [P_APP 1; P_APP 2];
-               [P_APP 2; P_APP 1; P_APP 2];
-               [P_APP 2; P_APP 2]]
-              (Lazy.force coq_fast_OMEGA15) 
-	  in
-          if Bigint.add c1 (Bigint.mult k2 c2) =? zero then 
-            let tac' = 
-              clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
-                (Lazy.force coq_fast_Zred_factor5) 
-	    in
-            tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
-            loop p (l1,l2)
-          else tac :: loop (P_APP 2 :: p) (l1,l2)
-	else if v1 > v2 then
-          clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc_reverse) ::
-          loop (P_APP 2 :: p) (l1,l2')
-	else
-          clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
-                            [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-                            [P_APP 1];
-                            [P_APP 2; P_APP 1; P_APP 2];
-                            [P_APP 2; P_APP 2]]
-            (Lazy.force coq_fast_OMEGA12) ::
-          loop (P_APP 2 :: p) (l1',l2)
-    | ({c=c1;v=v1}::l1), [] -> 
-        clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_Zplus_assoc_reverse) ::
-        loop (P_APP 2 :: p) (l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
-        clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
-                          [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
-                          [P_APP 1];
-                          [P_APP 2; P_APP 1; P_APP 2];
-                          [P_APP 2; P_APP 2]]
-          (Lazy.force coq_fast_OMEGA12) ::
-        loop (P_APP 2 :: p) ([],l2)
-    | [],[] -> [focused_simpl p_init] 
-  in
-  loop p_init (e1,e2)
-
-let rec shuffle_cancel p = function 
-  | [] -> [focused_simpl p]
-  | ({c=c1}::l1) ->
-      let tac = 
-	clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2];
-                          [P_APP 2; P_APP 2]; 
-                          [P_APP 1; P_APP 1; P_APP 2; P_APP 1]]
-          (if c1 >? zero then 
-	     (Lazy.force coq_fast_OMEGA13) 
-	   else 
-	     (Lazy.force coq_fast_OMEGA14)) 
-      in
-      tac :: shuffle_cancel p l1
-	
-let rec scalar p n = function
-  | Oplus(t1,t2) -> 
-      let tac1,t1' = scalar (P_APP 1 :: p) n t1 and 
-        tac2,t2' = scalar (P_APP 2 :: p) n t2 in
-      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
-        (Lazy.force coq_fast_Zmult_plus_distr_l) :: 
-      (tac1 @ tac2), Oplus(t1',t2')
-  | Oinv t ->
-      [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
-	 (Lazy.force coq_fast_Zmult_opp_comm);
-       focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n))
-  | Otimes(t1,Oz x) -> 
-      [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
-         (Lazy.force coq_fast_Zmult_assoc_reverse);
-       focused_simpl (P_APP 2 :: p)], 
-      Otimes(t1,Oz (n*x))
-  | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
-  | (Oatom _ as t) -> [], Otimes(t,Oz n)
-  | Oz i -> [focused_simpl p],Oz(n*i)
-  | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
-      
-let rec scalar_norm p_init = 
-  let rec loop p = function
-    | [] -> [focused_simpl p_init]
-    | (_::l) -> 
-	clever_rewrite p
-          [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2];
-           [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l 
-  in
-  loop p_init
-
-let rec norm_add p_init =
-  let rec loop p = function
-    | [] -> [focused_simpl p_init]
-    | _:: l -> 
-	clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_Zplus_assoc_reverse) ::
-	loop (P_APP 2 :: p) l 
-  in
-  loop p_init
-
-let rec scalar_norm_add p_init =
-  let rec loop p = function
-    | [] -> [focused_simpl p_init]
-    | _ :: l -> 
-	clever_rewrite p
-          [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
-           [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
-           [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]]
-          (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l 
-  in
-  loop p_init
-
-let rec negate p = function
-  | Oplus(t1,t2) -> 
-      let tac1,t1' = negate (P_APP 1 :: p) t1 and 
-        tac2,t2' = negate (P_APP 2 :: p) t2 in
-      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
-        (Lazy.force coq_fast_Zopp_plus_distr) :: 
-      (tac1 @ tac2),
-      Oplus(t1',t2')
-  | Oinv t ->
-      [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t
-  | Otimes(t1,Oz x) -> 
-      [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
-         (Lazy.force coq_fast_Zopp_mult_distr_r);
-       focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x))
-  | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
-  | (Oatom _ as t) ->
-      let r = Otimes(t,Oz(negone)) in
-      [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r
-  | Oz i -> [focused_simpl p],Oz(neg i)
-  | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |]))
-      
-let rec transform p t = 
-  let default isnat t' =
-    try 
-      let v,th,_ = find_constr t' in
-      [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-    with _ -> 
-      let v = new_identifier_var ()
-      and th = new_identifier () in
-      hide_constr t' v th isnat;
-      [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-  in
-  try match destructurate_term t with
-    | Kapp(Zplus,[t1;t2]) ->
-	let tac1,t1' = transform (P_APP 1 :: p) t1 
-	and tac2,t2' = transform (P_APP 2 :: p) t2 in
-	let tac,t' = shuffle p (t1',t2') in
-	tac1 @ tac2 @ tac, t'
-    | Kapp(Zminus,[t1;t2]) ->
-	let tac,t = 
-	  transform p
-	    (mkApp (Lazy.force coq_Zplus,
-		     [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
-	unfold sp_Zminus :: tac,t
-    | Kapp(Zsucc,[t1]) ->
-	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
-					 [| t1; mk_integer one |])) in
-	unfold sp_Zsucc :: tac,t
-   | Kapp(Zmult,[t1;t2]) ->
-       let tac1,t1' = transform (P_APP 1 :: p) t1 
-       and tac2,t2' = transform (P_APP 2 :: p) t2 in
-       begin match t1',t2' with
-         | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t'
-         | (Oz n,_) ->
-             let sym = 
-	       clever_rewrite p [[P_APP 1];[P_APP 2]] 
-		 (Lazy.force coq_fast_Zmult_comm) in
-             let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t'
-         | _ -> default false t
-       end
-   | Kapp((Zpos|Zneg|Z0),_) -> 
-       (try ([],Oz(recognize_number t)) with _ -> default false t)
-   | Kvar s -> [],Oatom s
-   | Kapp(Zopp,[t]) ->
-       let tac,t' = transform (P_APP 1 :: p) t in
-       let tac',t'' = negate p t' in
-       tac @ tac', t''
-   | Kapp(Z_of_nat,[t']) -> default true t'
-   | _ -> default false t
-  with e when catchable_exception e -> default false t
-      
-let shrink_pair p f1 f2 =
-  match f1,f2 with
-    | Oatom v,Oatom _ -> 
-	let r = Otimes(Oatom v,Oz two) in
-	clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r
-    | Oatom v, Otimes(_,c2) -> 
-	let r = Otimes(Oatom v,Oplus(c2,Oz one)) in
-	clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] 
-	  (Lazy.force coq_fast_Zred_factor2), r
-    | Otimes (v1,c1),Oatom v -> 
-	let r = Otimes(Oatom v,Oplus(c1,Oz one)) in
-	clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]]
-          (Lazy.force coq_fast_Zred_factor3), r
-    | Otimes (Oatom v,c1),Otimes (v2,c2) ->
-	let r = Otimes(Oatom v,Oplus(c1,c2)) in
-	clever_rewrite p 
-          [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]]
-          (Lazy.force coq_fast_Zred_factor4),r
-    | t1,t2 -> 
-	begin 
-	  oprint t1; print_newline (); oprint t2; print_newline (); 
-	  flush Pervasives.stdout; error "shrink.1"
-	end
-
-let reduce_factor p = function
-  | Oatom v ->
-      let r = Otimes(Oatom v,Oz one) in
-      [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r
-  | Otimes(Oatom v,Oz n) as f -> [],f
-  | Otimes(Oatom v,c) ->
-      let rec compute = function
-        | Oz n -> n
-	| Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2)
-	| _ -> error "condense.1" 
-      in
-      [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c))
-  | t -> oprint t; error "reduce_factor.1"
-
-let rec condense p = function
-  | Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight f1 = weight f2 then begin
-	let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
-	let assoc_tac = 
-          clever_rewrite p 
-            [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc) in
-	let tac_list,t' = condense p (Oplus(t,r)) in
-	(assoc_tac :: shrink_tac :: tac_list), t'
-      end else begin
-	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
-	let tac',t' = condense (P_APP 2 :: p) t in 
-	(tac @ tac'), Oplus(f,t') 
-      end
-  | Oplus(f1,Oz n) -> 
-      let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
-  | Oplus(f1,f2) -> 
-      if weight f1 = weight f2 then begin
-	let tac_shrink,t = shrink_pair p f1 f2 in
-	let tac,t' = condense p t in
-	tac_shrink :: tac,t'
-      end else begin
-	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
-	let tac',t' = condense (P_APP 2 :: p) f2 in 
-	(tac @ tac'),Oplus(f,t') 
-      end
-  | Oz _ as t -> [],t
-  | t -> 
-      let tac,t' = reduce_factor p t in
-      let final = Oplus(t',Oz zero) in
-      let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in
-      tac @ [tac'], final
-
-let rec clear_zero p = function
-  | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero ->
-      let tac =
-	clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
-	  (Lazy.force coq_fast_Zred_factor5) in
-      let tac',t = clear_zero p r in
-      tac :: tac',t
-  | Oplus(f,r) -> 
-      let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t)
-  | t -> [],t
-
-let replay_history tactic_normalisation = 
-  let aux  = id_of_string "auxiliary" in
-  let aux1 = id_of_string "auxiliary_1" in
-  let aux2 = id_of_string "auxiliary_2" in
-  let izero = mk_integer zero in
-  let rec loop t =
-    match t with
-      | HYP e :: l -> 
-	  begin 
-	    try 
-	      tclTHEN 
-		(List.assoc (hyp_of_tag e.id) tactic_normalisation) 
-		(loop l)
-	    with Not_found -> loop l end
-      | NEGATE_CONTRADICT (e2,e1,b) :: l ->
-	  let eq1 = decompile e1 
-	  and eq2 = decompile e2 in 
-	  let id1 = hyp_of_tag e1.id 
-	  and id2 = hyp_of_tag e2.id in
-	  let k = if b then negone else one in
-	  let p_initial = [P_APP 1;P_TYPE] in
-	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
-	  tclTHENLIST [
-	    (generalize_tac 
-	      [mkApp (Lazy.force coq_OMEGA17, [| 
-		val_of eq1;
-		val_of eq2;
-		mk_integer k; 
-		mkVar id1; mkVar id2 |])]);
-	    (mk_then tac);
-	    (intros_using [aux]);
-	    (resolve_id aux);
-            reflexivity
-          ]
-      | CONTRADICTION (e1,e2) :: l -> 
-	  let eq1 = decompile e1 
-	  and eq2 = decompile e2 in 
-	  let p_initial = [P_APP 2;P_TYPE] in
-	  let tac = shuffle_cancel p_initial e1.body in
-	  let solve_le =
-            let not_sup_sup = mkApp (build_coq_eq (), [| 
-					Lazy.force coq_comparison; 
-					Lazy.force coq_Gt;
-					Lazy.force coq_Gt |])
-	    in
-            tclTHENS 
-	      (tclTHENLIST [
-		(unfold sp_Zle);
-		(simpl_in_concl);
-		intro;
-		(absurd not_sup_sup) ])
-	      [ assumption ; reflexivity ] 
-	  in
-	  let theorem =
-            mkApp (Lazy.force coq_OMEGA2, [| 
-		      val_of eq1; val_of eq2; 
-		      mkVar (hyp_of_tag e1.id);
-		      mkVar (hyp_of_tag e2.id) |])
-	  in
-	  tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
-      | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
-	  let id = hyp_of_tag e1.id in
-	  let eq1 = val_of(decompile e1) 
-	  and eq2 = val_of(decompile e2) in
-	  let kk = mk_integer k 
-	  and dd = mk_integer d in
-	  let rhs = mk_plus (mk_times eq2 kk) dd in
-	  let state_eg = mk_eq eq1 rhs in
-	  let tac = scalar_norm_add [P_APP 3] e2.body in
-	  tclTHENS 
-	    (cut state_eg) 
-	    [ tclTHENS
-	        (tclTHENLIST [
-		  (intros_using [aux]);
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_OMEGA1,
-		      [| eq1; rhs; mkVar aux; mkVar id |])]);
-		  (clear [aux;id]);
-		  (intros_using [id]);
-		  (cut (mk_gt kk dd)) ])
-	        [ tclTHENS 
-		    (cut (mk_gt kk izero)) 
-		    [ tclTHENLIST [
-		        (intros_using [aux1; aux2]);
-		        (generalize_tac 
-			  [mkApp (Lazy.force coq_Zmult_le_approx,
-			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
-		        (clear [aux1;aux2;id]);
-		        (intros_using [id]);
-		        (loop l) ];
-		      tclTHENLIST [
-			(unfold sp_Zgt);
-			(simpl_in_concl);
-			reflexivity ] ];
-		  tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
-                ];
-	      tclTHEN (mk_then tac) reflexivity ]
-	    
-      | NOT_EXACT_DIVIDE (e1,k) :: l ->
-	  let c = floor_div e1.constant k in
-	  let d = Bigint.sub e1.constant (Bigint.mult c k) in
-	  let e2 =  {id=e1.id; kind=EQUA;constant = c; 
-                     body = map_eq_linear (fun c -> c / k) e1.body } in
-	  let eq2 = val_of(decompile e2) in
-	  let kk = mk_integer k 
-	  and dd = mk_integer d in
-	  let tac = scalar_norm_add [P_APP 2] e2.body in
-	  tclTHENS 
-	    (cut (mk_gt dd izero)) 
-	    [ tclTHENS (cut (mk_gt kk dd)) 
-		[tclTHENLIST [
-		  (intros_using [aux2;aux1]);
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_OMEGA4, 
-                      [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
-		  (clear [aux1;aux2]);
-		  (unfold sp_not);
-		  (intros_using [aux]);
-		  (resolve_id aux);
-		  (mk_then tac);
-		  assumption ] ;
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-		   simpl_in_concl; 
-		   reflexivity ] ];
-              tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl;
-		reflexivity ] ]
-      | EXACT_DIVIDE (e1,k) :: l ->
-	  let id = hyp_of_tag e1.id in
-	  let e2 =  map_eq_afine (fun c -> c / k) e1 in
-	  let eq1 = val_of(decompile e1) 
-	  and eq2 = val_of(decompile e2) in
-	  let kk = mk_integer k in
-	  let state_eq = mk_eq eq1 (mk_times eq2 kk) in
-	  if e1.kind = DISE then
-            let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS 
-	      (cut state_eq) 
-	      [tclTHENLIST [
-		(intros_using [aux1]);
-		(generalize_tac 
-		  [mkApp (Lazy.force coq_OMEGA18, 
-                    [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
-		(clear [aux1;id]);
-		(intros_using [id]);
-		(loop l) ];
-	       tclTHEN (mk_then tac) reflexivity ]
-	  else
-            let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS (cut state_eq) 
-	      [
-		tclTHENS 
-		 (cut (mk_gt kk izero)) 
-		 [tclTHENLIST [
-		   (intros_using [aux2;aux1]);
-		   (generalize_tac 
-		     [mkApp (Lazy.force coq_OMEGA3, 
-		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
-		   (clear [aux1;aux2;id]);
-		   (intros_using [id]);
-		   (loop l) ];
-		  tclTHENLIST [
-		    (unfold sp_Zgt);
-                    simpl_in_concl;
-		    reflexivity ] ];
-		tclTHEN (mk_then tac) reflexivity ]
-      | (MERGE_EQ(e3,e1,e2)) :: l ->
-	  let id = new_identifier () in
-	  tag_hypothesis id e3;
-	  let id1 = hyp_of_tag e1.id 
-	  and id2 = hyp_of_tag e2 in
-	  let eq1 = val_of(decompile e1) 
-	  and eq2 = val_of (decompile (negate_eq e1)) in
-	  let tac = 
-	    clever_rewrite [P_APP 3] [[P_APP 1]] 
-	      (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
-            scalar_norm [P_APP 3] e1.body 
-	  in
-	  tclTHENS 
-	    (cut (mk_eq eq1 (mk_inv eq2))) 
-	    [tclTHENLIST [
-	      (intros_using [aux]);
-	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8, 
-	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
-	      (clear [id1;id2;aux]);
-	      (intros_using [id]);
-	      (loop l) ];
-            tclTHEN (mk_then tac) reflexivity]
-	    
-      | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
-	  let id = new_identifier () 
-	  and id2 = hyp_of_tag orig.id in
-	  tag_hypothesis id e.id;
-	  let eq1 = val_of(decompile def) 
-	  and eq2 = val_of(decompile orig) in
-	  let vid = unintern_id v in
-	  let theorem =
-            mkApp (build_coq_ex (), [| 
-		      Lazy.force coq_Z;
-		      mkLambda
-			(Name vid,
-			 Lazy.force coq_Z,
-			 mk_eq (mkRel 1) eq1) |])
-	  in
-	  let mm = mk_integer m in
-	  let p_initial = [P_APP 2;P_TYPE] in
-	  let tac = 
-            clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) 
-              [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
-            shuffle_mult_right p_initial
-              orig.body m ({c= negone;v= v}::def.body) in
-	  tclTHENS 
-	    (cut theorem)  
-	    [tclTHENLIST [
-	      (intros_using [aux]);
-	      (elim_id aux);
-	      (clear [aux]);
-	      (intros_using [vid; aux]);
-	      (generalize_tac
-		[mkApp (Lazy.force coq_OMEGA9, 
-		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
-	      (mk_then tac);
-	      (clear [aux]);
-	      (intros_using [id]);
-	      (loop l) ];
-            tclTHEN (exists_tac (inj_open eq1)) reflexivity ]
-      | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
-	  let id1 = new_identifier () 
-	  and id2 = new_identifier () in
-	  tag_hypothesis id1 e1; tag_hypothesis id2 e2;
-	  let id = hyp_of_tag e.id in
-	  let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
-	  let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
-	  let eq = val_of(decompile e) in
-	  tclTHENS 
-	    (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
-	    [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
-             tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
-      | SUM(e3,(k1,e1),(k2,e2)) :: l ->
-	  let id = new_identifier () in
-	  tag_hypothesis id e3;
-	  let id1 = hyp_of_tag e1.id 
-	  and id2 = hyp_of_tag e2.id in
-	  let eq1 = val_of(decompile e1) 
-	  and eq2 = val_of(decompile e2) in
-	  if k1 =? one & e2.kind = EQUA then
-            let tac_thm =
-              match e1.kind with
-		| EQUA -> Lazy.force coq_OMEGA5 
-		| INEQ -> Lazy.force coq_OMEGA6 
-		| DISE -> Lazy.force coq_OMEGA20 
-	    in
-            let kk = mk_integer k2 in
-            let p_initial =
-              if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
-            let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
-            tclTHENLIST [ 
-	      (generalize_tac
-                [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
-	      (mk_then tac);
-	      (intros_using [id]);
-	      (loop l)
-            ]
-	  else
-            let kk1 = mk_integer k1 
-	    and kk2 = mk_integer k2 in
-	    let p_initial = [P_APP 2;P_TYPE] in
-	    let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
-            tclTHENS (cut (mk_gt kk1 izero)) 
-	      [tclTHENS 
-		 (cut (mk_gt kk2 izero)) 
-		 [tclTHENLIST [
-		   (intros_using [aux2;aux1]);
-		   (generalize_tac
-		     [mkApp (Lazy.force coq_OMEGA7, [| 
-		       eq1;eq2;kk1;kk2; 
-		       mkVar aux1;mkVar aux2;
-		       mkVar id1;mkVar id2 |])]);
-		   (clear [aux1;aux2]);
-		   (mk_then tac);
-		   (intros_using [id]);
-		   (loop l) ];
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-                   simpl_in_concl;
-		   reflexivity ] ];
-	      tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl; 
-		reflexivity ] ]
-      | CONSTANT_NOT_NUL(e,k) :: l -> 
-	  tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
-      | CONSTANT_NUL(e) :: l -> 
-	  tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
-      | CONSTANT_NEG(e,k) :: l ->
-	  tclTHENLIST [
-	    (generalize_tac [mkVar (hyp_of_tag e)]);
-            (unfold sp_Zle);
-	    simpl_in_concl;
-	    (unfold sp_not);
-	    (intros_using [aux]);
-	    (resolve_id aux);
-	    reflexivity 
-          ]
-      | _ -> tclIDTAC 
-  in
-  loop
-
-let normalize p_initial t =
-  let (tac,t') = transform p_initial t in
-  let (tac',t'') = condense p_initial t' in
-  let (tac'',t''') = clear_zero p_initial t'' in 
-  tac @ tac' @ tac'' , t'''
-    
-let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
-  let p_initial = [P_APP pos ;P_TYPE] in
-  let (tac,t') = normalize p_initial t in
-  let shift_left = 
-    tclTHEN 
-      (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
-      (tclTRY (clear [id]))
-  in
-  if tac <> [] then
-    let id' = new_identifier () in 
-    ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
-          :: tactic,
-     compile id' flag t' :: defs)
-  else 
-    (tactic,defs)
-    
-let destructure_omega gl tac_def (id,c) =
-  if atompart_of_id id = "State" then 
-    tac_def
-  else
-    try match destructurate_prop c with
-      | Kapp(Eq,[typ;t1;t2]) 
-	when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
-	  let t = mk_plus t1 (mk_inv t2) in
-	  normalize_equation 
-	    id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
-      | Kapp(Zne,[t1;t2]) ->
-	  let t = mk_plus t1 (mk_inv t2) in
-	  normalize_equation
-	    id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def
-      | Kapp(Zle,[t1;t2]) ->
-	  let t = mk_plus t2 (mk_inv t1) in
-	  normalize_equation
-	    id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def
-      | Kapp(Zlt,[t1;t2]) ->
-	  let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in
-	  normalize_equation
-	    id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def
-      | Kapp(Zge,[t1;t2]) ->
-	  let t = mk_plus t1 (mk_inv t2) in
-	  normalize_equation
-	    id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def
-      | Kapp(Zgt,[t1;t2]) ->
-	  let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in
-	  normalize_equation
-	    id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def
-      | _ -> tac_def
-    with e when catchable_exception e -> tac_def
-
-let reintroduce id =
-  (* [id] cannot be cleared if dependent: protect it by a try *)
-  tclTHEN (tclTRY (clear [id])) (intro_using id)
-
-let coq_omega gl =
-  clear_tables ();
-  let tactic_normalisation, system = 
-    List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
-  let prelude,sys = 
-    List.fold_left 
-      (fun (tac,sys) (t,(v,th,b)) ->
-	 if b then
-           let id = new_identifier () in
-           let i = new_id () in
-           tag_hypothesis id i;
-           (tclTHENLIST [
-	     (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
-	     (intros_using [v; id]);
-	     (elim_id id);
-	     (clear [id]);
-	     (intros_using [th;id]);
-	     tac ]),
-           {kind = INEQ; 
-	    body = [{v=intern_id v; c=one}]; 
-            constant = zero; id = i} :: sys
-	 else
-           (tclTHENLIST [
-	     (simplest_elim (applist (Lazy.force coq_new_var, [t])));
-	     (intros_using [v;th]);
-	     tac ]),
-           sys)
-      (tclIDTAC,[]) (dump_tables ())
-  in
-  let system = system @ sys in
-  if !display_system_flag then display_system display_var system;
-  if !old_style_flag then begin
-    try 
-      let _ = simplify (new_id,new_var_num,display_var) false system in
-      tclIDTAC gl
-    with UNSOLVABLE -> 
-      let _,path = depend [] [] (history ()) in
-      if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl 
-  end else begin 
-    try
-      let path = simplify_strong (new_id,new_var_num,display_var) system in
-      if !display_action_flag then display_action display_var path; 
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
-    with NO_CONTRADICTION -> error "Omega can't solve this system"
-  end
-
-let coq_omega = solver_time coq_omega
-
-let nat_inject gl =
-  let rec explore p t = 
-    try match destructurate_term t with
-      | Kapp(Plus,[t1;t2]) ->
-          tclTHENLIST [ 
-	    (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
-              ((Lazy.force coq_inj_plus),[t1;t2]));
-	    (explore (P_APP 1 :: p) t1);
-	    (explore (P_APP 2 :: p) t2)
-          ]
-      | Kapp(Mult,[t1;t2]) ->
-          tclTHENLIST [
-	    (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
-              ((Lazy.force coq_inj_mult),[t1;t2]));
-	    (explore (P_APP 1 :: p) t1);
-	    (explore (P_APP 2 :: p) t2)
-          ]
-      | Kapp(Minus,[t1;t2]) ->
-          let id = new_identifier () in
-          tclTHENS
-            (tclTHEN 
-	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) 
-	       (intros_using [id])) 
-	    [
-	      tclTHENLIST [
-	        (clever_rewrite_gen p 
-		  (mk_minus (mk_inj t1) (mk_inj t2))
-                  ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
-		(loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
-		(explore (P_APP 1 :: p) t1);
-		(explore (P_APP 2 :: p) t2) ];
-	      (tclTHEN 
-		 (clever_rewrite_gen p (mk_integer zero)
-                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
-		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
-	    ]
-      | Kapp(S,[t']) ->
-          let rec is_number t =
-            try match destructurate_term t with 
-		Kapp(S,[t]) -> is_number t
-              | Kapp(O,[]) -> true
-              | _ -> false
-            with e when catchable_exception e -> false 
-	  in
-          let rec loop p t =
-            try match destructurate_term t with 
-		Kapp(S,[t]) ->
-                  (tclTHEN 
-                     (clever_rewrite_gen p 
-			(mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
-			((Lazy.force coq_inj_S),[t])) 
-		     (loop (P_APP 1 :: p) t))
-              | _ -> explore p t 
-            with e when catchable_exception e -> explore p t 
-	  in
-          if is_number t' then focused_simpl p else loop p t
-      | Kapp(Pred,[t]) ->
-          let t_minus_one = 
-	    mkApp (Lazy.force coq_minus, [| t; 
-		      mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
-          tclTHEN
-            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one 
-               ((Lazy.force coq_pred_of_minus),[t]))
-            (explore p t_minus_one) 
-      | Kapp(O,[]) -> focused_simpl p
-      | _ -> tclIDTAC 
-    with e when catchable_exception e -> tclIDTAC 
-	
-  and loop = function
-    | [] -> tclIDTAC
-    | (i,t)::lit -> 
-	  begin try match destructurate_prop t with 
-              Kapp(Le,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
-		  (explore [P_APP 1; P_TYPE] t1);
-		  (explore [P_APP 2; P_TYPE] t2);
-		  (reintroduce i);
-		  (loop lit)
-                ]
-            | Kapp(Lt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
-		  (explore [P_APP 1; P_TYPE] t1);
-		  (explore [P_APP 2; P_TYPE] t2);
-		  (reintroduce i);
-		  (loop lit)
-                ]
-            | Kapp(Ge,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac 
-		    [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
-		  (explore [P_APP 1; P_TYPE] t1);
-		  (explore [P_APP 2; P_TYPE] t2);
-		  (reintroduce i);
-		  (loop lit)
-                ]
-            | Kapp(Gt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
-                    [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
-		  (explore [P_APP 1; P_TYPE] t1);
-		  (explore [P_APP 2; P_TYPE] t2);
-		  (reintroduce i);
-		  (loop lit)
-                ]
-            | Kapp(Neq,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
-		    [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
-		  (explore [P_APP 1; P_TYPE] t1);
-		  (explore [P_APP 2; P_TYPE] t2);
-		  (reintroduce i);
-		  (loop lit)
-                ]
-            | Kapp(Eq,[typ;t1;t2]) ->
-		if pf_conv_x gl typ (Lazy.force coq_nat) then
-                  tclTHENLIST [
-		    (generalize_tac 
-		      [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
-		    (explore [P_APP 2; P_TYPE] t1);
-		    (explore [P_APP 3; P_TYPE] t2);
-		    (reintroduce i);
-		    (loop lit)
-                  ]
-		else loop lit
-	    | _ -> loop lit
-	  with e when catchable_exception e -> loop lit end 
-  in
-  loop (List.rev (pf_hyps_types gl)) gl
-    
-let rec decidability gl t =
-  match destructurate_prop t with
-    | Kapp(Or,[t1;t2]) -> 
-	mkApp (Lazy.force coq_dec_or, [| t1; t2;
-		  decidability gl t1; decidability gl t2 |])
-    | Kapp(And,[t1;t2]) -> 
-	mkApp (Lazy.force coq_dec_and, [| t1; t2;
-		  decidability gl t1; decidability gl t2 |])
-    | Kapp(Iff,[t1;t2]) -> 
-	mkApp (Lazy.force coq_dec_iff, [| t1; t2;
-		  decidability gl t1; decidability gl t2 |])
-    | Kimp(t1,t2) -> 
-	mkApp (Lazy.force coq_dec_imp, [| t1; t2;
-		  decidability gl t1; decidability gl t2 |])
-    | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; 
-				    decidability gl t1 |])
-    | Kapp(Eq,[typ;t1;t2]) -> 
-	begin match destructurate_type (pf_nf gl typ) with
-          | Kapp(Z,[]) ->  mkApp (Lazy.force coq_dec_eq, [| t1;t2 |])
-          | Kapp(Nat,[]) ->  mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |])
-          | _ -> errorlabstrm "decidability" 
-		(str "Omega: Can't solve a goal with equality on " ++ 
-		   Printer.pr_lconstr typ)
-	end
-    | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |])
-    | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |])
-    | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |])
-    | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |])
-    | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |])
-    | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |])
-    | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |])
-    | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |])
-    | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |])
-    | Kapp(False,[]) -> Lazy.force coq_dec_False
-    | Kapp(True,[]) -> Lazy.force coq_dec_True
-    | Kapp(Other t,_::_) -> error 
-	("Omega: Unrecognized predicate or connective: "^t)
-    | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t)
-    | Kvar _ -> error "Omega: Can't solve a goal with proposition variables"
-    | _ -> error "Omega: Unrecognized proposition"
-
-let onClearedName id tac =
-  (* We cannot ensure that hyps can be cleared (because of dependencies), *)
-  (* so renaming may be necessary *)
-  tclTHEN
-    (tclTRY (clear [id]))
-    (fun gl -> 
-      let id = fresh_id [] id gl in
-      tclTHEN (introduction id) (tac id) gl)
-
-let destructure_hyps gl =
-  let rec loop = function
-    | [] -> (tclTHEN nat_inject coq_omega)
-    | (i,body,t)::lit ->
-	begin try match destructurate_prop t with
-	  | Kapp(False,[]) -> elim_id i
-          | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
-          | Kapp(Or,[t1;t2]) ->
-              (tclTHENS 
-                (elim_id i)
-                [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
-                  onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
-          | Kapp(And,[t1;t2]) ->
-              tclTHENLIST [
-                (elim_id i);
-		(tclTRY (clear [i]));
-		(fun gl -> 
-		  let i1 = fresh_id [] (add_suffix i "_left") gl in
-		  let i2 = fresh_id [] (add_suffix i "_right") gl in
-		  tclTHENLIST [
-		    (introduction i1);
-		    (introduction i2);
-		    (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl)
-	      ]
-          | Kapp(Iff,[t1;t2]) ->
-              tclTHENLIST [
-                (elim_id i);
-		(tclTRY (clear [i]));
-		(fun gl -> 
-		  let i1 = fresh_id [] (add_suffix i "_left") gl in
-		  let i2 = fresh_id [] (add_suffix i "_right") gl in
-		  tclTHENLIST [
-		    introduction i1;
-		    generalize_tac
-		      [mkApp (Lazy.force coq_imp_simp,
-                        [| t1; t2; decidability gl t1; mkVar i1|])];
-		    onClearedName i1 (fun i1 ->
-		      tclTHENLIST [
-			introduction i2;
-			generalize_tac
-			  [mkApp (Lazy.force coq_imp_simp,
-                            [| t2; t1; decidability gl t2; mkVar i2|])];
-			onClearedName i2 (fun i2 ->
-			  loop
-			  ((i1,None,mk_or (mk_not t1) t2)::
-			   (i2,None,mk_or (mk_not t2) t1)::lit))
-		      ])] gl)
-	      ]
-          | Kimp(t1,t2) ->
-              if
-                is_Prop (pf_type_of gl t1) &
-                is_Prop (pf_type_of gl t2) &
-                closed0 t2
-              then
-		tclTHENLIST [
-		  (generalize_tac [mkApp (Lazy.force coq_imp_simp,
-                    [| t1; t2; decidability gl t1; mkVar i|])]);
-		  (onClearedName i (fun i ->
-		    (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
-                ]
-              else
-		loop lit
-          | Kapp(Not,[t]) -> 
-              begin match destructurate_prop t with 
-		  Kapp(Or,[t1;t2]) -> 
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
-                    ]
-		| Kapp(And,[t1;t2]) -> 
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_and, [| t1; t2;
-			  decidability gl t1; mkVar i|])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
-                    ]
-		| Kapp(Iff,[t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_iff, [| t1; t2;
-			  decidability gl t1; decidability gl t2; mkVar i|])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,
-			        mk_or (mk_and t1 (mk_not t2))
-				      (mk_and (mk_not t1) t2))::lit))))
-                    ]
-		| Kimp(t1,t2) ->
-                    tclTHENLIST [
-		      (generalize_tac 
-		        [mkApp (Lazy.force coq_not_imp, [| t1; t2; 
-		          decidability gl t1;mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
-                    ]
-		| Kapp(Not,[t]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-			[mkApp (Lazy.force coq_not_not, [| t;
-			  decidability gl t; mkVar i |])]);
-		      (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
-                    ]
-		| Kapp(Zle, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zge, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zlt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac 
-                        [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Zgt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Le, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Ge, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Lt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Gt, [t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]);
-		      (onClearedName i (fun _ -> loop lit))
-                    ]
-		| Kapp(Eq,[typ;t1;t2]) ->
-                    if !old_style_flag then begin 
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) -> 
-                            tclTHENLIST [
-			      (simplest_elim 
-				(mkApp
-                                  (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| Kapp(Z,_) ->
-                            tclTHENLIST [
-			      (simplest_elim 
-				(mkApp
-				  (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| _ -> loop lit
-                    end else begin 
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) -> 
-                               (tclTHEN 
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
-			       (loop lit))
-			| Kapp(Z,_) ->
-                               (tclTHEN 
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
-			       (loop lit))
-			| _ -> loop lit
-                    end
-		| _ -> loop lit
-              end 
-          | _ -> loop lit 
-	with e when catchable_exception e -> loop lit
-	end 
-  in
-  loop (pf_hyps gl) gl
-
-let destructure_goal gl =
-  let concl = pf_concl gl in
-  let rec loop t =
-    match destructurate_prop t with
-      | Kapp(Not,[t]) ->
-          (tclTHEN 
-	     (tclTHEN (unfold sp_not) intro) 
-	     destructure_hyps)
-      | Kimp(a,b) -> (tclTHEN intro (loop b))
-      | Kapp(False,[]) -> destructure_hyps
-      | _ ->
-          (tclTHEN 
-	     (tclTHEN
-		(Tactics.refine 
-		   (mkApp (Lazy.force coq_dec_not_not, [| t;
-			      decidability gl t; mkNewMeta () |])))
-		intro) 
-	     (destructure_hyps)) 
-  in
-  (loop concl) gl
-
-let destructure_goal = all_time (destructure_goal)
-
-let omega_solver gl =
-  Coqlib.check_required_library ["Coq";"omega";"Omega"];
-  let result = destructure_goal gl in 
-  (* if !display_time_flag then begin text_time (); 
-     flush Pervasives.stdout end; *)
-  result
diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4
deleted file mode 100644
index 02545b30..00000000
--- a/contrib/omega/g_omega.ml4
+++ /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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $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_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/omega/omega.ml b/contrib/omega/omega.ml
deleted file mode 100644
index fd774c16..00000000
--- a/contrib/omega/omega.ml
+++ /dev/null
@@ -1,716 +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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(* 13/10/2002 : modified to cope with an external numbering of equations  *)
-(*   and hypothesis. Its use for Omega is not more complex and it makes   *)
-(*   things much simpler for the reflexive version where we should limit  *)
-(*   the number of source of numbering.                                   *)
-(**************************************************************************)
-
-open Names
-
-module type INT = sig
-  type bigint
-  val less_than : bigint -> bigint -> bool
-  val add : bigint -> bigint -> bigint
-  val sub : bigint -> bigint -> bigint
-  val mult : bigint -> bigint -> bigint
-  val euclid : bigint -> bigint -> bigint * bigint
-  val neg : bigint -> bigint
-  val zero : bigint
-  val one : bigint
-  val to_string : bigint -> string
-end
-
-let debug = ref false
-
-module MakeOmegaSolver (Int:INT) = struct
-
-type bigint = Int.bigint
-let (<?) = Int.less_than
-let (<=?) x y = Int.less_than x y or x = y
-let (>?) x y = Int.less_than y x
-let (>=?) x y = Int.less_than y x or x = y
-let (=?) = (=)
-let (+) = Int.add
-let (-) = Int.sub
-let ( * ) = Int.mult
-let (/) x y = fst (Int.euclid x y)
-let (mod) x y = snd (Int.euclid x y)
-let zero = Int.zero
-let one = Int.one
-let two = one + one
-let negone = Int.neg one
-let abs x = if Int.less_than x zero then Int.neg x else x
-let string_of_bigint = Int.to_string
-let neg = Int.neg
-
-(* To ensure that polymorphic (<) is not used mistakenly on big integers *)
-(* Warning: do not use (=) either on big int *)
-let (<) = ((<) : int -> int -> bool)
-let (>) = ((>) : int -> int -> bool)
-let (<=) = ((<=) : int -> int -> bool)
-let (>=) = ((>=) : int -> int -> bool)
-
-let pp i = print_int i; print_newline (); flush stdout
-
-let push v l = l := v :: !l
-
-let rec pgcd x y = if y =? zero then x else pgcd y (x mod y)
-
-let pgcd_l = function
-  | [] -> failwith "pgcd_l"
-  | x :: l -> List.fold_left pgcd x l
-
-let floor_div a b =
-  match a >=? zero , b >? zero with
-    | true,true -> a / b
-    | false,false -> a / b
-    | true, false -> (a-one) / b - one
-    | false,true  -> (a+one) / b - one
-
-type coeff = {c: bigint ; v: int}
-
-type linear = coeff list
-
-type eqn_kind = EQUA | INEQ | DISE
-
-type afine = { 
-  (* a number uniquely identifying the equation *)
-  id: int ; 
-  (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *)
-  kind: eqn_kind; 
-  (* the variables and their coefficient *)
-  body: coeff list; 
-  (* a constant *)
-  constant: bigint }
-
-type state_action = {
-  st_new_eq : afine;
-  st_def    : afine;
-  st_orig   : afine;
-  st_coef   : bigint;
-  st_var    : int }
-
-type action =
-  | DIVIDE_AND_APPROX of afine * afine * bigint * bigint
-  | NOT_EXACT_DIVIDE of afine * bigint
-  | FORGET_C of int
-  | EXACT_DIVIDE of afine * bigint
-  | SUM of int * (bigint * afine) * (bigint * afine)
-  | STATE of state_action 
-  | HYP of afine
-  | FORGET   of int * int
-  | FORGET_I of int * int
-  | CONTRADICTION of afine * afine
-  | NEGATE_CONTRADICT of afine * afine * bool
-  | MERGE_EQ of int * afine * int
-  | CONSTANT_NOT_NUL of int * bigint
-  | CONSTANT_NUL of int
-  | CONSTANT_NEG of int * bigint
-  | SPLIT_INEQ of afine * (int * action list) * (int * action list)
-  | WEAKEN of int * bigint
-
-exception UNSOLVABLE
-
-exception NO_CONTRADICTION
-
-let display_eq print_var (l,e) =
-  let _ = 
-    List.fold_left 
-      (fun not_first f ->
-	 print_string 
-	   (if f.c <? zero then "- " else if not_first then "+ " else "");
-	 let c = abs f.c in
-	 if c =? one then 
-	   Printf.printf "%s " (print_var f.v)
-	 else 
-	   Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); 
-	 true)
-      false l
-  in
-  if e >? zero then 
-    Printf.printf "+ %s " (string_of_bigint e)
-  else if e <? zero then 
-    Printf.printf "- %s " (string_of_bigint (abs e))
-
-let rec trace_length l =
-  let action_length accu = function
-    | SPLIT_INEQ (_,(_,l1),(_,l2)) ->
-	accu + one + trace_length l1 + trace_length l2
-    | _ -> accu + one in
-  List.fold_left action_length zero l
-
-let operator_of_eq = function 
-  | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
-
-let kind_of = function
-  | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
-
-let display_system print_var l = 
-  List.iter 
-    (fun { kind=b; body=e; constant=c; id=id} -> 
-       Printf.printf "E%d: " id;
-       display_eq print_var (e,c);
-       Printf.printf "%s 0\n" (operator_of_eq b))
-    l;
-  print_string "------------------------\n\n"
-
-let display_inequations print_var l = 
-  List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l;
-  print_string "------------------------\n\n"
-
-let sbi = string_of_bigint
-
-let rec display_action print_var = function
-  | act :: l -> begin match act with
-      | DIVIDE_AND_APPROX (e1,e2,k,d) ->
-          Printf.printf 
-            "Inequation E%d is divided by %s and the constant coefficient is \
-            rounded by substracting %s.\n" e1.id (sbi k) (sbi d)
-      | NOT_EXACT_DIVIDE (e,k) ->
-          Printf.printf
-            "Constant in equation E%d is not divisible by the pgcd \
-            %s of its other coefficients.\n" e.id (sbi k)
-      | EXACT_DIVIDE (e,k) ->
-          Printf.printf
-            "Equation E%d is divided by the pgcd \
-            %s of its coefficients.\n" e.id (sbi k)
-      | WEAKEN (e,k) ->
-          Printf.printf 
-            "To ensure a solution in the dark shadow \
-            the equation E%d is weakened by %s.\n" e (sbi k)
-      | SUM (e,(c1,e1),(c2,e2)) -> 
-          Printf.printf
-            "We state %s E%d = %s %s E%d + %s %s E%d.\n" 
-            (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2)
-            (kind_of e2.kind) e2.id
-      | STATE { st_new_eq = e } ->
-          Printf.printf "We define a new equation E%d: " e.id; 
-          display_eq print_var (e.body,e.constant); 
-          print_string (operator_of_eq e.kind); print_string " 0"
-      | HYP e ->   
-          Printf.printf "We define E%d: " e.id; 
-          display_eq print_var (e.body,e.constant); 
-          print_string (operator_of_eq e.kind); print_string " 0\n"
-      | FORGET_C e ->  Printf.printf "E%d is trivially satisfiable.\n" e
-      | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
-      | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
-      | MERGE_EQ (e,e1,e2) ->
-         Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e
-      | CONTRADICTION (e1,e2) -> 
-          Printf.printf
-            "Equations E%d and E%d imply a contradiction on their \
-            constant factors.\n" e1.id e2.id
-      | NEGATE_CONTRADICT(e1,e2,b) ->
-          Printf.printf
-            "Equations E%d and E%d state that their body is at the same time
-            equal and different\n" e1.id e2.id
-      | CONSTANT_NOT_NUL (e,k) -> 
-          Printf.printf "Equation E%d states %s = 0.\n" e (sbi k)
-      | CONSTANT_NEG(e,k) -> 
-          Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k)
-      | CONSTANT_NUL e ->
-          Printf.printf "Inequation E%d states 0 != 0.\n" e
-      | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> 
-          Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
-          display_action print_var l1;
-          print_newline ();
-          display_action print_var l2;
-          print_newline ()
-    end; display_action print_var l
-  | [] -> 
-      flush stdout
-
-let default_print_var v = Printf.sprintf "X%d" v (* For debugging *)
-
-(*""*)
-let add_event, history, clear_history =
-  let accu = ref [] in
-  (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu),
-  (fun () -> !accu),
-  (fun () -> accu := [])
-
-let nf_linear = Sort.list (fun x y -> x.v > y.v)
-
-let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
-
-let map_eq_linear f = 
-  let rec loop = function
-    | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l
-    | [] -> [] 
-  in
-  loop
-
-let map_eq_afine f e = 
-  { id = e.id; kind = e.kind; body = map_eq_linear f e.body; 
-    constant = f e.constant }
-
-let negate_eq = map_eq_afine (fun x -> neg x)
-
-let rec sum p0 p1 = match (p0,p1) with 
-  | ([], l) -> l | (l, []) -> l
-  | (((x1::l1) as l1'), ((x2::l2) as l2')) -> 
-      if x1.v = x2.v then
-	let c = x1.c + x2.c in
-	if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
-      else if x1.v > x2.v then 
-	x1 :: sum l1 l2'
-      else 
-	x2 :: sum l1' l2
-
-let sum_afine new_eq_id eq1 eq2 = 
-  { kind = eq1.kind; id = new_eq_id ();
-    body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant }
-
-exception FACTOR1
-
-let rec chop_factor_1 = function
-  | x :: l -> 
-    if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
-  | [] -> raise FACTOR1
-
-exception CHOPVAR
-
-let rec chop_var v = function
-  | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l')
-  | [] -> raise CHOPVAR
-
-let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
-  if e = [] then begin 
-    match eq_flag with
-      | EQUA ->
-          if x =? zero then [] else begin
-            add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE
-         end
-      | DISE ->
-          if x <> zero then [] else begin
-            add_event (CONSTANT_NUL id); raise UNSOLVABLE
-          end
-      | INEQ ->
-          if x >=? zero then [] else begin
-            add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE
-          end
-  end else
-    let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
-    if eq_flag=EQUA & x mod gcd <> zero then begin
-      add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
-    end else if eq_flag=DISE & x mod gcd <> zero then begin
-      add_event (FORGET_C eq.id); []
-    end else if gcd <> one then begin
-      let c = floor_div x gcd in
-      let d = x - c * gcd in
-      let new_eq = {id=id; kind=eq_flag; constant=c; 
-                    body=map_eq_linear (fun c -> c / gcd) e} in
-      add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
-                 else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
-      [new_eq]
-    end else [eq]
-
-let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2
-                        ({body=e1; constant=c1} as eq1) =
-  try
-    let (f,_) = chop_var v e1 in 
-    let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c 
-                else failwith "eliminate_with_in" in
-    let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
-    add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res
-  with CHOPVAR -> eq1
-
-let omega_mod a b = a - b * floor_div (two * a + b) (two * b)
-let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = 
-  let e = original.body in
-  let sigma = new_var_id () in
-  let smallest,var =
-    try
-      List.fold_left (fun (v,p) c ->  if v >? (abs c.c) then abs c.c,c.v else (v,p))
-              (abs (List.hd e).c, (List.hd e).v) (List.tl e)
-    with Failure "tl" -> display_system print_var [original] ; failwith "TL" in
-  let m = smallest + one in
-  let new_eq =
-    { constant = omega_mod original.constant m;
-      body = {c= neg m;v=sigma} :: 
-             map_eq_linear (fun a -> omega_mod a m) original.body;
-      id = new_eq_id (); kind = EQUA } in
-  let definition =
-    { constant = neg (floor_div (two * original.constant + m) (two * m));
-      body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m)))
-                             original.body;
-      id = new_eq_id (); kind = EQUA } in
-  add_event (STATE {st_new_eq = new_eq; st_def = definition;
-		    st_orig = original; st_coef = m; st_var = sigma});
-  let new_eq = List.hd (normalize new_eq) in
-  let eliminated_var, def = chop_var var new_eq.body in
-  let other_equations = 
-    Util.list_map_append
-      (fun e -> 
-        normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
-  let inequations = 
-    Util.list_map_append
-      (fun e ->
-        normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
-  let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
-  let mod_original = map_eq_afine (fun c -> c / m) original' in
-  add_event (EXACT_DIVIDE (original',m));
-  List.hd (normalize mod_original),other_equations,inequations
-
-let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = 
-  if !debug then display_system print_var (e::other);
-  try
-    let v,def = chop_factor_1 e.body in
-    (Util.list_map_append
-      (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
-     Util.list_map_append
-       (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
-  with FACTOR1 ->
-    eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
-
-let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) =
-  let rec fst_eq_1 = function
-     (eq::l) -> 
-        if List.exists (fun x -> abs x.c =? one) eq.body then eq,l
-        else let (eq',l') = fst_eq_1 l in (eq',eq::l')
-   | [] -> raise Not_found in
-  match sys_eq with
-     [] -> if !debug then display_system print_var sys_ineq; sys_ineq
-   | (e1::rest) -> 
-       let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in
-       if eq.body = [] then 
-         if eq.constant =? zero then begin
-           add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq)
-         end else begin
-           add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
-         end
-       else
-	 banerjee new_ids 
-	   (eliminate_one_equation new_ids (eq,other,sys_ineq))
-
-type kind = INVERTED | NORMAL
-
-let redundancy_elimination new_eq_id system =
-  let normal = function
-     ({body=f::_} as e) when f.c <? zero ->  negate_eq e, INVERTED
-   | e -> e,NORMAL in
-  let table = Hashtbl.create 7 in
-  List.iter
-    (fun e -> 
-       let ({body=ne} as nx) ,kind = normal e in
-       if ne = [] then
-         if nx.constant <? zero then begin
-           add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
-         end else add_event (FORGET_C nx.id)
-       else
-       try 
-         let (optnormal,optinvert) = Hashtbl.find table ne in
-         let final =
-           if kind = NORMAL then begin
-             match optnormal with 
-                Some v -> 
-                  let kept =
-                    if v.constant <? nx.constant 
-                    then begin add_event (FORGET (v.id,nx.id));v end
-                    else begin add_event (FORGET (nx.id,v.id));nx end in
-                  (Some(kept),optinvert)
-              | None -> Some nx,optinvert
-           end else begin
-             match optinvert with 
-                Some v ->
-                  let _kept =
-                    if v.constant >? nx.constant 
-                    then begin add_event (FORGET_I (v.id,nx.id));v end
-                    else begin add_event (FORGET_I (nx.id,v.id));nx end in
-                  (optnormal,Some(if v.constant >? nx.constant then v else nx))
-              | None -> optnormal,Some nx
-           end in
-         begin match final with
-            (Some high, Some low) -> 
-              if high.constant <? low.constant then begin
-                add_event(CONTRADICTION (high,negate_eq low));
-                raise UNSOLVABLE
-              end
-          | _ -> () end;
-         Hashtbl.remove table ne;
-         Hashtbl.add table ne final
-       with Not_found ->
-         Hashtbl.add table ne 
-           (if kind = NORMAL then (Some nx,None) else (None,Some nx)))
-    system;
-  let accu_eq = ref [] in
-  let accu_ineq = ref [] in
-  Hashtbl.iter
-    (fun p0 p1 -> match (p0,p1) with 
-       | (e, (Some x, Some y)) when x.constant =? y.constant ->
-           let id=new_eq_id () in
-           add_event (MERGE_EQ(id,x,y.id));
-           push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq
-       | (e, (optnorm,optinvert)) ->
-           begin match optnorm with 
-               Some x -> push x accu_ineq | _ -> () end;
-           begin match optinvert with 
-               Some x -> push (negate_eq x) accu_ineq | _ -> () end)
-    table;
-  !accu_eq,!accu_ineq
-
-exception SOLVED_SYSTEM
-
-let select_variable system =
-  let table = Hashtbl.create 7 in
-  let push v c= 
-    try let r = Hashtbl.find table v in r := max !r (abs c)
-    with Not_found -> Hashtbl.add table v (ref (abs c)) in
-  List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system;
-  let vmin,cmin = ref (-1), ref zero in
-  let var_cpt = ref 0 in
-  Hashtbl.iter
-    (fun v ({contents =  c}) ->
-       incr var_cpt;
-       if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
-    table;
-  if !var_cpt < 1 then raise SOLVED_SYSTEM;
-  !vmin
-
-let classify v system =
-  List.fold_left 
-    (fun (not_occ,below,over) eq ->
-       try let f,eq' = chop_var v eq.body in
-       if f.c >=? zero then (not_occ,((f.c,eq) :: below),over)
-       else (not_occ,below,((neg f.c,eq) :: over))
-       with CHOPVAR -> (eq::not_occ,below,over))
-    ([],[],[]) system
-
-let product new_eq_id dark_shadow low high =
-  List.fold_left
-    (fun accu (a,eq1) ->
-       List.fold_left
-         (fun accu (b,eq2) ->
-            let eq = 
-              sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1)
-                (map_eq_afine (fun c -> c * a) eq2) in
-            add_event(SUM(eq.id,(b,eq1),(a,eq2)));
-            match normalize eq with
-	      | [eq] ->
-                  let final_eq =
-                    if dark_shadow then 
-                      let delta = (a - one) * (b - one) in
-                      add_event(WEAKEN(eq.id,delta));
-                      {id = eq.id; kind=INEQ; body = eq.body; 
-                       constant = eq.constant - delta} 
-                    else eq
-                  in final_eq :: accu
-              | (e::_) -> failwith "Product dardk"
-              | [] -> accu)
-         accu high)
-    [] low
-
-let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system =
-  let v = select_variable system in
-  let (ineq_out, ineq_low,ineq_high) = classify v system in
-  let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in
-  if !debug then display_system print_var expanded; expanded
-
-let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
-  if List.exists (fun e -> e.kind = DISE) system then 
-    failwith "disequation in simplify";
-  clear_history ();
-  List.iter (fun e -> add_event (HYP e)) system;
-  let system = Util.list_map_append normalize system in
-  let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
-  let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
-  let system = (eqs @ simp_eq,simp_ineq) in
-  let rec loop1a system =
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
-  and loop1b sys_ineq =
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in
-    if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) 
-  in
-  let rec loop2 system =
-    try
-      let expanded = fourier_motzkin new_ids dark_shadow system in
-      loop2 (loop1b expanded)
-    with SOLVED_SYSTEM ->
-      if !debug then display_system print_var system; system 
-  in
-  loop2 (loop1a system)
-
-let rec depend relie_on accu = function
-  | act :: l -> 
-      begin match act with
-	| DIVIDE_AND_APPROX (e,_,_,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| EXACT_DIVIDE (e,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| WEAKEN (e,_) ->
-            if List.mem e relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| SUM (e,(_,e1),(_,e2)) -> 
-            if List.mem e relie_on then 
-	      depend (e1.id::e2.id::relie_on) (act::accu) l
-            else 
-	      depend relie_on accu l
-	| STATE {st_new_eq=e;st_orig=o} ->
-            if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
-            else depend relie_on accu l
-	| HYP e ->   
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| FORGET_C _ -> depend relie_on accu l
-	| FORGET _ -> depend relie_on accu l
-	| FORGET_I _ -> depend relie_on accu l
-	| MERGE_EQ (e,e1,e2) ->
-            if List.mem e relie_on then 
-	      depend (e1.id::e2::relie_on) (act::accu) l
-            else 
-	      depend relie_on accu l
-	| NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l
-	| CONTRADICTION (e1,e2) -> 
-	    depend (e1.id::e2.id::relie_on) (act::accu) l
-	| CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l
-	| CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l
-	| CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l
-	| NEGATE_CONTRADICT (e1,e2,_) -> 
-            depend (e1.id::e2.id::relie_on) (act::accu) l
-	| SPLIT_INEQ _ -> failwith "depend"
-      end
-  | [] -> relie_on, accu
-
-(*
-let depend relie_on accu trace = 
-  Printf.printf "Longueur de la trace initiale : %d\n" 
-    (trace_length trace + trace_length accu);
-  let rel',trace' = depend relie_on accu trace in
-  Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
-  rel',trace'
-*)
-
-let solve (new_eq_id,new_eq_var,print_var) system =
-  try let _ = simplify new_eq_id false system in failwith "no contradiction"
-  with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
-      
-let negation (eqs,ineqs) =
-  let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in
-  let normal = function
-    | ({body=f::_} as e) when f.c <? zero ->  negate_eq e, INVERTED
-    | e -> e,NORMAL in
-  let table = Hashtbl.create 7 in
-  List.iter (fun e -> 
-               let {body=ne;constant=c} ,kind = normal e in
-               Hashtbl.add table (ne,c) (kind,e)) diseq;
-  List.iter (fun e ->
-               assert (e.kind = EQUA);
-               let {body=ne;constant=c},kind = normal e in
-               try 
-		 let (kind',e') = Hashtbl.find table (ne,c) in
-		 add_event (NEGATE_CONTRADICT (e,e',kind=kind'));
-		 raise UNSOLVABLE
-               with Not_found -> ()) eqs
-
-exception FULL_SOLUTION of action list * int list
-
-let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
-  clear_history ();
-  List.iter (fun e -> add_event (HYP e)) system;
-  (* Initial simplification phase *)
-  let rec loop1a system =
-    negation system;
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
-  and loop1b sys_ineq =
-    let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
-    if simp_eq = [] then dise @ simp_ineq
-    else loop1a (simp_eq,dise @ simp_ineq) 
-  in
-  let rec loop2 system =
-    try
-      let expanded = fourier_motzkin new_ids false system in
-      loop2 (loop1b expanded)
-    with SOLVED_SYSTEM -> if !debug then display_system print_var system; system 
-  in
-  let rec explode_diseq = function 
-    | (de::diseq,ineqs,expl_map) ->
-	let id1 = new_eq_id () 
-	and id2 = new_eq_id () in
-	let e1 = 
-          {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in
-	let e2 = 
-	  {id = id2; kind=INEQ; body = map_eq_linear neg de.body; 
-           constant = neg de.constant - one} in
-	let new_sys =
-          List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) 
-	    ineqs @ 
-          List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) 
-	    ineqs 
-	in
-	explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map)
-    | ([],ineqs,expl_map) -> ineqs,expl_map 
-  in
-  try 
-    let system = Util.list_map_append normalize system in
-    let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
-    let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
-    let system = (eqs @ simp_eq,simp_ineq @ dise) in
-    let system' = loop1a system in
-    let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in
-    let first_segment = history () in
-    let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in
-    let all_solutions =
-      List.map
-        (fun (decomp,sys) -> 
-           clear_history ();
-           try let _ = loop2 sys in raise NO_CONTRADICTION
-           with UNSOLVABLE -> 
-             let relie_on,path = depend [] [] (history ()) in
-             let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
-             let red = List.map (fun (x,_,_) -> x) dc in
-             (red,relie_on,decomp,path))
-        sys_exploded 
-    in
-    let max_count sys = 
-      let tbl = Hashtbl.create 7 in
-      let augment x = 
-        try incr (Hashtbl.find tbl x) 
-	with Not_found -> Hashtbl.add tbl x (ref 1) in
-      let eq = ref (-1) and c = ref 0 in
-      List.iter (function 
-		   | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on))
-                   | (l,_,_,_) -> List.iter augment l) sys;
-      Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
-      !eq 
-    in
-    let rec solve systems = 
-      try 
-	let id = max_count systems in 
-        let rec sign = function 
-	  | ((id',_,b)::l) -> if id=id' then b else sign l 
-          | [] -> failwith "solve" in
-        let s1,s2 =
-          List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
-        let s1' = 
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
-        let s2' = 
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
-        let (r1,relie1) = solve s1' 
-	and (r2,relie2) = solve s2' in
-	let (eq,id1,id2) = List.assoc id explode_map in
-	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
-      with FULL_SOLUTION (x0,x1) -> (x0,x1) 
-    in
-    let act,relie_on = solve all_solutions in
-    snd(depend relie_on act first_segment)
-  with UNSOLVABLE -> snd (depend [] [] (history ()))
-
-end
diff --git a/contrib/ring/LegacyArithRing.v b/contrib/ring/LegacyArithRing.v
deleted file mode 100644
index e062b731..00000000
--- a/contrib/ring/LegacyArithRing.v
+++ /dev/null
@@ -1,90 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
-
-(* Instantiation of the Ring tactic for the naturals of Arith $*)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export Arith.
-Require Import Eqdep_dec.
-
-Open Local Scope nat_scope.
-
-Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
-  match n, m with
-  | O, O => true
-  | S n', S m' => nateq n' m'
-  | _, _ => false
-  end.
-
-Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; intros; try contradiction.
-  trivial.
-  unfold Is_true in H1.
-  rewrite (H n1 H1).
-  trivial.
-Qed.
-
-Hint Resolve nateq_prop: arithring.
-
-Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
-  split; intros; auto with arith arithring.
-(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
-  trivial.*)
-Defined.
-
-
-Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
-
-Goal forall n:nat, S n = 1 + n.
-intro; reflexivity.
-Save S_to_plus_one.
-
-(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
-   exp is already O and only for those occurrences than can be reached by going
-   down plus and mult operations  *)
-Ltac rewrite_S_to_plus_term t :=
-  match constr:t with
-  | 1 => constr:1
-  | (S ?X1) =>
-      let t1 := rewrite_S_to_plus_term X1 in
-      constr:(1 + t1)
-  | (?X1 + ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 + t2)
-  | (?X1 * ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 * t2)
-  | _ => constr:t
-  end.
-
-(* Apply S_to_plus on both sides of an equality *)
-Ltac rewrite_S_to_plus :=
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 :=  
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2) in |- *
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 := 
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2) in |- *
-  end.
-
-Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/contrib/ring/LegacyNArithRing.v b/contrib/ring/LegacyNArithRing.v
deleted file mode 100644
index c689fc40..00000000
--- a/contrib/ring/LegacyNArithRing.v
+++ /dev/null
@@ -1,46 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
-
-(* Instantiation of the Ring tactic for the binary natural numbers *)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export ZArith_base.
-Require Import NArith.
-Require Import Eqdep_dec.
-
-Unboxed Definition Neq (n m:N) :=
-  match (n ?= m)%N with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
-  intros n m H; unfold Neq in H.
-  apply Ncompare_Eq_eq.
-  destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq.
-  split.
-    apply Nplus_comm.
-    apply Nplus_assoc.
-    apply Nmult_comm.
-    apply Nmult_assoc.
-    apply Nplus_0_l.
-    apply Nmult_1_l.
-    apply Nmult_0_l.
-    apply Nmult_plus_distr_r.
-(*    apply Nplus_reg_l.*)
-    apply Neq_prop.
-Qed.
-
-Add Legacy Semi Ring
-  N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/contrib/ring/LegacyRing.v b/contrib/ring/LegacyRing.v
deleted file mode 100644
index 40323b3d..00000000
--- a/contrib/ring/LegacyRing.v
+++ /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        *)
-(************************************************************************)
-
-(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *)
-
-Require Export Bool.
-Require Export LegacyRing_theory.
-Require Export Quote.
-Require Export Ring_normalize.
-Require Export Ring_abstract.
-
-(* As an example, we provide an instantation for bool. *)
-(* Other instatiations are given in ArithRing and ZArithRing in the
-   same directory *)
-
-Definition BoolTheory :
-  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
-split; simpl in |- *.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct x; destruct y; reflexivity || simpl in |- *; tauto.
-Defined.
-
-Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
- [ true false ].
diff --git a/contrib/ring/LegacyRing_theory.v b/contrib/ring/LegacyRing_theory.v
deleted file mode 100644
index d15d18a6..00000000
--- a/contrib/ring/LegacyRing_theory.v
+++ /dev/null
@@ -1,376 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *)
-
-Require Export Bool.
-
-Set Implicit Arguments.
-
-Section Theory_of_semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-(* There is also a "weakly decidable" equality on A. That means 
-  that if (A_eq x y)=true then x=y but x=y can arise when 
-  (A_eq x y)=false. On an abstract ring the function [x,y:A]false
-  is a good choice. The proof of A_eq_prop is in this case easy. *)
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-
-Record Semi_Ring_Theory : Prop := 
-  {SR_plus_comm : forall n m:A, n + m = m + n;
-   SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   SR_mult_comm : forall n m:A, n * m = m * n;
-   SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
-   SR_plus_zero_left : forall n:A, 0 + n = n;
-   SR_mult_one_left : forall n:A, 1 * n = n;
-   SR_mult_zero_left : forall n:A, 0 * n = 0;
-   SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-(*   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
-   SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Semi_Ring_Theory.
-
-Let plus_comm := SR_plus_comm T.
-Let plus_assoc := SR_plus_assoc T.
-Let mult_comm := SR_mult_comm T.
-Let mult_assoc := SR_mult_assoc T.
-Let plus_zero_left := SR_plus_zero_left T.
-Let mult_one_left := SR_mult_one_left T. 
-Let mult_zero_left := SR_mult_zero_left T.
-Let distr_left := SR_distr_left T.
-(*Let plus_reg_left := SR_plus_reg_left T.*)
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left (*plus_reg_left*).
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
-Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry  in |- *; eauto. Qed.
-
-Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve SR_plus_permute SR_mult_permute.
-
-Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry  in |- *; apply SR_distr_right. Qed.
-
-Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-Lemma SR_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma SR_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; auto.
-Qed.
-
-Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; auto.
-Qed.
-(*
-Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
-Qed.
-*)
-End Theory_of_semi_rings.
-
-Section Theory_of_rings.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-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_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;
-   Th_opp_def : forall n:A, n + - n = 0;
-   Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-   Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Ring_Theory.
-
-Let plus_comm := Th_plus_comm T.
-Let plus_assoc := Th_plus_assoc 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. 
-Let opp_def := Th_opp_def T.
-Let distr_left := Th_distr_left T.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
-Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve Th_plus_permute Th_mult_permute.
-
-Lemma aux1 : forall a:A, a + a = a -> a = 0.
-intros.
-generalize (opp_def a).
-pattern a at 1 in |- *.
-rewrite <- H.
-rewrite <- plus_assoc.
-rewrite opp_def.
-elim plus_comm.
-rewrite plus_zero_left.
-trivial.
-Qed.
-
-Lemma Th_mult_zero_left : forall n:A, 0 * n = 0.
-intros.
-apply aux1.
-rewrite <- distr_left.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-Hint Resolve Th_mult_zero_left.
-
-Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z.
-intros.
-rewrite <- (plus_zero_left y).
-elim H0.
-elim plus_assoc.
-elim (plus_comm y z).
-rewrite plus_assoc.
-rewrite H.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-
-Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y.
-intros.
-apply (aux2 (x:=(x * y)));
- [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ].
-Qed.
-Hint Resolve Th_opp_mult_left.
-
-Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y.
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y).
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y).
-intros.
-apply (aux2 (x:=(x + y)));
- [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc;
-    rewrite opp_def; rewrite plus_zero_left; auto
- | auto ].
-Qed.
-
-Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p).
-eauto. Qed.
-
-Lemma Th_opp_opp : forall n:A, - - n = n.
-intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ].
-Qed.
-Hint Resolve Th_opp_opp.
-
-Lemma Th_opp_opp2 : forall n:A, n = - - n.
-symmetry  in |- *; eauto. Qed.
-
-Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y.
-intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto.
-Qed.
-
-Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y.
-symmetry  in |- *; apply Th_mult_opp_opp. Qed.
-
-Lemma Th_opp_zero : - 0 = 0.
-rewrite <- (plus_zero_left (- 0)).
-auto. Qed.
-(*
-Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
-intros; generalize (f_equal (fun z => - n + z) H).
-repeat rewrite plus_assoc.
-rewrite (plus_comm (- n) n).
-rewrite opp_def.
-repeat rewrite Th_plus_zero_left; eauto.
-Qed.
-
-Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros.
-eapply Th_plus_reg_left with n. 
-rewrite (plus_comm n m).
-rewrite (plus_comm n p).
-auto.
-Qed.
-*)
-Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry  in |- *; apply Th_distr_right.
-Qed.
-
-End Theory_of_rings.
-
-Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Ring_Theory_of :
-  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) 
-    (Aopp:A -> A) (Aeq:A -> A -> bool),
-    Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
-    Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-intros until 1; case H.
-split; intros; simpl in |- *; eauto.
-Defined.
-
-(* Every ring can be viewed as a semi-ring : this property will be used
-  in Abstract_polynom. *)
-Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
diff --git a/contrib/ring/LegacyZArithRing.v b/contrib/ring/LegacyZArithRing.v
deleted file mode 100644
index a410fbc5..00000000
--- a/contrib/ring/LegacyZArithRing.v
+++ /dev/null
@@ -1,37 +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        *)
-(************************************************************************)
-
-(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *)
-
-(* Instantiation of the Ring tactic for the binary integers of ZArith *)
-
-Require Export LegacyArithRing.
-Require Export ZArith_base.
-Require Import Eqdep_dec.
-Require Import LegacyRing.
-
-Unboxed Definition Zeq (x y:Z) :=
-  match (x ?= y)%Z with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
-  intros x y H; unfold Zeq in H.
-  apply Zcompare_Eq_eq.
-  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
-  split; intros; eauto with zarith.
-  apply Zeq_prop; assumption.
-Qed.
-
-(* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
- [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/contrib/ring/Quote.v b/contrib/ring/Quote.v
deleted file mode 100644
index 6f7414a3..00000000
--- a/contrib/ring/Quote.v
+++ /dev/null
@@ -1,85 +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        *)
-(************************************************************************)
-
-(* $Id: Quote.v 6295 2004-11-12 16:40:39Z gregoire $ *)
-
-(***********************************************************************
-  The "abstract" type index is defined to represent variables.
-
-  index : Set
-  index_eq : index -> bool
-  index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
-  index_lt : index -> bool
-  varmap : Type -> Type.	
-  varmap_find : (A:Type)A -> index -> (varmap A) -> A.
-
-  The first arg. of varmap_find is the default value to take
-  if the object is not found in the varmap.
-
-  index_lt defines a total well-founded order, but we don't prove that.
-
-***********************************************************************)
-
-Set Implicit Arguments.
-Unset Boxed Definitions.
-
-Section variables_map.
-
-Variable A : Type.
-
-Inductive varmap : Type :=
-  | Empty_vm : varmap
-  | Node_vm : A -> varmap -> varmap -> varmap.
-
-Inductive index : Set :=
-  | Left_idx : index -> index
-  | Right_idx : index -> index
-  | End_idx : index.
-
-Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A :=
-  match i, v with
-  | End_idx, Node_vm x _ _ => x
-  | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2
-  | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1
-  | _, _ => default_value
-  end.
-
-Fixpoint index_eq (n m:index) {struct m} : bool :=
-  match n, m with
-  | End_idx, End_idx => true
-  | Left_idx n', Left_idx m' => index_eq n' m'
-  | Right_idx n', Right_idx m' => index_eq n' m'
-  | _, _ => false
-  end.
-
-Fixpoint index_lt (n m:index) {struct m} : bool :=
-  match n, m with
-  | End_idx, Left_idx _ => true
-  | End_idx, Right_idx _ => true
-  | Left_idx n', Right_idx m' => true
-  | Right_idx n', Right_idx m' => index_lt n' m'
-  | Left_idx n', Left_idx m' => index_lt n' m'
-  | _, _ => false
-  end.
-
-Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m.
-  simple induction n; simple induction m; simpl in |- *; intros.
-  rewrite (H i0 H1); reflexivity.
-  discriminate.
-  discriminate.
-  discriminate.
-  rewrite (H i0 H1); reflexivity.
-  discriminate.
-  discriminate.
-  discriminate.
-  reflexivity.
-Qed.
-
-End variables_map.
-
-Unset Implicit Arguments.
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
deleted file mode 100644
index c2467ebf..00000000
--- a/contrib/ring/Ring_abstract.v
+++ /dev/null
@@ -1,706 +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        *)
-(************************************************************************)
-
-(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-Require Import Ring_normalize.
-
-Unset Boxed Definitions.
-
-Section abstract_semi_rings.
-
-Inductive aspolynomial : Type :=
-  | ASPvar : index -> aspolynomial
-  | ASP0 : aspolynomial
-  | ASP1 : aspolynomial
-  | ASPplus : aspolynomial -> aspolynomial -> aspolynomial
-  | ASPmult : aspolynomial -> aspolynomial -> aspolynomial.
-
-Inductive abstract_sum : Type :=
-  | Nil_acs : abstract_sum
-  | Cons_acs : varlist -> abstract_sum -> abstract_sum.
-
-Fixpoint abstract_sum_merge (s1:abstract_sum) :
- abstract_sum -> abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      (fix asm_aux (s2:abstract_sum) : abstract_sum :=
-         match s2 with
-         | Cons_acs l2 t2 =>
-             if varlist_lt l1 l2
-             then Cons_acs l1 (abstract_sum_merge t1 s2)
-             else Cons_acs l2 (asm_aux t2)
-         | Nil_acs => s1
-         end)
-  | Nil_acs => fun s2 => s2
-  end.
-
-Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      if varlist_lt l1 l2
-      then Cons_acs l1 s2
-      else Cons_acs l2 (abstract_varlist_insert l1 t2)
-  | Nil_acs => Cons_acs l1 Nil_acs
-  end.
-
-Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      abstract_varlist_insert (varlist_merge l1 l2)
-        (abstract_sum_scalar l1 t2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      abstract_sum_merge (abstract_sum_scalar l1 s2)
-        (abstract_sum_prod t1 s2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum :=
-  match p with
-  | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs
-  | ASP1 => Cons_acs Nil_var Nil_acs
-  | ASP0 => Nil_acs
-  | ASPplus l r =>
-      abstract_sum_merge (aspolynomial_normalize l)
-        (aspolynomial_normalize r)
-  | ASPmult l r =>
-      abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r)
-  end.
-
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Fixpoint interp_asp (p:aspolynomial) : A :=
-  match p with
-  | ASPvar i => interp_var Azero vm i
-  | ASP0 => Azero
-  | ASP1 => Aone
-  | ASPplus l r => Aplus (interp_asp l) (interp_asp r)
-  | ASPmult l r => Amult (interp_asp l) (interp_asp r)
-  end.
-
-(* Local *) Definition iacs_aux :=
-              (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A :=
-                 match s with
-                 | Nil_acs => a
-                 | Cons_acs l t =>
-                     Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 end).
-
-Definition interp_acs (s:abstract_sum) : A :=
-  match s with
-  | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Nil_acs => Azero
-  end.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hint Immediate T.
-
-Remark iacs_aux_ok :
- forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
-Proof.
-  simple induction s; simpl in |- *; intros.
-  trivial.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.
-
-Lemma abstract_varlist_insert_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).
-
-  simple induction s.
-  trivial.
-
-  simpl in |- *; intros.
-  elim (varlist_lt l v); simpl in |- *.  	
-  eauto.
-  rewrite iacs_aux_ok.
-  rewrite H; auto.
-
-Qed.
-
-Lemma abstract_sum_merge_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
-
-Proof.  
-  simple induction x.
-  trivial.
-  simple induction y; intros.
-
-  auto.
-
-  simpl in |- *; elim (varlist_lt v v0); simpl in |- *.
-  repeat rewrite iacs_aux_ok.
-  rewrite H; simpl in |- *; auto.
-
-  simpl in H0.
-  repeat rewrite iacs_aux_ok.
-  rewrite H0. simpl in |- *; auto.
-Qed.
-
-Lemma abstract_sum_scalar_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
-Proof.
-  simple induction s.
-  simpl in |- *; eauto.
-
-  simpl in |- *; intros.
-  rewrite iacs_aux_ok.
-  rewrite abstract_varlist_insert_ok.
-  rewrite H.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  auto.
-Qed.
-
-Lemma abstract_sum_prod_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).
-
-Proof.
-  simple induction x.
-  intros; simpl in |- *; eauto.
-
-  destruct y as [| v0 a0]; intros.
-
-  simpl in |- *; rewrite H; eauto.
-
-  unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *.
-  rewrite abstract_sum_merge_ok.
-  rewrite abstract_sum_scalar_ok.
-  rewrite H; simpl in |- *; auto.
-Qed.
-
-Theorem aspolynomial_normalize_ok :
- forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
-Proof.
-  simple induction x; simpl in |- *; intros; trivial.
-  rewrite abstract_sum_merge_ok.
-  rewrite H; rewrite H0; eauto.
-  rewrite abstract_sum_prod_ok.
-  rewrite H; rewrite H0; eauto.
-Qed.
-
-End abstract_semi_rings.
-
-Section abstract_rings.
-
-(* In abstract polynomials there is no constants other
-   than 0 and 1. An abstract ring is a ring whose operations plus, 
-   and mult are not functions but  constructors. In other words,
-   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
-   term. "closed" mean here "without plus and mult". *)
-
-(* this section is not parametrized by a (semi-)ring.
-   Nevertheless, they are two different types for semi-rings and rings 
-   and there will be 2 correction theorems *)
-
-Inductive apolynomial : Type :=
-  | APvar : index -> apolynomial
-  | AP0 : apolynomial
-  | AP1 : apolynomial
-  | APplus : apolynomial -> apolynomial -> apolynomial
-  | APmult : apolynomial -> apolynomial -> apolynomial
-  | APopp : apolynomial -> apolynomial.
-
-(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
-   Invariant : the list is sorted and there is no varlist is present
-   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
-
-Inductive signed_sum : Type :=
-  | Nil_varlist : signed_sum
-  | Plus_varlist : varlist -> signed_sum -> signed_sum
-  | Minus_varlist : varlist -> signed_sum -> signed_sum.
-
-Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      (fix ssm_aux (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Plus_varlist l1 (signed_sum_merge t1 s2)
-             else Plus_varlist l2 (ssm_aux t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Plus_varlist l1 (signed_sum_merge t1 s2)
-              else Minus_varlist l2 (ssm_aux t2)
-         | Nil_varlist => s1
-         end)
-  | Minus_varlist l1 t1 =>
-      (fix ssm_aux2 (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Minus_varlist l1 (signed_sum_merge t1 s2)
-              else Plus_varlist l2 (ssm_aux2 t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Minus_varlist l1 (signed_sum_merge t1 s2)
-             else Minus_varlist l2 (ssm_aux2 t2)
-         | Nil_varlist => s1
-         end)
-  | Nil_varlist => fun s2 => s2
-  end.
-
-Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Plus_varlist l1 s2
-      else Plus_varlist l2 (plus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Plus_varlist l1 s2
-       else Minus_varlist l2 (plus_varlist_insert l1 t2)
-  | Nil_varlist => Plus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Minus_varlist l1 s2
-       else Plus_varlist l2 (minus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Minus_varlist l1 s2
-      else Minus_varlist l2 (minus_varlist_insert l1 t2)
-  | Nil_varlist => Minus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint signed_sum_opp (s:signed_sum) : signed_sum :=
-  match s with
-  | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2)
-  | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-
-Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Minus_varlist l1 t1 =>
-      signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum :=
-  match p with
-  | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist
-  | AP1 => Plus_varlist Nil_var Nil_varlist
-  | AP0 => Nil_varlist
-  | APplus l r =>
-      signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r)
-  | APmult l r =>
-      signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r)
-  | APopp q => signed_sum_opp (apolynomial_normalize q)
-  end.
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-(* Local *) Definition isacs_aux :=
-              (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A :=
-                 match s with
-                 | Nil_varlist => a
-                 | Plus_varlist l t =>
-                     Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 | Minus_varlist l t =>
-                     Aplus a
-                       (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
-                 end).
-
-Definition interp_sacs (s:signed_sum) : A :=
-  match s with
-  | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t
-  | Nil_varlist => Azero
-  end.
-
-Fixpoint interp_ap (p:apolynomial) : A :=
-  match p with
-  | APvar i => interp_var Azero vm i
-  | AP0 => Azero
-  | AP1 => Aone
-  | APplus l r => Aplus (interp_ap l) (interp_ap r)
-  | APmult l r => Amult (interp_ap l) (interp_ap r)
-  | APopp q => Aopp (interp_ap q)
-  end.
-
-Hint Resolve (Th_plus_comm T).
-Hint Resolve (Th_plus_assoc T).
-Hint Resolve (Th_plus_assoc2 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).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hint Immediate T.
-
-Lemma isacs_aux_ok :
- forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
-Proof.
-  simple induction s; simpl in |- *; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
-
-Ltac solve1 v v0 H H0 :=
-  simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok;
-   [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ].
-
-Lemma signed_sum_merge_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
-
-  simple induction x.
-  intro; simpl in |- *; auto.
-
-  simple induction y; intros.
-
-  auto.
-
-  solve1 v v0 H H0.
-
-  simpl in |- *; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl in |- *.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T). 
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
-      (interp_vl Amult Aone Azero vm v0)).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  simple induction y; intros.
-
-  auto.
-
-  simpl in |- *; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl in |- *.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T). 
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  solve1 v v0 H H0.
-
-Qed.
-
-Ltac solve2 l v H :=
-  elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok;
-   [ auto | rewrite H; auto ].
-
-Lemma plus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl in |- *; intros.
-  solve2 l v H.
-
-  simpl in |- *; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl in |- *.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve2 l v H.
-
-Qed.
-
-Lemma minus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_varlist_insert l s) =
-   Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl in |- *; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl in |- *.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
-      (interp_vl Amult Aone Azero vm v)).
-  rewrite (Th_opp_def T).
-  auto.
-
-  simpl in |- *; intros.
-  solve2 l v H.
-
-  simpl in |- *; intros; solve2 l v H.
-
-Qed.
-
-Lemma signed_sum_opp_ok :
- forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
-Proof.
-
-  simple induction s; simpl in |- *; intros.
-
-  symmetry  in |- *; apply (Th_opp_zero T).
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma plus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl in |- *; intros.
-  rewrite plus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  simpl in |- *; intros.
-  rewrite minus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  reflexivity.
-
-Qed.
-
-Lemma minus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_sum_scalar l s) =
-   Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
-Proof.
-
-  simple induction s; simpl in |- *; intros.
-
-  rewrite (Th_mult_zero_right T); symmetry  in |- *; apply (Th_opp_zero T).
-
-  simpl in |- *; intros.
-  rewrite minus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  simpl in |- *; intros.
-  rewrite plus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma signed_sum_prod_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
-Proof.
-
-  simple induction x.
-
-  simpl in |- *; eauto 1.
-
-  intros; simpl in |- *.
-  rewrite signed_sum_merge_ok.
-  rewrite plus_sum_scalar_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  intros; simpl in |- *.
-  repeat rewrite isacs_aux_ok.
-  rewrite signed_sum_merge_ok.
-  rewrite minus_sum_scalar_ok.
-  rewrite H.
-  rewrite (Th_distr_left T).
-  rewrite (Th_opp_mult_left T).
-  reflexivity.
-
-Qed.
-
-Theorem apolynomial_normalize_ok :
- forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
-Proof.
-  simple induction p; simpl in |- *; auto 1.
-  intros.
-    rewrite signed_sum_merge_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_prod_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_opp_ok.
-    rewrite H; reflexivity.
-Qed.  
-
-End abstract_rings.
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
deleted file mode 100644
index e8d9f1ee..00000000
--- a/contrib/ring/Ring_normalize.v
+++ /dev/null
@@ -1,902 +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        *)
-(************************************************************************)
-
-(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-Unset Boxed Definitions.
-
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  intros.
-  apply index_eq_prop.
-  generalize H.
-  case (index_eq n m); simpl in |- *; trivial; intros.
-  contradiction.
-Qed.
-
-Section semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples : 
-  3 < x < y
-  x*y < x*y*y*z 
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) 
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *) 
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-ring polynomials *)
-Inductive spolynomial : Type :=
-  | SPvar : index -> spolynomial
-  | SPconst : A -> spolynomial
-  | SPplus : spolynomial -> spolynomial -> spolynomial
-  | SPmult : spolynomial -> spolynomial -> spolynomial.
-
-Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
-  match p with
-  | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SPconst c => Cons_monom c Nil_var Nil_monom
-  | SPplus l r =>
-      canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r)
-  | SPmult l r =>
-      canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r)
-  end.
-
-(* Deletion of useless 0 and 1 in canonical sums *)
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition spolynomial_simplify (x:spolynomial) :=
-  canonical_sum_simplify (spolynomial_normalize x).
-
-(* End definitions. *)
-
-(* Section interpretation. *)
-
-(*** Here a variable map is defined and the interpetation of a spolynom
-  acording to a certain variables map. Once again the choosen definition
-  is generic and could be changed ****)
-
-Variable vm : varmap A.
-
-(* Interpretation of list of variables 
- * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
- * The unbound variables are mapped to 0. Normally this case sould
- * never occur. Since we want only to prove correctness theorems, which form
- * is : for any varmap and any spolynom ... this is a safe and pain-saving
- * choice *)
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-(* Local *) Definition ivl_aux :=
-              (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-                 match t with
-                 | Nil_var => interp_var x
-                 | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-                 end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-(* Local *) Definition interp_m (c:A) (l:varlist) :=
-              match l with
-              | Nil_var => c
-              | Cons_var x t => Amult c (ivl_aux x t)
-              end.
-
-(* Local *) Definition ics_aux :=
-              (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-                 match s with
-                 | Nil_monom => a
-                 | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-                 | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-                 end).
-
-(* Interpretation of a canonical sum *)
-Definition interp_cs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_sp (p:spolynomial) : A :=
-  match p with
-  | SPconst c => c
-  | SPvar i => interp_var i
-  | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2)
-  | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2)
-  end.
-
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl in |- *; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   ivl_aux i v = Amult (interp_var i) (interp_vl v).
-Proof.
-  simple induction v; simpl in |- *; intros.
-  trivial.
-  rewrite H; trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
-Proof.
-  simple induction x.
-  simpl in |- *; trivial.
-  simple induction y.
-  simpl in |- *; trivial.
-  simpl in |- *; intros.
-  elim (index_lt i i0); simpl in |- *; intros.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H. simpl in |- *.
-  rewrite ivl_aux_ok.
-  eauto.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H0.
-  rewrite ivl_aux_ok.
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
-Proof.
-  simple induction s; simpl in |- *; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
-Proof.
-  destruct l as [| i v].
-  simpl in |- *; trivial.
-  reflexivity.
-Qed.
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
-
-simple induction x; simpl in |- *.
-trivial.
-
-simple induction y; simpl in |- *; intros.
-(* monom and nil *)
-eauto.
-
-(* monom and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-trivial.
-
-elim (varlist_lt v v0); simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
- eauto.
-
-(* monom and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-rewrite (SR_mult_one_left T).
-trivial.
-
-elim (varlist_lt v v0); simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
- eauto.
-
-simple induction y; simpl in |- *; intros.
-(* varlist and nil *)
-trivial.
-
-(* varlist and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
- eauto.
-
-(* varlist and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
- eauto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   interp_cs (monom_insert a l s) =
-   Aplus (Amult a (interp_vl l)) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl in |- *; rewrite interp_m_ok; trivial.
-
-simpl in |- *; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- eauto.
-elim (varlist_lt l v); simpl in |- *;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl in |- *; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl in |- *; trivial.
-
-simpl in |- *; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl in |- *; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
-simple induction s.
-simpl in |- *; eauto.
-
-simpl in |- *; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-
-simpl in |- *; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
-simple induction s.
-simpl in |- *; trivial.
-
-simpl in |- *; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl in |- *; intros.
-rewrite varlist_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar3 c l s) =
-   Amult c (Amult (interp_vl l) (interp_cs s)).
-simple induction s.
-simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity.
-
-simpl in |- *; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl in |- *; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T). 
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
-simple induction x; simpl in |- *; intros.
-trivial.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar3_ok.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
-symmetry  in |- *.
-eauto.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar2_ok.
-rewrite ics_aux_ok.
-rewrite H.
-trivial.
-Qed.
-
-Theorem spolynomial_normalize_ok :
- forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
-simple induction p; simpl in |- *; intros.
-
-reflexivity.
-reflexivity.
-
-rewrite canonical_sum_merge_ok.
-rewrite H; rewrite H0.
-reflexivity.
-
-rewrite canonical_sum_prod_ok.
-rewrite H; rewrite H0.
-reflexivity.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
-simple induction s.
-
-reflexivity.
-
-(* cons_monom *)
-simpl in |- *; intros.
-generalize (SR_eq_prop T a Azero).
-elim (Aeq a Azero).
-intro Heq; rewrite (Heq I).
-rewrite H.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite (SR_mult_zero_left T).
-trivial.
-
-intros; simpl in |- *.
-generalize (SR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intro Heq; rewrite (Heq I).
-simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_one_left T).
-reflexivity.
-
-simpl in |- *.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-reflexivity.
-
-(* cons_varlist *)
-simpl in |- *; intros.
-repeat rewrite ics_aux_ok.
-rewrite H.
-reflexivity.
-
-Qed.
-
-Theorem spolynomial_simplify_ok :
- forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
-intro.
-unfold spolynomial_simplify in |- *.
-rewrite canonical_sum_simplify_ok.
-apply spolynomial_normalize_ok.
-Qed.
-
-(* End properties. *)
-End semi_rings.
-
-Implicit Arguments Cons_varlist.
-Implicit Arguments Cons_monom.
-Implicit Arguments SPconst.
-Implicit Arguments SPplus.
-Implicit Arguments SPmult.
-
-Section rings.
-
-(* Here the coercion between Ring and Semi-Ring will be useful *)
-
-Set Implicit Arguments.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-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_comm T).
-Hint Resolve (Th_mult_assoc T).
-Hint Resolve (Th_mult_assoc2 T).
-Hint Resolve (Th_plus_zero_left T).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hint Immediate T.
-
-(*** Definitions *)
-
-Inductive polynomial : Type :=
-  | Pvar : index -> polynomial
-  | Pconst : A -> polynomial
-  | Pplus : polynomial -> polynomial -> polynomial
-  | Pmult : polynomial -> polynomial -> polynomial
-  | Popp : polynomial -> polynomial.
-
-Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A :=
-  match x with
-  | Pplus l r =>
-      canonical_sum_merge Aplus Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pmult l r =>
-      canonical_sum_prod Aplus Amult Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pconst c => Cons_monom c Nil_var (Nil_monom A)
-  | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A)
-  | Popp p =>
-      canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-        (polynomial_normalize p)
-  end.
-
-Definition polynomial_simplify (x:polynomial) :=
-  canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x).
-
-Fixpoint spolynomial_of (x:polynomial) : spolynomial A :=
-  match x with
-  | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r)
-  | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r)
-  | Pconst c => SPconst c
-  | Pvar i => SPvar A i
-  | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_p (p:polynomial) : A :=
-  match p with
-  | Pconst c => c
-  | Pvar i => varmap_find Azero i vm
-  | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2)
-  | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2)
-  | Popp p1 => Aopp (interp_p p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma spolynomial_of_ok :
- forall p:polynomial,
-   interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
-simple induction p; reflexivity || (simpl in |- *; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H.
-rewrite (Th_opp_mult_left2 T).
-rewrite (Th_mult_one_left T).
-reflexivity.
-Qed.
-
-Theorem polynomial_normalize_ok :
- forall p:polynomial,
-   polynomial_normalize p =
-   spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
-simple induction p; reflexivity || (simpl in |- *; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl in |- *.
-elim
- (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-    (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
- [ reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem polynomial_simplify_ok :
- forall p:polynomial,
-   interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
-intro.
-unfold polynomial_simplify in |- *.
-rewrite spolynomial_of_ok.
-rewrite polynomial_normalize_ok.
-rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
-rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
-reflexivity.
-Qed.
-
-End rings.
-
-Infix "+" := Pplus : ring_scope.
-Infix "*" := Pmult : ring_scope.
-Notation "- x" := (Popp x) : ring_scope.
-Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
-
-Delimit Scope ring_scope with ring.
diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v
deleted file mode 100644
index 7bf33b17..00000000
--- a/contrib/ring/Setoid_ring.v
+++ /dev/null
@@ -1,13 +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        *)
-(************************************************************************)
-
-(* $Id: Setoid_ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Setoid_ring_theory.
-Require Export Quote.
-Require Export Setoid_ring_normalize.
\ No newline at end of file
diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v
deleted file mode 100644
index 8eb49a37..00000000
--- a/contrib/ring/Setoid_ring_normalize.v
+++ /dev/null
@@ -1,1165 +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        *)
-(************************************************************************)
-
-(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *)
-
-Require Import Setoid_ring_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-Unset Boxed Definitions.
- 
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; simpl in |- *;
-   try reflexivity || contradiction.
-  intros; rewrite (H i0); trivial.
-  intros; rewrite (H i0); trivial.
-Qed.
-
-Section setoid.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable plus_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Aplus a a1)  (Aplus a0 a2).
-Variable mult_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Amult a a1) (Amult a0 a2).
-Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve equiv_refl equiv_trans.
-Hint Immediate equiv_sym.
-
-Section semi_setoid_rings.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples : 
-  3 < x < y
-  x*y < x*y*y*z 
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) 
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *) 
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-setoid-ring polynomials *)
-
-Inductive setspolynomial : Type :=
-  | SetSPvar : index -> setspolynomial
-  | SetSPconst : A -> setspolynomial
-  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
-  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
-
-Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
-  match p with
-  | SetSPplus l r =>
-      canonical_sum_merge (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPmult l r =>
-      canonical_sum_prod (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPconst c => Cons_monom c Nil_var Nil_monom
-  | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  end.
-
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition setspolynomial_simplify (x:setspolynomial) :=
-  canonical_sum_simplify (setspolynomial_normalize x).
-
-Variable vm : varmap A.
-
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-Definition ivl_aux :=
-  (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-     match t with
-     | Nil_var => interp_var x
-     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-     end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-Definition interp_m (c:A) (l:varlist) :=
-  match l with
-  | Nil_var => c
-  | Cons_var x t => Amult c (ivl_aux x t)
-  end.
-
-Definition ics_aux :=
-  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-     match s with
-     | Nil_monom => a
-     | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-     | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-     end).
-
-Definition interp_setcs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_setsp (p:setspolynomial) : A :=
-  match p with
-  | SetSPconst c => c
-  | SetSPvar i => interp_var i
-  | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
-  | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
-  end.
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SSR_plus_comm T).
-Hint Resolve (SSR_plus_assoc T).
-Hint Resolve (SSR_plus_assoc2 S T).
-Hint Resolve (SSR_mult_comm T).
-Hint Resolve (SSR_mult_assoc T).
-Hint Resolve (SSR_mult_assoc2 S T).
-Hint Resolve (SSR_plus_zero_left T).
-Hint Resolve (SSR_plus_zero_left2 S T).
-Hint Resolve (SSR_mult_one_left T).
-Hint Resolve (SSR_mult_one_left2 S T).
-Hint Resolve (SSR_mult_zero_left T).
-Hint Resolve (SSR_mult_zero_left2 S T).
-Hint Resolve (SSR_distr_left T).
-Hint Resolve (SSR_distr_left2 S T).
-Hint Resolve (SSR_plus_reg_left T).
-Hint Resolve (SSR_plus_permute S plus_morph T).
-Hint Resolve (SSR_mult_permute S mult_morph T).
-Hint Resolve (SSR_distr_right S plus_morph T).
-Hint Resolve (SSR_distr_right2 S plus_morph T).
-Hint Resolve (SSR_mult_zero_right S T).
-Hint Resolve (SSR_mult_zero_right2 S T).
-Hint Resolve (SSR_plus_zero_right S T).
-Hint Resolve (SSR_plus_zero_right2 S T).
-Hint Resolve (SSR_mult_one_right S T).
-Hint Resolve (SSR_mult_one_right2 S T).
-Hint Resolve (SSR_plus_reg_right S T).
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl in |- *; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
-Proof.
-  simple induction v; simpl in |- *; intros.
-  trivial.
-  rewrite (H i); trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
-Proof.
-  simple induction x.
-  simpl in |- *; trivial.
-  simple induction y.
-  simpl in |- *; trivial.
-  simpl in |- *; intros.
-  elim (index_lt i i0); simpl in |- *; intros.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
-  rewrite (H (Cons_var i0 v0)).
-  simpl in |- *.
-  rewrite (ivl_aux_ok v0 i0).
-  eauto.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite
-   (ivl_aux_ok
-      ((fix vm_aux (l2:varlist) : varlist :=
-          match l2 with
-          | Nil_var => Cons_var i v
-          | Cons_var v2 t2 =>
-              if index_lt i v2
-              then Cons_var i (varlist_merge v l2)
-              else Cons_var v2 (vm_aux t2)
-          end) v0) i0).
-  rewrite H0.
-  rewrite (ivl_aux_ok v i).
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum),
-   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
-Proof.
- simple induction s; simpl in |- *; intros; trivial.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
-Proof.
-  destruct l as [| i v]; trivial.
-Qed.
-
-Hint Resolve ivl_aux_ok.
-Hint Resolve ics_aux_ok.
-Hint Resolve interp_m_ok.
-
-(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_merge x y))
-     (Aplus (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl in |- *.
-trivial.
-
-simple induction y; simpl in |- *; intros.
-eauto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *.
-rewrite (ics_aux_ok (interp_m a v0) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a a0) v0).
-rewrite (interp_m_ok a v0).
-rewrite (interp_m_ok a0 v0).
-setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult a0 (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl in |- *.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
- .
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *.
-rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_m a0 v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)).
-rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; 
- auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_m a v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a Aone) v0).
-rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl in |- *.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H (Cons_varlist v0 c0)); simpl in |- *.
-rewrite (ics_aux_ok (interp_vl v0) c0).
-auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl in |- *.
-auto.
-
-simple induction y; simpl in |- *; intros.
-trivial.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult a (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl in |- *; intros.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_m a v0) c0).
-rewrite (H (Cons_monom a v0 c0)); simpl in |- *.
-rewrite (ics_aux_ok (interp_m a v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_m a v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
- simpl in |- *; auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0); intros.
-rewrite (H1 I); simpl in |- *.
-rewrite
- (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
- ; rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone Aone) v0).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
-[ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
-
-elim (varlist_lt v v0); simpl in |- *.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
- simpl in |- *.
-rewrite (ics_aux_ok (interp_vl v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl in |- *; auto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (monom_insert a l s))
-     (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
-Proof.
-simple induction s; intros.
-simpl in |- *; rewrite (interp_m_ok a l); trivial.
-
-simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
-setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl in |- *; intros.
-rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
-auto.
-
-rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
- rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
-auto.
-
-simpl in |- *.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus a Aone) v).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl in |- *; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (varlist_insert l s))
-     (Aplus (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl in |- *; intros.
-trivial.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl in |- *; intros; auto.
-rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H; auto.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
-rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus Aone Aone) v).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl in |- *; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
-rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar a s))
-     (Amult a (interp_setcs s)).
-Proof.
-simple induction s; simpl in |- *; intros.
-trivial.
-
-rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
-rewrite H.
-setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
-rewrite (interp_m_ok a v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
-     (Amult (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl in |- *; intros; auto.
-rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
-     (Amult c (Amult (interp_vl l) (interp_setcs s))).
-Proof.
-simple induction s; simpl in |- *; intros.
-rewrite (SSR_mult_zero_right S T (interp_vl l)).
-auto.
-
-rewrite
- (monom_insert_ok (Amult c a) (varlist_merge l v)
-    (canonical_sum_scalar3 c l c0)).
-rewrite (ics_aux_ok (interp_m a v) c0).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c0)));
- [ idtac | trivial ].
-setoid_replace
- (Amult c
-    (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-       (Amult (interp_vl l) (interp_setcs c0)))) with
- (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
- (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
- [ idtac | trivial ].
-auto.
-
-rewrite
- (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
- .
-rewrite (ics_aux_ok (interp_vl v) c0).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
- (Amult c
-    (Aplus (Amult (interp_vl l) (interp_vl v))
-       (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_prod x y))
-     (Amult (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl in |- *; intros.
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
-    (canonical_sum_prod c y)).
-rewrite (canonical_sum_scalar3_ok a v y).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H y).
-setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
- (Amult (Amult a (interp_vl v)) (interp_setcs y));
- [ idtac | trivial ].
-setoid_replace
- (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
- with
- (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
-    (Amult (interp_setcs c) (interp_setcs y)));
- [ idtac | trivial ].
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
- .
-rewrite (canonical_sum_scalar2_ok v y).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (H y).
-trivial.
-Qed.
-
-Theorem setspolynomial_normalize_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
-Proof.
-simple induction p; simpl in |- *; intros; trivial.
-rewrite
- (canonical_sum_merge_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-
-rewrite
- (canonical_sum_prod_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
-Proof.
-simple induction s; simpl in |- *; intros.
-trivial.
-
-generalize (SSR_eq_prop T a Azero).
-elim (Aeq a Azero).
-simpl in |- *.
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H0 I).
-setoid_replace (Amult Azero (interp_vl v)) with Azero;
- [ idtac | trivial ].
-rewrite H.
-trivial.
-
-intros; simpl in |- *.
-generalize (SSR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H1 I).
-simpl in |- *.
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-
-simpl in |- *.
-intros.
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite H; trivial.
-
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-Qed.
-
-Theorem setspolynomial_simplify_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
-Proof.
-intro.
-unfold setspolynomial_simplify in |- *.
-rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
-exact (setspolynomial_normalize_ok p).
-Qed.
-
-End semi_setoid_rings.
-
-Implicit Arguments Cons_varlist.
-Implicit Arguments Cons_monom.
-Implicit Arguments SetSPconst.
-Implicit Arguments SetSPplus.
-Implicit Arguments SetSPmult.
-
-
-
-Section setoid_rings.
-
-Set Implicit Arguments.
-
-Variable vm : varmap A.
-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_comm T).
-Hint Resolve (STh_mult_assoc T).
-Hint Resolve (STh_mult_assoc2 S T).
-Hint Resolve (STh_plus_zero_left T).
-Hint Resolve (STh_plus_zero_left2 S T).
-Hint Resolve (STh_mult_one_left T).
-Hint Resolve (STh_mult_one_left2 S T).
-Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
-Hint Resolve (STh_distr_left T).
-Hint Resolve (STh_distr_left2 S T).
-Hint Resolve (STh_plus_reg_left S plus_morph T).
-Hint Resolve (STh_plus_permute S plus_morph T).
-Hint Resolve (STh_mult_permute S mult_morph T).
-Hint Resolve (STh_distr_right S plus_morph T).
-Hint Resolve (STh_distr_right2 S plus_morph T).
-Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
-Hint Resolve (STh_plus_zero_right S T).
-Hint Resolve (STh_plus_zero_right2 S T).
-Hint Resolve (STh_mult_one_right S T).
-Hint Resolve (STh_mult_one_right2 S T).
-Hint Resolve (STh_plus_reg_right S plus_morph T).
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hint Immediate T.
-
-
-(*** Definitions *)
-
-Inductive setpolynomial : Type :=
-  | SetPvar : index -> setpolynomial
-  | SetPconst : A -> setpolynomial
-  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPopp : setpolynomial -> setpolynomial.
-
-Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
-  match x with
-  | SetPplus l r =>
-      canonical_sum_merge (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPmult l r =>
-      canonical_sum_prod (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPconst c => Cons_monom c Nil_var Nil_monom
-  | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SetPopp p =>
-      canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
-  end.
-
-Definition setpolynomial_simplify (x:setpolynomial) :=
-  canonical_sum_simplify (setpolynomial_normalize x).
-
-Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
-  match x with
-  | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
-  | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
-  | SetPconst c => SetSPconst c
-  | SetPvar i => SetSPvar i
-  | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_setp (p:setpolynomial) : A :=
-  match p with
-  | SetPconst c => c
-  | SetPvar i => varmap_find Azero i vm
-  | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
-  | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
-  | SetPopp p1 => Aopp (interp_setp p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma setspolynomial_of_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
-simple induction p; trivial; simpl in |- *; intros.
-rewrite H; rewrite H0; trivial.
-rewrite H; rewrite H0; trivial.
-rewrite H.
-rewrite
- (STh_opp_mult_left2 S plus_morph mult_morph T Aone
-    (interp_setsp vm (setspolynomial_of s))).
-rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
-trivial.
-Qed.
-
-Theorem setpolynomial_normalize_ok :
- forall p:setpolynomial,
-   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
-simple induction p; trivial; simpl in |- *; intros.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl in |- *.
-elim
- (canonical_sum_scalar3 (Aopp Aone) Nil_var
-    (setspolynomial_normalize (setspolynomial_of s)));
- [ reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem setpolynomial_simplify_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
-intro.
-unfold setpolynomial_simplify in |- *.
-rewrite (setspolynomial_of_ok p).
-rewrite setpolynomial_normalize_ok.
-rewrite
- (canonical_sum_simplify_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T)
-    (setspolynomial_normalize (setspolynomial_of p)))
- .
-rewrite
- (setspolynomial_normalize_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T) (setspolynomial_of p))
- .
-trivial.
-Qed.
-
-End setoid_rings.
-
-End setoid.
diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v
deleted file mode 100644
index 88abd7de..00000000
--- a/contrib/ring/Setoid_ring_theory.v
+++ /dev/null
@@ -1,427 +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        *)
-(************************************************************************)
-
-(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *)
-
-Require Export Bool.
-Require Export Setoid.
-
-Set Implicit Arguments.
-
-Section Setoid_rings.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-
-Infix Local "==" := Aequiv (at level 70, no associativity).
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x).
-
-Variable plus_morph :
- forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
-Variable mult_morph :
-  forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
-Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Section Theory_of_semi_setoid_rings.
-
-Record Semi_Setoid_Ring_Theory : Prop := 
-  {SSR_plus_comm : forall n m:A, n + m == m + n;
-   SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   SSR_mult_comm : forall n m:A, n * m == m * n;
-   SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
-   SSR_plus_zero_left : forall n:A, 0 + n == n;
-   SSR_mult_one_left : forall n:A, 1 * n == n;
-   SSR_mult_zero_left : forall n:A, 0 * n == 0;
-   SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
-   SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Semi_Setoid_Ring_Theory.
-
-Let plus_comm := SSR_plus_comm T.
-Let plus_assoc := SSR_plus_assoc T.
-Let mult_comm := SSR_mult_comm T.
-Let mult_assoc := SSR_mult_assoc T.
-Let plus_zero_left := SSR_plus_zero_left T.
-Let mult_one_left := SSR_mult_one_left T. 
-Let mult_zero_left := SSR_mult_zero_left T.
-Let distr_left := SSR_distr_left T.
-Let plus_reg_left := SSR_plus_reg_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left plus_reg_left
-  equiv_refl (*equiv_sym*).
-Hint Immediate equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because
-  Auto does not symmetry *) 
-Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto. Qed.
-
-Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve SSR_plus_permute SSR_mult_permute.
-
-Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-auto.
-Qed.
-
-Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply SSR_distr_right.
-Qed.
-
-Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n).
-intro; apply plus_reg_left with n; trivial.
-Qed.
-
-End Theory_of_semi_setoid_rings.
-
-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_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;
-   STh_opp_def : forall n:A, n + - n == 0;
-   STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Setoid_Ring_Theory.
-
-Let plus_comm := STh_plus_comm T.
-Let plus_assoc := STh_plus_assoc 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. 
-Let opp_def := STh_opp_def T.
-Let distr_left := STh_distr_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left equiv_refl equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-
-Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
-auto. Qed.
-
-Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve STh_plus_permute STh_mult_permute.
-
-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)) by auto.
-rewrite (plus_assoc a a (- a)).
-rewrite H.
-apply opp_def.
-Qed.
-
-Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
-intros.
-apply Saux1.
-rewrite <- (distr_left 0 0 n).
-rewrite (plus_zero_left 0).
-trivial.
-Qed.
-Hint Resolve STh_mult_zero_left.
-
-Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto.
-Qed.
-
-Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z.
-intros.
-rewrite <- (plus_zero_left y).
-rewrite <- H0.
-rewrite <- (plus_assoc x z y).
-rewrite (plus_comm z y).
-rewrite (plus_assoc x y z).
-rewrite H.
-auto.
-Qed.
-
-Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
-intros.
-apply Saux2 with (x * y); auto.
-rewrite <- (distr_left x (- x) y).
-rewrite (opp_def x).
-auto.
-Qed.
-Hint Resolve STh_opp_mult_left.
-
-Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
-auto.
-Qed.
-
-Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
-intros.
-apply Saux2 with (x + y); auto.
-rewrite (STh_plus_permute (x + y) (- x) (- y)).
-rewrite <- (plus_assoc x y (- y)).
-rewrite (opp_def y); rewrite (STh_plus_zero_right x).
-rewrite (STh_opp_def2 x); trivial.
-Qed.
-
-Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
-auto.
-Qed.
-
-Lemma STh_opp_opp : forall n:A, - - n == n.
-intro.
-apply Saux2 with (- n); auto.
-rewrite (plus_comm (- n) n); auto.
-Qed.
-Hint Resolve STh_opp_opp.
-
-Lemma STh_opp_opp2 : forall n:A, n == - - n.
-auto.
-Qed.
-
-Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
-intros.
-rewrite (STh_opp_mult_left2 x (- y)).
-rewrite (STh_opp_mult_right2 x y).
-trivial.
-Qed.
-
-Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
-intros.
-apply equiv_sym.
-apply STh_mult_opp_opp.
-Qed.
-
-Lemma STh_opp_zero : - 0 == 0.
-rewrite <- (plus_zero_left (- 0)).
-trivial.
-Qed.
-
-Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p.
-intros.
-rewrite <- (plus_zero_left m).
-rewrite <- (plus_zero_left p).
-rewrite <- (opp_def n).
-rewrite (plus_comm n (- n)).
-rewrite <- (plus_assoc (- n) n m).
-rewrite <- (plus_assoc (- n) n p).
-auto.
-Qed.
-
-Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros.
-apply STh_plus_reg_left with n.
-rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
-Qed.
-
-Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-trivial.
-Qed.
-
-Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply STh_distr_right.
-Qed.
-
-End Theory_of_setoid_rings.
-
-Hint Resolve STh_mult_zero_left STh_plus_reg_left: core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Setoid_Ring_Theory_of :
-  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
-intros until 1; case H.
-split; intros; simpl in |- *; eauto.
-Defined.
-
-Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
- Semi_Setoid_Ring_Theory.
-
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
-
-End Setoid_rings.
diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4
deleted file mode 100644
index d0058026..00000000
--- a/contrib/ring/g_quote.ml4
+++ /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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_quote.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
-
-open Quote
-
-TACTIC EXTEND quote
-  [ "quote" ident(f) ] -> [ quote f [] ]
-| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
-END
diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4
deleted file mode 100644
index 2f964988..00000000
--- a/contrib/ring/g_ring.ml4
+++ /dev/null
@@ -1,136 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *)
-
-open Quote
-open Ring
-open Tacticals
-
-TACTIC EXTEND ring
-| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
-END
-
-(* The vernac commands "Add Ring" and co *)
-
-let cset_of_constrarg_list l = 
-  List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
-
-VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Legacy" "Ring" 
-          constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
-  -> [ add_theory true false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Ring" 
-      	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
-  -> [ add_theory false false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Abstract" "Ring" 
-    	  constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aopp) constr(aeq) constr(t) ] 
-  -> [ add_theory true true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Abstract" "Semi" "Ring" 
-          constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aeq) constr(t) ] 
-  -> [ add_theory false true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Setoid" "Ring"
-      	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) 
-	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
-	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] 
-  -> [ add_theory true false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = Some (constr_of om) })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Setoid" "Ring" 
-          constr(a) constr(aequiv) constr(asetth) constr(aplus)
-	  constr(amult) constr(aone) constr(azero) constr(aeq) 
-          constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] 
-  -> [ add_theory false false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = None })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-END
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
deleted file mode 100644
index 7cd22a36..00000000
--- a/contrib/ring/quote.ml
+++ /dev/null
@@ -1,491 +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        *)
-(************************************************************************)
-
-(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
-
-(* The `Quote' tactic *)
-
-(* The basic idea is to automatize the inversion of interpetation functions 
-   in 2-level approach 
-
-   Examples are given in \texttt{theories/DEMOS/DemoQuote.v}
-
-   Suppose you have a langage \texttt{L} of 'abstract terms' 
-   and a type \texttt{A} of 'concrete terms' 
-   and a function \texttt{f : L -> (varmap A L) -> A}.
-
-   Then, the tactic \texttt{Quote f} will replace an
-   expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} 
-   such that \texttt{e} and \texttt{(f vm t)} are convertible.
-
-   The problem is then inverting the function f.
-
-   The tactic works when:
-
-   \begin{itemize}
-   \item L is a simple inductive datatype. The constructors of L may
-     have one of the three following forms:
-
-     \begin{enumerate}
-     \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L|
-     \item variable leaf like: \verb|Cvar : index -> L|
-     \item constant leaf like \verb|Cconst : A -> L|
-     \end{enumerate}
-
-     The definition of \texttt{L} must contain at most one variable
-     leaf and at most one constant leaf.
-
-     When there are both a variable leaf and a constant leaf, there is
-     an ambiguity on inversion. The term t can be either the
-     interpretation of \texttt{(Cconst t)} or the interpretation of
-     (\texttt{Cvar}~$i$) in a variables map containing the binding $i
-     \rightarrow$~\texttt{t}. How to discriminate between these
-     choices ?
-     
-     To solve the dilemma, one gives to \texttt{Quote} a list of
-     \emph{constant constructors}: a term will be considered as a
-     constant if it is either a constant constructor of the
-     application of a constant constructor to constants. For example
-     the list \verb+[S, O]+ defines the closed natural
-     numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is
-     not. 
-
-     The definition of constants vary for each application of the
-     tactic, so it can even be different for two applications of 
-     \texttt{Quote} with the same function.
-     
-   \item \texttt{f} is a quite simple fixpoint on
-     \texttt{L}. In particular, \texttt{f} must verify: 
-
-\begin{verbatim}
-     (f (Cvar i)) = (varmap_find vm default_value i)
-\end{verbatim}
-\begin{verbatim}
-     (f (Cconst c)) = c
-\end{verbatim}
-
-     where \texttt{index} and \texttt{varmap\_find} are those defined
-     the \texttt{Quote} module. \emph{The tactic won't work with
-     user's own variables map !!}  It is mandatory to use the
-     variables map defined in module \texttt{Quote}.
-     
-   \end{itemize}
-
-   The method to proceed is then clear:
-
-   \begin{itemize}
-   \item Start with an empty hashtable of "registed leafs"
-      that map constr to integers and a "variable counter" equal to 0.
-    \item Try to match the term with every right hand side of the 
-      definition of f.
-
-      If there is one match, returns the correponding left hand
-      side and call yourself recursively to get the arguments of this
-      left hand side.
-
-      If there is no match, we are at a leaf. That is the
-      interpretation of either a variable or a constant.
-
-      If it is a constant, return \texttt{Cconst} applied to that
-      constant. 
-
-      If not, it is a variable. Look in the hashtable 
-      if this leaf has been already encountered. If not, increment
-      the variables counter and add an entry to the hashtable; then
-      return \texttt{(Cvar !variables\_counter)}
-   \end{itemize}
-*)
-
-
-(*i*) 
-open Pp
-open Util
-open Names
-open Term
-open Pattern
-open Matching
-open Tacmach
-open Tactics
-open Proof_trees
-open Tacexpr
-(*i*)
-
-(*s First, we need to access some Coq constants
-  We do that lazily, because this code can be linked before
-  the constants are loaded in the environment *)
-
-let constant dir s = Coqlib.gen_constant "Quote" ("ring"::dir) s
-
-let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm")
-let coq_Node_vm = lazy (constant ["Quote"] "Node_vm")
-let coq_varmap_find = lazy (constant ["Quote"] "varmap_find")
-let coq_Right_idx = lazy (constant ["Quote"] "Right_idx")
-let coq_Left_idx = lazy (constant ["Quote"] "Left_idx")
-let coq_End_idx = lazy (constant ["Quote"] "End_idx")
-
-(*s Then comes the stuff to decompose the body of interpetation function
-  and pre-compute the inversion data.
-
-For a function like:
-
-\begin{verbatim}
-  Fixpoint interp[vm:(varmap Prop); f:form] :=
-     Cases f of
-     | (f_and f1  f1 f2) => (interp f1)/\(interp f2)
-     | (f_or f1  f1 f2) => (interp f1)\/(interp f2)
-     | (f_var i) => (varmap_find Prop default_v i vm)
-     | (f_const c) => c
-\end{verbatim}
-
-With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the
-corresponding scheme will be: 
-
-\begin{verbatim}
-  {normal_lhs_rhs = 
-     [ "(f_and ?1 ?2)", "?1 /\ ?2";
-       "(f_or ?1 ?2)", " ?1 \/ ?2";];
-   return_type = "Prop";
-   constants = Some [C1,...Cn];
-   variable_lhs = Some "(f_var ?1)";
-   constant_lhs = Some "(f_const ?1)"
-  }
-\end{verbatim}
-
-If there is no constructor for variables in the type \texttt{form}, 
-then [variable_lhs] is [None]. Idem for constants and
-[constant_lhs]. Both cannot be equal to [None].
-
-The metas in the RHS must correspond to those in the LHS (one cannot 
-exchange ?1 and ?2 in the example above) 
-
-*)
-
-module ConstrSet = Set.Make(
-  struct 
-    type t = constr
-    let compare = (Pervasives.compare : t->t->int)
-  end)
-
-type inversion_scheme = {
-  normal_lhs_rhs : (constr * constr_pattern) list;
-  variable_lhs : constr option;
-  return_type : constr;
-  constants : ConstrSet.t;
-  constant_lhs : constr option }
-
-(*s [compute_ivs gl f cs] computes the inversion scheme associated to
-  [f:constr] with constants list [cs:constr list] in the context of 
-  goal [gl]. This function uses the auxiliary functions
-  [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *)
-
-let i_can't_do_that () = error "Quote: not a simple fixpoint"
-
-let decomp_term c = kind_of_term (strip_outer_cast c)
-
-(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ...
-  ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
-  type [typ] *)
-
-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
-    | Ind(sp,0) -> 
-        let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
-        mkApp (mkConstruct ((sp,0),i+1), argsi)
-    | _ -> i_can't_do_that ()
-
-(*s This function builds the pattern from the RHS. Recursive calls are
-  replaced by meta-variables ?i corresponding to those in the LHS *)
-
-let compute_rhs bodyi index_of_f =
-  let rec aux c = 
-    match kind_of_term c with
-      | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> 
-          let i = destRel (array_last args) in 
-	  PMeta (Some (coerce_meta_in i))
-      | App (f,args) ->
-          PApp (pattern_of_constr f, Array.map aux args)
-      | Cast (c,_,_) -> aux c 
-      | _ -> pattern_of_constr c
-  in
-  aux bodyi
-
-(*s Now the function [compute_ivs] itself *)
-
-let compute_ivs gl f cs =
-  let cst = try destConst f with _ -> i_can't_do_that () in
-  let body = Environ.constant_value (Global.env()) cst in
-  match decomp_term body with
-    | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
-        let (args3, body3) = decompose_lam body2 in
-        let nargs3 = List.length args3 in
-        begin match decomp_term body3 with
-          | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
-              let n_lhs_rhs = ref []
-              and v_lhs = ref (None : constr option)
-              and c_lhs = ref (None : constr option) in
-              Array.iteri
-                (fun i ci -> 
-                   let argsi, bodyi = decompose_lam ci in
-                   let nargsi = List.length argsi in
-           (* REL (narg3 + nargsi + 1) is f *)
-           (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
-           (* REL 1 to REL nargsi are argsi (reverse order) *)
-           (* First we test if the RHS is the RHS for constants *)
-                   if bodyi = mkRel 1 then 
-                     c_lhs := Some (compute_lhs (snd (List.hd args3))
-                                      i nargsi)
-           (* Then we test if the RHS is the RHS for variables *)
-                   else begin match decompose_app bodyi with 
-                     | vmf, [_; _; a3; a4 ]
-                         when isRel a3 & isRel a4 &
-			   pf_conv_x gl vmf 
-                           (Lazy.force coq_varmap_find)->
-                             v_lhs := Some (compute_lhs 
-                                              (snd (List.hd args3))
-                                              i nargsi)
-           (* Third case: this is a normal LHS-RHS *)
-                     | _ -> 
-                         n_lhs_rhs :=
-                         (compute_lhs (snd (List.hd args3)) i nargsi,
-                          compute_rhs bodyi (nargs3 + nargsi + 1))
-                         :: !n_lhs_rhs
-                   end) 
-                lci;
-	      
-              if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
-
-	      (* The Cases predicate is a lambda; we assume no dependency *)
-	      let p = match kind_of_term p with
-		| Lambda (_,_,p) -> Termops.pop p
-		| _ -> p
-	      in
-              
-              { normal_lhs_rhs = List.rev !n_lhs_rhs;
-                variable_lhs = !v_lhs;
-                return_type = p;
-                constants = List.fold_right ConstrSet.add cs ConstrSet.empty;
-                constant_lhs = !c_lhs }
-                     
-              | _ -> i_can't_do_that ()
-        end
-    |_ -> i_can't_do_that ()
-
-(* TODO for that function:
-\begin{itemize}
-\item handle the case where the return type is an argument of the
-  function
-\item handle the case of simple mutual inductive (for example terms
-  and lists of terms) formulas with the corresponding mutual
-  recursvive interpretation functions. 
-\end{itemize}
-*) 
-
-(*s Stuff to build variables map, currently implemented as complete
-binary search trees (see file \texttt{Quote.v}) *)
-
-(* First the function to distinghish between constants (closed terms) 
-   and variables (open terms) *)
-
-let rec closed_under cset t =
-  (ConstrSet.mem t cset) or
-  (match (kind_of_term t) with
-     | Cast(c,_,_) -> closed_under cset c  
-     | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
-     | _ -> false)
-    
-(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
-   binary search tree containing the [ci], that is:
-
-\begin{verbatim}
-                  c1
-                 /  \
-               c2    c3
-              /  \
-             c4  c5
-\end{verbatim}
-
-The second argument is a constr (the common type of the [ci])
-*)
-    
-let btree_of_array a ty =
-  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_vm  
-  and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in
-  let rec aux n =
-    if n > size_of_a 
-    then empty
-    else if  n > semi_size_of_a 
-    then mkApp (node, [| ty; a.(n-1); empty; empty |])
-    else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |])
-  in 
-  aux 1
-
-(*s [btree_of_array] and [path_of_int] verify the following invariant:\\
-   {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] 
-  = [a.(n)]\\
-  [n] must be [> 0] *)
-
-let path_of_int n = 
-  (* 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 -> mkApp ((if b then Lazy.force coq_Right_idx 
-                         else Lazy.force coq_Left_idx),
-                         [| c |]))
-    (List.rev (digits_of_int n))
-    (Lazy.force coq_End_idx)
-
-(*s The tactic works with a list of subterms sharing the same
-  variables map. We need to sort terms in order to avoid than
-  strange things happen during replacement of terms by their
-  'abstract' counterparties. *)
-
-(* [subterm t t'] tests if constr [t'] occurs in [t] *)
-(* This function does not descend under binders (lambda and Cases) *)
-
-let rec subterm gl (t : constr) (t' : constr) = 
-  (pf_conv_x gl t t') or
-  (match (kind_of_term t) with 
-     | App (f,args) -> array_exists (fun t -> subterm gl t t') args
-     | Cast(t,_,_) -> (subterm gl t t')
-     | _ -> false)
-           
-(*s We want to sort the list according to reverse subterm order. *)
-(* Since it's a partial order the algoritm of Sort.list won't work !! *)
-
-let rec sort_subterm gl l = 
-  let rec insert c = function
-    | [] -> [c]
-    | (h::t as l) when c = h -> l (* Avoid doing the same work twice *)
-    | h::t -> if subterm gl c h then c::h::t else h::(insert c t)  
-  in 
-  match l with 
-    | [] -> []
-    | h::t -> insert h (sort_subterm gl t)
-
-(*s Now we are able to do the inversion itself.
-  We destructurate the term and use an imperative hashtable
-  to store leafs that are already encountered. 
-  The type of arguments is:\\
-  [ivs : inversion_scheme]\\
-  [lc: constr list]\\
-  [gl: goal sigma]\\ *)
-
-let quote_terms ivs lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"Quote"];
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    let rec auxl l = 
-      match l with
-        | (lhs, rhs)::tail ->
-            begin try 
-              let s1 = matches rhs c in
-              let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
-	      in
-              Termops.subst_meta s2 lhs
-            with PatternMatchingFailure -> auxl tail
-            end 
-        |  [] -> 
-             begin match ivs.variable_lhs with 
-               | None -> 
-                   begin match ivs.constant_lhs with
-                     | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
-                     | None -> anomaly "invalid inversion scheme for quote"
-                   end
-               | Some var_lhs -> 
-                   begin match ivs.constant_lhs with
-                     | Some c_lhs when closed_under ivs.constants c ->
-			 Termops.subst_meta [1, c] c_lhs
-                     | _ -> 
-			 begin 
-                           try Hashtbl.find varhash c 
-                           with Not_found -> 
-                             let newvar = 
-                               Termops.subst_meta [1, (path_of_int !counter)] 
-				 var_lhs in
-                             begin 
-                               incr counter;
-                               varlist := c :: !varlist;
-                               Hashtbl.add varhash c newvar;
-                               newvar
-                             end
-			 end
-                   end 
-             end
-    in 
-    auxl ivs.normal_lhs_rhs 
-  in
-  let lp = List.map aux lc in 
-  (lp, (btree_of_array (Array.of_list (List.rev !varlist)) 
-          ivs.return_type ))
-
-(*s actually we could "quote" a list of terms instead of the 
-  conclusion of current goal. Ring for example needs that, but Ring doesn't
-  uses Quote yet. *)
- 
-let quote f lid gl =
-  let f = pf_global gl f in
-  let cl = List.map (pf_global gl) lid in
-  let ivs = compute_ivs gl f cl in
-  let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with
-    | [p], vm -> (p,vm)
-    | _ -> assert false
-  in
-  match ivs.variable_lhs with
-    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
-    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
-
-(*i 
-
-Just testing ...
-
-#use "include.ml";;
-open Quote;;
-
-let r = raw_constr_of_string;;
-
-let ivs = {
-  normal_lhs_rhs = 
-   [ r "(f_and ?1 ?2)", r "?1/\?2";
-     r "(f_not ?1)", r "~?1"];
-  variable_lhs = Some (r "(f_atom ?1)");
-  return_type = r "Prop";
-  constants = ConstrSet.empty;
-  constant_lhs = (r "nat") 
-};;
-
-let t1 = r "True/\(True /\ ~False)";;
-let t2 = r "True/\~~False";;
-
-quote_term ivs () t1;;
-quote_term ivs () t2;;
-
-let ivs2 =
-  normal_lhs_rhs = 
-   [ r "(f_and ?1 ?2)", r "?1/\?2";
-     r "(f_not ?1)", r "~?1"
-     r "True", r "f_true"];
-  variable_lhs = Some (r "(f_atom ?1)");
-  return_type = r "Prop";
-  constants = ConstrSet.empty;
-  constant_lhs = (r "nat")
-
-i*)
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
deleted file mode 100644
index f2706307..00000000
--- a/contrib/ring/ring.ml
+++ /dev/null
@@ -1,926 +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        *)
-(************************************************************************)
-
-(* $Id: ring.ml 11800 2009-01-18 18:34:15Z msozeau $ *)
-
-(* ML part of the Ring tactic *)
-
-open Pp
-open Util
-open Flags
-open Term
-open Names
-open Libnames
-open Nameops
-open Reductionops
-open Tacticals
-open Tacexpr
-open Tacmach
-open Proof_trees
-open Printer
-open Equality
-open Vernacinterp
-open Vernacexpr
-open Libobject
-open Closure
-open Tacred
-open Tactics
-open Pattern 
-open Hiddentac
-open Nametab
-open Quote
-open Mod_subst
-
-let mt_evd = Evd.empty
-let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
-
-let ring_dir = ["Coq";"ring"]
-let setoids_dir = ["Coq";"Setoids"]
-
-let ring_constant = Coqlib.gen_constant_in_modules "Ring"
-  [ring_dir@["LegacyRing_theory"];
-   ring_dir@["Setoid_ring_theory"];
-   ring_dir@["Ring_normalize"];
-   ring_dir@["Ring_abstract"];
-   setoids_dir@["Setoid"];
-   ring_dir@["Setoid_ring_normalize"]]
-
-(* Ring theory *)
-let coq_Ring_Theory = lazy (ring_constant "Ring_Theory")
-let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory")
-
-(* Setoid ring theory *)
-let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory")
-let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory")
-
-(* Ring normalize *)
-let coq_SPplus = lazy (ring_constant "SPplus")
-let coq_SPmult = lazy (ring_constant "SPmult")
-let coq_SPvar = lazy (ring_constant "SPvar")
-let coq_SPconst = lazy (ring_constant "SPconst")
-let coq_Pplus = lazy (ring_constant "Pplus")
-let coq_Pmult = lazy (ring_constant "Pmult")
-let coq_Pvar = lazy (ring_constant "Pvar")
-let coq_Pconst = lazy (ring_constant "Pconst")
-let coq_Popp = lazy (ring_constant "Popp")
-let coq_interp_sp = lazy (ring_constant "interp_sp")
-let coq_interp_p = lazy (ring_constant "interp_p")
-let coq_interp_cs = lazy (ring_constant "interp_cs")
-let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify")
-let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify")
-let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok")
-let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok")
-
-(* Setoid theory *)
-let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory")
-
-let coq_seq_refl = lazy(ring_constant "Seq_refl")
-let coq_seq_sym = lazy(ring_constant "Seq_sym")
-let coq_seq_trans = lazy(ring_constant "Seq_trans")
-
-(* Setoid Ring normalize *)
-let coq_SetSPplus = lazy (ring_constant "SetSPplus")
-let coq_SetSPmult = lazy (ring_constant "SetSPmult")
-let coq_SetSPvar = lazy (ring_constant "SetSPvar")
-let coq_SetSPconst = lazy (ring_constant "SetSPconst")
-let coq_SetPplus = lazy (ring_constant "SetPplus")
-let coq_SetPmult = lazy (ring_constant "SetPmult")
-let coq_SetPvar = lazy (ring_constant "SetPvar")
-let coq_SetPconst = lazy (ring_constant "SetPconst")
-let coq_SetPopp = lazy (ring_constant "SetPopp")
-let coq_interp_setsp = lazy (ring_constant "interp_setsp")
-let coq_interp_setp = lazy (ring_constant "interp_setp")
-let coq_interp_setcs = lazy (ring_constant "interp_setcs")
-let coq_setspolynomial_simplify = 
-  lazy (ring_constant "setspolynomial_simplify")
-let coq_setpolynomial_simplify = 
-  lazy (ring_constant "setpolynomial_simplify")
-let coq_setspolynomial_simplify_ok = 
-  lazy (ring_constant "setspolynomial_simplify_ok")
-let coq_setpolynomial_simplify_ok = 
-  lazy (ring_constant "setpolynomial_simplify_ok")
-
-(* Ring abstract *)
-let coq_ASPplus = lazy (ring_constant "ASPplus")
-let coq_ASPmult = lazy (ring_constant "ASPmult")
-let coq_ASPvar = lazy (ring_constant "ASPvar")
-let coq_ASP0 = lazy (ring_constant "ASP0")
-let coq_ASP1 = lazy (ring_constant "ASP1")
-let coq_APplus = lazy (ring_constant "APplus")
-let coq_APmult = lazy (ring_constant "APmult")
-let coq_APvar = lazy (ring_constant "APvar")
-let coq_AP0 = lazy (ring_constant "AP0")
-let coq_AP1 = lazy (ring_constant "AP1")
-let coq_APopp = lazy (ring_constant "APopp")
-let coq_interp_asp = lazy (ring_constant "interp_asp")
-let coq_interp_ap = lazy (ring_constant "interp_ap")
-let coq_interp_acs = lazy (ring_constant "interp_acs")
-let coq_interp_sacs = lazy (ring_constant "interp_sacs")
-let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
-let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
-let coq_aspolynomial_normalize_ok = 
-  lazy (ring_constant "aspolynomial_normalize_ok")
-let coq_apolynomial_normalize_ok = 
-  lazy (ring_constant "apolynomial_normalize_ok")
-
-(* Logic --> to be found in Coqlib *)
-open Coqlib
-
-let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
-
-(*********** Useful types and functions ************)
-
-module OperSet = 
-  Set.Make (struct 
-	      type t = global_reference
-	      let compare = (Pervasives.compare : t->t->int)
-	    end)
-
-type morph =
-    { plusm : constr;
-      multm : constr;
-      oppm : constr option;
-    }
-
-type theory =
-    { th_ring : bool;                  (* false for a semi-ring *)
-      th_abstract : bool;
-      th_setoid : bool;                (* true for a setoid ring *)
-      th_equiv : constr option;
-      th_setoid_th : constr option;
-      th_morph : morph option;
-      th_a : constr;                   (* e.g. nat *)
-      th_plus : constr;
-      th_mult : constr;
-      th_one : constr;
-      th_zero : constr;
-      th_opp : constr option;          (* None if semi-ring *)
-      th_eq : constr;
-      th_t : constr;                   (* e.g. NatTheory *)
-      th_closed : ConstrSet.t;         (* e.g. [S; O] *)
-                                       (* Must be empty for an abstract ring *)
-    }
-
-(* Theories are stored in a table which is synchronised with the Reset 
-   mechanism. *)
-
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
-
-let theories_map = ref Cmap.empty
-
-let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
-let theories_map_find c = Cmap.find c !theories_map
-let theories_map_mem c = Cmap.mem c !theories_map
-
-let _ = 
-  Summary.declare_summary "tactic-ring-table"
-    { Summary.freeze_function = (fun () -> !theories_map);
-      Summary.unfreeze_function = (fun t -> theories_map := t);
-      Summary.init_function = (fun () -> theories_map := Cmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
-
-(* declare a new type of object in the environment, "tactic-ring-theory"
-   The functions theory_to_obj and obj_to_theory do the conversions
-   between theories and environement objects. *)
-
-
-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
-    if plusm' == morph.plusm 
-      && multm' == morph.multm 
-      && oppm' == morph.oppm then 
-	morph
-    else
-      { plusm = plusm' ;
-	multm = multm' ;
-	oppm = oppm' ;
-      }
-  
-let subst_set subst cset = 
-  let same = ref true in
-  let copy_subst c newset = 
-    let c' = subst_mps subst c in
-      if not (c' == c) then same := false;
-      ConstrSet.add c' newset
-  in
-  let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
-    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_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_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
-    if th_equiv' == th.th_equiv 
-      && th_setoid_th' == th.th_setoid_th 
-      && th_morph' == th.th_morph
-      && th_a' == th.th_a
-      && th_plus' == th.th_plus
-      && th_mult' == th.th_mult
-      && th_one' == th.th_one
-      && th_zero' == th.th_zero
-      && th_opp' == th.th_opp
-      && th_eq' == th.th_eq
-      && th_t' == th.th_t
-      && th_closed' == th.th_closed 
-    then 
-      th 
-    else
-    { th_ring = th.th_ring ;  
-      th_abstract = th.th_abstract ;
-      th_setoid = th.th_setoid ;  
-      th_equiv = th_equiv' ;
-      th_setoid_th = th_setoid_th' ;
-      th_morph = th_morph' ;
-      th_a = th_a' ;            
-      th_plus = th_plus' ;
-      th_mult = th_mult' ;
-      th_one = th_one' ;
-      th_zero = th_zero' ;
-      th_opp = th_opp' ;        
-      th_eq = th_eq' ;
-      th_t = th_t' ;            
-      th_closed = th_closed' ;  
-    }
-
-
-let subst_th (_,subst,(c,th as obj)) = 
-  let c' = subst_mps subst c in
-  let th' = subst_theory subst th in
-    if c' == c && th' == th then obj else
-      (c',th')
-
-
-let (theory_to_obj, obj_to_theory) = 
-  let cache_th (_,(c, th)) = theories_map_add (c,th)
-  and export_th x = Some x in
-  declare_object {(default_object "tactic-ring-theory") with
-		    open_function = (fun i o -> if i=1 then cache_th o);
-                    cache_function = cache_th;
-		    subst_function = subst_th;
-		    classify_function = (fun (_,x) -> Substitute x);
-		    export_function = export_th }
-
-(* from the set A, guess the associated theory *)
-(* With this simple solution, the theory to use is automatically guessed *)
-(* But only one theory can be declared for a given Set *)
-
-let guess_theory a =
-  try 
-    theories_map_find a
-  with Not_found -> 
-    errorlabstrm "Ring" 
-      (str "No Declared Ring Theory for " ++
-	 pr_lconstr a ++ fnl () ++
-	 str "Use Add [Semi] Ring to declare it")
-
-(* Looks up an option *)
-
-let unbox = function 
-  | Some w -> w
-  | None -> anomaly "Ring : Not in case of a setoid ring."
-
-(* Protects the convertibility test against undue exceptions when using it 
-   with untyped terms *)
-
-let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
-
-
-(* Add a Ring or a Semi-Ring to the database after a type verification *)
-
-let implement_theory env t th args =
-  is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
-
-(* (\* The following test checks whether the provided morphism is the default *)
-(*    one for the given operation. In principle the test is too strict, since *)
-(*    it should possible to provide another proof for the same fact (proof *)
-(*    irrelevance). In particular, the error message is be not very explicative. *\) *)
-let states_compatibility_for env plus mult opp morphs =
- let check op compat = true in
-(*   is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *)
-(*    compat in *)
- check plus morphs.plusm &&
- check mult morphs.multm &&
- (match (opp,morphs.oppm) with
-     None, None -> true
-   | Some opp, Some compat -> check opp compat
-   | _,_ -> assert false)
-
-let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = 
-  if theories_map_mem a then errorlabstrm "Add Semi Ring" 
-    (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
-       pr_lconstr a);
-  let env = Global.env () in
-    if (want_ring & want_setoid & (
-	not (implement_theory env t coq_Setoid_Ring_Theory
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])
-        ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))
-        )) then 
-      errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
-    if (not want_ring & want_setoid & (
-        not (implement_theory env t coq_Semi_Setoid_Ring_Theory 
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))))
-    then
-      errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory");
-    if (want_ring & not want_setoid &
-	not (implement_theory env t coq_Ring_Theory
-	  [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then
-      errorlabstrm "addring" (str "Not a valid Ring theory");
-    if (not want_ring & not want_setoid &
-	not (implement_theory env t coq_Semi_Ring_Theory
-	  [| a; aplus; amult; aone; azero; aeq |])) then 
-      errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
-    Lib.add_anonymous_leaf
-      (theory_to_obj 
-	 (a, { th_ring = want_ring;
-	       th_abstract = want_abstract;
-	       th_setoid = want_setoid;
-	       th_equiv = aequiv;
-	       th_setoid_th = asetth;
-	       th_morph = amorph;
-	       th_a = a;
-	       th_plus = aplus;
-	       th_mult = amult;
-	       th_one = aone;
-	       th_zero = azero;
-	       th_opp = aopp;
-	       th_eq = aeq;
-	       th_t = t;
-	       th_closed = cset }))
-
-(******** The tactic itself *********)
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (concrete)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_spolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the spolynom p by a recursive destructuration of c 
-     and builds the varmap with side-effects *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SPconst, [|th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
-	    let newvar =
-              mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in 
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map 
-    (fun p -> 
-       (mkLApp (coq_interp_sp,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp (coq_interp_cs,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp (coq_spolynomial_simplify, 
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
-			       th.th_eq; p|])) |]),
-	mkLApp (coq_spolynomial_simplify_ok,
-	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (concrete)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_polynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Zminus *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-            (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
-	    mkLApp(coq_Pplus,
-                  [|th.th_a; aux c1;
-	            mkLApp(coq_Popp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_Popp, [|th.th_a; aux c1|])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_Pconst, [|th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
-	    let newvar =
-              mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
-       (mkLApp(coq_interp_p,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                 (unbox th.th_opp); v; p |])),
-	mkLApp(coq_interp_cs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp(coq_polynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_polynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (abstract)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_aspolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the aspolynom p by a recursive destructuration of c 
-     and builds the varmap with side-effects *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
-	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in 
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map 
-    (fun p -> 
-       (mkLApp(coq_interp_asp,
-               [| th.th_a; th.th_plus; th.th_mult; 
-		  th.th_one; th.th_zero; v; p |]),
-	mkLApp(coq_interp_acs,
-               [| th.th_a; th.th_plus; th.th_mult; 
-		  th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
-	mkLApp(coq_spolynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (abstract)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_apolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
-      (* The special case of Zminus *)
-      | App (binop, [|c1; c2|]) 
-	  when safe_pf_conv_x gl c
-            (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
-	    mkLApp(coq_APplus,
-                   [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_APopp, [| aux c1 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
-	    let newvar =
-              mkLApp(coq_APvar, [| path_of_int !counter |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
-       (mkLApp(coq_interp_ap,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; 
-		  th.th_zero; (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_sacs,
-	       [| th.th_a; th.th_plus; th.th_mult; 
-		  th.th_one; th.th_zero; (unbox th.th_opp); v; 
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
-	mkLApp(coq_apolynomial_normalize_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
-    lp
-    
-(*
-   gl : goal sigma
-   th : setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setpolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Zminus *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-	    (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
-	      mkLApp(coq_SetPplus,
-                     [| th.th_a; aux c1;
-			mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetPconst, [| th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c 
-	  with Not_found -> 
-	    let newvar =
-              mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map 
-    (fun p -> 
-       (mkLApp(coq_interp_setp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                  (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_setcs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp(coq_setpolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_setpolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp);
-                  th.th_eq; (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm; (unbox th.th_morph).multm;
-		  (unbox (unbox th.th_morph).oppm); v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
- 
-Builds 
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setspolynom gl th lc =
-  let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c = 
-    match (kind_of_term (strip_outer_cast c)) with 
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
-      | _ -> 
-	  try Hashtbl.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
-	    begin 
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Hashtbl.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_setsp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp(coq_interp_setcs,
-               [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl 
-		    (mkLApp(coq_setspolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult; 
-			       th.th_one; th.th_zero; 
-			       th.th_eq; p |])) |]),
-	mkLApp(coq_setspolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero; th.th_eq;
-                  (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm;
-                  (unbox th.th_morph).multm; v; th.th_t; p |])))
-    lp
-
-module SectionPathSet =
-  Set.Make(struct
-	     type t = section_path
-	     let compare = Pervasives.compare
-	   end)
-
-(* Avec l'uniformisation des red_kind, on perd ici sur la structure
-   SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
-let constants_to_unfold = 
-(*  List.fold_right SectionPathSet.add *)
-  let transform s = 
-    let sp = path_of_string s in
-    let dir, id = repr_path sp in
-      Libnames.encode_con dir id 
-  in
-  List.map transform
-    [ "Coq.ring.Ring_normalize.interp_cs";
-      "Coq.ring.Ring_normalize.interp_var";
-      "Coq.ring.Ring_normalize.interp_vl";
-      "Coq.ring.Ring_abstract.interp_acs";
-      "Coq.ring.Ring_abstract.interp_sacs";
-      "Coq.ring.Quote.varmap_find";
-      (* anciennement des Local devenus Definition *)
-      "Coq.ring.Ring_normalize.ics_aux";
-      "Coq.ring.Ring_normalize.ivl_aux";
-      "Coq.ring.Ring_normalize.interp_m";
-      "Coq.ring.Ring_abstract.iacs_aux";
-      "Coq.ring.Ring_abstract.isacs_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_cs";
-      "Coq.ring.Setoid_ring_normalize.interp_var";
-      "Coq.ring.Setoid_ring_normalize.interp_vl";
-      "Coq.ring.Setoid_ring_normalize.ics_aux";
-      "Coq.ring.Setoid_ring_normalize.ivl_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_m";
-    ]
-(*    SectionPathSet.empty *)
-
-(* Unfolds the functions interp and find_btree in the term c of goal gl *)
-open RedFlags
-let polynom_unfold_tac =
-  let flags =
-    (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
-  reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
-      
-let polynom_unfold_tac_in_term gl =
-  let flags = 
-    (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
-  in
-  cbv_norm_flags flags (pf_env gl) (project gl)
-
-(* lc : constr list *)
-(* th : theory associated to t *)
-(* op : clause (None for conclusion or Some id for hypothesis id) *)
-(* gl : goal  *)
-(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) 
-   where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
-   are guessed and such that c_i = (interp R RC v p_i) *)
-let raw_polynom th op lc gl =
-  (* first we sort the terms : if t' is a subterm of t it must appear
-     after t in the list. This is to avoid that the normalization of t'
-     modifies t in a non-desired way *)
-  let lc = sort_subterm gl lc in
-  let ltriplets = 
-    if th.th_setoid then
-      if th.th_ring
-      then build_setpolynom gl th lc
-      else build_setspolynom gl th lc
-    else
-      if th.th_ring then
-	if th.th_abstract
-	then build_apolynom gl th lc
-	else build_polynom gl th lc
-      else
-	if th.th_abstract 
-	then build_aspolynom gl th lc
-	else build_spolynom gl th lc in 
-  let polynom_tac = 
-    List.fold_right2
-      (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
-         let c'''i = 
-	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i 
-	 in
-         if !term_quality && safe_pf_conv_x gl c'''i ci then 
-	   tac (* convertible terms *)
-         else if th.th_setoid
-	 then
-           (tclORELSE 
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkLApp(coq_seq_sym, 
-				  [| th.th_a; (unbox th.th_equiv);
-                                     (unbox th.th_setoid_th);
-				     c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS
-		 (tclORELSE
-                   (Equality.general_rewrite true
-		     Termops.all_occurrences c'i_eq_c''i)
-                   (Equality.general_rewrite false 
-		     Termops.all_occurrences c'i_eq_c''i))
-                 [tac]))
-	 else
-           (tclORELSE
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkApp(build_coq_sym_eq (),
-				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS 
-		 (elim_type 
-		    (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
-		 [ tac;
-                   h_exact c'i_eq_c''i ]))
-)
-      lc ltriplets polynom_unfold_tac 
-  in
-  polynom_tac gl
-
-let guess_eq_tac th =
-  (tclORELSE reflexivity
-     (tclTHEN
-	polynom_unfold_tac
-        (tclTHEN
-	   (* Normalized sums associate on the right *)
-	   (tclREPEAT
-	      (tclTHENFIRST
-		 (apply (mkApp(build_coq_f_equal2 (),
-		               [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity))
-	   (tclTRY
-	      (tclTHENLAST
-		 (apply (mkApp(build_coq_f_equal2 (),
-			       [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity)))))
-
-let guess_equiv_tac th = 
-  (tclORELSE (apply (mkLApp(coq_seq_refl,
-			    [| th.th_a; (unbox th.th_equiv);
-			       (unbox th.th_setoid_th)|])))
-     (tclTHEN 
-	polynom_unfold_tac
-	(tclREPEAT 
-	   (tclORELSE 
-	      (apply (unbox th.th_morph).plusm)
-	      (apply (unbox th.th_morph).multm)))))
-
-let match_with_equiv c = match (kind_of_term c) with
-  | App (e,a) -> 
-      if (List.mem e []) (*  (Setoid_replace.equiv_list ())) *)
-      then Some (decompose_app c)
-      else None
-  | _ -> None
-
-let polynom lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
-  match lc with 
-   (* If no argument is given, try to recognize either an equality or
-      a declared relation with arguments c1 ... cn, 
-      do "Ring c1 c2 ... cn" and then try to apply the simplification
-      theorems declared for the relation *)
-    | [] ->
-	(match Hipattern.match_with_equation (pf_concl gl) with
-	   | Some (eq,t::args) ->
-	       let th = guess_theory t in
-	       if List.exists 
-		 (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) args
-	       then 
-		 errorlabstrm "Ring :"
-		   (str" All terms must have the same type");
-	       (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl
-	   | _ -> (match match_with_equiv (pf_concl gl) with
-		     | Some (equiv, c1::args) ->
-			 let t = (pf_type_of gl c1) in
-			 let th = (guess_theory t) in
-			   if List.exists 
-			     (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
-			   then 
-			     errorlabstrm "Ring :"
-			       (str" All terms must have the same type");
-			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl		   
-		     | _ -> errorlabstrm "polynom :" 
-			 (str" This goal is not an equality nor a setoid equivalence")))
-    (* Elsewhere, guess the theory, check that all terms have the same type
-       and apply raw_polynom *)
-    | c :: lc' -> 
-	let t = pf_type_of gl c in 
-	let th = guess_theory t in 
-	  if List.exists 
-	    (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
-	  then 
-	    errorlabstrm "Ring :"
-	      (str" All terms must have the same type");
-	  (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/contrib/romega/README b/contrib/romega/README
deleted file mode 100644
index 86c9e58a..00000000
--- a/contrib/romega/README
+++ /dev/null
@@ -1,6 +0,0 @@
-This work was done for the RNRT Project Calife. 
-As such it is distributed under the LGPL licence.
-
-Report bugs to :
-  pierre.cregut@francetelecom.com
-
diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v
deleted file mode 100644
index 4281cc57..00000000
--- a/contrib/romega/ROmega.v
+++ /dev/null
@@ -1,12 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence : LGPL version 2.1
-
- *************************************************************************)
-
-Require Import ReflOmegaCore.
-Require Export Setoid.
-Require Export PreOmega.
-Require Export ZArith_base.
diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v
deleted file mode 100644
index 12176d66..00000000
--- a/contrib/romega/ReflOmegaCore.v
+++ /dev/null
@@ -1,3216 +0,0 @@
-(* -*- coding: utf-8 -*- *)
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence du projet : LGPL version 2.1
-
- *************************************************************************)
-
-Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base.
-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.
-
-  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{Definition of reified integer expressions}
-   Terms are either:
-   \begin{itemize}
-   \item integers [Tint]
-   \item variables [Tvar]
-   \item operation over integers (addition, product, opposite, subtraction)
-   The last two are translated in additions and products. *)
-
-Inductive term : Set :=
-  | Tint : int -> term
-  | Tplus : term -> term -> term
-  | Tmult : term -> term -> term
-  | Tminus : term -> term -> term
-  | Topp : term -> term
-  | 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].
-Arguments Scope Topp [romega_scope romega_scope].
-
-Infix "+" := Tplus : romega_scope.
-Infix "*" := Tmult : romega_scope.
-Infix "-" := Tminus : romega_scope.
-Notation "- x" := (Topp x) : 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 (* 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
-  | NeqTerm : term -> term -> proposition
-  | Tor : proposition -> proposition -> proposition
-  | Tand : proposition -> proposition -> proposition
-  | Timp : proposition -> proposition -> proposition
-  | Tprop : nat -> proposition.
-
-(* Definition of goals as a list of hypothesis *)
-Notation hyps := (list proposition).      
-
-(* Definition of lists of subgoals  (set of open goals) *)
-Notation lhyps := (list hyps).
-
-(* a single goal packed in a subgoal list *)
-Notation singleton := (fun a : hyps => a :: nil).
-
-(* an absurd goal *)
-Definition absurd := FalseTerm :: nil.
-
-(* \subsubsection{Traces for merging equations}
-   This inductive type describes how the monomial of two equations should be
-   merged when the equations are added.
-
-   For [F_equal], both equations have the same head variable and coefficient
-   must be added, furthermore if coefficients are opposite, [F_cancel] should
-   be used to collapse the term. [F_left] and [F_right] indicate which monomial
-   should be put first in the result *)
-
-Inductive t_fusion : Set :=
-  | F_equal : t_fusion
-  | F_cancel : t_fusion
-  | F_left : t_fusion
-  | F_right : t_fusion.
-
-(* \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 *)
-  | C_LEFT : step -> step
-  (* 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 *)
-  | 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_REDUCE : step
-  | C_MULT_PLUS_DISTR : step
-  | C_MULT_OPP_LEFT : step
-  | C_MULT_ASSOC_R : step
-  | C_PLUS_ASSOC_R : step
-  | C_PLUS_ASSOC_L : step
-  | C_PLUS_PERMUTE : step
-  | C_PLUS_COMM : step
-  | C_RED0 : step
-  | C_RED1 : step
-  | C_RED2 : step
-  | C_RED3 : step
-  | C_RED4 : step
-  | C_RED5 : step
-  | C_RED6 : step
-  | C_MULT_ASSOC_REDUCED : step
-  | C_MINUS : step
-  | C_MULT_COMM : step.
-
-(* \subsubsection{Omega steps} *)
-(* The following inductive type describes steps as they can be found in
-   the trace coming from the decision procedure Omega. *)
-
-Inductive t_omega : Set :=
-  (* n = 0 and n!= 0 *)
-  | O_CONSTANT_NOT_NUL : nat -> 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 : 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. *)
-
-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.
-
-(* 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{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.
-
-(* 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{Efficient decidable equality} *)
-(* For each reified data-type, we define an efficient equality test. 
-   It is not the one produced by [Decide Equality].
-   
-   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} *)
-
-(* \subsubsection{Reified terms} *)
-
-Open Scope romega_scope.
-
-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.
-
-Close Scope romega_scope.  
-
-Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
-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
- | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5); 
-    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
- | intros t21 H3; elim H with (1 := H3); 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.
-Proof.
- simple induction t1;
- [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    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;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
-    intros t21 t22 H3; unfold not in |- *; intro H4;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
-    intros t21 t22 H3; unfold not in |- *; intro H4;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3;
-    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 beq_nat_false with (1 := H); simplify_eq H0; 
-    auto ].
-Qed.
-
-(* \subsubsection{Tactiques pour éliminer ces tests} 
-
-   Si on se contente de faire un [Case (eq_typ t1 t2)] on perd 
-   totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2].
-
-   Initialement, les développements avaient été réalisés avec les
-   tests rendus par [Decide Equality], c'est à dire un test rendant
-   des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un 
-   tel test préserve bien l'information voulue mais calculatoirement de
-   telles fonctions sont trop lentes. *)
-
-(* 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_eq_ind; intro Aux;
-   [ generalize (eq_term_true t1 t2 Aux); clear Aux
-   | generalize (eq_term_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 ].
-
-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 ].
-
-
-(* \subsection{Interprétations}
-   \subsubsection{Interprétation des termes dans 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
-  | (t1 * t2)%term => interp_term env t1 * interp_term env t2
-  | (t1 - t2)%term => interp_term env t1 - interp_term env t2
-  | (- t)%term => - interp_term env t
-  | [n]%term => nth n env 0
-  end.
-
-(* \subsubsection{Interprétation des prédicats} *) 
-
-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
-  | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2
-  | TrueTerm => True
-  | FalseTerm => False
-  | Tnot p' => ~ interp_proposition envp env p'
-  | 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 => (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 => nth n envp True
-  end.
-
-(* \subsubsection{Inteprétation des listes d'hypothèses}
-   \paragraph{Sous forme de conjonction}
-   Interprétation sous forme d'une conjonction d'hypothèses plus faciles
-   à manipuler individuellement *)
-
-Fixpoint interp_hyps (envp : list Prop) (env : list int) 
- (l : hyps) {struct l} : Prop :=
-  match l with
-  | nil => True
-  | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l'
-  end.
-
-(* \paragraph{sous forme de but}
-   C'est cette interpétation que l'on utilise sur le but (car on utilise
-   [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 : list Prop) 
- (env : list int) (l : hyps) {struct l} : Prop :=
-  match l with
-  | nil => interp_proposition envp env c
-  | p' :: l' =>
-      interp_proposition envp env p' -> interp_goal_concl c envp env l'
-  end.
-
-Notation interp_goal := (interp_goal_concl FalseTerm).
-
-(* Les théorèmes qui suivent assurent la correspondance entre les deux
-   interprétations. *)
-
-Theorem goal_to_hyps :
- forall (envp : list Prop) (env : list int) (l : hyps),
- (interp_hyps envp env l -> False) -> interp_goal envp env 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 : list Prop) (env : list int) (l : hyps),
- interp_goal envp env l -> interp_hyps envp env l -> False.
-Proof.
- simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
-Qed.
-      
-(* \subsection{Manipulations sur les hypothèses} *)
-
-(* \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 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 
-   opérations sur les hypothèses et non sur les buts (contravariance)}.
-   On définit la validité pour une opération prenant une ou deux propositions
-   en argument (cela suffit pour omega). *)
-
-Definition valid1 (f : proposition -> 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 : 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).
-
-(* Dans cette notion de validité, la fonction prend directement une 
-   liste de propositions et rend une nouvelle liste de proposition. 
-   On reste contravariant *)
-
-Definition valid_hyps (f : hyps -> 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 : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps),
-  valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
-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 : 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 : list Prop) (env : list int) 
- (l : lhyps) {struct l} : Prop :=
-  match l with
-  | nil => True
-  | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l'
-  end.
-
-Theorem list_goal_to_hyps :
- forall (envp : list Prop) (env : list int) (l : lhyps),
- (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
-Proof.
- simple induction l; simpl in |- *;
- [ auto
- | intros h1 l1 H H1; split;
-    [ apply goal_to_hyps; intro H2; apply H1; auto
-    | apply H; intro H2; apply H1; auto ] ].
-Qed.
-
-Theorem list_hyps_to_goal :
- forall (envp : list Prop) (env : list int) (l : lhyps),
- interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
-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 : 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 : 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.
-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 : 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).
-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
-    | right; apply (HR l2); left; trivial
-    | right; apply (HR l2); right; trivial ] ].
-
-Qed.
-
-(* \subsubsection{Opérateurs valides sur les hypothèses} *)
-
-(* Extraire une hypothèse de la liste *)
-Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
-
-Theorem nth_valid :
- forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
- interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
-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
-    | intros; simpl in |- *; apply H; elim H1; auto ] ].
-Qed.
-
-(* Appliquer une opération (valide) sur deux hypothèses extraites de 
-   la liste et ajouter le résultat à la liste. *)
-Definition apply_oper_2 (i j : nat)
-  (f : proposition -> proposition -> proposition) (l : hyps) :=
-  f (nth_hyps i l) (nth_hyps j l) :: l.
-
-Theorem apply_oper_2_valid :
- forall (i j : nat) (f : proposition -> proposition -> proposition),
- valid2 f -> valid_hyps (apply_oper_2 i j f).
-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.
-
-(* Modifier une hypothèse par application d'une opération valide *)
-
-Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) 
- (l : hyps) {struct i} : hyps :=
-  match l with
-  | nil => nil (A:=proposition)
-  | p :: l' =>
-      match i with
-      | O => f p :: l'
-      | S j => p :: apply_oper_1 j f l'
-      end
-  end.
-
-Theorem apply_oper_1_valid :
- forall (i : nat) (f : proposition -> proposition),
- valid1 f -> valid_hyps (apply_oper_1 i f).
-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;
-       [ apply Hf with (1 := H1) | assumption ] ]
- | intros n Hrec lp; case lp;
-    [ simpl in |- *; auto
-    | simpl in |- *; intros p l' (H1, H2); split;
-       [ assumption | apply Hrec; assumption ] ] ].
-Qed.
-
-(* \subsubsection{Manipulations de termes} *)
-(* Les fonctions suivantes permettent d'appliquer une fonction de
-   réécriture sur un sous terme du terme principal. Avec la composition,
-   cela permet de construire des réécritures complexes proches des 
-   tactiques de conversion *)
-
-Definition apply_left (f : term -> term) (t : term) :=
-  match t with
-  | (x + y)%term => (f x + y)%term
-  | (x * y)%term => (f x * y)%term
-  | (- x)%term => (- f x)%term
-  | x => x
-  end.
-
-Definition apply_right (f : term -> term) (t : term) :=
-  match t with
-  | (x + y)%term => (x + f y)%term
-  | (x * y)%term => (x * f y)%term
-  | x => x
-  end.
-
-Definition apply_both (f g : term -> term) (t : term) :=
-  match t with
-  | (x + y)%term => (f x + g y)%term
-  | (x * y)%term => (f x * g y)%term
-  | x => x
-  end.
-
-(* Les théorèmes suivants montrent la stabilité (conditionnée) des 
-   fonctions. *)
-
-Theorem apply_left_stable :
- forall f : term -> term, term_stable f -> term_stable (apply_left f).
-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).
-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).
-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)).
-Proof.
- unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
-Qed.
-
-(* \subsection{Les règles de réécriture} *)
-(* Chacune des règles de réécriture est accompagnée par sa preuve de 
-   stabilité. Toutes ces preuves ont la même forme : il faut analyser 
-   suivant la forme du terme (élimination de chaque Case). On a besoin d'une
-   élimination uniquement dans les cas d'utilisation d'égalité décidable. 
-
-   Cette tactique itère la décomposition des Case. Elle est
-   constituée de deux fonctions s'appelant mutuellement :
-   \begin{itemize} 
-    \item une fonction d'enrobage qui lance la recherche sur le but,
-    \item une fonction récursive qui décompose ce but. Quand elle a trouvé un
-          Case, elle l'élimine. 
-   \end{itemize}  
-   Les motifs sur les cas sont très imparfaits et dans certains cas, il
-   semble que cela ne marche pas. On aimerait plutot un motif de la
-   forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on 
-   utilise le bon type.
-
-   Chaque élimination introduit correctement exactement le nombre d'hypothèses
-   nécessaires et conserve dans le cas d'une égalité la connaissance du
-   résultat du test en faisant la réécriture. Pour un test de comparaison,
-   on conserve simplement le résultat.
-
-   Cette fonction déborde très largement la résolution des réécritures
-   simples et fait une bonne partie des preuves des pas de Omega.
-*)
-
-(* \subsubsection{La tactique pour prouver la stabilité} *)
-
-Ltac loop t :=
-  match t with
-  (* Global *)
-  | (?X1 = ?X2) => loop X1 || loop X2
-  | (_ -> ?X1) => loop X1
-  (* Interpretations *)
-  | (interp_hyps _ _ ?X1) => loop X1
-  | (interp_list_hyps _ _ ?X1) => loop X1
-  | (interp_proposition _ _ ?X1) => loop X1
-  | (interp_term _ ?X1) => loop X1
-  (* Propositions *)
-  | (EqTerm ?X1 ?X2) => loop X1 || loop X2
-  | (LeqTerm ?X1 ?X2) => loop X1 || loop X2
-  (* Termes *)
-  | (?X1 + ?X2)%term => loop X1 || loop X2
-  | (?X1 - ?X2)%term => loop X1 || loop X2
-  | (?X1 * ?X2)%term => loop X1 || loop X2
-  | (- ?X1)%term => loop X1
-  | (Tint ?X1) => loop X1
-  (* Eliminations *)
-  | match ?X1 with
-    | EqTerm x x0 => _
-    | LeqTerm x x0 => _
-    | TrueTerm => _
-    | FalseTerm => _
-    | Tnot x => _
-    | GeqTerm x x0 => _
-    | GtTerm x x0 => _
-    | LtTerm x x0 => _
-    | NeqTerm x x0 => _
-    | Tor x x0 => _
-    | Tand x x0 => _
-    | Timp x x0 => _
-    | Tprop x => _
-    end => destruct X1; auto; Simplify
-  | match ?X1 with
-    | Tint x => _
-    | (x + x0)%term => _
-    | (x * x0)%term => _
-    | (x - x0)%term => _
-    | (- x)%term => _
-    | [x]%term => _
-    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 _) =>
-      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.
-
-Ltac prove_stable x th :=
-  match constr:x with
-  | ?X1 =>
-      unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *;
-       apply th
-  end.
-
-(* \subsubsection{Les règles elle mêmes} *)
-Definition Tplus_assoc_l (t : term) :=
-  match t with
-  | (n + (m + p))%term => (n + m + p)%term
-  | _ => t
-  end.
-
-Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l.
-Proof.
- prove_stable Tplus_assoc_l (ring.(Radd_assoc)).
-Qed.
-
-Definition Tplus_assoc_r (t : term) :=
-  match t with
-  | (n + m + p)%term => (n + (m + p))%term
-  | _ => t
-  end.
-
-Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r.
-Proof.
- prove_stable Tplus_assoc_r plus_assoc_reverse.
-Qed.
-
-Definition Tmult_assoc_r (t : term) :=
-  match t with
-  | (n * m * p)%term => (n * (m * p))%term
-  | _ => t
-  end.
-
-Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r.
-Proof.
- prove_stable Tmult_assoc_r mult_assoc_reverse.
-Qed.
-
-Definition Tplus_permute (t : term) :=
-  match t with
-  | (n + (m + p))%term => (m + (n + p))%term
-  | _ => t
-  end.
-
-Theorem Tplus_permute_stable : term_stable Tplus_permute.
-Proof.
- prove_stable Tplus_permute plus_permute.
-Qed.
-
-Definition Tplus_comm (t : term) :=
-  match t with
-  | (x + y)%term => (y + x)%term
-  | _ => t
-  end.
-
-Theorem Tplus_comm_stable : term_stable Tplus_comm.
-Proof.
- prove_stable Tplus_comm plus_comm.
-Qed.
-
-Definition Tmult_comm (t : term) :=
-  match t with
-  | (x * y)%term => (y * x)%term
-  | _ => t
-  end.
-
-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 =>
-      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.
-Proof.
- prove_stable T_OMEGA10 OMEGA10.
-Qed.
-
-Definition T_OMEGA11 (t : term) :=
-  match t with
-  | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term =>
-      (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term
-  | _ => t
-  end.
-
-Theorem T_OMEGA11_stable : term_stable T_OMEGA11.
-Proof.
- prove_stable T_OMEGA11 OMEGA11.
-Qed.
-
-Definition T_OMEGA12 (t : term) :=
-  match t with
-  | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term =>
-      (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term
-  | _ => t
-  end.
-
-Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
-Proof.
- prove_stable T_OMEGA12 OMEGA12.
-Qed. 
-
-Definition T_OMEGA13 (t : term) :=
-  match t with
-  | (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.
-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 =>
-      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.
-Proof.
- prove_stable T_OMEGA15 OMEGA15.
-Qed.
-
-Definition T_OMEGA16 (t : term) :=
-  match t with
-  | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term
-  | _ => t
-  end.
-
-
-Theorem T_OMEGA16_stable : term_stable T_OMEGA16.
-Proof.
- prove_stable T_OMEGA16 OMEGA16.
-Qed.
-
-Definition Tred_factor5 (t : term) :=
-  match t with
-  | (x * Tint c + y)%term => if beq c 0 then y else t
-  | _ => t
-  end.
-
-Theorem Tred_factor5_stable : term_stable Tred_factor5.
-Proof.
- prove_stable Tred_factor5 red_factor5.
-Qed.
-
-Definition Topp_plus (t : term) :=
-  match t with
-  | (- (x + y))%term => (- x + - y)%term
-  | _ => t
-  end.
-
-Theorem Topp_plus_stable : term_stable Topp_plus.
-Proof.
- prove_stable Topp_plus opp_plus_distr.
-Qed.
-
-
-Definition Topp_opp (t : term) :=
-  match t with
-  | (- - x)%term => x
-  | _ => t
-  end.
-
-Theorem Topp_opp_stable : term_stable Topp_opp.
-Proof.
- prove_stable Topp_opp opp_involutive.
-Qed.
-
-Definition Topp_mult_r (t : term) :=
-  match t with
-  | (- (x * Tint k))%term => (x * Tint (- k))%term
-  | _ => t
-  end.
-
-Theorem Topp_mult_r_stable : term_stable Topp_mult_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
-  | _ => t
-  end.
-
-Theorem Topp_one_stable : term_stable Topp_one.
-Proof.
- prove_stable Topp_one opp_eq_mult_neg_1.
-Qed.
-
-Definition Tmult_plus_distr (t : term) :=
-  match t with
-  | ((n + m) * p)%term => (n * p + m * p)%term
-  | _ => t
-  end.
-
-Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr.
-Proof.
- prove_stable Tmult_plus_distr mult_plus_distr_r.
-Qed.
-
-Definition Tmult_opp_left (t : term) :=
-  match t with
-  | (- x * Tint y)%term => (x * Tint (- y))%term
-  | _ => t
-  end.
-
-Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left.
-Proof.
- prove_stable Tmult_opp_left mult_opp_comm.
-Qed.
-
-Definition Tmult_assoc_reduced (t : term) :=
-  match t with
-  | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term
-  | _ => t
-  end.
-
-Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced.
-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.
-Proof.
- prove_stable Tred_factor0 red_factor0.
-Qed.
-
-Definition Tred_factor1 (t : term) :=
-  match t with
-  | (x + y)%term =>
-      if eq_term x y 
-      then (x * Tint 2)%term
-      else t 
-  | _ => t
-  end.
-
-Theorem Tred_factor1_stable : term_stable Tred_factor1.
-Proof.
- prove_stable Tred_factor1 red_factor1.
-Qed.
-
-Definition Tred_factor2 (t : term) :=
-  match t with
-  | (x + y * Tint k)%term =>
-      if eq_term x y 
-      then (x * Tint (1 + k))%term
-      else t
-  | _ => t
-  end.
-
-Theorem Tred_factor2_stable : term_stable Tred_factor2.
-Proof.
- prove_stable Tred_factor2 red_factor2.
-Qed.
-
-Definition Tred_factor3 (t : term) :=
-  match t with
-  | (x * Tint k + y)%term =>
-      if eq_term x y 
-      then (x * Tint (1 + k))%term
-      else t
-  | _ => t
-  end.
-
-Theorem Tred_factor3_stable : term_stable Tred_factor3.
-Proof.
- prove_stable Tred_factor3 red_factor3.
-Qed.
-
-
-Definition Tred_factor4 (t : term) :=
-  match t with
-  | (x * Tint k1 + y * Tint k2)%term =>
-      if eq_term x y 
-      then (x * Tint (k1 + k2))%term
-      else t
-  | _ => t
-  end.
-
-Theorem Tred_factor4_stable : term_stable Tred_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.
-Proof.
- prove_stable Tred_factor6 red_factor6.
-Qed.
-
-Definition Tminus_def (t : term) :=
-  match t with
-  | (x - y)%term => (x + - y)%term
-  | _ => t
-  end.
-
-Theorem Tminus_def_stable : term_stable Tminus_def.
-Proof.
- prove_stable Tminus_def minus_def.
-Qed.
-
-(* \subsection{Fonctions de réécriture complexes} *)
-
-(* \subsubsection{Fonction de réduction} *)
-(* Cette fonction réduit un terme dont la forme normale est un entier. Il
-   suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs
-   réifiés. La réduction est ``gratuite''.  *)
-
-Fixpoint reduce (t : term) : term :=
-  match t with
-  | (x + y)%term =>
-      match reduce x with
-      | Tint x' =>
-          match reduce y with
-          | Tint y' => Tint (x' + y')
-          | y' => (Tint x' + y')%term
-          end
-      | x' => (x' + reduce y)%term
-      end
-  | (x * y)%term =>
-      match reduce x with
-      | Tint x' =>
-          match reduce y with
-          | Tint y' => Tint (x' * y')
-          | y' => (Tint x' * y')%term
-          end
-      | x' => (x' * reduce y)%term
-      end
-  | (x - y)%term =>
-      match reduce x with
-      | Tint x' =>
-          match reduce y with
-          | Tint y' => Tint (x' - y')
-          | y' => (Tint x' - y')%term
-          end
-      | x' => (x' - reduce y)%term
-      end
-  | (- x)%term =>
-      match reduce x with
-      | Tint x' => Tint (- x')
-      | x' => (- x')%term
-      end
-  | _ => t
-  end.
-
-Theorem reduce_stable : term_stable reduce.
-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);
-      [ intro z0; case (reduce t1); intros; auto
-      | intros; auto
-      | intros; auto
-      | intros; auto
-      | intros; auto
-      | intros; auto ])); intros t0 H0; simpl in |- *; 
- rewrite H0; case (reduce t0); intros; auto.
-Qed.
-
-(* \subsubsection{Fusions}
-    \paragraph{Fusion de deux équations} *)
-(* On donne une somme de deux équations qui sont supposées normalisées. 
-   Cette fonction prend une trace de fusion en argument et transforme
-   le terme en une équation normalisée. C'est une version très simplifiée
-   du moteur de réécriture [rewrite]. *)
-
-Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
-  match trace with
-  | nil => reduce t
-  | step :: trace' =>
-      match step with
-      | F_equal => apply_right (fusion trace') (T_OMEGA10 t)
-      | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t))
-      | F_left => apply_right (fusion trace') (T_OMEGA11 t)
-      | F_right => apply_right (fusion trace') (T_OMEGA12 t)
-      end
-  end.
-    
-Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
-Proof.
- simple induction t; simpl in |- *;
- [ exact reduce_stable
- | intros stp l H; case stp;
-    [ apply compose_term_stable;
-       [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ]
-    | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable;
-       rewrite Tred_factor5_stable; apply H
-    | apply compose_term_stable;
-       [ 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} *)
-
-Definition fusion_right (trace : list t_fusion) (t : term) : term :=
-  match trace with
-  | nil => reduce t (* Il faut mettre un compute *)
-  | step :: trace' =>
-      match step with
-      | F_equal => apply_right (fusion trace') (T_OMEGA15 t)
-      | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t))
-      | F_left => apply_right (fusion trace') (Tplus_assoc_r t)
-      | F_right => apply_right (fusion trace') (T_OMEGA12 t)
-      end
-  end.
-
-(* \paragraph{Fusion avec annihilation} *)
-(* Normalement le résultat est une constante *)
-
-Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
-  match trace with
-  | O => reduce t
-  | S trace' => fusion_cancel trace' (T_OMEGA13 t)
-  end.
-
-Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
-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. 
-
-(* \subsubsection{Opérations affines sur une équation} *)
-(* \paragraph{Multiplication scalaire et somme d'une constante} *)
-
-Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
-  match trace with
-  | O => reduce t
-  | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t)
-  end.
-
-Theorem scalar_norm_add_stable :
- forall t : nat, term_stable (scalar_norm_add t).
-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 ] ].
-Qed.
-   
-(* \paragraph{Multiplication scalaire} *)
-Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
-  match trace with
-  | O => reduce t
-  | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t)
-  end.
-
-Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
-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 ] ].
-Qed.
-
-(* \paragraph{Somme d'une constante} *)
-Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
-  match trace with
-  | O => reduce t
-  | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t)
-  end.
-
-Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
-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 ] ].
-Qed.
-
-(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
-
-
-Fixpoint rewrite (s : step) : term -> term :=
-  match s with
-  | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2)
-  | C_LEFT s => apply_left (rewrite s)
-  | C_RIGHT s => apply_right (rewrite s)
-  | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t)
-  | C_NOP => fun t : term => t
-  | C_OPP_PLUS => Topp_plus
-  | C_OPP_OPP => Topp_opp
-  | C_OPP_MULT_R => Topp_mult_r
-  | C_OPP_ONE => Topp_one
-  | C_REDUCE => reduce
-  | C_MULT_PLUS_DISTR => Tmult_plus_distr
-  | C_MULT_OPP_LEFT => Tmult_opp_left
-  | C_MULT_ASSOC_R => Tmult_assoc_r
-  | C_PLUS_ASSOC_R => Tplus_assoc_r
-  | C_PLUS_ASSOC_L => Tplus_assoc_l
-  | C_PLUS_PERMUTE => Tplus_permute
-  | C_PLUS_COMM => Tplus_comm
-  | C_RED0 => Tred_factor0
-  | C_RED1 => Tred_factor1
-  | C_RED2 => Tred_factor2
-  | C_RED3 => Tred_factor3
-  | C_RED4 => Tred_factor4
-  | C_RED5 => Tred_factor5
-  | C_RED6 => Tred_factor6
-  | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
-  | C_MINUS => Tminus_def
-  | C_MULT_COMM => Tmult_comm
-  end.
-
-Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
-Proof.
- simple induction s; simpl in |- *;
- [ intros; apply apply_both_stable; auto
- | intros; apply apply_left_stable; auto
- | intros; apply apply_right_stable; auto
- | unfold term_stable in |- *; intros; elim H0; apply H
- | unfold term_stable in |- *; auto
- | exact Topp_plus_stable
- | exact Topp_opp_stable
- | exact Topp_mult_r_stable
- | exact Topp_one_stable
- | exact reduce_stable
- | exact Tmult_plus_distr_stable
- | exact Tmult_opp_left_stable
- | exact Tmult_assoc_r_stable
- | exact Tplus_assoc_r_stable
- | exact Tplus_assoc_l_stable
- | exact Tplus_permute_stable
- | exact Tplus_comm_stable
- | exact Tred_factor0_stable
- | exact Tred_factor1_stable
- | exact Tred_factor2_stable
- | exact Tred_factor3_stable
- | exact Tred_factor4_stable
- | exact Tred_factor5_stable
- | exact Tred_factor6_stable
- | exact Tmult_assoc_reduced_stable
- | exact Tminus_def_stable
- | exact Tmult_comm_stable ].
-Qed.
-
-(* \subsection{tactiques de résolution d'un but omega normalisé} 
-   Trace de la procédure 
-\subsubsection{Tactiques générant une contradiction}
-\paragraph{[O_CONSTANT_NOT_NUL]} *)
-
-Definition constant_not_nul (i : nat) (h : hyps) :=
-  match nth_hyps i h with
-  | 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).
-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.   
-
-(* \paragraph{[O_CONSTANT_NEG]} *)
-
-Definition constant_neg (i : nat) (h : hyps) :=
-  match nth_hyps i h with
-  | 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).
-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 : int) (body : term) 
-  (t i : nat) (l : hyps) :=
-  match nth_hyps i l with
-  | 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 : int) (body : term) (t i : nat),
- valid_hyps (not_exact_divide k1 k2 body t i).
-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 Nul) b1 =>
-      match nth_hyps j l with
-      | LeqTerm (Tint Nul') b2 =>
-          match fusion_cancel t (b1 + b2)%term with
-          | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k 
-                      then absurd 
-                      else l
-          | _ => l
-          end
-      | _ => l
-      end
-  | _ => l
-  end.
-
-Theorem contradiction_valid :
- forall t i j : nat, valid_hyps (contradiction t i j).
-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; 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 |- *.
- 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 Nul) b1 =>
-      match nth_hyps i2 h with
-      | NeqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
-          then absurd 
-          else h
-      | _ => h
-      end
-  | NeqTerm (Tint Nul) b1 =>
-      match nth_hyps i2 h with
-      | EqTerm (Tint Nul') b2 =>
-          if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 
-          then absurd 
-          else h 
-      | _ => h
-      end
-  | _ => h
-  end.
-
-Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
-  match nth_hyps i1 h with
-  | EqTerm (Tint Nul) b1 =>
-      match nth_hyps i2 h with
-      | 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 Nul) b1 =>
-      match nth_hyps i2 h with
-      | 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
-  end.
-
-Theorem negate_contradict_valid :
- forall i j : nat, valid_hyps (negate_contradict i j).
-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; 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).
-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; 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} *)
-(* \paragraph{[O_SUM]}
- C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant
- les opérateurs de comparaison des deux arguments) d'où une
- 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 : int) (trace : list t_fusion)
-  (prop1 prop2 : proposition) :=
-  match prop1 with
-  | EqTerm (Tint Null) b1 =>
-      match prop2 with
-      | 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)
-          else TrueTerm
-      | _ => TrueTerm
-      end
-  | 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)
-              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)
-              else TrueTerm
-          | _ => TrueTerm
-          end
-      else TrueTerm 
-  | NeqTerm (Tint Null) b1 =>
-      match prop2 with
-      | 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 sum_valid :
- 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 plus_comm; apply sum2; try assumption; apply sum4; assumption
- | apply sum3; try assumption; apply sum4; 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 : int) (body : term) (t : nat)
-  (prop : proposition) :=
-  match prop with
-  | 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 : 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.
-
-
-(* \paragraph{[O_DIV_APPROX]}
-  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 : int) (body : term) 
-  (t : nat) (prop : proposition) :=
-  match prop with
-  | 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 : int) (body : term) (t : nat),
- valid1 (divide_and_approx k1 k2 body t).
-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 Null) b1 =>
-      match prop2 with
-      | 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).
-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 opp_eq_mult_neg_1; trivial ].
-Qed.
-
-
-
-(* \paragraph{[O_CONSTANT_NUL]} *)
-
-Definition constant_nul (i : nat) (h : hyps) :=
-  match nth_hyps i h with
-  | 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).
-Proof.
- unfold valid_hyps, constant_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- intro H1; absurd (0 = 0); intuition.
-Qed.
-
-(* \paragraph{[O_STATE]} *)
-
-Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
-  match prop1 with
-  | EqTerm (Tint Null) b1 =>
-      match prop2 with
-      | EqTerm b2 b3 =>
-          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 : 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.
- now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
-Qed.
-
-(* \subsubsection{Tactiques générant plusieurs but}
-   \paragraph{[O_SPLIT_INEQ]} 
-   La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
-
-Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) 
-  (l : hyps) :=
-  match nth_hyps i l with
-  | 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)
-       else l :: nil
-  | _ => l :: nil
-  end.
-
-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).
-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; 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 not in |- *; intros E1 E2; apply E1;
-    symmetry  in |- *; trivial ].
-Qed.
-
-
-(* \subsection{La fonction de rejeu de la trace} *)
-
-Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
-  match t with
-  | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l)
-  | O_CONSTANT_NEG n => singleton (constant_neg n l)
-  | O_DIV_APPROX k1 k2 body t cont n =>
-      execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l)
-  | O_NOT_EXACT_DIVIDE k1 k2 body t i =>
-      singleton (not_exact_divide k1 k2 body t i l)
-  | O_EXACT_DIVIDE k body t cont n =>
-      execute_omega cont (apply_oper_1 n (exact_divide k body t) l)
-  | O_SUM k1 i1 k2 i2 t cont =>
-      execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l)
-  | O_CONTRADICTION t i j => singleton (contradiction t i j l)
-  | O_MERGE_EQ t i1 i2 cont =>
-      execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l)
-  | O_SPLIT_INEQ t i cont1 cont2 =>
-      split_ineq i t (execute_omega cont1) (execute_omega cont2) l
-  | O_CONSTANT_NUL i => singleton (constant_nul i l)
-  | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l)
-  | O_NEGATE_CONTRADICT_INV t i j =>
-      singleton (negate_contradict_inv t i j l)
-  | O_STATE m s i1 i2 cont =>
-      execute_omega cont (apply_oper_2 i1 i2 (state m s) l)
-  end.
-
-Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t).
-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;
-    apply (constant_neg_valid n ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
-    intros k1 k2 body n t' Ht' m ep e lp H; apply Ht';
-    apply
-     (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 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
-     (apply_oper_1_valid m (exact_divide k body n)
-        (exact_divide_valid k body n) ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
-    intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht';
-    apply
-     (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e
-        lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
-    apply (contradiction_valid n n0 n1 ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
-    intros trace i1 i2 t' Ht' ep e lp H; apply Ht';
-    apply
-     (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e
-        lp H)
- | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *;
-    intros ep e lp H;
-    apply
-     (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e
-        lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left;
-    apply (constant_nul_valid i ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left;
-    apply (negate_contradict_valid i j ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H;
-    left; apply (negate_contradict_inv_valid n i j ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
-    intros m s i1 i2 t' Ht' ep e lp H; apply Ht';
-    apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ].
-Qed.
-
-
-(* \subsection{Les opérations globales sur le but} 
-   \subsubsection{Normalisation} *)
-
-Definition move_right (s : step) (p : proposition) :=
-  match p with
-  | 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)
-  | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
-  | p => p
-  end.
-
-Theorem move_right_valid : forall s : step, valid1 (move_right s).
-Proof.
- unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
- elim (rewrite_stable s e); simpl in |- *;
- [ 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).
-Proof.
- intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
- apply move_right_valid.
-Qed.
-
-Fixpoint do_normalize_list (l : list step) (i : nat) 
- (h : hyps) {struct l} : hyps :=
-  match l with
-  | s :: l' => do_normalize_list l' (S i) (do_normalize i s h)
-  | nil => h
-  end.
-
-Theorem do_normalize_list_valid :
- forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
-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 : list Prop) (env : list int) (l : hyps),
- interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l.
-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 : list Prop) (env : list int) (l : hyps),
- interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l.
-Proof.
- intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
-Qed.
-
-
-Theorem append_goal :
- 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).
-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.
-
-(* 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
-   calculus *)
-
-Fixpoint decidability (p : proposition) : bool :=
-  match p with
-  | EqTerm _ _ => true
-  | LeqTerm _ _ => true
-  | GeqTerm _ _ => true
-  | GtTerm _ _ => true
-  | LtTerm _ _ => true
-  | NeqTerm _ _ => true
-  | FalseTerm => true
-  | TrueTerm => true
-  | Tnot t => decidability t
-  | Tand t1 t2 => decidability t1 && decidability t2
-  | Timp t1 t2 => decidability t1 && decidability t2
-  | Tor t1 t2 => decidability t1 && decidability t2
-  | Tprop _ => false
-  end.
-
-Theorem decidable_correct :
- forall (ep : list Prop) (e : list int) (p : proposition),
- decidability p = true -> decidable (interp_proposition ep e p).
-Proof.
- simple induction p; simpl in |- *; intros;
- [ apply dec_eq
- | apply dec_le
- | left; auto
- | right; unfold not in |- *; auto
- | apply dec_not; auto
- | 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 : list Prop) (env : list int) 
- (c : proposition) (l : hyps) {struct l} : Prop :=
-  match l with
-  | nil => interp_proposition envp env c
-  | p' :: l' =>
-      interp_proposition envp env p' -> interp_full_goal envp env c l'
-  end.
-
-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
-  end.
-
-(* Relates the interpretation of a complete goal with the interpretation
-   of its hypothesis and conclusion *)
-
-Theorem interp_full_false :
- 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).
-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
-   If the decidability cannot be "proven", then just forget about the 
-   conclusion (equivalent of replacing it with false) *)
-
-Definition to_contradict (lc : hyps * proposition) :=
-  match lc with
-  | (l, c) => if decidability c then Tnot c :: l else l
-  end.
-
-(* The previous operation is valid in the sense that the new list of
-   hypothesis implies the original goal *)
-
-Theorem to_contradict_valid :
- forall (ep : list Prop) (e : list int) (lc : hyps * proposition),
- interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
-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
-    | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2);
-       auto ]
- | intros H1 H2; apply interp_full_false; intro H3;
-    elim hyps_to_goal with (1 := H2); assumption ].
-Qed.
-
-(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list
-   of lists *)
-
-Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} :
- list (list A) :=
-  match l with
-  | nil => nil
-  | l :: ll => (x :: l) :: map_cons A x ll
-  end.
-
-(* This function breaks up a list of hypothesis in a list of simpler 
-   list of hypothesis that together implie the original one. The goal
-   of all this is to transform the goal in a list of solvable problems. 
-   Note that :
-	- we need a way to drive the analysis as some hypotheis may not
-          require a split. 
-        - this procedure must be perfectly mimicked by the ML part otherwise
-          hypothesis will get desynchronised and this will be a mess.
- *)
- 
-Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
-  match nn with
-  | O => ll :: nil
-  | S n =>
-      match ll with
-      | nil => nil :: nil
-      | Tor p1 p2 :: l =>
-          destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l)
-      | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l)
-      | Timp p1 p2 :: l =>
-          if decidability p1
-          then
-           destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l)
-          else map_cons _ (Timp p1 p2) (destructure_hyps n l)
-      | Tnot p :: l =>
-          match p with
-          | Tnot p1 =>
-              if decidability p1
-              then destructure_hyps n (p1 :: l)
-              else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l)
-          | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l)
-          | Tand p1 p2 =>
-              if decidability p1
-              then
-               destructure_hyps n (Tnot p1 :: l) ++
-               destructure_hyps n (Tnot p2 :: l)
-              else map_cons _ (Tnot p) (destructure_hyps n l)
-          | _ => map_cons _ (Tnot p) (destructure_hyps n l)
-          end
-      | x :: l => map_cons _ x (destructure_hyps n l)
-      end
-  end.
-
-Theorem map_cons_val :
- 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).
-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).
-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
-    | intros p l; case p;
-       try
-        (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
-          auto);
-       [ intro p'; case p';
-          try
-           (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
-             auto);
-          [ simpl in |- *; intros p1 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_eq_ind; 
-             intro H3;
-             [ apply H; simpl in |- *; split;
-                [ apply not_not; auto | assumption ]
-             | auto ]
-          | 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_eq_ind; 
-             intro H3;
-             [ apply append_valid; elim not_and with (2 := H1);
-                [ intro; left; apply H; simpl in |- *; auto
-                | intro; right; apply H; simpl in |- *; auto
-                | auto ]
-             | auto ] ]
-       | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid;
-          (elim H1; intro H3; simpl in |- *; [ left | right ]); 
-          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_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 : 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) 
-  (p : proposition) :=
-  match p with
-  | Timp x y => Timp (f x) y
-  | Tor x y => Tor (f x) y
-  | Tand x y => Tand (f x) y
-  | Tnot x => Tnot (f x)
-  | x => x
-  end.
-
-Theorem p_apply_left_stable :
- forall f : proposition -> proposition,
- prop_stable f -> prop_stable (p_apply_left f).
-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.
-
-Definition p_apply_right (f : proposition -> proposition)
-  (p : proposition) :=
-  match p with
-  | Timp x y => Timp x (f y)
-  | Tor x y => Tor x (f y)
-  | Tand x y => Tand x (f y)
-  | Tnot x => Tnot (f x)
-  | x => x
-  end.
-
-Theorem p_apply_right_stable :
- forall f : proposition -> proposition,
- prop_stable f -> prop_stable (p_apply_right f).
-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
-   | intros p1 p2; elim (H ep e p2); tauto
-   | intros p1 p2; elim (H ep e p2); tauto ]).
-Qed.
-
-Definition p_invert (f : proposition -> proposition) 
-  (p : proposition) :=
-  match p with
-  | EqTerm x y => Tnot (f (NeqTerm x y))
-  | LeqTerm x y => Tnot (f (GtTerm x y))
-  | GeqTerm x y => Tnot (f (LtTerm x y))
-  | GtTerm x y => Tnot (f (LeqTerm x y))
-  | LtTerm x y => Tnot (f (GeqTerm x y))
-  | NeqTerm x y => Tnot (f (EqTerm x y))
-  | x => x
-  end.
-
-Theorem p_invert_stable :
- forall f : proposition -> proposition,
- prop_stable f -> prop_stable (p_invert f).
-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 |- *;
-      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 |- *;
-      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 |- *;
-      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_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_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; tauto ]).
-Qed.
-
-Theorem move_right_stable : forall s : step, prop_stable (move_right s).
-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 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 (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.
-
-
-Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
-  match s with
-  | P_LEFT s => p_apply_left (p_rewrite s)
-  | P_RIGHT s => p_apply_right (p_rewrite s)
-  | P_STEP s => move_right s
-  | P_INVERT s => p_invert (move_right s)
-  | P_NOP => fun p : proposition => p
-  end.
-
-Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
-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
- | apply move_right_stable
- | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ].
-Qed.
-
-Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
-  match l with
-  | nil => lh
-  | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh)
-  end.
-
-Theorem normalize_hyps_valid :
- forall l : list h_step, valid_hyps (normalize_hyps l).
-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;
-    [ unfold valid1 in |- *; intros ep1 e1 p1 H2;
-       elim (p_rewrite_stable s ep1 e1 p1); auto
-    | assumption ] ].
-Qed.
-
-Theorem normalize_hyps_goal :
- 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.
-Proof.
- intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
-Qed.
-
-Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
- proposition :=
-  match s with
-  | D_left :: l =>
-      match p with
-      | Tand x y => extract_hyp_pos l x
-      | _ => p
-      end
-  | D_right :: l =>
-      match p with
-      | Tand x y => extract_hyp_pos l y
-      | _ => p
-      end
-  | D_mono :: l => match p with
-                   | Tnot x => extract_hyp_neg l x
-                   | _ => p
-                   end
-  | _ => p
-  end
- 
- with extract_hyp_neg (s : list direction) (p : proposition) {struct s} :
- proposition :=
-  match s with
-  | D_left :: l =>
-      match p with
-      | Tor x y => extract_hyp_neg l x
-      | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p
-      | _ => Tnot p
-      end
-  | D_right :: l =>
-      match p with
-      | Tor x y => extract_hyp_neg l y
-      | Timp x y => extract_hyp_neg l y
-      | _ => Tnot p
-      end
-  | D_mono :: l =>
-      match p with
-      | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p
-      | _ => Tnot p
-      end
-  | _ =>
-      match p with
-      | Tnot x => if decidability x then x else Tnot p
-      | _ => Tnot p
-      end
-  end.
-
-Definition co_valid1 (f : proposition -> 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).
-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_eq_ind;
-       [ intro H; generalize (decidable_correct ep e p H);
-          unfold decidable in |- *; tauto
-       | simpl in |- *; auto ] ]
- | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto;
-    case p; auto; simpl in |- *; intros;
-    (apply H1; tauto) ||
-      (apply H2; tauto) ||
-        (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 :=
-  match s with
-  | E_SPLIT i dl s1 s2 =>
-      match extract_hyp_pos dl (nth_hyps i h) with
-      | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h)
-      | Tnot (Tand x y) =>
-          if decidability x
-          then
-           decompose_solve s1 (Tnot x :: h) ++
-           decompose_solve s2 (Tnot y :: h)
-          else h :: nil
-      | Timp x y => 
-          if decidability x then 
-            decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h)
-          else h::nil
-      | _ => h :: nil
-      end
-  | E_EXTRACT i dl s1 =>
-      decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h)
-  | E_SOLVE t => execute_omega t h
-  end.
-
-Theorem decompose_solve_valid :
- forall s : e_step, valid_list_goal (decompose_solve 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_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
-             | left; apply H; simpl in |- *; tauto ]
-          | simpl in |- *; auto ]
-       | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2;
-          [ 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_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
-             | left; apply H; simpl in |- *; tauto ]
-          | simpl in |- *; auto ] ]
-    | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ]
- | intros; apply H; simpl in |- *; split;
-    [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto
-    | auto ]
- | apply omega_valid with (1 := H) ].
-Qed.
-
-(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
-
-Definition valid_lhyps (f : lhyps -> 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 :=
-  match lp with
-  | (FalseTerm :: nil) :: lp' => reduce_lhyps lp'
-  | x :: lp' => x :: reduce_lhyps lp'
-  | nil => nil (A:=hyps)
-  end.
-
-Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
-Proof.
- unfold valid_lhyps in |- *; intros ep e lp; elim lp;
- [ simpl in |- *; auto
- | intros a l HR; elim a;
-    [ simpl in |- *; tauto
-    | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ].
-Qed.
-
-Theorem do_reduce_lhyps :
- forall (envp : list Prop) (env : list int) (l : lhyps),
- interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
-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.
-
-Definition concl_to_hyp (p : proposition) :=
-  if decidability p then Tnot p else TrueTerm.
-
-Definition do_concl_to_hyp :
-  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.
-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_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 ]
- | simpl in |- *; tauto ].
-Qed.
-
-Definition omega_tactic (t1 : e_step) (t2 : list h_step) 
-  (c : proposition) (l : hyps) :=
-  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 : 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.
-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
deleted file mode 100644
index bdec6bf4..00000000
--- a/contrib/romega/const_omega.ml
+++ /dev/null
@@ -1,350 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence : LGPL version 2.1
-
- *************************************************************************)
-
-let module_refl_name = "ReflOmegaCore"
-let module_refl_path = ["Coq"; "romega"; module_refl_name]
-
-type result = 
-   Kvar of string
- | Kapp of string * Term.constr list
- | Kimp of Term.constr * Term.constr
- | Kufo;;
-
-let destructurate t =
-  let c, args = Term.decompose_app t in
-  match Term.kind_of_term c, args with
-    | Term.Const sp, args ->
-	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.ConstRef sp)),
-	      args)
-    | Term.Construct csp , args ->
-	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.ConstructRef csp)),
-	      args)
-    | Term.Ind isp, args ->
-	Kapp (Names.string_of_id
-		(Nametab.id_of_global (Libnames.IndRef isp)),
-	      args)
-    | Term.Var id,[] -> Kvar(Names.string_of_id id)
-    | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
-    | Term.Prod (Names.Name _,_,_),[] ->
-	Util.error "Omega: Not a quantifier-free goal"
-    | _ -> Kufo
-
-exception Destruct
-
-let dest_const_apply t = 
-  let f,args = Term.decompose_app t in 
-  let ref = 
-  match Term.kind_of_term f with 
-    | Term.Const sp      -> Libnames.ConstRef sp
-    | Term.Construct csp -> Libnames.ConstructRef csp
-    | Term.Ind isp       -> Libnames.IndRef isp
-    | _ -> raise Destruct
-  in  Nametab.id_of_global ref, args
-
-let logic_dir = ["Coq";"Logic";"Decidable"]
-
-let coq_modules =
-  Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules
-    @ [["Coq"; "Lists"; "List"]]
-    @ [module_refl_path]
-    @ [module_refl_path@["ZOmega"]]
-
-let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
-
-(* Logic *)
-let coq_eq = lazy(constant  "eq")
-let coq_refl_equal = lazy(constant  "refl_equal")
-let coq_and = lazy(constant "and")
-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_I = lazy(constant "I")
-
-(* ReflOmegaCore/ZOmega *)
-
-let coq_h_step = lazy (constant "h_step")
-let coq_pair_step = lazy (constant  "pair_step")
-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_t_int = lazy (constant  "Tint")
-let coq_t_plus = lazy (constant  "Tplus")
-let coq_t_mult = lazy (constant  "Tmult")
-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")
-let coq_p_lt = lazy (constant  "LtTerm")
-let coq_p_gt = lazy (constant  "GtTerm")
-let coq_p_neq = lazy (constant  "NeqTerm")
-let coq_p_true = lazy (constant  "TrueTerm")
-let coq_p_false = lazy (constant  "FalseTerm")
-let coq_p_not = lazy (constant  "Tnot")
-let coq_p_or = lazy (constant  "Tor")
-let coq_p_and = lazy (constant  "Tand")
-let coq_p_imp = lazy (constant  "Timp")
-let coq_p_prop = lazy (constant  "Tprop")
-
-(* Constructors for shuffle tactic *)
-let coq_t_fusion =  lazy (constant  "t_fusion")
-let coq_f_equal =  lazy (constant  "F_equal")
-let coq_f_cancel =  lazy (constant  "F_cancel")
-let coq_f_left =  lazy (constant  "F_left")
-let coq_f_right =  lazy (constant  "F_right")
-
-(* Constructors for reordering tactics *)
-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")
-let coq_c_do_seq = lazy (constant  "C_SEQ")
-let coq_c_nop = lazy (constant  "C_NOP")
-let coq_c_opp_plus = lazy (constant  "C_OPP_PLUS")
-let coq_c_opp_opp = lazy (constant  "C_OPP_OPP")
-let coq_c_opp_mult_r = lazy (constant  "C_OPP_MULT_R")
-let coq_c_opp_one = lazy (constant  "C_OPP_ONE")
-let coq_c_reduce = lazy (constant  "C_REDUCE")
-let coq_c_mult_plus_distr = lazy (constant  "C_MULT_PLUS_DISTR")
-let coq_c_opp_left = lazy (constant  "C_MULT_OPP_LEFT")
-let coq_c_mult_assoc_r = lazy (constant  "C_MULT_ASSOC_R")
-let coq_c_plus_assoc_r = lazy (constant  "C_PLUS_ASSOC_R")
-let coq_c_plus_assoc_l = lazy (constant  "C_PLUS_ASSOC_L")
-let coq_c_plus_permute = lazy (constant  "C_PLUS_PERMUTE")
-let coq_c_plus_comm = lazy (constant  "C_PLUS_COMM")
-let coq_c_red0 = lazy (constant  "C_RED0")
-let coq_c_red1 = lazy (constant  "C_RED1")
-let coq_c_red2 = lazy (constant  "C_RED2")
-let coq_c_red3 = lazy (constant  "C_RED3")
-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_minus = lazy (constant  "C_MINUS")
-let coq_c_mult_comm = lazy (constant  "C_MULT_COMM")
-
-let coq_s_constant_not_nul = lazy (constant  "O_CONSTANT_NOT_NUL")
-let coq_s_constant_neg = lazy (constant  "O_CONSTANT_NEG")
-let coq_s_div_approx = lazy (constant  "O_DIV_APPROX")
-let coq_s_not_exact_divide = lazy (constant  "O_NOT_EXACT_DIVIDE")
-let coq_s_exact_divide = lazy (constant  "O_EXACT_DIVIDE")
-let coq_s_sum = lazy (constant  "O_SUM")
-let coq_s_state = lazy (constant  "O_STATE")
-let coq_s_contradiction = lazy (constant  "O_CONTRADICTION")
-let coq_s_merge_eq = lazy (constant  "O_MERGE_EQ")
-let coq_s_split_ineq =lazy (constant  "O_SPLIT_INEQ")
-let coq_s_constant_nul =lazy (constant  "O_CONSTANT_NUL")
-let coq_s_negate_contradict =lazy (constant  "O_NEGATE_CONTRADICT")
-let coq_s_negate_contradict_inv =lazy (constant  "O_NEGATE_CONTRADICT_INV")
-
-(* construction for the [extract_hyp] tactic *)
-let coq_direction = lazy  (constant  "direction")
-let coq_d_left = lazy  (constant  "D_left")
-let coq_d_right = lazy  (constant  "D_right")
-let coq_d_mono = lazy  (constant  "D_mono")
-
-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_interp_sequent = lazy (constant  "interp_goal_concl")
-let coq_do_omega = lazy (constant  "do_omega")
-
-(* \subsection{Construction d'expressions} *)
-
-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 |] )
-
-let do_right t = 
-  if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
-  else Term.mkApp (Lazy.force coq_c_do_right, [|t |])
-
-let do_both t1 t2 = 
-  if t1 = Lazy.force coq_c_nop then do_right t2
-  else if t2 = Lazy.force coq_c_nop then do_left t1
-  else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |])
-
-let do_seq t1 t2 =
-  if t1 = Lazy.force coq_c_nop then t2
-  else if t2 = Lazy.force coq_c_nop then t1
-  else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |])
-  
-let rec do_list = function
-  | [] -> Lazy.force coq_c_nop
-  | [x] -> x
-  | (x::l) -> do_seq x (do_list l)
-
-(* Nat *)
-
-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
-    | [] ->
-	Term.mkApp (Lazy.force coq_nil, [|typ|])
-    | (step :: l) -> 
-	Term.mkApp (Lazy.force coq_cons, [|typ; 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
deleted file mode 100644
index 0f00e918..00000000
--- a/contrib/romega/const_omega.mli
+++ /dev/null
@@ -1,176 +0,0 @@
-(*************************************************************************
-
-   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
deleted file mode 100644
index 39b6c210..00000000
--- a/contrib/romega/g_romega.ml4
+++ /dev/null
@@ -1,42 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence : LGPL version 2.1
-
- *************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Refl_omega
-open Refiner
-
-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
deleted file mode 100644
index fc4f7a8f..00000000
--- a/contrib/romega/refl_omega.ml
+++ /dev/null
@@ -1,1299 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence : LGPL version 2.1
-
- *************************************************************************)
-
-open Util
-open Const_omega
-module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
-open OmegaSolver
-
-(* \section{Useful functions and flags} *)
-(* Especially useful debugging functions *)
-let debug = ref false
-
-let show_goal gl =
-  if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl
-
-let pp i = print_int i; print_newline (); flush stdout
-
-(* More readable than the prefix notation *)
-let (>>) = Tacticals.tclTHEN
-
-let mkApp = Term.mkApp
-
-(* \section{Types}
-  \subsection{How to walk in a term}
-  To represent how to get to a proposition. Only choice points are
-  kept (branch to choose in a disjunction  and identifier of the disjunctive 
-  connector) *)
-type direction = Left of int | Right of int
-
-(* Step to find a proposition (operators are at most binary). A list is
-   a path *)
-type occ_step = O_left | O_right | O_mono
-type occ_path = occ_step list
-
-(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
-   d'une liste de pas à partir de la racine de l'hypothèse *)
-type occurence = {o_hyp : Names.identifier; o_path : occ_path}
-
-(* \subsection{refiable formulas} *)
-type oformula =
-    (* integer *)
-  | Oint of Bigint.bigint
-    (* recognized binary and unary operations *)
-  | Oplus of oformula * oformula
-  | Omult of oformula * oformula
-  | Ominus of oformula * oformula
-  | Oopp of  oformula
-    (* an atome in the environment *)
-  | Oatom of int
-    (* weird expression that cannot be translated *)
-  | Oufo of oformula
-
-(* Operators for comparison recognized by Omega *)
-type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
-
-(* Type des prédicats réifiés (fragment de calcul propositionnel. Les 
- * quantifications sont externes au langage) *)
-type oproposition = 
-    Pequa of Term.constr * oequation
-  | Ptrue 
-  | Pfalse
-  | Pnot of oproposition
-  | Por of int * oproposition * oproposition
-  | Pand of int * oproposition * oproposition
-  | Pimp of int * oproposition * oproposition
-  | Pprop of Term.constr
-
-(* Les équations ou proposiitions atomiques utiles du calcul *)
-and oequation = {
-    e_comp: comparaison;		(* comparaison *)
-    e_left: oformula;			(* formule brute gauche *)
-    e_right: oformula;			(* formule brute droite *)
-    e_trace: Term.constr;		(* tactique de normalisation *)
-    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
-    e_negated: bool;			(* vrai si apparait en position nié 
-					   après normalisation *)
-    e_depends: direction  list;		(* liste des points de disjonction dont 
-					   dépend l'accès à l'équation avec la 
-					   direction (branche) pour y accéder *)
-    e_omega: afine		(* la fonction normalisée *)
-  } 
-
-(* \subsection{Proof context} 
-  This environment codes 
-  \begin{itemize}
-  \item the terms and propositions that are given as
-  parameters of the reified proof (and are represented as variables in the
-  reified goals)
-  \item translation functions linking the decision procedure and the Coq proof
-  \end{itemize} *)
-
-type environment = {
-  (* La liste des termes non reifies constituant l'environnement global *)
-  mutable terms : Term.constr list;
-  (* La meme chose pour les propositions *)
-  mutable props : Term.constr list;
-  (* Les variables introduites par omega *)
-  mutable om_vars : (oformula * int) list;
-  (* Traduction des indices utilisés ici en les indices finaux utilisés par 
-   * la tactique Omega après dénombrement des variables utiles *)
-  real_indices : (int,int) Hashtbl.t;
-  mutable cnt_connectors : int;
-  equations : (int,oequation) Hashtbl.t;
-  constructors : (int, occurence) Hashtbl.t
-}
-
-(* \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;
-  s_trace : action list }
-
-(* Arbre de solution résolvant complètement un ensemble de systèmes *)
-type solution_tree = 
-    Leaf of solution
-    (* un noeud interne représente un point de branchement correspondant à
-       l'élimination d'un connecteur générant plusieurs buts
-       (typ. disjonction). Le premier argument
-       est l'identifiant du connecteur *)
-  | Tree of int * solution_tree * solution_tree
-
-(* Représentation de l'environnement extrait du but initial sous forme de
-   chemins pour extraire des equations ou d'hypothèses *)
-
-type context_content = 
-    CCHyp of occurence
-  | CCEqua of int
-
-(* \section{Specific utility functions to handle base types} *)
-(* Nom arbitraire de l'hypothèse codant la négation du but final *)  
-let id_concl = Names.id_of_string "__goal__"
-
-(* Initialisation de l'environnement de réification de la tactique *)
-let new_environment () = {
-  terms = []; props = []; om_vars = []; cnt_connectors = 0; 
-  real_indices = Hashtbl.create 7;
-  equations = Hashtbl.create 7;
-  constructors = Hashtbl.create 7;
-}
-
-(* Génération d'un nom d'équation *)
-let new_connector_id env =  
-   env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
-
-(* Calcul de la branche complémentaire *)
-let barre = function Left x -> Right x | Right x -> Left x
-
-(* Identifiant associé à une branche *)
-let indice = function Left x | Right x -> x 
-
-(* Affichage de l'environnement de réification (termes et propositions) *)
-let print_env_reification env = 
-  let rec loop c i = function
-      [] -> Printf.printf "  ===============================\n\n"
-    | t :: l -> 
-	Printf.printf "  (%c%02d) := " c i;
-	Pp.ppnl (Printer.pr_lconstr t);
-	Pp.flush_all ();
-	loop c (succ i) l in
-  print_newline ();
-  Printf.printf "  ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
-  Printf.printf "  ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms
-
-
-(* \subsection{Gestion des environnements de variable pour Omega} *)
-(* generation d'identifiant d'equation pour Omega *)
-
-let new_omega_eq, rst_omega_eq = 
-  let cpt = ref 0 in 
-  (function () -> incr cpt; !cpt), 
-  (function () -> cpt:=0)
-
-(* generation d'identifiant de variable pour Omega *)
-
-let new_omega_var, rst_omega_var = 
-  let cpt = ref 0 in 
-  (function () -> incr cpt; !cpt), 
-  (function () -> cpt:=0)
-
-(* Affichage des variables d'un système *)
-
-let display_omega_var i = Printf.sprintf "OV%d" i
-
-(* Recherche la variable codant un terme pour Omega et crée la variable dans
-   l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
-   le terme d'un monome (le plus souvent un atome) *)
-
-let intern_omega env t =
-  begin try List.assoc t env.om_vars
-  with Not_found -> 
-    let v = new_omega_var () in 
-    env.om_vars <- (t,v) :: env.om_vars; v
-  end
-
-(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
-   variable est créée par Omega et où il faut la lier après coup à un atome
-   réifié introduit de force *)
-let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
-
-(* Récupère le terme associé à une variable *)
-let unintern_omega env id =
-  let rec loop = function 
-	[] -> failwith "unintern" 
-      | ((t,j)::l) -> if id = j then t else loop l in
-  loop env.om_vars
-
-(* \subsection{Gestion des environnements de variable pour la réflexion} 
-   Gestion des environnements de traduction entre termes des constructions
-   non réifiés et variables des termes reifies. Attention il s'agit de 
-   l'environnement initial contenant tout. Il faudra le réduire après
-   calcul des variables utiles. *)
-
-let add_reified_atom t env =
-  try list_index0 t env.terms
-  with Not_found ->
-    let i = List.length env.terms in
-    env.terms <- env.terms @ [t]; i
-
-let get_reified_atom env = 
-  try List.nth env.terms with _ -> failwith "get_reified_atom"
-
-(* \subsection{Gestion de l'environnement de proposition pour Omega} *)
-(* ajout d'une proposition *)
-let add_prop env t =
-  try list_index0 t env.props
-  with Not_found ->
-    let i = List.length env.props in  env.props <- env.props @ [t]; i
-
-(* accès a une proposition *)
-let get_prop v env = try List.nth v env with _ -> failwith "get_prop"
-
-(* \subsection{Gestion du nommage des équations} *)
-(* Ajout d'une equation dans l'environnement de reification *)
-let add_equation env e =
-  let id = e.e_omega.id in
-  try let _ = Hashtbl.find env.equations id in ()
-  with Not_found -> Hashtbl.add env.equations id e
-
-(* accès a une equation *)
-let get_equation env id = 
-  try Hashtbl.find env.equations id
-  with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e
-
-(* Affichage des termes réifiés *)
-let rec oprint ch = function 
-  | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
-  | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2  
-  | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 
-  | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 
-  | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1
-  | Oatom n -> Printf.fprintf ch "V%02d" n
-  | Oufo x ->  Printf.fprintf ch "?"
-
-let rec pprint ch = function
-    Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 })  ->
-      let connector = 
-	match comp with 
-	  Eq -> "=" | Leq -> "<=" | Geq -> ">="
-	| Gt -> ">" | Lt -> "<" | Neq -> "!=" in
-      Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2  
-  | Ptrue -> Printf.fprintf ch "TT"
-  | Pfalse -> Printf.fprintf ch "FF"
-  | Pnot t -> Printf.fprintf ch "not(%a)" pprint t
-  | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2  
-  | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2  
-  | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2  
-  | Pprop c -> Printf.fprintf ch "Prop"
-
-let rec weight env = function
-  | Oint _ -> -1
-  | Oopp c -> weight env c
-  | Omult(c,_) -> weight env c
-  | Oplus _ -> failwith "weight"
-  | Ominus _ -> failwith "weight minus"
-  | Oufo _ -> -1
-  | Oatom _ as c -> (intern_omega env c)
-
-(* \section{Passage entre oformules et représentation interne de Omega} *)
-
-(* \subsection{Oformula vers Omega} *)
-
-let omega_of_oformula env kind = 
-  let rec loop accu = function
-    | Oplus(Omult(v,Oint n),r) -> 
-	loop ({v=intern_omega env v; c=n} :: accu) r
-    | Oint n ->
-	let id = new_omega_eq () in
-	(*i tag_equation name id; i*)
-	{kind = kind; body = List.rev accu; 
-	 constant = n; id = id}
-    | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in
-  loop []
-
-(* \subsection{Omega vers Oformula} *)
-
-let rec oformula_of_omega env af = 
-  let rec loop = function
-    | ({v=v; c=n}::r) ->
-	Oplus(Omult(unintern_omega env v,Oint n),loop r)
-    | [] -> Oint af.constant in
-  loop af.body
-
-let app f v = mkApp(Lazy.force f,v)
-
-(* \subsection{Oformula vers COQ reel} *)
-
-let rec coq_of_formula env t =
-  let rec loop = function
-  | 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 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 |]
-  | Oopp t ->
-      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 [| 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) ->
-      app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |]
-
-let reified_of_formula env f =
-  begin try reified_of_formula env f with e -> oprint stderr f; raise e end
-
-let rec reified_of_proposition env = function
-    Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> 
-      app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> 
-      app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> 
-      app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> 
-      app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) ->  
-      app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> 
-      app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |]
-  | Ptrue -> Lazy.force coq_p_true
-  | Pfalse -> Lazy.force coq_p_false
-  | Pnot t -> 
-      app coq_p_not [| reified_of_proposition env t |]
-  | Por (_,t1,t2) -> 
-      app coq_p_or
-	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
-  | Pand(_,t1,t2) -> 
-      app coq_p_and
-	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
-  | Pimp(_,t1,t2) -> 
-      app coq_p_imp
-	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
-  | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
-
-let reified_of_proposition env f =
-  begin try reified_of_proposition env f 
-  with e -> pprint stderr f; raise e end
-
-(* \subsection{Omega vers COQ réifié} *)
-
-let reified_of_omega env body constant = 
-  let coeff_constant = 
-    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 [| Z.mk c |] |] in
-    app coq_t_plus [|coef; t |] in
-  List.fold_right mk_coeff body coeff_constant
-
-let reified_of_omega env body c  = 
-  begin try 
-    reified_of_omega env body c 
-  with e -> 
-    display_eq display_omega_var (body,c); raise e 
-  end
-
-(* \section{Opérations sur les équations}
-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. *)
-(* 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
-  | Oatom i -> [i]
-  | Oufo _ -> []
-
-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} *)
-
-let rec scalar n = function
-   Oplus(t1,t2) -> 
-     let tac1,t1' = scalar  n t1 and 
-         tac2,t2' = scalar  n t2 in
-     do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], 
-     Oplus(t1',t2')
- | Oopp t ->
-     do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n))
- | Omult(t1,Oint x) -> 
-     do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
- | Omult(t1,t2) -> 
-     Util.error "Omega: Can't solve a goal with non-linear products"
- | (Oatom _ as t) -> do_list [], Omult(t,Oint n)
- | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
- | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
- | Ominus _ -> failwith "scalar minus"
-
-(* \subsection{Propagation de l'inversion} *)
-
-let rec negate = function
-   Oplus(t1,t2) -> 
-     let tac1,t1' = negate t1 and 
-         tac2,t2' = negate t2 in
-     do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)],
-     Oplus(t1',t2')
- | Oopp t ->
-     do_list [Lazy.force coq_c_opp_opp], t
- | Omult(t1,Oint x) -> 
-     do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
- | Omult(t1,t2) -> 
-     Util.error "Omega: Can't solve a goal with non-linear products"
- | (Oatom _ as t) ->
-     do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
- | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
- | Oufo c -> do_list [], Oufo (Oopp c)
- | Ominus _ -> failwith "negate minus"
-
-let rec norm l = (List.length l)
-
-(* \subsection{Mélange (fusion) de deux équations} *)
-(* \subsubsection{Version avec coefficients} *)
-let rec shuffle_path k1 e1 k2 e2 =
-  let rec loop = function
-      (({c=c1;v=v1}::l1) as l1'),
-      (({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
-          if k1*c1 + k2 * c2 = zero then (
-            Lazy.force coq_f_cancel :: loop (l1,l2))
-          else (
-            Lazy.force coq_f_equal :: loop (l1,l2) )
-	else if v1 > v2 then (
-	  Lazy.force coq_f_left :: loop(l1,l2'))
-	else (
-	  Lazy.force coq_f_right :: loop(l1',l2))
-    | ({c=c1;v=v1}::l1), [] -> 
-	  Lazy.force coq_f_left :: loop(l1,[])
-    | [],({c=c2;v=v2}::l2) -> 
-	  Lazy.force coq_f_right :: loop([],l2)
-    | [],[] -> flush stdout; [] in
-  mk_shuffle_list (loop (e1,e2))
-
-(* \subsubsection{Version sans coefficients} *)
-let rec shuffle env (t1,t2) = 
-  match t1,t2 with
-    Oplus(l1,r1), Oplus(l2,r2) ->
-      if weight env l1 > weight env l2 then 
-	let l_action,t' = shuffle env (r1,t2) in
-	do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t')
-      else 
-	let l_action,t' = shuffle env (t1,r2) in
-	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
-  | Oplus(l1,r1), t2 -> 
-      if weight env l1 > weight env t2 then
-        let (l_action,t') = shuffle env (r1,t2) in
-	do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t')
-      else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
-  | t1,Oplus(l2,r2) -> 
-      if weight env l2 > weight env t1 then
-        let (l_action,t') = shuffle env (t1,r2) in
-	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
-      else do_list [],Oplus(t1,t2)
-  | Oint t1,Oint t2 ->
-      do_list [Lazy.force coq_c_reduce], Oint(t1+t2)
-  | t1,t2 ->
-      if weight env t1 < weight env t2 then
-	do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
-      else do_list [],Oplus(t1,t2)
-
-(* \subsection{Fusion avec réduction} *)
-
-let shrink_pair f1 f2 =
-  begin match f1,f2 with
-     Oatom v,Oatom _ -> 
-       Lazy.force coq_c_red1, Omult(Oatom v,Oint two)
-   | Oatom v, Omult(_,c2) -> 
-       Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one))
-   | Omult (v1,c1),Oatom v -> 
-       Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one))
-   | Omult (Oatom v,c1),Omult (v2,c2) ->
-       Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
-   | t1,t2 -> 
-       oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); 
-       flush Pervasives.stdout; Util.error "shrink.1"
-  end
-
-(* \subsection{Calcul d'une sous formule constante} *)
-
-let reduce_factor = function
-   Oatom v ->
-     let r = Omult(Oatom v,Oint one) in
-       [Lazy.force coq_c_red0],r
-  | Omult(Oatom v,Oint n) as f -> [],f
-  | Omult(Oatom v,c) ->
-      let rec compute = function
-          Oint n -> n
-	| Oplus(t1,t2) -> compute t1 + compute t2 
-	| _ -> Util.error "condense.1" in
-	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
-  | t -> Util.error "reduce_factor.1"
-
-(* \subsection{Réordonnancement} *)
-
-let rec condense env = function
-    Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight env f1 = weight env f2 then begin
-	let shrink_tac,t = shrink_pair f1 f2 in
-	let assoc_tac = Lazy.force coq_c_plus_assoc_l in
-	let tac_list,t' = condense env (Oplus(t,r)) in
-	assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t'
-      end else begin
-	let tac,f = reduce_factor f1 in
-	let tac',t' = condense env t in 
-	[do_both (do_list tac) (do_list tac')], Oplus(f,t') 
-      end
-  | Oplus(f1,Oint n) -> 
-      let tac,f1' = reduce_factor f1 in 
-      [do_left (do_list tac)],Oplus(f1',Oint n)
-  | Oplus(f1,f2) -> 
-      if weight env f1 = weight env f2 then begin
-	let tac_shrink,t = shrink_pair f1 f2 in
-	let tac,t' = condense env t in
-	tac_shrink :: tac,t'
-      end else begin
-	let tac,f = reduce_factor f1 in
-	let tac',t' = condense env f2 in 
-	[do_both (do_list tac) (do_list tac')],Oplus(f,t') 
-      end
-  | (Oint _ as t)-> [],t
-  | t -> 
-      let tac,t' = reduce_factor t in
-      let final = Oplus(t',Oint zero) in
-      tac @ [Lazy.force coq_c_red6], final
-
-(* \subsection{Elimination des zéros} *)
-
-let rec clear_zero = function
-   Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
-     let tac',t = clear_zero r in
-     Lazy.force coq_c_red5 :: tac',t
-  | Oplus(f,r) -> 
-      let tac,t = clear_zero r in 
-      (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
-  | t -> [],t;;
-
-(* \subsection{Transformation des hypothèses} *)
-
-let rec reduce env = function
-    Oplus(t1,t2) ->
-      let t1', trace1 = reduce env t1 in
-      let t2', trace2 = reduce env t2 in
-      let trace3,t' = shuffle env (t1',t2') in
-      t', do_list [do_both trace1 trace2; trace3]
-  | Ominus(t1,t2) ->
-      let t,trace = reduce env (Oplus(t1, Oopp t2)) in
-      t, do_list [Lazy.force coq_c_minus; trace]
-  | Omult(t1,t2) as t ->
-      let t1', trace1 = reduce env t1 in
-      let t2', trace2 = reduce env t2 in
-      begin match t1',t2' with
-      | (_, Oint n) ->
-	  let tac,t' = scalar n t1' in
-	  t', do_list [do_both trace1 trace2; tac]
-      | (Oint n,_) ->
-	  let tac,t' = scalar n t2' in
-	  t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac]
-      | _ -> Oufo t, Lazy.force coq_c_nop
-      end
-  | Oopp t ->
-      let t',trace = reduce env  t in
-      let trace',t'' = negate t' in
-      t'', do_list [do_left trace; trace']
-  | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop
-
-let normalize_linear_term env t =
-  let t1,trace1 = reduce env t in
-  let trace2,t2 = condense env t1 in
-  let trace3,t3 = clear_zero t2 in
-  do_list [trace1; do_list trace2; do_list trace3], t3
-
-(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
-let negate_oper = function
-    Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
- 
-let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = 
-  let mk_step t1 t2 f kind =
-    let t = f t1 t2 in
-    let trace, oterm = normalize_linear_term env t in
-    let equa = omega_of_oformula env kind oterm in 
-    { e_comp = oper; e_left = t1; e_right = t2; 
-      e_negated = negated; e_depends = depends; 
-      e_origin = { o_hyp = origin; o_path = List.rev path };
-      e_trace = trace; e_omega = equa } in
-  try match (if negated then (negate_oper oper) else oper) with
-    | Eq  -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA
-    | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE
-    | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ
-    | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ
-    | Lt  ->
-        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1))
-	  INEQ
-    | Gt ->
-        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) 
-	  INEQ
-  with e when Logic.catchable_exception e -> raise e
-
-(* \section{Compilation des hypothèses} *)
-
-let rec oformula_of_constr env t =
-  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
-  let depends2 = if add_to_depends then Right i::depends else depends in
-  if add_to_depends then
-    Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path};
-  let t1' = 
-    oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
-  let t2' =
-    oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
-  (* On numérote le connecteur dans l'environnement. *)
-  c i t1' t2'
-
-and mk_equation env ctxt c connector t1 t2 =
-  let t1' = oformula_of_constr env t1 in
-  let t2' = oformula_of_constr env t2 in
-  (* On ajoute l'equation dans l'environnement. *)
-  let omega = normalize_equation env ctxt (connector,t1',t2') in
-  add_equation env omega;
-  Pequa (c,omega)
-
-and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = 
-  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
-    | Rand (t1,t2) -> 
-	binprop env ctxt negated negated gl
-	  (fun i x y -> Pand(i,x,y)) t1 t2
-    | Rimp (t1,t2) ->
-	binprop env ctxt (not negated) (not negated) gl 
-	  (fun i x y -> Pimp(i,x,y)) 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
-
-(* Destructuration des hypothèses et de la conclusion *)
-
-let reify_gl env gl =
-  let concl = Tacmach.pf_concl gl in
-  let t_concl =
-    Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in
-  if !debug then begin
-    Printf.printf "REIFED PROBLEM\n\n";
-    Printf.printf "  CONCL: "; pprint stdout t_concl; Printf.printf "\n"
-  end;
-  let rec loop = function
-      (i,t) :: lhyps ->
-	let t' = oproposition_of_constr env (false,[],i,[]) gl t in
-	if !debug then begin
-	  Printf.printf "  %s: " (Names.string_of_id i);
-	  pprint stdout t';
-	  Printf.printf "\n"
-	end;
-	(i,t') :: loop lhyps
-    | [] -> 
-	if !debug then print_env_reification env; 
-	[] in
-  let t_lhyps = loop (Tacmach.pf_hyps_types gl) in
-  (id_concl,t_concl) :: t_lhyps 
-
-let rec destructurate_pos_hyp orig list_equations list_depends = function
-  | Pequa (_,e) -> [e :: list_equations]
-  | Ptrue | Pfalse | Pprop _ -> [list_equations]
-  | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t
-  | Por (i,t1,t2) -> 
-      let s1 = 
-	destructurate_pos_hyp orig list_equations (i::list_depends) t1 in
-      let s2 = 
-	destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
-      s1 @ s2
-  | Pand(i,t1,t2) -> 
-      let list_s1 =
-	destructurate_pos_hyp orig list_equations (list_depends) t1 in
-      let rec loop = function 
-	  le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll
-	| [] -> [] in
-      loop list_s1
-  | Pimp(i,t1,t2) -> 
-      let s1 =
-	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
-      let s2 =
-	destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
-      s1 @ s2
-
-and destructurate_neg_hyp orig list_equations list_depends = function
-  | Pequa (_,e) -> [e :: list_equations]
-  | Ptrue | Pfalse | Pprop _ -> [list_equations]
-  | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t
-  | Pand (i,t1,t2) -> 
-      let s1 =
-	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
-      let s2 =
-	destructurate_neg_hyp orig list_equations (i::list_depends) t2 in
-      s1 @ s2
-  | Por(_,t1,t2) -> 
-      let list_s1 =
-	destructurate_neg_hyp orig list_equations list_depends t1 in
-      let rec loop = function 
-	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
-	| [] -> [] in
-      loop list_s1
-  | Pimp(_,t1,t2) -> 
-      let list_s1 =
-	destructurate_pos_hyp orig list_equations list_depends t1 in
-      let rec loop = function 
-	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
-	| [] -> [] in
-      loop list_s1
-
-let destructurate_hyps syst =
-  let rec loop = function
-      (i,t) :: l -> 
-	let l_syst1 = destructurate_pos_hyp i []  [] t in
-	let l_syst2 = loop l in
-	list_cartesian (@) l_syst1 l_syst2
-    | [] -> [[]] in
-  loop syst
-
-(* \subsection{Affichage d'un système d'équation} *)
-
-(* Affichage des dépendances de système *)
-let display_depend = function
-    Left i -> Printf.printf " L%d" i 
-  | Right i -> Printf.printf " R%d" i
-
-let display_systems syst_list = 
-  let display_omega om_e = 
-    Printf.printf "  E%d : %a %s 0\n"
-      om_e.id
-      (fun _ -> display_eq display_omega_var) 
-      (om_e.body, om_e.constant)
-      (operator_of_eq om_e.kind) in
-
-  let display_equation oformula_eq = 
-    pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline ();
-    display_omega oformula_eq.e_omega;
-    Printf.printf "  Depends on:"; 
-    List.iter display_depend oformula_eq.e_depends;
-    Printf.printf "\n  Path: %s" 
-      (String.concat ""
-	 (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
-	    oformula_eq.e_origin.o_path));
-    Printf.printf "\n  Origin: %s (negated : %s)\n\n"
-      (Names.string_of_id oformula_eq.e_origin.o_hyp)
-      (if oformula_eq.e_negated then "yes" else "no") in
-
-  let display_system syst =
-    Printf.printf "=SYSTEM===================================\n";
-    List.iter display_equation syst in
-  List.iter display_system syst_list
-
-(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
-   calcul des hypothèses *)
-
-let rec hyps_used_in_trace = function
-  | act :: l -> 
-      begin match act with
-	| 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 l
-      end
-  | [] -> []
-
-(* Extraction des variables déclarées dans une équation. Permet ensuite
-   de les déclarer dans l'environnement de la procédure réflexive et
-   éviter les créations de variable au vol *)
-
-let rec variable_stated_in_trace = function
-  | act :: l -> 
-      begin match act with
-	| STATE action ->
-	    (*i nlle_equa: afine, def: afine, eq_orig: afine, i*)
-            (*i coef: int, var:int                            i*)
-	    action :: variable_stated_in_trace l
-	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
-	    variable_stated_in_trace act1 @ variable_stated_in_trace act2
-	| _ -> variable_stated_in_trace l
-      end
-  | [] -> []
-;;
-
-let add_stated_equations env tree = 
-  (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
-     de définir dans le mauvais ordre *)
-  let stated_equations = 
-    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
-    (* Notez que si l'ordre de création des variables n'est pas respecté, 
-     * ca va planter *)
-    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 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
-    (* enregistre le lien entre la variable omega et la variable Coq *)
-    intern_omega_force env (Oatom v) st.st_var; 
-    (v, term_to_generalize,term_to_reify,st.st_def.id) in
- List.map add_env stated_equations
-
-(* 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 (List.rev l) (get_eclatement env r)
-  | [] -> []
-
-let select_smaller l = 
-  let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in
-  try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller"
-
-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 failwith "Exit" 
-	else x :: select l
-    | [] -> [] in
-  map_succeed (function (sol,splits) -> (sol,select splits)) systems
-
-let rec equas_of_solution_tree = function
-    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 *)
-(* Things get shorter, but may also get wrong, since a Prop is considered 
-   to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance 
-   Pfalse is decidable. So should not be used on conclusion (??) *)
-
-let really_useful_prop l_equa c =
-  let rec real_of = function
-      Pequa(t,_) -> t
-    | Ptrue ->  app  coq_True [||]
-    | Pfalse -> app  coq_False [||]
-    | Pnot t1 -> app coq_not [|real_of t1|]
-    | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|]
-    | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|]
-    (* Attention : implications sur le lifting des variables à comprendre ! *)
-    | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
-    | Pprop t -> t in
-  let rec loop c = 
-    match c with 
-      Pequa(_,e) ->
-	if List.mem e.e_omega.id l_equa then Some c else None
-    | Ptrue -> None
-    | Pfalse -> None
-    | Pnot t1 -> 
-	begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end
-    | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2
-    | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2
-    | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2
-    | Pprop t -> None
-  and binop f t1 t2 = 
-    begin match loop t1, loop t2 with
-      None, None -> None 
-    | Some t1',Some t2' -> Some (f(t1',t2'))
-    | Some t1',None -> Some (f(t1',Pprop (real_of t2)))
-    | None,Some t2' -> Some (f(Pprop (real_of t1),t2'))
-    end in
-  match loop c with
-    None -> Pprop (real_of c)
-  | Some t -> t
-
-let rec display_solution_tree ch = function
-    Leaf t -> 
-      output_string ch 
-       (Printf.sprintf "%d[%s]" 
-	 t.s_index
-         (String.concat " " (List.map string_of_int t.s_equa_deps)))
-  | Tree(i,t1,t2) -> 
-      Printf.fprintf ch "S%d(%a,%a)" i 
-	display_solution_tree t1 display_solution_tree t2
-
-let rec solve_with_constraints all_solutions path = 
-  let rec build_tree sol buf = function
-      [] -> Leaf sol
-    | (Left i :: remainder) -> 
-	Tree(i,
-	     build_tree sol (Left i :: buf) remainder, 
-	     solve_with_constraints all_solutions (List.rev(Right i :: buf)))
-    | (Right i :: remainder) -> 
-	 Tree(i,
-	      solve_with_constraints all_solutions (List.rev (Left i ::  buf)),
-	      build_tree sol (Right i :: buf) remainder) in
-  let weighted = filter_compatible_systems path all_solutions in
-  let (winner_sol,winner_deps) =
-    try select_smaller weighted 
-    with e ->  
-      Printf.printf "%d - %d\n" 
-	(List.length weighted) (List.length all_solutions);
-      List.iter display_depend path; raise e in
-  build_tree winner_sol (List.rev path) winner_deps 
-
-let find_path {o_hyp=id;o_path=p} env = 
-  let rec loop_path = function
-      ([],l) -> Some l
-    | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
-    | _ -> None in
-  let rec loop_id i = function
-      CCHyp{o_hyp=id';o_path=p'} :: l when id = id' ->
-	begin match loop_path (p',p) with
-	  Some r -> i,r
-	| None -> loop_id (succ i) l
-	end
-    | _ :: l -> loop_id (succ i) l
-    | [] -> failwith "find_path" in
-  loop_id 0 env
-
-let mk_direction_list l = 
-  let trans = function 
-      O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in
-  mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l)
-
-
-(* \section{Rejouer l'historique} *)
-
-let get_hyp env_hyp i =
-  try list_index0 (CCEqua i) env_hyp
-  with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
-
-let replay_history env env_hyp =
-  let rec loop env_hyp t =
-    match t with
-      | CONTRADICTION (e1,e2) :: l -> 
-	  let trace = mk_nat (List.length e1.body) in
-	  mkApp (Lazy.force coq_s_contradiction,
-		 [| trace ; mk_nat (get_hyp env_hyp e1.id); 
-		    mk_nat (get_hyp env_hyp e2.id) |])
-      | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
-	  mkApp (Lazy.force coq_s_div_approx,
-		 [| 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) |])
-      | NOT_EXACT_DIVIDE (e1,k) :: l ->
-	  let e2_constant = floor_div e1.constant k in
-	  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,
-		 [|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)|])
-      | EXACT_DIVIDE (e1,k) :: l ->
-	  let e2_body =  
-	    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,
-		 [|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)|])
-      | (MERGE_EQ(e3,e1,e2)) :: l ->
-	  let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in
-          mkApp (Lazy.force coq_s_merge_eq,
-		 [| mk_nat (List.length e1.body);
-		    mk_nat n1; mk_nat n2;
-		    loop (CCEqua e3:: env_hyp) l |])
-      | SUM(e3,(k1,e1),(k2,e2)) :: l ->
-	  let n1 = get_hyp env_hyp e1.id 
-	  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,
-		 [| 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,
-		 [|  mk_nat (get_hyp env_hyp e) |])
-      | CONSTANT_NEG(e,k) :: l ->
-          mkApp (Lazy.force coq_s_constant_neg,
-		 [|  mk_nat (get_hyp env_hyp e) |])
-      | STATE {st_new_eq=new_eq; st_def =def; 
-		      st_orig=orig; st_coef=m;
-                      st_var=sigma } :: l ->
-	  let n1 = get_hyp env_hyp orig.id 
-	  and n2 = get_hyp env_hyp def.id in
-	  let v = unintern_omega env sigma in
-	  let o_def = oformula_of_omega env def in
-	  let o_orig = oformula_of_omega env orig in
-	  let body =
-	     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,
-		 [| 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 ->
-	  mkApp (Lazy.force coq_s_constant_nul, 
-		 [|  mk_nat (get_hyp env_hyp e) |])
-      |	NEGATE_CONTRADICT(e1,e2,true) :: l ->
-	  mkApp (Lazy.force coq_s_negate_contradict, 
-		 [|  mk_nat (get_hyp env_hyp e1.id);
-		     mk_nat (get_hyp env_hyp e2.id) |])
-      |	NEGATE_CONTRADICT(e1,e2,false) :: l ->
-	  mkApp (Lazy.force coq_s_negate_contradict_inv, 
-		 [|  mk_nat (List.length e2.body); 
-		     mk_nat (get_hyp env_hyp e1.id);
-		     mk_nat (get_hyp env_hyp e2.id) |])
-      | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l ->
-	  let i =  get_hyp env_hyp e.id in
-	  let r1 = loop (CCEqua e1 :: env_hyp) l1 in
-	  let r2 = loop (CCEqua e2 :: env_hyp) l2 in
-	  mkApp (Lazy.force coq_s_split_ineq, 
-                  [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |])
-      |	(FORGET_C _ | FORGET _ | FORGET_I _) :: l ->
-	  loop env_hyp l
-      | (WEAKEN  _ ) :: l -> failwith "not_treated"
-      |	[] -> failwith "no contradiction"
-  in loop env_hyp
-
-let rec decompose_tree env ctxt = function
-   Tree(i,left,right) ->
-     let org = 
-       try Hashtbl.find env.constructors i 
-       with Not_found ->
-	 failwith (Printf.sprintf "Cannot find constructor %d" i) in
-     let (index,path) = find_path org ctxt in
-     let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in
-     let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in
-     app coq_e_split 
-       [| mk_nat index;
-	  mk_direction_list path;
-	  decompose_tree env (left_hyp::ctxt) left;
-	  decompose_tree env (right_hyp::ctxt) right |]
-  | Leaf s ->
-      decompose_tree_hyps s.s_trace env ctxt  s.s_equa_deps
-and decompose_tree_hyps trace env ctxt = function
-    [] -> app coq_e_solve [| replay_history env ctxt trace |]
-  | (i::l) -> 
-      let equation =
-        try Hashtbl.find env.equations i 
-        with Not_found ->
-	  failwith (Printf.sprintf "Cannot find equation %d" i) in
-      let (index,path) = find_path equation.e_origin ctxt in
-      let full_path = if equation.e_negated then path @ [O_mono] else path in
-      let cont = 
-	decompose_tree_hyps trace env 
-	   (CCEqua equation.e_omega.id :: ctxt) l in
-      app coq_e_extract [|mk_nat index;
-			  mk_direction_list full_path;
-			  cont |]
-
-(* \section{La fonction principale} *)
- (* Cette fonction construit la
-trace pour la procédure de décision réflexive.  A partir des résultats
-de l'extraction des systèmes, elle lance la résolution par Omega, puis
-l'extraction d'un ensemble minimal de solutions permettant la
-résolution globale du système et enfin construit la trace qui permet
-de faire rejouer cette solution par la tactique réflexive. *)
-
-let resolution env full_reified_goal systems_list =
-  let num = ref 0 in
-  let solve_system list_eq = 
-    let index = !num in
-    let system = List.map (fun eq -> eq.e_omega) list_eq in
-    let trace = 
-      simplify_strong 
-	(new_omega_eq,new_omega_var,display_omega_var) 
-	system in 
-    (* calcule les hypotheses utilisées pour la solution *)
-    let vars = hyps_used_in_trace trace in
-    let splits = get_eclatement env vars in
-    if !debug then begin
-      Printf.printf "SYSTEME %d\n" index;
-      display_action display_omega_var trace;
-      print_string "\n  Depend :";
-      List.iter (fun i -> Printf.printf " %d" i) vars;
-      print_string "\n  Split points :";
-      List.iter display_depend splits;
-      Printf.printf "\n------------------------------------\n"
-    end;
-    incr num;
-    {s_index = index; s_trace = trace; s_equa_deps = vars}, splits  in
-  if !debug then Printf.printf "\n====================================\n";
-  let all_solutions = List.map solve_system systems_list in
-  let solution_tree = solve_with_constraints all_solutions [] in
-  if !debug then  begin
-    display_solution_tree stdout solution_tree;
-    print_newline()
-  end;
-  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
-  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_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     
-    really_useful_vars @@ concl_vars
-  in 
-  (* variables a introduire *)
-  let to_introduce = add_stated_equations env solution_tree in
-  let stated_vars =  List.map (fun (v,_,_,_) -> v) to_introduce in
-  let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in
-  let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in
-  (* L'environnement de base se construit en deux morceaux :
-     - les variables des équations utiles (et de la conclusion)
-     - les nouvelles variables declarées durant les preuves *)
-  let all_vars_env = useful_vars @ stated_vars in
-  let basic_env =
-    let rec loop i = function
-	var :: l -> 
-	  let t = get_reified_atom env var in 
-	  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 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),_) -> 
-                 app coq_p_eq [| reified_of_formula env l; 
-                                 reified_of_formula env r |])
-              to_introduce in
-  let reified_concl = 
-    match useful_hyps with
-      (Pnot p) :: _ -> reified_of_proposition env p
-    | _ ->  reified_of_proposition env Pfalse in
-  let l_reified_terms =
-    (List.map
-      (fun p ->
-         reified_of_proposition env (really_useful_prop useful_equa_id p))
-      (List.tl useful_hyps)) in
-  let env_props_reified = mk_plist env.props in
-  let reified_goal = 
-    mk_list (Lazy.force coq_proposition)
-            (l_reified_stated @ l_reified_terms) in
-  let reified = 
-    app coq_interp_sequent 
-       [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in
-  let normalize_equation e = 
-    let rec loop = function
-	[] -> app (if e.e_negated then coq_p_invert else coq_p_step)
-	          [| e.e_trace |]
-      |	((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_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 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 =
-    mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in
-
-  let initial_context =
-    List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in
-  let context = 
-    CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
-  let decompose_tactic = decompose_tree env context solution_tree in
-
-  Tactics.generalize 
-    (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
-  Tactics.change_in_concl None reified >> 
-  Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
-  show_goal >>
-  Tactics.normalise_vm_in_concl >>
-  (*i Alternatives to the previous line: 
-   - Normalisation without VM: 
-      Tactics.normalise_in_concl
-   - Skip the conversion check and rely directly on the QED: 
-      Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> 
-  i*)
-  Tactics.apply (Lazy.force coq_I)
-
-let total_reflexive_omega_tactic gl = 
-  Coqlib.check_required_library ["Coq";"romega";"ROmega"];
-  rst_omega_eq (); 
-  rst_omega_var ();
-  try
-  let env = new_environment () in
-  let full_reified_goal = reify_gl env gl in
-  let systems_list = destructurate_hyps full_reified_goal in
-  if !debug then display_systems systems_list;
-  resolution env full_reified_goal systems_list gl
-  with NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
-
-
-(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
-
-
diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v
deleted file mode 100644
index e90fea84..00000000
--- a/contrib/rtauto/Bintree.v
+++ /dev/null
@@ -1,489 +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        *)
-(************************************************************************)
-
-(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *)
-
-Require Export List.
-Require Export BinPos.
-
-Unset Boxed Definitions.
-
-Open Scope positive_scope.
-
-Ltac clean := try (simpl; congruence). 
-Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
-
-Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
-
-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));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Lt_Gt : forall p q cmp,
-       (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt.
-apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Psucc_Eq: forall p q,
-  (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro;apply Gt_Eq_Gt;auto.
-apply Gt_Lt_Gt.
-Qed.
-
-Lemma Eq_Psucc_Gt: forall p q,
-  (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro H;elim (Pcompare_not_Eq p (Psucc q));tauto.
-intro H;apply Gt_Eq_Gt;auto.
-intro H;rewrite Pcompare_Eq_eq with p q;auto.
-generalize q;clear q IHq p H;induction q;simpl;auto.
-intro H;elim (Pcompare_not_Eq p q);tauto.
-Qed.
-
-Lemma Gt_Psucc_Gt : forall n p cmp cmp0,
- (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt.
-induction n;intros [ | p | p];simpl;try congruence.
-intros; apply IHn with cmp;trivial.
-intros; apply IHn with Gt;trivial.
-intros;apply Gt_Lt_Gt;trivial.
-intros [ | | ] _ H.
-apply Gt_Eq_Gt;trivial.
-apply Gt_Lt_Gt;trivial.
-trivial.
-Qed.
-
-Lemma Gt_Psucc: forall p q,
-       (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-apply Gt_Psucc_Eq.
-intro;apply Gt_Eq_Gt;apply IHq;auto.
-apply Gt_Eq_Gt.
-apply Gt_Lt_Gt.
-Qed.
-
-Lemma Psucc_Gt : forall p,
-       (Psucc p ?= p) Eq = Gt.
-induction p;simpl.
-apply Gt_Eq_Gt;auto.
-generalize p;clear p IHp.
-induction p;simpl;auto.
-reflexivity.
-Qed.
-
-Fixpoint pos_eq (m n:positive) {struct m} :bool :=
-match m, n with
-  xI mm, xI nn => pos_eq mm nn
-| xO mm, xO nn => pos_eq mm nn
-| xH, xH => true
-| _, _ => false
-end. 
-
-Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
-induction m;simpl;intro n;destruct n;congruence ||
-(intro e;apply f_equal with positive;auto).
-Defined.
-
-Theorem refl_pos_eq : forall m, pos_eq m m = true.
-induction m;simpl;auto.
-Qed.
-
-Definition pos_eq_dec (m n:positive) :{m=n}+{m<>n} .
-fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence).
-case (pos_eq_dec mm nn).
-intro e;left;apply (f_equal xI e).
-intro ne;right;congruence.
-case (pos_eq_dec mm nn).
-intro e;left;apply (f_equal xO e).
-intro ne;right;congruence.
-left;reflexivity.
-Defined.
-
-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.
-reflexivity.
-Qed.
-
-Theorem pos_eq_dec_ex : forall m n,
- pos_eq m n =true -> exists h:m=n,
- 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).
-intros x ex; rewrite ex. 
-exists (f_equal xI x).
-reflexivity.
-simpl;intro e.
-elim (pos_eq_dec_ex _ _ e).
-intros x ex; rewrite ex. 
-exists (f_equal xO x).
-reflexivity.
-simpl.
-exists (refl_equal xH).
-reflexivity.
-Qed.
-
-Fixpoint nat_eq (m n:nat) {struct m}: bool:=
-match m, n with 
-O,O => true
-| S mm,S nn => nat_eq mm nn
-| _,_ => false
-end.
-
-Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n.
-induction m;simpl;intro n;destruct n;congruence ||
-(intro e;apply f_equal with nat;auto).
-Defined.
-
-Theorem refl_nat_eq : forall n, nat_eq n n = true.
-induction n;simpl;trivial.
-Defined.
-
-Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A :=
-match l with nil => None
-| x::q => 
-match n with O => Some x
-| S m => Lget A m q
-end end .
-
-Implicit Arguments Lget [A].
-
-Lemma map_app : forall (A B:Set) (f:A -> B) l m, 
-List.map  f (l ++ m) = List.map  f  l ++ List.map  f  m.
-induction l.
-reflexivity.
-simpl.
-intro m ; apply f_equal with (list B);apply IHl.
-Qed.
-
-Lemma length_map : forall (A B:Set) (f:A -> B) l, 
-length (List.map  f l) = length l.
-induction l.
-reflexivity.
-simpl; apply f_equal with nat;apply IHl.
-Qed.
-
-Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, 
-Lget i (List.map  f l) = 
-match Lget i l with Some a => 
-Some (f a) | None => None end.
-induction i;intros [ | x l ] ;trivial.
-simpl;auto.
-Qed.
-
-Lemma Lget_app : forall (A:Set) (a:A) l i,
-Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l.
-induction l;simpl Lget;simpl length.
-intros [ | i];simpl;reflexivity.
-intros [ | i];simpl.
-reflexivity.
-auto.
-Qed.
-
-Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), 
-Lget i l = Some a ->
-Lget i (l ++ delta) = Some a.
-induction l;destruct i;simpl;try congruence;auto.
-Qed.
-
-Section Store.
-
-Variable A:Type.
-
-Inductive Poption : Type:=
-  PSome : A -> Poption
-| PNone : Poption.
-
-Inductive Tree : Type :=
-   Tempty : Tree
- | Branch0 : Tree -> Tree -> Tree
- | Branch1 : A -> Tree -> Tree -> Tree.
-        
-Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := 
-  match T with
-    Tempty => PNone
-  | Branch0 T1 T2 =>
-    match p with
-      xI pp => Tget pp T2
-    | xO pp => Tget pp T1
-    | xH => PNone
-    end
-  | Branch1 a T1 T2 =>
-    match p with
-      xI pp => Tget pp T2
-    | xO pp => Tget pp T1
-    | xH => PSome a
-    end
-end.
-
-Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := 
- match T with
-   | Tempty =>
-       match p with
-       | xI pp => Branch0 Tempty (Tadd pp a Tempty)
-       | xO pp => Branch0 (Tadd pp a Tempty) Tempty
-       | xH => Branch1 a Tempty Tempty
-       end
-   | Branch0 T1 T2 =>
-       match p with
-       | xI pp => Branch0 T1 (Tadd pp a T2)
-       | xO pp => Branch0 (Tadd pp a T1) T2
-       | xH => Branch1 a T1 T2
-       end
-   | Branch1 b T1 T2 =>
-       match p with
-       | xI pp => Branch1 b T1 (Tadd pp a T2)
-       | xO pp => Branch1 b (Tadd pp a T1) T2
-       | xH => Branch1 a T1 T2
-       end
-   end.
-
-Definition mkBranch0 (T1 T2:Tree) :=
-  match T1,T2 with
-    Tempty ,Tempty => Tempty
-  | _,_ => Branch0 T1 T2
-  end.
-  
-Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
-   match T with
-      | Tempty => Tempty
-      | Branch0 T1 T2 => 
-        match p with
-        | xI pp => mkBranch0 T1 (Tremove pp T2)                  
-        | xO pp => mkBranch0 (Tremove pp T1) T2
-        | xH => T
-        end
-      | Branch1 b T1 T2 =>
-        match p with
-        | xI pp => Branch1 b T1 (Tremove pp T2)
-        | xO pp => Branch1 b (Tremove pp T1) T2
-        | xH => mkBranch0 T1 T2
-        end
-      end.
-                                                                                                                        
- 
-Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
-destruct p;reflexivity.
-Qed.
-
-Theorem Tget_Tadd: forall i j a T,
-       Tget i (Tadd j a T) =
-       match (i ?= j) Eq with
-         Eq => PSome a
-       | Lt => Tget i T
-       | Gt => Tget i T
-       end.
-intros i j.
-caseq ((i ?= j) Eq).
-intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
-induction j;destruct T;simpl;try (apply IHj);congruence.
-generalize i;clear i;induction j;destruct T;simpl in H|-*;
-destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
-generalize i;clear i;induction j;destruct T;simpl in H|-*;
-destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
-Qed.
-
-Record Store : Type :=  
-mkStore  {index:positive;contents:Tree}.
-
-Definition empty := mkStore xH Tempty.
-
-Definition push a  S :=
-mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).
-
-Definition get i S := Tget i (contents S).
-
-Lemma get_empty : forall i, get i empty = PNone.
-intro i; case i; unfold empty,get; simpl;reflexivity.
-Qed.
-
-Inductive Full : Store -> Type:=
-    F_empty : Full empty
-  | F_push : forall a S, Full S -> Full (push a S).
-
-Theorem get_Full_Gt : forall S, Full S ->
-       forall i, (i ?= index S) Eq = Gt -> get i S = PNone.
-intros S W;induction W.
-unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
-intros i e;rewrite Tget_Tadd.
-rewrite (Gt_Psucc _ _ e). 
-unfold get in IHW.
-apply IHW;apply Gt_Psucc;assumption.
-Qed.
-
-Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
-intros [index0 contents0] F.
-case F.
-unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
-intros a S.
-rewrite Tget_Tadd.
-rewrite Psucc_Gt.
-intro W.
-change (get (Psucc (index S)) S =PNone).
-apply get_Full_Gt; auto.
-apply Psucc_Gt.
-Qed.
-
-Theorem get_push_Full : 
-  forall i a S, Full S -> 
-  get i (push a S) =
-  match (i ?= index S) Eq with
-    Eq => PSome a
-  | Lt => get i S
-  | Gt => PNone
-end.
-intros i a S F.
-caseq ((i ?= index S) Eq).
-intro e;rewrite (Pcompare_Eq_eq _ _ e).
-destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
-rewrite Pcompare_refl;reflexivity.
-intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
-simpl index in H;rewrite H;reflexivity.
-intro H;generalize H;clear H.
-unfold get,push;simpl index;simpl contents.
-rewrite Tget_Tadd;intro e;rewrite e.
-change (get i S=PNone).
-apply get_Full_Gt;auto.
-Qed.
-
-Lemma Full_push_compat : forall i a S, Full S ->
-forall x, get i S = PSome x -> 
- get i (push a S) = PSome x.
-intros i a S F x H. 
-caseq ((i ?= index S) Eq);intro test.
-rewrite (Pcompare_Eq_eq _ _ test) in H.
-rewrite (get_Full_Eq _ F) in H;congruence.
-rewrite <- H.
-rewrite (get_push_Full i a).
-rewrite test;reflexivity.
-assumption.
-rewrite (get_Full_Gt _ F) in H;congruence.
-Qed.
-
-Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. 
-intros [ind cont] F one; inversion F.
-reflexivity.
-simpl index in one;assert (h:=Psucc_not_one (index S)).
-congruence.
-Qed.
-
-Lemma push_not_empty: forall a S, (push a S) <> empty.
-intros a [ind cont];unfold push,empty.
-simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
-Qed. 
-
-Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
-match F with
-F_empty => False
-| F_push a SS FF => x=a \/ In x SS FF
-end.
-
-Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , 
-get i S = PSome x -> In x S F.
-induction F.
-intro i;rewrite get_empty; congruence.
-intro i;rewrite get_push_Full;trivial.
-caseq ((i ?= index S) Eq);simpl.
-left;congruence.
-right;eauto.
-congruence.
-Qed.
-
-End Store.
-
-Implicit Arguments PNone [A].
-Implicit Arguments PSome [A].
-
-Implicit Arguments Tempty [A].
-Implicit Arguments Branch0 [A].
-Implicit Arguments Branch1 [A].
-
-Implicit Arguments Tget [A].
-Implicit Arguments Tadd [A].
-
-Implicit Arguments Tget_Tempty [A].
-Implicit Arguments Tget_Tadd [A].
-
-Implicit Arguments mkStore [A].
-Implicit Arguments index [A].
-Implicit Arguments contents [A].
-
-Implicit Arguments empty [A].
-Implicit Arguments get [A].
-Implicit Arguments push [A].
-
-Implicit Arguments get_empty [A].
-Implicit Arguments get_push_Full [A].
-
-Implicit Arguments Full [A].
-Implicit Arguments F_empty [A].
-Implicit Arguments F_push [A].
-Implicit Arguments In [A].
-
-Section Map. 
-
-Variables A B:Set.
-
-Variable f: A -> B.
-
-Fixpoint Tmap (T: Tree A) : Tree B :=
-match T with
-Tempty => Tempty
-| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2)
-| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
-end.
-
-Lemma Tget_Tmap: forall T i, 
-Tget i (Tmap T)= match Tget i T with PNone => PNone 
-| PSome a => PSome (f a) end.
-induction T;intro i;case i;simpl;auto.
-Defined.
-
-Lemma Tmap_Tadd: forall i a T,
-Tmap (Tadd i a T) = Tadd i (f a) (Tmap T).
-induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity.
-Defined.
-
-Definition map (S:Store A) : Store B :=
-mkStore (index S) (Tmap (contents S)).
-
-Lemma get_map: forall i S, 
-get i (map S)= match get i S with PNone => PNone 
-| PSome a => PSome (f a) end.
-destruct S;unfold get,map,contents,index;apply Tget_Tmap.
-Defined.
-
-Lemma map_push: forall a S, 
-map (push a S) = push (f a) (map S).
-intros a S.
-case S.
-unfold push,map,contents,index.
-intros;rewrite Tmap_Tadd;reflexivity.
-Defined.
-
-Theorem Full_map : forall S, Full S -> Full (map S).
-intros S F. 
-induction F.
-exact F_empty.
-rewrite map_push;constructor 2;assumption.
-Defined.
-
-End Map.
-
-Implicit Arguments Tmap [A B].
-Implicit Arguments map [A B].
-Implicit Arguments Full_map [A B f].
-
-Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
diff --git a/contrib/rtauto/Rtauto.v b/contrib/rtauto/Rtauto.v
deleted file mode 100644
index 98fca90f..00000000
--- a/contrib/rtauto/Rtauto.v
+++ /dev/null
@@ -1,398 +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        *)
-(************************************************************************)
-
-(* $Id: Rtauto.v 7639 2005-12-02 10:01:15Z gregoire $ *)
-
-
-Require Export List.
-Require Export Bintree.
-Require Import Bool.
-Unset Boxed Definitions.
-
-Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
-Ltac clean:=try (simpl;congruence).
-
-Inductive form:Set:=
-  Atom : positive -> form
-| Arrow : form -> form -> form
-| Bot
-| Conjunct : form -> form -> form 
-| Disjunct : form -> form -> form.
-
-Notation "[ n ]":=(Atom n).
-Notation "A =>> B":= (Arrow A B) (at level 59, right associativity).
-Notation "#" := Bot.
-Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity).
-Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity).
-
-Definition ctx := Store form.
-
-Fixpoint pos_eq (m n:positive) {struct m} :bool :=
-match m with
-  xI mm => match n with xI nn => pos_eq mm nn | _ => false end
-| xO mm => match n with xO nn => pos_eq mm nn | _ => false end
-| xH => match n with xH => true | _ => false end
-end. 
-
-Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
-induction m;simpl;destruct n;congruence ||
-(intro e;apply f_equal with positive;auto).
-Qed.
-
-Fixpoint form_eq (p q:form) {struct p} :bool :=
-match p with
-  Atom m => match q with Atom n => pos_eq m n | _ => false end
-| Arrow p1 p2 => 
-match q with 
-  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 
-| _ => false end
-| Bot => match q with Bot => true | _ => false end
-| Conjunct p1 p2 => 
-match q with 
-  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
-| _ => false 
-end
-| Disjunct p1 p2 => 
-match q with 
-  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
-| _ => false 
-end
-end. 
-
-Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
-induction p;destruct q;simpl;clean.
-intro h;generalize (pos_eq_refl _ _ h);congruence.
-caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
-caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
-caseq (form_eq p1 q1);clean.
-intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
-Qed.
-
-Implicit Arguments form_eq_refl [p q].
-
-Section with_env.
-
-Variable env:Store Prop.
-
-Fixpoint interp_form (f:form): Prop :=
-match f with
-[n]=> match get n env with PNone => True | PSome P => P end
-| A =>> B => (interp_form A) -> (interp_form B)
-| # => False
-| A //\\ B => (interp_form A) /\ (interp_form B)
-| A \\// B => (interp_form A) \/ (interp_form B)
-end.
-
-Notation "[[ A ]]" := (interp_form A).
-
-Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop :=
-match F with
-  F_empty => G
-| F_push H hyps0 F0 =>  interp_ctx hyps0 F0  ([[H]] -> G)
-end.
-
-Require Export BinPos.
-
-Ltac wipe := intros;simpl;constructor.  
-
-Lemma compose0 : 
-forall hyps F (A:Prop),
- A -> 
- (interp_ctx hyps F A).
-induction F;intros A H;simpl;auto.
-Qed.
-
-Lemma compose1 : 
-forall hyps F (A B:Prop),
- (A -> B) ->
- (interp_ctx hyps F A) ->
- (interp_ctx hyps F B).
-induction F;intros A B H;simpl;auto.
-apply IHF;auto.
-Qed.
-
-Theorem compose2 : 
-forall hyps F (A B C:Prop),
- (A -> B -> C) -> 
- (interp_ctx hyps F A) ->
- (interp_ctx hyps F B) ->
- (interp_ctx hyps F C).
-induction F;intros A B C H;simpl;auto.
-apply IHF;auto.
-Qed.
-
-Theorem compose3 : 
-forall hyps F (A B C D:Prop),
- (A -> B -> C -> D) -> 
- (interp_ctx hyps F A) -> 
- (interp_ctx hyps F B) ->
- (interp_ctx hyps F C) ->
- (interp_ctx hyps F D).
-induction F;intros A B C D H;simpl;auto.
-apply IHF;auto.
-Qed.
-
-Lemma weaken : forall hyps F f G,
- (interp_ctx hyps F G) ->
- (interp_ctx (hyps\f)  (F_push f hyps F) G).
-induction F;simpl;intros;auto.
-apply compose1 with ([[a]]-> G);auto.
-Qed.
-
-Theorem project_In : forall hyps F g, 
-In g hyps F ->
-interp_ctx hyps F [[g]].
-induction F;simpl.
-contradiction.
-intros g H;destruct H.
-subst;apply compose0;simpl;trivial.
-apply compose1 with [[g]];auto.
-Qed.
-
-Theorem project : forall hyps F p g, 
-get  p hyps = PSome g->
-interp_ctx hyps F [[g]].
-intros hyps F p g e; apply project_In.
-apply get_In with p;assumption.
-Qed.
-
-Implicit Arguments project [hyps p g].
-
-Inductive proof:Set :=
-  Ax : positive -> proof
-| I_Arrow : proof -> proof
-| E_Arrow : positive -> positive -> proof -> proof
-| D_Arrow : positive -> proof -> proof -> proof
-| E_False : positive -> proof
-| I_And: proof -> proof -> proof
-| E_And: positive -> proof -> proof
-| D_And: positive -> proof -> proof
-| I_Or_l: proof -> proof
-| I_Or_r: proof -> proof
-| E_Or: positive -> proof -> proof -> proof
-| D_Or: positive -> proof -> proof
-| Cut: form -> proof -> proof -> proof.
-
-Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
-
-Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
- match P with
-   Ax i => 
-     match get i hyps with
-         PSome F => form_eq F gl
- | _ => false
-    end 
-| I_Arrow p =>
-   match gl with
-      A  =>> B  => check_proof (hyps \ A) B p
-   | _ => false        
-    end 
-| E_Arrow i j p =>
-   match get i hyps,get j hyps with
-       PSome A,PSome (B =>>C) =>
-         form_eq A B && check_proof (hyps \ C) (gl) p
-    | _,_ => false
-    end
-| D_Arrow i p1 p2 => 
-   match get i hyps with
-      PSome  ((A =>>B)=>>C) =>
-     (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
-    | _ => false
-  end
-| E_False i =>
-  match get i hyps with
-    PSome # => true
-  | _ => false
-  end
-| I_And p1 p2 =>
-   match gl with
-      A //\\ B =>
-      check_proof hyps A p1 && check_proof hyps B p2
-      | _ => false
-      end
-| E_And i p => 
-   match get i hyps with
-      PSome  (A //\\ B) => check_proof (hyps \ A \ B) gl p
-    | _=> false
-   end
-| D_And i p => 
-   match get i hyps with
-      PSome  (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
-    | _=> false
-   end
-| I_Or_l p =>
-   match gl with
-      (A \\// B) => check_proof hyps A p
-      | _ => false
-      end
-| I_Or_r p =>
-   match gl with
-      (A \\// B) => check_proof hyps B p
-      | _ => false
-      end
-| E_Or i p1 p2 =>
-  match get i hyps with
-  PSome (A \\// B) =>
-  check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
-  | _=> false
-  end
-| D_Or i p => 
-   match get i hyps with
-      PSome  (A \\// B =>> C) =>
-      (check_proof (hyps \ A=>>C \ B=>>C) gl p)
-    | _=> false
-   end
-| Cut A p1 p2 =>
-  check_proof hyps A p1 && check_proof (hyps \ A) gl p2
-end. 
-
-Theorem interp_proof: 
-forall p hyps F gl, 
-check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].
-
-induction p;intros hyps F gl.
-
-(* cas Axiom *)
-Focus 1.
-simpl;caseq (get p hyps);clean.
-intros f nth_f e;rewrite <- (form_eq_refl e).
-apply project with p;trivial.
-
-(* Cas Arrow_Intro *)
-Focus 1.
-destruct gl;clean.
-simpl;intros.
-change (interp_ctx (hyps\gl1)  (F_push gl1 hyps F) [[gl2]]).
-apply IHp;try constructor;trivial.
-
-(* Cas Arrow_Elim *)
-Focus 1.
-simpl check_proof;caseq (get p hyps);clean.
-intros f ef;caseq (get p0 hyps);clean.
-intros f0 ef0;destruct f0;clean.
-caseq (form_eq f f0_1);clean.
-simpl;intros e check_p1.
-generalize  (project  F ef) (project  F ef0) 
-(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
-clear check_p1 IHp p p0 p1 ef ef0.
-simpl.
-apply compose3.
-rewrite (form_eq_refl e).
-auto.
-
-(* cas Arrow_Destruct *)
-Focus 1.
-simpl;caseq (get p1 hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
-intros check_p1 check_p2.
-generalize (project F ef)
-(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)   
-(F_push f1_1 (hyps \ f1_2 =>> f2)
- (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
-(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
-simpl;apply compose3;auto.
-
-(* Cas False_Elim *)
-Focus 1.
-simpl;caseq (get p hyps);clean.
-intros f ef;destruct f;clean.
-intros _; generalize (project F ef).
-apply compose1;apply False_ind.
-
-(* Cas And_Intro *)
-Focus 1.
-simpl;destruct gl;clean.
-caseq (check_proof hyps gl1 p1);clean.
-intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
-apply compose2 ;simpl;auto.
-
-(* cas And_Elim *)
-Focus 1.
-simpl;caseq (get p hyps);clean.
-intros f ef;destruct f;clean.
-intro check_p;generalize  (project F ef)
-(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
-simpl;apply compose2;intros [h1 h2];auto.
-
-(* cas And_Destruct *)
-Focus 1.
-simpl;caseq (get p hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-intro H;generalize  (project F ef)
-(IHp (hyps \ f1_1 =>> f1_2 =>> f2)  
-(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
-apply compose2;auto.
-
-(* cas Or_Intro_left *)
-Focus 1.
-destruct gl;clean.
-intro Hp;generalize (IHp hyps F gl1 Hp).
-apply compose1;simpl;auto.
-
-(* cas Or_Intro_right *)
-Focus 1.
-destruct gl;clean.
-intro Hp;generalize (IHp hyps F gl2 Hp).
-apply compose1;simpl;auto.
-
-(* cas Or_elim *)
-Focus 1.
-simpl;caseq (get p1 hyps);clean.
-intros f ef;destruct f;clean.
-caseq (check_proof (hyps \ f1) gl p2);clean.
-intros check_p1 check_p2;generalize (project F ef)
-(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
-(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
-simpl;apply compose3;simpl;intro h;destruct h;auto.
-
-(* cas Or_Destruct *)
-Focus 1.
-simpl;caseq (get p hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-intro check_p0;generalize (project F ef)
-(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
-(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) 
- (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
-apply compose2;auto.
-
-(* cas Cut *)
-Focus 1.
-simpl;caseq (check_proof hyps f p1);clean.
-intros check_p1 check_p2;
-generalize (IHp1 hyps F f check_p1) 
-(IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
-simpl; apply compose2;auto.
-Qed.
-
-Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
-intros gl prf;caseq (check_proof empty gl prf);intro check_prf.
-change (interp_ctx empty F_empty [[gl]]) ;
-apply interp_proof with prf;assumption.
-trivial.
-Qed.
-
-End with_env.
-
-(*
-(* A small example *)
-Parameters A B C D:Prop.
-Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
-exact (Reflect (empty \ A \ B \ C)
-([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
-(I_Arrow (E_And 1 (E_Or 3 
-  (I_Or_l (I_And (Ax 2) (Ax 4))) 
-  (I_Or_r (I_And (Ax 2) (Ax 4))))))).
-Qed.
-Print toto.
-*)
diff --git a/contrib/rtauto/g_rtauto.ml4 b/contrib/rtauto/g_rtauto.ml4
deleted file mode 100644
index d7bb6e31..00000000
--- a/contrib/rtauto/g_rtauto.ml4
+++ /dev/null
@@ -1,16 +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        *)
-(************************************************************************)
-
-(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*)
-
-(*i camlp4deps: "parsing/grammar.cma"  i*)
-
-TACTIC EXTEND rtauto
-  [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
-END
-
diff --git a/contrib/rtauto/proof_search.ml b/contrib/rtauto/proof_search.ml
deleted file mode 100644
index 98643e0f..00000000
--- a/contrib/rtauto/proof_search.ml
+++ /dev/null
@@ -1,546 +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        *)
-(************************************************************************)
-
-(* $Id: proof_search.ml 7233 2005-07-15 12:34:56Z corbinea $ *)
-
-open Term
-open Util  
-open Goptions
-
-type s_info=
-    {mutable created_steps     : int; (* node count*)
-     mutable pruned_steps      : int;
-     mutable created_branches  : int; (* path count *)
-     mutable pruned_branches   : int;
-     mutable created_hyps      : int; (* hyps count *)
-     mutable pruned_hyps       : int;
-     mutable branch_failures   : int;
-     mutable branch_successes  : int;
-     mutable nd_branching      : int}
-
-let s_info=
-    {created_steps    = 0; (* node count*)
-     pruned_steps     = 0;
-     created_branches = 0; (* path count *)
-     pruned_branches  = 0;
-     created_hyps     = 0; (* hyps count *)
-     pruned_hyps      = 0;
-     branch_failures  = 0;
-     branch_successes = 0;
-     nd_branching     = 0}
-
-let reset_info () =
-     s_info.created_steps    <- 0; (* node count*)
-     s_info.pruned_steps     <- 0;
-     s_info.created_branches <- 0; (* path count *)
-     s_info.pruned_branches  <- 0;
-     s_info.created_hyps     <- 0; (* hyps count *)
-     s_info.pruned_hyps      <- 0;
-     s_info.branch_failures  <- 0;
-     s_info.branch_successes <- 0;
-     s_info.nd_branching     <- 0
-
-let pruning = ref true
-
-let opt_pruning=
-  {optsync=true;
-   optname="Rtauto Pruning";
-   optkey=SecondaryTable("Rtauto","Pruning");
-   optread=(fun () -> !pruning);
-   optwrite=(fun b -> pruning:=b)}
-
-let _ = declare_bool_option opt_pruning 
-
-type form=
-    Atom of int
-  | Arrow of form * form
-  | Bot 
-  | Conjunct of form * form
-  | Disjunct of form * form
-
-type tag=int
-
-let decomp_form=function
-    Atom i -> Some (i,[])
-  | Arrow (f1,f2) -> Some (-1,[f1;f2]) 
-  | Bot -> Some (-2,[])
-  | Conjunct (f1,f2) -> Some (-3,[f1;f2])
-  | Disjunct (f1,f2) -> Some (-4,[f1;f2])
-
-module Fmap=Map.Make(struct type t=form let compare=compare end)
-
-type sequent = 
-    {rev_hyps: form Intmap.t;
-     norev_hyps: form Intmap.t;
-     size:int;
-     left:int Fmap.t;
-     right:(int*form) list Fmap.t;
-     cnx:(int*int*form*form) list;
-     abs:int option;
-     gl:form}
-
-let add_one_arrow i f1 f2 m=
-  try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with
-      Not_found ->
-	Fmap.add f1 [i,f2] m
-
-type proof =
-    Ax of int
-  | I_Arrow of proof
-  | E_Arrow of int*int*proof
-  | D_Arrow of int*proof*proof
-  | E_False of int
-  | I_And of proof*proof
-  | E_And of int*proof
-  | D_And of int*proof
-  | I_Or_l of proof
-  | I_Or_r of proof
-  | E_Or of int*proof*proof
-  | D_Or of int*proof
-  | Pop of int*proof
-      
-type rule =
-    SAx of int
-  | SI_Arrow 
-  | SE_Arrow of int*int
-  | SD_Arrow of int
-  | SE_False of int
-  | SI_And 
-  | SE_And of int
-  | SD_And of int
-  | SI_Or_l
-  | SI_Or_r
-  | SE_Or of int
-  | SD_Or of int
-
-let add_step s sub =
-  match s,sub with
-      SAx i,[] -> Ax i
-    | SI_Arrow,[p] -> I_Arrow p
-    | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p)
-    | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2)
-    | SE_False i,[] -> E_False i
-    | SI_And,[p1;p2] -> I_And(p1,p2)
-    | SE_And i,[p] -> E_And(i,p)
-    | SD_And i,[p] -> D_And(i,p)
-    | SI_Or_l,[p] -> I_Or_l p
-    | SI_Or_r,[p] -> I_Or_r p
-    | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
-    | SD_Or i,[p] -> D_Or(i,p)
-    | _,_ -> anomaly "add_step: wrong arity" 
-    
-type 'a with_deps = 
-    {dep_it:'a;
-     dep_goal:bool;
-     dep_hyps:Intset.t}
-
-type slice=
-    {proofs_done:proof list;
-     proofs_todo:sequent with_deps list;
-     step:rule;
-     needs_goal:bool;
-     needs_hyps:Intset.t;
-     changes_goal:bool;
-     creates_hyps:Intset.t}
-
-type state = 
-    Complete of proof
-  | Incomplete of sequent * slice list
-
-let project = function
-    Complete prf -> prf
-  | Incomplete (_,_) -> anomaly "not a successful state"
-
-let pop n prf =
-  let nprf=
-    match prf.dep_it with
-	Pop (i,p) -> Pop (i+n,p)
-      | p -> Pop(n,p) in
-    {prf with dep_it = nprf}
-
-let rec fill stack proof =
-  match stack with 
-      [] -> Complete proof.dep_it
-    | slice::super ->
-	if 
-	  !pruning &&
-	  slice.proofs_done=[] &&
-	  not (slice.changes_goal && proof.dep_goal) &&
-	  not (Intset.exists 
-		 (fun i -> Intset.mem i proof.dep_hyps) 
-		 slice.creates_hyps)
-	then
-	  begin
-	    s_info.pruned_steps<-s_info.pruned_steps+1;
-	    s_info.pruned_branches<- s_info.pruned_branches +
-	    List.length slice.proofs_todo;
-	    let created_here=Intset.cardinal slice.creates_hyps in
-	      s_info.pruned_hyps<-s_info.pruned_hyps+
-	      List.fold_left 
-		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) 
-		created_here slice.proofs_todo;
-	    fill super (pop (Intset.cardinal slice.creates_hyps) proof)
-	  end
-	else
-	  let dep_hyps=
-	    Intset.union slice.needs_hyps 
-	      (Intset.diff proof.dep_hyps slice.creates_hyps) in
-	  let dep_goal=
-	    slice.needs_goal || 
-	    ((not slice.changes_goal) && proof.dep_goal) in
-	  let proofs_done=
-	    proof.dep_it::slice.proofs_done in
-	    match slice.proofs_todo with
-		[] ->
-		  fill super {dep_it = 
-				add_step slice.step (List.rev proofs_done);
-			      dep_goal = dep_goal;
-			      dep_hyps = dep_hyps}
-	      | current::next ->
-		  let nslice=
-		    {proofs_done=proofs_done;
-		     proofs_todo=next;
-		     step=slice.step;
-		     needs_goal=dep_goal;
-		     needs_hyps=dep_hyps;
-		     changes_goal=current.dep_goal;
-		     creates_hyps=current.dep_hyps} in
-		    Incomplete (current.dep_it,nslice::super)
-
-let append stack (step,subgoals) =
-  s_info.created_steps<-s_info.created_steps+1;
-  match subgoals with 
-      [] -> 
-	s_info.branch_successes<-s_info.branch_successes+1;
-	fill stack {dep_it=add_step step.dep_it [];
-		    dep_goal=step.dep_goal;
-		    dep_hyps=step.dep_hyps}
-    | hd :: next ->
-	s_info.created_branches<-
-	s_info.created_branches+List.length next;
-	let slice=
-	  {proofs_done=[];
-	   proofs_todo=next;
-	   step=step.dep_it;
-	   needs_goal=step.dep_goal;
-	   needs_hyps=step.dep_hyps;
-	   changes_goal=hd.dep_goal;
-	   creates_hyps=hd.dep_hyps} in
-	  Incomplete(hd.dep_it,slice::stack)
-
-let embed seq=
-  {dep_it=seq;
-   dep_goal=false;
-   dep_hyps=Intset.empty}
-
-let change_goal seq gl=
-    {seq with 
-       dep_it={seq.dep_it with gl=gl};
-       dep_goal=true}
-	
-let add_hyp seqwd f=
-  s_info.created_hyps<-s_info.created_hyps+1;
-  let seq=seqwd.dep_it in
-  let num = seq.size+1 in
-  let left = Fmap.add f num seq.left in
-  let cnx,right=
-    try
-      let l=Fmap.find f seq.right in
-	List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx,
-	Fmap.remove f seq.right
-    with Not_found -> seq.cnx,seq.right in
-  let nseq=
-    match f with
-	Bot -> 
-	  {seq with 
-	     left=left;
-	     right=right;
-	     size=num;
-	     abs=Some num;
-	     cnx=cnx}
-      | Atom _ ->
-	  {seq with 
-	     size=num;
-	     left=left;
-	     right=right;
-	     cnx=cnx}
-      | Conjunct (_,_) | Disjunct (_,_) ->
-	  {seq with
-	     rev_hyps=Intmap.add num f seq.rev_hyps; 
-	     size=num;
-	     left=left;
-	     right=right;
-	     cnx=cnx}
-      | Arrow (f1,f2) ->
-	  let ncnx,nright=
-	    try 
-	      let i = Fmap.find f1 seq.left in	  
-		(i,num,f1,f2)::cnx,right
-	    with Not_found ->
-	      cnx,(add_one_arrow num f1 f2 right) in
-	    match f1 with
-		Conjunct (_,_) | Disjunct (_,_) ->
-		  {seq with
-		     rev_hyps=Intmap.add num f seq.rev_hyps; 
-		     size=num;
-		     left=left;
-		     right=nright;
-		     cnx=ncnx}
-	      | Arrow(_,_) ->
-		  {seq with
-		     norev_hyps=Intmap.add num f seq.norev_hyps; 
-		     size=num;
-		     left=left;
-		     right=nright;
-		     cnx=ncnx}
-	      | _ -> 
-		  {seq with
-		     size=num;
-		     left=left;
-		     right=nright;
-		     cnx=ncnx} in
-    {seqwd with 
-       dep_it=nseq;
-       dep_hyps=Intset.add num seqwd.dep_hyps}
-
-exception Here_is of (int*form)
-
-let choose m= 
-  try 
-    Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
-    raise Not_found
-  with 
-      Here_is (i,f) -> (i,f)
-
-
-let search_or seq=
-  match seq.gl with
-      Disjunct (f1,f2) -> 
-	[{dep_it = SI_Or_l;
-	  dep_goal = true;
-	  dep_hyps = Intset.empty},
-	 [change_goal (embed seq) f1];
-	 {dep_it = SI_Or_r;
-	  dep_goal = true;
-	  dep_hyps = Intset.empty},
-	 [change_goal (embed seq) f2]]
-    | _ -> []
-
-let search_norev seq=
-  let goals=ref (search_or seq) in
-  let add_one i f= 
-    match f with
-	Arrow (Arrow (f1,f2),f3) ->
-	  let nseq = 
-	    {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
-	    goals:=
-	      ({dep_it=SD_Arrow(i);
-		dep_goal=false;
-		dep_hyps=Intset.singleton i},
-	       [add_hyp 
-		  (add_hyp 
-		     (change_goal (embed nseq) f2) 
-		     (Arrow(f2,f3))) 
-		  f1;
-		add_hyp (embed nseq) f3]):: !goals
-      | _ -> anomaly "search_no_rev: can't happen" in
-    Intmap.iter add_one seq.norev_hyps;
-    List.rev !goals
-
-let search_in_rev_hyps seq=
-  try 
-    let i,f=choose seq.rev_hyps in
-    let make_step step=
-      {dep_it=step;
-       dep_goal=false;
-       dep_hyps=Intset.singleton i} in
-    let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
-      match f with
-	  Conjunct (f1,f2) -> 
-	    [make_step (SE_And(i)),
-	     [add_hyp (add_hyp (embed nseq) f1) f2]]
-	| Disjunct (f1,f2) ->
-	    [make_step (SE_Or(i)),
-	     [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]]
-	| Arrow (Conjunct (f1,f2),f0) -> 
-	    [make_step (SD_And(i)),
-	     [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]]
-	| Arrow (Disjunct (f1,f2),f0) ->
-	    [make_step (SD_Or(i)),
-	     [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
-	| _ -> anomaly "search_in_rev_hyps: can't happen"	      
-  with
-      Not_found -> search_norev seq
- 
-let search_rev seq=
-  match seq.cnx with
-      (i,j,f1,f2)::next -> 
-	let nseq=
-	  match f1 with
-	      Conjunct (_,_) | Disjunct (_,_) ->
-		{seq with cnx=next;
-		   rev_hyps=Intmap.remove j seq.rev_hyps}
-	    | Arrow (_,_) ->
-		{seq with cnx=next;
-		   norev_hyps=Intmap.remove j seq.norev_hyps}
-	    | _ ->
-		{seq with cnx=next} in
-	  [{dep_it=SE_Arrow(i,j);
-	    dep_goal=false;
-	    dep_hyps=Intset.add i (Intset.singleton j)},
-	   [add_hyp (embed nseq) f2]]
-    | [] -> 
-	match seq.gl with
-	    Arrow (f1,f2) ->
-	      [{dep_it=SI_Arrow;
-		dep_goal=true;
-		dep_hyps=Intset.empty},
-	       [add_hyp (change_goal (embed seq) f2) f1]]
-	  | Conjunct (f1,f2) ->
-	      [{dep_it=SI_And;
-		dep_goal=true;
-		dep_hyps=Intset.empty},[change_goal (embed seq) f1;
-					change_goal (embed seq) f2]]
-	  | _ -> search_in_rev_hyps seq
-
-let search_all seq=
-  match seq.abs with
-      Some i -> 
-	[{dep_it=SE_False (i);
-	  dep_goal=false;
-	  dep_hyps=Intset.singleton i},[]]
-    | None ->
-	try 
-	  let ax = Fmap.find seq.gl seq.left in
-	    [{dep_it=SAx (ax);
-	      dep_goal=true;
-	      dep_hyps=Intset.singleton ax},[]]
-	with Not_found -> search_rev seq
-
-let bare_sequent = embed 
-		     {rev_hyps=Intmap.empty;
-		      norev_hyps=Intmap.empty;
-		      size=0;
-		      left=Fmap.empty;
-		      right=Fmap.empty;
-		      cnx=[];
-		      abs=None;
-		      gl=Bot}
-		     
-let init_state hyps gl=
-  let init = change_goal bare_sequent gl in
-  let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in
-    Incomplete (goal.dep_it,[])
-
-let success= function
-    Complete _ -> true
-  | Incomplete (_,_) -> false
-
-let branching = function
-    Incomplete (seq,stack) ->
-      check_for_interrupt ();
-      let successors = search_all seq in
-      let _ =
-	match successors with
-	    [] -> s_info.branch_failures<-s_info.branch_failures+1
-	  | _::next ->  
-	      s_info.nd_branching<-s_info.nd_branching+List.length next in
-	List.map (append stack) successors
-  | Complete prf -> anomaly "already succeeded"
-
-open Pp 
-
-let rec pp_form =
-  function
-      Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2)
-    | f -> pp_or f
-and pp_or = function
-    Disjunct(f1,f2) ->
-      (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2)
-  | f -> pp_and f
-and pp_and = function
-    Conjunct(f1,f2) ->
-      (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2)
-  | f -> pp_atom f
-and pp_atom= function
-    Bot -> str "#"
-  | Atom n -> int n
-  | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" 
-
-let pr_form f = msg (pp_form f)
-
-let pp_intmap map = 
-  let pp=ref (str "") in  
-   Intmap.iter (fun i obj -> pp:= (!pp ++ 
-		pp_form obj ++ cut ())) map;
-    str "{ " ++ v 0 (!pp) ++ str " }"
-
-let pp_list pp_obj l=
-let pp=ref (str "") in
-  List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l;
-  str "[ " ++ !pp ++ str "]"
-
-let pp_mapint map =
-  let pp=ref (str "") in  
-   Fmap.iter (fun obj l -> pp:= (!pp ++ 
-		pp_form obj ++ str " => " ++ 
-				 pp_list (fun (i,f) -> pp_form f) l ++ 
-				 cut ()) ) map;
-    str "{ " ++ vb 0 ++  (!pp) ++ str " }" ++ close ()
-
-let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
-
-let pp_gl gl= cut () ++
-  str "{ " ++ vb 0 ++ 
-	      begin
-		match gl.abs with
-		    None -> str ""
-		  | Some i -> str "ABSURD" ++ cut ()
-	      end ++
-  str "rev   =" ++ pp_intmap gl.rev_hyps ++ cut () ++
-  str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
-  str "arrows=" ++ pp_mapint gl.right ++ cut () ++ 
-  str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++ 
-  str "goal  =" ++ pp_form gl.gl ++ str " }" ++ close ()
-
-let pp = 
-  function
-      Incomplete(gl,ctx) -> msgnl (pp_gl gl)
-    | _ -> msg (str "<complete>")
-
-let pp_info () = 
-  let count_info = 
-    if !pruning then
-	str "Proof steps : " ++ 
-	int s_info.created_steps ++ str " created / " ++ 
-	int s_info.pruned_steps ++ str " pruned" ++ fnl () ++
-	str "Proof branches : " ++ 
-	int s_info.created_branches ++ str " created / " ++ 
-	int s_info.pruned_branches ++ str " pruned" ++ fnl () ++
-	str "Hypotheses : " ++ 
-	int s_info.created_hyps ++ str " created / " ++ 
-	int s_info.pruned_hyps ++ str " pruned" ++ fnl ()
-    else
-	str "Pruning is off" ++ fnl () ++
-	str "Proof steps : " ++ 
-	int s_info.created_steps ++ str " created" ++ fnl () ++
-	str "Proof branches : " ++ 
-	int s_info.created_branches ++ str " created" ++ fnl () ++
-	str "Hypotheses : " ++ 
-	int s_info.created_hyps ++ str " created" ++ fnl () in
-    msgnl
-      ( str "Proof-search statistics :" ++ fnl () ++
-	count_info ++ 
-	str "Branch ends: " ++
-	int s_info.branch_successes ++ str " successes / " ++
-	int s_info.branch_failures ++ str " failures" ++ fnl () ++
-	str "Non-deterministic choices : " ++
-	int s_info.nd_branching ++ str " branches")
-
-
- 
diff --git a/contrib/rtauto/proof_search.mli b/contrib/rtauto/proof_search.mli
deleted file mode 100644
index eb11aeae..00000000
--- a/contrib/rtauto/proof_search.mli
+++ /dev/null
@@ -1,49 +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        *)
-(************************************************************************)
-
-(* $Id: proof_search.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
-
-type form=
-    Atom of int
-  | Arrow of form * form
-  | Bot 
-  | Conjunct of form * form
-  | Disjunct of form * form
-  
-type proof =
-    Ax of int
-  | I_Arrow of proof
-  | E_Arrow of int*int*proof
-  | D_Arrow of int*proof*proof
-  | E_False of int
-  | I_And of proof*proof
-  | E_And of int*proof
-  | D_And of int*proof
-  | I_Or_l of proof
-  | I_Or_r of proof
-  | E_Or of int*proof*proof
-  | D_Or of int*proof
-  | Pop of int*proof
-
-type state
-
-val project: state -> proof
-
-val init_state : ('a * form * 'b)  list -> form -> state
-
-val branching: state -> state list
-
-val success: state -> bool
-
-val pp: state -> unit
-
-val pr_form : form -> unit
-
-val reset_info : unit -> unit
-
-val pp_info : unit -> unit
diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml
deleted file mode 100644
index 81256f4a..00000000
--- a/contrib/rtauto/refl_tauto.ml
+++ /dev/null
@@ -1,337 +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        *)
-(************************************************************************)
-
-(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *)
-
-module Search = Explore.Make(Proof_search)
-
-open Util
-open Term
-open Termops
-open Names
-open Evd
-open Tacmach
-open Proof_search
-
-let force count lazc = incr count;Lazy.force lazc 
-
-let step_count = ref 0
-
-let node_count = ref 0  
-
-let logic_constant = 
-  Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] 
-
-let li_False = lazy (destInd (logic_constant "False"))
-let li_and = lazy (destInd (logic_constant "and"))
-let li_or =  lazy (destInd (logic_constant "or"))
-
-let data_constant =
-  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] 
-
-let l_true_equals_true = 
-  lazy (mkApp(logic_constant "refl_equal", 
-        [|data_constant "bool";data_constant "true"|]))
-
-let pos_constant =
-  Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"]
-
-let l_xI = lazy (pos_constant "xI")
-let l_xO = lazy (pos_constant "xO")
-let l_xH = lazy (pos_constant "xH")
-
-let store_constant = 
-  Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"]
-
-let l_empty = lazy (store_constant "empty")
-let l_push = lazy (store_constant "push")
-
-let constant=
-  Coqlib.gen_constant "refl_tauto" ["rtauto";"Rtauto"]
-
-let l_Reflect = lazy (constant "Reflect")
-
-let l_Atom = lazy (constant "Atom")
-let l_Arrow = lazy (constant "Arrow")
-let l_Bot = lazy (constant "Bot")
-let l_Conjunct = lazy (constant "Conjunct")
-let l_Disjunct = lazy (constant "Disjunct")
-
-let l_Ax = lazy (constant "Ax")
-let l_I_Arrow = lazy (constant "I_Arrow")
-let l_E_Arrow = lazy (constant "E_Arrow")
-let l_D_Arrow = lazy (constant "D_Arrow")
-let l_E_False = lazy (constant "E_False")
-let l_I_And = lazy (constant "I_And")
-let l_E_And = lazy (constant "E_And")
-let l_D_And = lazy (constant "D_And")
-let l_I_Or_l = lazy (constant "I_Or_l")
-let l_I_Or_r = lazy (constant "I_Or_r")
-let l_E_Or = lazy (constant "E_Or")
-let l_D_Or = lazy (constant "D_Or")
-
-
-let special_whd gl=
-  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
-
-let special_nf gl=
-  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
-
-type atom_env=
-    {mutable next:int;
-     mutable env:(constr*int) list}
-
-let make_atom atom_env term=
-  try
-    let (_,i)=
-      List.find (fun (t,_)-> eq_constr term t) atom_env.env
-    in Atom i
-  with Not_found ->
-    let i=atom_env.next in
-      atom_env.env <- (term,i)::atom_env.env;
-      atom_env.next<- i + 1;
-      Atom i
-
-let rec make_form atom_env gls term =
-  let normalize=special_nf gls in
-  let cciterm=special_whd gls term  in
-    match kind_of_term cciterm with
-	Prod(_,a,b) -> 
-	  if not (dependent (mkRel 1) b) && 
-	    Retyping.get_sort_family_of 
-	    (pf_env gls) (Tacmach.project gls) a = InProp
-	  then 
-	    let fa=make_form atom_env gls a in
-	    let fb=make_form atom_env gls b in
-	      Arrow (fa,fb)
-	  else
-	    make_atom atom_env (normalize term)
-      | Cast(a,_,_) -> 
-	  make_form atom_env gls a
-      | Ind ind ->
-	  if ind = Lazy.force li_False then
-	    Bot
-	  else
-	    make_atom atom_env (normalize term)
-      | App(hd,argv) when Array.length argv = 2 ->
-	  begin
-	    try 
-	      let ind = destInd hd in
-		if ind = Lazy.force li_and then
-		  let fa=make_form atom_env gls argv.(0) in
-		  let fb=make_form atom_env gls argv.(1) in
-		    Conjunct (fa,fb)
-		else if ind = Lazy.force li_or then
-		  let fa=make_form atom_env gls argv.(0) in
-		  let fb=make_form atom_env gls argv.(1) in
-		    Disjunct (fa,fb)
-		else make_atom atom_env (normalize term)
-	    with Invalid_argument _ -> make_atom atom_env (normalize term)
-	  end
-      | _ -> make_atom atom_env (normalize term)
-
-let rec make_hyps atom_env gls lenv = function
-    [] -> []
-  | (_,Some body,typ)::rest -> 
-      make_hyps atom_env gls (typ::body::lenv) rest  
-  | (id,None,typ)::rest ->
-      let hrec=
-	make_hyps atom_env gls (typ::lenv) rest in
-	if List.exists (dependent (mkVar id)) lenv || 
-	  (Retyping.get_sort_family_of 
-	     (pf_env gls) (Tacmach.project gls) typ <> InProp) 
-	then
-	  hrec 
-	else
-	  (id,make_form atom_env gls typ)::hrec
-
-let rec build_pos n =
-  if n<=1 then force node_count l_xH 
-  else if n land 1 = 0 then 
-    mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
-  else 
-    mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
-
-let rec build_form = function
-    Atom n -> mkApp (force node_count l_Atom,[|build_pos n|])
-  | Arrow (f1,f2) -> 
-      mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|])
-  | Bot -> force node_count l_Bot
-  | Conjunct (f1,f2) -> 
-      mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|])
-  | Disjunct (f1,f2) -> 
-      mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|])
-
-let rec decal k = function 
-    [] -> k
-  | (start,delta)::rest -> 
-      if k>start then
-	k - delta
-      else 
-	decal k rest
-
-let add_pop size d pops=
-  match pops with
-      [] -> [size+d,d]
-    | (_,sum)::_ -> (size+sum,sum+d)::pops  
-
-let rec build_proof pops size = 
-  function
-      Ax i ->
-	mkApp (force step_count l_Ax,
-	       [|build_pos (decal i pops)|])
-      | I_Arrow p -> 
-	  mkApp (force step_count l_I_Arrow,
-		 [|build_proof pops (size + 1) p|])
-      | E_Arrow(i,j,p) -> 
-	  mkApp (force step_count l_E_Arrow, 
-		 [|build_pos (decal i pops);
-		   build_pos (decal j pops);
-		   build_proof pops (size + 1) p|])
-      | D_Arrow(i,p1,p2) -> 
-	  mkApp (force step_count l_D_Arrow, 
-		 [|build_pos (decal i pops);
-		   build_proof pops (size + 2) p1;
-		   build_proof pops (size + 1) p2|])
-      | E_False i -> 
-	  mkApp (force step_count l_E_False,
-		 [|build_pos (decal i pops)|])
-      | I_And(p1,p2) -> 
-	  mkApp (force step_count l_I_And, 
-		 [|build_proof pops size p1;
-		   build_proof pops size p2|])
-      | E_And(i,p) -> 
-	  mkApp (force step_count l_E_And,
-		 [|build_pos (decal i pops);
-		   build_proof pops (size + 2) p|])
-      | D_And(i,p) -> 
-	  mkApp (force step_count l_D_And,
-		 [|build_pos (decal i pops);
-		   build_proof pops (size + 1) p|])
-      | I_Or_l(p) -> 
-	  mkApp (force step_count l_I_Or_l,
-		 [|build_proof pops size p|])
-      | I_Or_r(p) -> 
-	  mkApp (force step_count l_I_Or_r,
-		 [|build_proof pops size p|])
-      | E_Or(i,p1,p2) ->
-	  mkApp (force step_count l_E_Or, 
-		 [|build_pos (decal i pops);
-		   build_proof pops (size + 1) p1;
-		   build_proof pops (size + 1) p2|])
-      | D_Or(i,p) -> 
-	  mkApp (force step_count l_D_Or,
-		 [|build_pos (decal i pops);
-		   build_proof pops (size + 2) p|])
-      | Pop(d,p) ->
-	  build_proof (add_pop size d pops) size p 
-	    
-let build_env gamma=
-  List.fold_right (fun (p,_) e -> 
-		     mkApp(force node_count l_push,[|mkProp;p;e|])) 
-    gamma.env (mkApp (force node_count l_empty,[|mkProp|]))
-
-open Goptions
-
-let verbose = ref false
-
-let opt_verbose=
-  {optsync=true;
-   optname="Rtauto Verbose";
-   optkey=SecondaryTable("Rtauto","Verbose");
-   optread=(fun () -> !verbose);
-   optwrite=(fun b -> verbose:=b)}
-
-let _ = declare_bool_option opt_verbose 
-
-let check = ref false
-
-let opt_check=
-  {optsync=true;
-   optname="Rtauto Check";
-   optkey=SecondaryTable("Rtauto","Check");
-   optread=(fun () -> !check);
-   optwrite=(fun b -> check:=b)}
-
-let _ = declare_bool_option opt_check 
-
-open Pp
-
-let rtauto_tac gls=
-  Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"];
-  let gamma={next=1;env=[]} in
-  let gl=gls.it.evar_concl in
-  let _=
-    if Retyping.get_sort_family_of 
-      (pf_env gls) (Tacmach.project gls) gl <> InProp 
-    then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
-  let glf=make_form gamma gls gl in
-  let hyps=make_hyps gamma gls [gl] 
-      (Environ.named_context_of_val gls.it.evar_hyps) in
-  let formula=
-    List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in  
-  let search_fun = 
-    if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
-      Search.debug_depth_first
-    else 
-      Search.depth_first in
-  let _ = 
-    begin
-      reset_info ();
-      if !verbose then
-	msgnl (str "Starting proof-search ...");
-    end in
-  let search_start_time = System.get_time () in
-  let prf = 
-    try project (search_fun (init_state [] formula)) 
-    with Not_found ->
-      errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in
-  let search_end_time = System.get_time () in
-  let _ = if !verbose then
-    begin
-      msgnl (str "Proof tree found in " ++ 
-	     System.fmt_time_difference search_start_time search_end_time);
-      pp_info ();
-      msgnl (str "Building proof term ... ")
-    end in
-  let build_start_time=System.get_time () in
-  let _ = step_count := 0; node_count := 0 in
-  let main = mkApp (force node_count l_Reflect,
-		    [|build_env gamma;
-		      build_form formula;
-		      build_proof [] 0 prf|]) in
-  let term=
-    Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
-  let build_end_time=System.get_time () in
-  let _ = if !verbose then
-    begin
-      msgnl (str "Proof term built in " ++ 
-	     System.fmt_time_difference build_start_time build_end_time ++
-	     fnl () ++
-	     str "Proof size : " ++ int !step_count ++ 
-	     str " steps" ++ fnl () ++
-	     str "Proof term size : " ++ int (!step_count+ !node_count) ++
-	     str " nodes (constants)" ++ fnl () ++
-	     str "Giving proof term to Coq ... ")
-    end in
-  let tac_start_time = System.get_time () in
-  let result=
-    if !check then 
-      Tactics.exact_check term gls
-    else
-      Tactics.exact_no_check term gls in
-  let tac_end_time = System.get_time () in
-  let _ = 
-    if !check then msgnl (str "Proof term type-checking is on");
-    if !verbose then
-      msgnl (str "Internal tactic executed in " ++ 
-	     System.fmt_time_difference tac_start_time tac_end_time) in
-    result
-
diff --git a/contrib/rtauto/refl_tauto.mli b/contrib/rtauto/refl_tauto.mli
deleted file mode 100644
index 480dbb30..00000000
--- a/contrib/rtauto/refl_tauto.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        *)
-(************************************************************************)
-(* $Id: refl_tauto.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
-
-(* raises Not_found if no proof is found *)
-
-type atom_env=
-    {mutable next:int;
-     mutable env:(Term.constr*int) list}
-
-val make_form : atom_env ->
-    Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form
-
-val make_hyps :
-    atom_env ->
-    Proof_type.goal Tacmach.sigma ->
-    Term.types list ->
-    (Names.identifier * Term.types option * Term.types) list ->
-    (Names.identifier * Proof_search.form) list
-
-val rtauto_tac : Proof_type.tactic
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
deleted file mode 100644
index 601cabe0..00000000
--- a/contrib/setoid_ring/ArithRing.v
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Mult.
-Require Import BinNat.
-Require Import Nnat.
-Require Export Ring.
-Set Implicit Arguments.
-
-Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
- Proof.
-  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
-  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
-  exact mult_plus_distr_r. 
- Qed.
-
-Lemma nat_morph_N : 
-   semi_morph 0 1 plus mult (eq (A:=nat)) 
-          0%N 1%N Nplus Nmult Neq_bool nat_of_N.
-Proof.
-  constructor;trivial.
-  exact nat_of_Nplus.
-  exact nat_of_Nmult.
-  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
-Qed.
-
-Ltac natcst t :=
-  match isnatcst t with
-    true => constr:(N_of_nat t)
-  | _ => constr:InitialRing.NotConstant
-  end.
-
-Ltac Ss_to_add f acc :=
-  match f with
-  | S ?f1 => Ss_to_add f1 (S acc)
-  | _ => constr:(acc + f)%nat
-  end.
-
-Ltac natprering :=
-  match goal with
-    |- context C [S ?p] =>
-    match p with
-      O => fail 1 (* avoid replacing 1 with 1+0 ! *)
-    | p => match isnatcst p with 
-           | true => fail 1
-           | false => let v := Ss_to_add p (S 0) in
-                         fold v; natprering
-           end
-    end
-  | _ => idtac
-  end.
-
-Add Ring natr : natSRth
-  (morphism nat_morph_N, constants [natcst], preprocess [natprering]).
-
diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v
deleted file mode 100644
index 50902004..00000000
--- a/contrib/setoid_ring/BinList.v
+++ /dev/null
@@ -1,93 +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        *)
-(************************************************************************)
-
-Set Implicit Arguments.
-Require Import BinPos.
-Require Export List.
-Require Export ListTactics.
-Open Local Scope positive_scope.
-
-Section MakeBinList.
- Variable A : Type.
- Variable default : A.
-
- Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
-  match p with
-  | xH => tail l
-  | xO p => jump p (jump p l)
-  | xI p  => jump p (jump p (tail l))
-  end.
-
- Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
-  match p with
-  | xH => hd default l
-  | xO p => nth p (jump p l)
-  | xI p => nth p (jump p (tail l))
-  end. 
-
- Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
- Proof. 
-  induction j;simpl;intros.
-  repeat rewrite IHj;trivial.
-  repeat rewrite IHj;trivial.
-  trivial.
- Qed.
-
- Lemma jump_Psucc : forall j l, 
-  (jump (Psucc j) l) = (jump 1 (jump j l)).
- Proof.
-  induction j;simpl;intros.
-  repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial.
-  repeat rewrite jump_tl;trivial.
-  trivial.
- Qed.
-
- Lemma jump_Pplus : forall i j l, 
-  (jump (i + j) l) = (jump i (jump j l)).
- Proof.
-  induction i;intros.
-  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi;trivial.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
- Qed.
-
- Lemma jump_Pdouble_minus_one : forall i l,
-  (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
- Proof.
-  induction i;intros;simpl.
-  repeat rewrite jump_tl;trivial.
-  rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial.
-  trivial.
- Qed.
-
- 
- Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
- Proof.
-  induction p;simpl;intros.
-  rewrite <-jump_tl;rewrite IHp;trivial.
-  rewrite <-jump_tl;rewrite IHp;trivial.
-  trivial.
- Qed.
-
- Lemma nth_Pdouble_minus_one :
-  forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
- Proof.
-  induction p;simpl;intros.
-  repeat rewrite jump_tl;trivial.
-  rewrite jump_Pdouble_minus_one.
-  repeat rewrite <- jump_tl;rewrite IHp;trivial.
-  trivial.
- Qed.
-
-End MakeBinList.
-
-
diff --git a/contrib/setoid_ring/Field.v b/contrib/setoid_ring/Field.v
deleted file mode 100644
index a944ba5f..00000000
--- a/contrib/setoid_ring/Field.v
+++ /dev/null
@@ -1,10 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Field_theory.
-Require Export Field_tac.
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
deleted file mode 100644
index cccee604..00000000
--- a/contrib/setoid_ring/Field_tac.v
+++ /dev/null
@@ -1,406 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Ring_tac BinList Ring_polynom InitialRing.
-Require Export Field_theory.
-
- (* syntaxification *)
- Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := 
- let rec mkP t :=
-    match Cst t with
-    | InitialRing.NotConstant =>
-        match t with 
-        | (radd ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEadd e1 e2)
-        | (rmul ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEmul e1 e2)
-        | (rsub ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEsub e1 e2)
-        | (ropp ?t1) =>
-          let e1 := mkP t1 in constr:(FEopp e1)
-        | (rdiv ?t1 ?t2) => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEdiv e1 e2)
-        | (rinv ?t1) =>
-          let e1 := mkP t1 in constr:(FEinv e1)
-        | (rpow ?t1 ?n) =>
-          match CstPow n with
-          | InitialRing.NotConstant => 
-            let p := Find_at t fv in constr:(@FEX C p)
-          | ?c => let e1 := mkP t1 in constr:(FEpow e1 c)
-          end
-  
-        | _ =>
-          let p := Find_at t fv in constr:(@FEX C p)
-        end
-    | ?c => constr:(FEc c)
-    end
- in mkP t.
-
-Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
- let rec TFV t fv :=
-  match Cst t with
-  | InitialRing.NotConstant =>
-      match t with
-      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (opp ?t1) => TFV t1 fv
-      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (inv ?t1) => TFV t1 fv
-      | (pow ?t1 ?n) =>
-        match CstPow n with
-        | InitialRing.NotConstant => AddFvTail t fv
-        | _ => TFV t1 fv
-        end
-      | _ => AddFvTail t fv
-      end
-  | _ => fv
-  end 
- in TFV t fv.
-
-Ltac ParseFieldComponents lemma req :=
-  match type of lemma with
-  | context [
-     (*   PCond _ _ _  _ _ _ _  _ _  _ _ -> *)
-        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.
-
-(* simplifying the non-zero condition... *)
-
-Ltac fold_field_cond req :=
-  let rec fold_concl t :=
-    match t with
-      ?x /\ ?y =>
-        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
-    | req ?x ?y -> False => constr:(~ req x y)
-    | _ => t
-    end in
-  match goal with
-    |- ?t => let ft := fold_concl t in change ft
-  end.
-
-Ltac simpl_PCond req :=
-  protect_fv "field_cond";
-  (try exact I);
-  fold_field_cond req.
-
-Ltac simpl_PCond_BEURK req :=
-  protect_fv "field_cond";
-  fold_field_cond req.
-
-(* Rewriting (field_simplify) *)
-Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
-  let Main radd rmul rsub ropp rdiv rinv rpow C :=
-    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let mkFE := 
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let simpl_field H := (protect_fv "field" in H;f H) in
-    let lemma_tac fv RW_tac :=
-      let rr_lemma := fresh "f_rw_lemma" in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let vlpe := fresh "list_hyp" in
-      let vlmp := fresh "list_hyp_norm" in
-      let vlmp_eq := fresh "list_hyp_norm_eq" in
-      let prh := proofHyp_tac lH in
-      pose (vlpe := lpe);
-      match type of lemma with
-      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] =>
-        compute_assertion vlmp_eq vlmp 
-            (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
-         (assert (rr_lemma := lemma 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 "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 req Main.
-
-Ltac Field_simplify_gen f := 
-     fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
-       pre(); 
-       Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req 
-                  ring_subst_niter lH rl; 
-      post().
-
-Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H).
-
-Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
-  let G := Get_goal in
-  field_lookup Field_simplify [] rl G.
-
-Tactic Notation (at level 0) 
-  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
-  let G := Get_goal in
-  field_lookup Field_simplify [lH] rl G.
-
-Tactic Notation "field_simplify" 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 [] 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:= 
-   Field_simplify_gen ltac:(fun H => rewrite H in hyp).
-
-Tactic Notation (at level 0) 
-  "field_simplify" constr_list(rl) "in" hyp(h) :=
-  let t := type of h in
-  field_lookup (Field_simplify_in h) [] rl t.
-
-Tactic Notation (at level 0) 
-  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
-  let t := type of h in
-  field_lookup (Field_simplify_in h) [lH] rl t.
-*)
-
-(** Generic tactic for solving equations *)
-
-Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
-  let Main radd rmul rsub ropp rdiv rinv rpow C :=
-    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let mkFE := 
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-    let rec ParseExpr ilemma :=
-      match type of ilemma with
-        forall nfe, ?fe = nfe -> _ =>
-          (fun t => 
-            let x := fresh "fld_expr" in 
-            let H := fresh "norm_fld_expr" in
-            compute_assertion H x fe;
-            ParseExpr (ilemma x H) t;
-            try clear x H)
-      | _ => (fun t => t ilemma)
-      end in
-    let Main_eq t1 t2 :=
-      let fv := FV_hypo_tac mkFV req lH in
-      let fv := mkFFV t1 fv in
-      let fv := mkFFV t2 fv in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let prh := proofHyp_tac lH in
-      let vlpe := fresh "list_hyp" in
-      let fe1 := mkFE t1 fv in
-      let fe2 := mkFE t2 fv in
-      pose (vlpe := lpe);
-      let nlemma := fresh "field_lemma" in
-      (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
-       || fail "field anomaly:failed to build lemma"); 
-      ParseExpr nlemma
-         ltac:(fun ilemma =>
-                  apply ilemma 
-                  || fail "field anomaly: failed in applying lemma";
-                  [ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
-      clear vlpe nlemma in
-    OnEquation req Main_eq in
-  ParseFieldComponents lemma req Main.
-
-(* solve completely a field equation, leaving non-zero conditions to be
-   proved (field) *)
-
-Ltac FIELD :=
-   let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
-   fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl =>
-       pre(); 
-       Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req 
-         Ring_tac.ring_subst_niter lH;
-       try exact I;
-       post().
- 
-Tactic Notation (at level 0) "field" :=
-  let G := Get_goal in
-  field_lookup FIELD [] G.
-
-Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
-  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 =>
-       pre(); 
-       Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok 
-          req Ring_tac.ring_subst_niter lH;
-       post().
-
-Tactic Notation (at level 0) "field_simplify_eq" :=  
-  let G := Get_goal in
-  field_lookup FIELD_SIMPL [] G.
-
-Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=  
-  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;   
-    match type of hyp with
-    | req ?t1 ?t2 =>
-      let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
-      let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
-      let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-      let mkFE := 
-        mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
-      let rec ParseExpr ilemma :=
-        match type of ilemma with
-        |  forall nfe, ?fe = nfe -> _ =>
-          (fun t => 
-            let x := fresh "fld_expr" in 
-            let H := fresh "norm_fld_expr" in
-            compute_assertion H x fe;
-            ParseExpr (ilemma x H) t;
-            try clear H x)
-        | _ => (fun t => t ilemma)
-        end in
-      let fv := FV_hypo_tac mkFV req lH in
-      let fv := mkFFV t1 fv in
-      let fv := mkFFV t2 fv in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let prh := proofHyp_tac lH in
-      let fe1 := mkFE t1 fv in
-      let fe2 := mkFE t2 fv in
-      let vlpe := fresh "vlpe" in
-      ParseExpr (lemma n fv lpe fe1 fe2 prh)
-         ltac:(fun ilemma =>
-             match type of ilemma with
-             | req _ _ ->  _ -> ?EQ => 
-               let tmp := fresh "tmp" in
-               assert (tmp : EQ);
-               [ apply ilemma; 
-                 [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req]
-               | protect_fv "field" in tmp;
-                 generalize tmp;clear tmp ];
-               clear hyp  
-             end)
-     end in
-  ParseFieldComponents lemma req Main.
-
-Ltac FIELD_SIMPL_EQ :=
- fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
-       pre(); 
-       Field_simplify_eq cst_tac pow_tac lemma cond_ok req
-         Ring_tac.ring_subst_niter lH;
-       post().
-
-Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
-  let t := type of H in
-  generalize H;
-  field_lookup FIELD_SIMPL_EQ [] t;
-  [ try exact I
-  | clear H;intro H].
-
-
-Tactic Notation (at level 0) 
-  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=  
-  let t := type of H in
-  generalize H;
-  field_lookup FIELD_SIMPL_EQ [lH] t;
-  [ try exact I
-  |clear H;intro H].
- 
-(* Adding a new field *)
-
-Ltac ring_of_field f :=
-  match type of f with
-  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
-  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
-  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
-  end.
-
-Ltac coerce_to_almost_field set ext f :=
-  match type of f with
-  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
-  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
-  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
-  end.
-
-Ltac field_elements set ext fspec 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 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 _ 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
deleted file mode 100644
index b2e5cc4b..00000000
--- a/contrib/setoid_ring/Field_theory.v
+++ /dev/null
@@ -1,1944 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Ring.
-Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
-Require Import ZArith_base.
-(*Require Import Omega.*)
-Set Implicit Arguments.
-
-Section MakeFieldPol.
-
-(* Field elements *)     
- Variable R:Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
- Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
- Variable req : R -> R -> Prop.
-
- Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
- Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
- Notation "x == y" := (req x y) (at level 70, no associativity).
-
- (* Equality properties *)
- Variable Rsth : Setoid_Theory R req.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
- Variable SRinv_ext : forall p q, p == q ->  / p == / q.
- 
- (* Field properties *)
-  Record almost_field_theory : Prop := mk_afield {
-    AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
-    AF_1_neq_0 : ~ 1 == 0;
-    AFdiv_def : forall p q, p / q == p * / q;
-    AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
-  }.
-
-Section AlmostField.
-
- Variable AFth : almost_field_theory.
- Let ARth := AFth.(AF_AR).
- Let rI_neq_rO := AFth.(AF_1_neq_0).
- Let rdiv_def := AFth.(AFdiv_def).
- Let rinv_l := AFth.(AFinv_l).
-
- (* Coefficients *) 
- Variable C: Type.
- Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool. 
- Variable phi : C -> R.
-
- Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
-                               cO cI cadd cmul csub copp ceqb phi.
-
-Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
-Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-case (ceqb c1 c2); auto.
-Qed.
-
-
- (* C notations *)		 
- Notation "x +! y" := (cadd x y) (at level 50).
- Notation "x *! y " := (cmul x y) (at level 40).
- Notation "x -! y " := (csub x y) (at level 50).
- Notation "-! x" := (copp x) (at level 35).
- Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
- Notation "[ x ]" := (phi x) (at level 0).
-
-
- (* 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.
-  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
-  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
-  Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
- 
-Let eq_trans := Setoid.Seq_trans _ _ Rsth.
-Let eq_sym := Setoid.Seq_sym _ _ Rsth.
-Let eq_refl := Setoid.Seq_refl _ _ Rsth.
-
-Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
-Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
-             (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
-Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
-             (ARmul_1_l  ARth) (ARmul_0_l  ARth) 
-             (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
-             (ARopp_mul_l ARth) (ARopp_add  ARth) 
-             (ARsub_def  ARth) .
-
- (* Power coefficients *)
- Variable Cpow : Set.
- Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R. 
- Variable pow_th : power_theory rI rmul req Cp_phi rpow.
- (* sign function *)
- Variable get_sign : C -> option C.
- Variable get_sign_spec : sign_theory 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 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).
-
-(* add abstract semi-ring to help with some proofs *)
-Add Ring Rring : (ARth_SRth ARth).
-
-
-(* additional ring properties *)
-
-Lemma rsub_0_l : forall r, 0 - r == - r.
-intros; rewrite (ARsub_def ARth) in |- *;ring.
-Qed.
-
-Lemma rsub_0_r : forall r, r - 0 == r.
-intros; rewrite (ARsub_def ARth) in |- *.
-rewrite (ARopp_zero Rsth Reqe ARth) in |- *;  ring.
-Qed.
-
-(***************************************************************************
-                                                                          
-                       Properties of division                             
-                                                                          
-  ***************************************************************************)
- 
-Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
-intros p q H.
-rewrite rdiv_def in |- *.
-transitivity (/ q * q * p); [  ring | idtac ].
-rewrite rinv_l in |- *; auto.
-Qed.
-Hint Resolve rdiv_simpl .
- 
-Theorem SRdiv_ext:
- forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 ->  p1 / q1 == p2 / q2.
-intros p1 p2 H q1 q2 H0.
-transitivity (p1 * / q1); auto.
-transitivity (p2 * / q2); auto.
-Qed.
-Hint Resolve SRdiv_ext .
-
- Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed.
-
-Lemma rmul_reg_l : forall p q1 q2,
-  ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
-intros.
-rewrite <- (@rdiv_simpl q1 p) in |- *; trivial.
-rewrite <- (@rdiv_simpl q2 p) in |- *; trivial.
-repeat rewrite rdiv_def in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
-auto.
-Qed.
-
-Theorem field_is_integral_domain : forall r1 r2,
-  ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
-Proof.
-red in |- *; intros.
-apply H0.
-transitivity (1 * r2); auto.
-transitivity (/ r1 * r1 * r2); auto.
-rewrite <- (ARmul_assoc ARth) in |- *.
-rewrite H1 in |- *.
-apply ARmul_0_r with (1 := Rsth) (2 := ARth).
-Qed.
-
-Theorem ropp_neq_0 : forall r,
-  ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
-intros.
-setoid_replace (- r) with (- (1) * r).
- apply field_is_integral_domain; trivial.
- rewrite <- (ARopp_mul_l ARth) in |- *.
-   rewrite (ARmul_1_l ARth) in |- *.
-   reflexivity.
-Qed.
-
-Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
-intros.
-rewrite (AFdiv_def AFth) in |- *.
-rewrite (ARmul_comm ARth) in |- *.
-apply (AFinv_l AFth).
-trivial.
-Qed.
-
-Theorem rdiv1: forall r,  r == r / 1.
-intros r; transitivity (1 * (r / 1)); auto.
-Qed.
- 
-Theorem rdiv2:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
-Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl in |- *; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
-apply (Radd_ext Reqe).
- transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
- transitivity (r2 * (r4 * (r3 / r4))); auto.
-   transitivity (r2 * r3); auto.
-Qed.
-
-
-Theorem rdiv2b:
- forall r1 r2 r3 r4 r5,
- ~ (r2*r5) == 0 ->
- ~ (r4*r5) == 0 ->
- r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
-Proof.
-intros r1 r2 r3 r4 r5 H H0.
-assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
-assert (HH4: ~ r2 * (r4 * r5) == 0) 
-   by complete (repeat apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
-rewrite rdiv_simpl in |- *; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
-apply (Radd_ext Reqe).
- transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
- transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
-Qed.
-
-Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
-intros r1 r2.
-transitivity (- (r1 * / r2)); auto.
-transitivity (- r1 * / r2); auto.
-Qed.
-Hint Resolve rdiv5 .
-
-Theorem rdiv3:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-transitivity (r1 / r2 + - (r3 / r4)); auto.
-transitivity (r1 / r2 + - r3 / r4); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto.
-apply rdiv2; auto.
-apply SRdiv_ext; auto.
-transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
-Qed.
-
-
-Theorem rdiv3b:
- forall r1 r2 r3 r4 r5,
- ~ (r2 * r5) == 0 ->
- ~ (r4 * r5) == 0 ->
- r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
-Proof.
-intros r1 r2 r3 r4 r5 H H0.
-transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
-transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
-apply rdiv2b; auto; try ring.
-apply (SRdiv_ext); auto.
-transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
-Qed.
-
-Theorem rdiv6:
- forall r1 r2,
- ~ r1 == 0 -> ~ r2 == 0 ->  / (r1 / r2) == r2 / r1.
-intros r1 r2 H H0.
-assert (~ r1 / r2 == 0) as Hk.
- intros H1; case H.
-   transitivity (r2 * (r1 / r2)); auto.
-   rewrite H1 in |- *;  ring.
- apply rmul_reg_l with (r1 / r2); auto.
-   transitivity (/ (r1 / r2) * (r1 / r2)); auto.
-   transitivity 1; auto.
-   repeat rewrite rdiv_def in |- *.
-   transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
-   repeat rewrite rinv_l in |- *; auto.
-Qed.
-Hint Resolve rdiv6 .
- 
- Theorem rdiv4:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
-Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl in |- *; trivial.
-transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
-repeat rewrite rdiv_simpl in |- *; trivial.
-Qed.
-
- Theorem 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 ->
- ~ r4 == 0 ->
- (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
-Proof.
-intros.
-rewrite (rdiv_def (r1 / r2)) in |- *.
-rewrite rdiv6 in |- *; trivial.
-apply rdiv4; trivial.
-Qed.
-
-Theorem 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.
-transitivity (0 * / r2); auto.
-Qed.
-
-
-Theorem cross_product_eq : forall r1 r2 r3 r4,
-  ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
-intros.
-transitivity (r1 / r2 * (r4 / r4)).
- rewrite rdiv_r_r in |- *; trivial.
-   symmetry  in |- *.
-   apply (ARmul_1_r Rsth ARth).
- rewrite rdiv4 in |- *; trivial.
-   rewrite H1 in |- *.
-   rewrite (ARmul_comm ARth r2 r4) in |- *.
-   rewrite <- rdiv4 in |- *; trivial.
-   rewrite rdiv_r_r in |- * by trivial.
-  apply (ARmul_1_r Rsth ARth).
-Qed.
-
-(***************************************************************************
-                                                                          
-                       Some equality test                             
-                                                                          
-  ***************************************************************************)
-
-Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
- match p1, p2 with
-   xH, xH => true
-  | xO p3, xO p4 => positive_eq p3 p4
-  | xI p3, xI p4 => positive_eq p3 p4
-  | _, _ => false
- end.
- 
-Theorem positive_eq_correct:
- forall p1 p2,  if positive_eq p1 p2 then p1 = p2 else p1 <> p2.
-intros p1; elim p1;
- (try (intros p2; case p2; simpl; auto; intros; discriminate)).
-intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
-generalize (rec p4); case (positive_eq p3 p4); auto.
-intros H1; apply f_equal with ( f := xI ); auto.
-intros H1 H2; case H1; injection H2; auto.
-intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
-generalize (rec p4); case (positive_eq p3 p4); auto.
-intros H1; apply f_equal with ( f := xO ); auto.
-intros H1 H2; case H1; injection H2; auto.
-Qed.
- 
-Definition N_eq n1 n2 := 
-  match n1, n2 with
-  | N0, N0 => true
-  | Npos p1, Npos p2 => positive_eq p1 p2
-  | _, _ => false
-  end.
-
-Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2.
-Proof.
-  intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail).
-  assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2);
-     [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial].
-Qed.
-
-(* equality test *)
-Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
- match e1, e2 with
-   PEc c1, PEc c2 => ceqb c1 c2
-  | PEX p1, PEX p2 => positive_eq p1 p2
-  | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEopp e3, PEopp e4 => PExpr_eq e3 e4
-  | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false
-  | _, _ => false
- end.
- 
-Add Morphism (pow_pos rmul) : pow_morph.
-intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
-Qed.
-
-Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph.
-intros x y H [|p];simpl;auto. apply pow_morph;trivial.
-Qed.
-(*
-Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n).
-Proof.
-  intros; repeat rewrite pow_th.(rpow_pow_N).
-  destruct n;simpl. apply eq_refl.
-  induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl.
-Qed.
-*)
-Theorem PExpr_eq_semi_correct:
- forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
-intros l e1; elim e1.
-intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros c2; apply (morph_eq CRmorph).
-intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2);
- (try (intros; discriminate)); intros H; rewrite H; auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
-intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); auto.
-intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
-intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4);
-intros;try discriminate.
-repeat rewrite  pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto.
-Qed.
-
-(* add *)
-Definition NPEadd e1 e2 :=
-  match e1, e2 with
-    PEc c1, PEc c2 => PEc (cadd c1 c2)
-  | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
-    (* Peut t'on factoriser ici ??? *)
-  | _, _ => PEadd e1 e2
-  end.
-
-Theorem NPEadd_correct:
- forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
-Proof.
-intros l e1 e2.
-destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl;
- try (ring [(morph0 CRmorph)]).
- apply (morph_add CRmorph).
-Qed.
-
-Definition NPEpow x n :=
-  match n with
-  | N0 => PEc cI
-  | Npos p =>
-    if positive_eq p xH then x else
-    match x with 
-    | PEc c => 
-      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)  
-    | _ => PEpow x n         
-    end
-  end.
-
-Theorem NPEpow_correct : forall l e n,
-  NPEeval l (NPEpow e n) == NPEeval l (PEpow e n).
-Proof.
- destruct n;simpl.
- rewrite pow_th.(rpow_pow_N);simpl;auto.
- generalize (positive_eq_correct p xH).
- destruct (positive_eq p 1);intros.
- rewrite H;rewrite  pow_th.(rpow_pow_N). trivial.
- clear H;destruct e;simpl;auto.
- repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
- symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
- symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
- induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
-Qed.
-
-(* mul *) 
-Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
-  match x, y with
-    PEc c1, PEc c2 => PEc (cmul c1 c2)
-  | PEc c, _ =>
-      if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
-  |  _, PEc c =>
-      if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
-  | PEpow e1 n1, PEpow e2 n2 =>
-      if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
-  | _, _ => PEmul x y
-  end.
-
-Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
-induction p;simpl;auto;try ring [IHp].
-Qed.
-          
-Theorem NPEmul_correct : forall l e1 e2,
-  NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
-induction e1;destruct e2; simpl in |- *;try reflexivity;
- repeat apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity;
- try ring [(morph0 CRmorph) (morph1 CRmorph)].
- apply (morph_mul CRmorph).
-assert (H:=N_eq_correct n n0);destruct (N_eq n n0).
-rewrite NPEpow_correct. simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite IHe1;rewrite <- H;destruct n;simpl;try ring.
-apply pow_pos_mul.
-simpl;auto.
-Qed.
-
-(* sub *)
-Definition NPEsub e1 e2 :=
-  match e1, e2 with
-    PEc c1, PEc c2 => PEc (csub c1 c2)
-  | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
-     (* Peut-on factoriser ici *)
-  | _, _ => PEsub e1 e2
-  end.
-
-Theorem NPEsub_correct:
- forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
-intros l e1 e2.
-destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
- try rewrite (morph0 CRmorph) in |- *; try reflexivity;
- try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
-apply (morph_sub CRmorph).
-Qed.
- 
-(* opp *)
-Definition NPEopp e1 :=
-  match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
- 
-Theorem NPEopp_correct:
- forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
-intros l e1; case e1; simpl; auto.
-intros; apply (morph_opp CRmorph).
-Qed.
- 
-(* simplification *)
-Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
- match e with
-   PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
-  | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
-  | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
-  | PEopp e1 => NPEopp (PExpr_simp e1)
-  | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
-  | _ => e
- end.
- 
-Theorem PExpr_simp_correct:
- forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
-intros l e; elim e; simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEadd_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEsub_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEmul_correct.
-simpl; auto.
-intros e1 He1.
-transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
-apply NPEopp_correct.
-simpl; auto.
-intros e1 He1 n;simpl.
-rewrite NPEpow_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite He1;auto.
-Qed.
-
-
-(****************************************************************************
-                                                                          
-                               Datastructure                              
-                                                                          
-  ***************************************************************************)
-
-(* The input: syntax of a field expression *)
-
-Inductive FExpr : Type :=
-   FEc: C ->  FExpr
- | FEX: positive ->  FExpr
- | FEadd: FExpr -> FExpr ->  FExpr
- | FEsub: FExpr -> FExpr ->  FExpr
- | FEmul: FExpr -> FExpr ->  FExpr
- | FEopp: FExpr ->  FExpr
- | FEinv: FExpr ->  FExpr
- | FEdiv: FExpr -> FExpr ->  FExpr
- | FEpow: FExpr -> N -> FExpr .
- 
-Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
-  match pe with
-  | FEc c     => phi c
-  | FEX x     => BinList.nth 0 x l
-  | FEadd x y => FEeval l x + FEeval l y
-  | FEsub x y => FEeval l x - FEeval l y
-  | FEmul x y => FEeval l x * FEeval l y
-  | FEopp x   => - FEeval l x
-  | FEinv x   => / FEeval l x
-  | FEdiv x y => FEeval l x / FEeval l y
-  | FEpow x n => rpow (FEeval l x) (Cp_phi n)
-  end.
-
-Strategy expand [FEeval].
-
-(* The result of the normalisation *)
- 
-Record linear : Type := mk_linear {
-   num : PExpr C;
-   denum : PExpr C;
-   condition : list (PExpr C) }.
-
-(***************************************************************************
-
-                Semantics and properties of side condition
-
-  ***************************************************************************)
- 
-Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
-  match le with
-  | nil => True
-  | e1 :: nil => ~ req (NPEeval l e1) rO
-  | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
-  end.
-
-Theorem PCond_cons_inv_l :
-   forall l a l1, PCond l (a::l1) ->  ~ NPEeval l a == 0.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
-Qed.
- 
-Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
-Qed.
-
-Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
-intros l l1 l2; elim l1; simpl app in |- *.
- simpl in |- *; auto.
- destruct l0; simpl in *.
-  destruct l2; firstorder.
-  firstorder.
-Qed.
- 
-Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
-intros l l1 l2; elim l1; simpl app; auto.
-intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
-Qed.
- 
-(* An unsatisfiable condition: issued when a division by zero is detected *)
-Definition absurd_PCond := cons (PEc cO) nil.
-
-Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
-unfold absurd_PCond in |- *; simpl in |- *.
-red in |- *; intros.
-apply H.
-apply (morph0 CRmorph).
-Qed.
-
-(***************************************************************************
-                                                                          
-                               Normalisation                              
-                                                                          
-  ***************************************************************************)
-
-Fixpoint isIn (e1:PExpr C)  (p1:positive)
-                      (e2:PExpr C)  (p2:positive) {struct e2}: option (N * PExpr C) :=
-  match e2 with
-  | PEmul e3 e4 =>
-       match isIn e1 p1 e3 p2 with
-       | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
-       | Some (Npos p, e5) => 
-          match isIn e1 p e4 p2 with
-          | Some (n, e6) => Some (n, NPEmul e5 e6)
-          | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
-          end
-       | None => 
-         match isIn e1 p1 e4 p2 with
-         | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
-         | None => None
-         end
-       end
-  | PEpow e3 N0 => None 
-  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
-  | _ =>
-     if  PExpr_eq e1 e2 then
-         match Zminus (Zpos p1) (Zpos p2) with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None 
-   end.
- 
- Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
- Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
-
- Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) 
-                        ARth.(ARmul_comm) ARth.(ARmul_assoc)).
-
- Lemma isIn_correct_aux : forall l e1 e2 p1 p2, 
-  match 
-      (if  PExpr_eq e1 e2 then
-         match Zminus (Zpos p1) (Zpos p2) with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None) 
-   with
-   | Some(n, e3) => 
-       NPEeval l (PEpow e2 (Npos p2)) == 
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-       (Zpos p1 > NtoZ n)%Z
-   |  _ => True
-  end.
-Proof.
-  intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
-   case (PExpr_eq e1 e2); simpl; auto; intros H.
-  case_eq ((p1 ?= p2)%positive Eq);intros;simpl. 
-  repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
-  rewrite (Pcompare_Eq_eq _ _ H0).  
-  rewrite H by trivial. ring [ (morph1 CRmorph)].
-  fold (NPEpow e2 (Npos (p2 - p1))).
-  rewrite NPEpow_correct;simpl.
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite H;trivial. split. 2:refine (refl_equal _).
-  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. 
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite H;trivial.
-   change (ZtoN
-     match (p1 ?= p1 - p2)%positive Eq with
-     | Eq => 0
-     | Lt => Zneg (p1 - p2 - p1)
-     | Gt => Zpos (p1 - (p1 - p2))
-     end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))).
-  replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z.
-  split.
-  repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
-  rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
-  ring [ (morph1 CRmorph)].
- assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). 
- apply Zplus_gt_reg_l with (Zpos p2).
- rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z.
- apply Zplus_gt_compat_r. refine (refl_equal _).
- simpl;rewrite H0;trivial.
-Qed.
-
-Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
-induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl.
-ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
-Qed.
-
-
-Theorem isIn_correct: forall l e1 p1 e2 p2,
-  match isIn e1 p1 e2 p2 with 
-   | Some(n, e3) => 
-       NPEeval l (PEpow e2 (Npos p2)) == 
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-        (Zpos p1 > NtoZ n)%Z
-   |  _ => True
-  end.
-Proof.
-Opaque NPEpow.
-intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
-  try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
-generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
-destruct n. 
-  simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
-  generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
-  destruct n;simpl.
-    rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl.
-    intros (H1,H2) (H3,H4).
-    unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
-    rewrite pow_pos_mul. rewrite H1;rewrite H3.
-    assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == 
-        pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
-        NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
-   rewrite <- pow_pos_plus. rewrite Pplus_minus.
-   split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
-   repeat rewrite pow_th.(rpow_pow_N);simpl. 
-   intros (H1,H2) (H3,H4).
-   unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
-   rewrite H2 in H1;simpl in H1.
-   assert (Zpos p1 > Zpos p6)%Z.
-     apply Zgt_trans with (Zpos p4). exact H4. exact H2.
-  unfold Zgt in H;simpl in H;rewrite H.
-  split. 2:exact H.
-  rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
-  assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-                (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
-             pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
-                NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
-  rewrite <- pow_pos_plus.
-  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. 
- rewrite NPEmul_correct. simpl;ring.
-  assert 
-     (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
- change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
- rewrite <- Zplus_assoc. rewrite (Zplus_assoc  (- Zpos p4)).
- simpl. rewrite Pcompare_refl. 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). 
- intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3.
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
- rewrite pow_pos_mul. split. ring [H2]. exact H3.
- generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
- destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl.
- intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
- intros (H1, H2);rewrite H1;split.
-   unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1.
-   simpl in H1;ring [H1]. trivial. 
- trivial. 
- destruct n. trivial.
- generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
- destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
- repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split;trivial.
- rewrite pow_pos_pow_pos;trivial.
- trivial.
-Qed.
-
-Record rsplit : Type := mk_rsplit {
-   rsplit_left : PExpr C;
-   rsplit_common : PExpr C;
-   rsplit_right : PExpr C}.
-
-(* Stupid name clash *)
-Notation left := rsplit_left.
-Notation right := rsplit_right.
-Notation common := rsplit_common.
-
-Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :=
-  match e1 with
-  | PEmul e3 e4 =>
-      let r1 := split_aux e3 p e2 in
-      let r2 := split_aux e4 p (right r1) in
-          mk_rsplit (NPEmul (left r1) (left r2))
-                    (NPEmul (common r1) (common r2))
-                    (right r2)
-  | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
-  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2      
-  | _ => 
-       match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
-       end
-  end. 
-
-Lemma split_aux_correct_1 : forall l e1 p e2,
-  let res :=  match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
-       end in
-       NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
-   /\
-       NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
-Proof.
- intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
- destruct (isIn e1 p e2 1). destruct p0.
- Opaque NPEpow NPEmul.
-  destruct n;simpl; 
-    (repeat rewrite NPEmul_correct;simpl;
-     repeat rewrite NPEpow_correct;simpl;
-     repeat rewrite pow_th.(rpow_pow_N);simpl).
-  intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
-  intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H.
-  simpl in H;split;try ring [H].
-  rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
-  simpl;intros. repeat rewrite NPEmul_correct;simpl.
-  rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
-Qed.
-
-Theorem split_aux_correct: forall l e1 p e2,
-  NPEeval l (PEpow e1 (Npos p)) == 
-       NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
-/\
-  NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
-                                   (common (split_aux e1 p e2))).
-Proof.
-intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
-generalize (IHe1_1 k e2); clear IHe1_1.
-generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. 
-simpl. repeat (rewrite NPEmul_correct;simpl).
-repeat rewrite pow_th.(rpow_pow_N);simpl. 
-intros (H1,H2) (H3,H4);split.
-rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
-rewrite H4;rewrite H2;ring.
-destruct n;simpl.
-split. repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite NPEmul_correct. simpl.
- induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
- rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
-generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
-repeat rewrite NPEmul_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
-Qed.
-
-Definition split e1 e2 := split_aux e1 xH e2.
- 
-Theorem split_correct_l: forall l e1 e2,
-  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
-                                   (common (split e1 e2))).
-Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
-rewrite pow_th.(rpow_pow_N);simpl;auto.
-Qed.
-
-Theorem split_correct_r: forall l e1 e2,
-  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
-                                   (common (split e1 e2))).
-Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
-Qed.
-
-Fixpoint Fnorm (e : FExpr) : linear := 
-  match e with
-  | FEc c => mk_linear (PEc c) (PEc cI) nil
-  | FEX x => mk_linear (PEX C x) (PEc cI) nil
-  | FEadd e1 e2 =>
-      let x := Fnorm e1 in
-      let y := Fnorm e2 in
-      let s := split (denum x) (denum y) in
-      mk_linear
-        (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
- 
-  | FEsub e1 e2 =>
-      let x := Fnorm e1 in
-      let y := Fnorm e2 in
-      let s := split (denum x) (denum y) in
-      mk_linear
-        (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
-  | FEmul e1 e2 =>
-      let x := Fnorm e1 in
-      let y := Fnorm e2 in
-      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
-      mk_linear (NPEopp (num x)) (denum x) (condition x)
-  | FEinv e1 =>
-      let x := Fnorm e1 in
-      mk_linear (denum x) (num x) (num x :: condition x)
-  | FEdiv e1 e2 =>
-      let x := Fnorm e1 in
-      let y := Fnorm e2 in
-      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
-      mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
-  end.
-
-
-(* Example *)
-(*
-Eval compute
-   in (Fnorm
-        (FEdiv
-          (FEc cI)
-          (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
-*)
-
- Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
-Proof.
- induction p;simpl.
-  intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
-  apply IHp.
-  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp). 
-  reflexivity.
-  rewrite H1. ring. rewrite Hp;ring. 
-  intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  reflexivity. rewrite Hp;ring. trivial.
-Qed.
- 
-Theorem Pcond_Fnorm:
- forall l e,
- PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
-intros l e; elim e.
- simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
- simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
-   apply field_is_integral_domain.
-  intros HH; apply Hrec1.
-    apply PCond_app_inv_l with (1 := Hcond).
-    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 |- *.
-   auto.
- intros e1 Hrec1 Hcond.
-   simpl condition in Hcond.
-   simpl denum in |- *.
-   apply PCond_cons_inv_l with (1:=Hcond).
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
-   apply field_is_integral_domain.
-    intros HH; apply Hrec1.
-    specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
-    apply PCond_app_inv_l with (1 := Hcond1).
-    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).
-  destruct n;simpl;intros.
-  apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
-Qed.
-Hint Resolve Pcond_Fnorm.
-
-
-(***************************************************************************
-                                                                          
-                       Main theorem                                       
-                                                                          
-  ***************************************************************************)
-
-Theorem Fnorm_FEeval_PEeval:
- forall l fe,
- PCond l (condition (Fnorm fe)) ->
- FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
-Proof.
-intros l fe; elim fe; simpl.
-intros c H; rewrite CRmorph.(morph1); apply rdiv1.
-intros p H; rewrite CRmorph.(morph1); apply rdiv1.
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEadd_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv2b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEsub_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv3b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct; simpl.
-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.
-
-intros e1 He1 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); apply rdiv6; auto.
-apply PCond_cons_inv_l with ( 1 := HH ).
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with (condition (Fnorm e2)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with (condition (Fnorm e1)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct;simpl.
-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).
-rewrite He1';clear He1'.
-destruct n;simpl. apply rdiv1.
-generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
-  (Pcond_Fnorm _ _ Hcond).
-intros r r0 Hdiff;induction p;simpl.
-repeat (rewrite <- rdiv4;trivial).
-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).
- 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.
-
-Theorem Fnorm_crossproduct:
- forall l fe1 fe2,
- let nfe1 := Fnorm fe1 in
- let nfe2 := Fnorm fe2 in
- NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
- NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval in |- * by
- apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval in |- * by
-  apply PCond_app_inv_r with (1 := Hcond).
-  apply cross_product_eq; trivial.
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_l with (1 := Hcond).
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_r with (1 := Hcond).
-Qed.
-
-(* Correctness lemmas of reflexive tactics *)
-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 cdiv).
-
-Theorem Fnorm_correct:
- forall n l lpe fe,
-  Ninterp_PElist l lpe ->
-  Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
-  PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
-intros n l lpe fe Hlpe H H1;
- apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
-apply rdiv8; auto.
-transitivity (NPEeval l (PEc cO)); auto.
-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.
-Qed.
-
-(* simplify a field expression into a fraction *)
-(* TODO: simplify when den is constant... *)
-Definition display_linear l num den :=
-  NPphi_dev l num / NPphi_dev l den.
-
-Definition display_pow_linear l num den :=
-  NPphi_pow l num / NPphi_pow l den.
-
-Theorem Field_rw_correct :
- forall n lpe l,
-   Ninterp_PElist l lpe ->
-   forall lmp, Nmk_monpol_list lpe = lmp ->
-   forall fe nfe, Fnorm fe = nfe ->
-   PCond l (condition nfe) ->
-   FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
-Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_linear; apply SRdiv_ext;
-  eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
-Qed.
-
-Theorem Field_rw_pow_correct :
- forall n lpe l,
-   Ninterp_PElist l lpe ->
-   forall lmp, Nmk_monpol_list lpe = lmp ->
-   forall fe nfe, Fnorm fe = nfe ->
-   PCond l (condition nfe) ->
-   FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
-Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_pow_linear; apply SRdiv_ext;
-  eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
-Qed.
-
-Theorem Field_correct :
- forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
- forall lmp, Nmk_monpol_list lpe = lmp ->
- forall nfe1, Fnorm fe1 = nfe1 ->
- forall nfe2, Fnorm fe2 = nfe2 ->
- Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
-          (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
-apply Fnorm_crossproduct; trivial.
-eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
-Qed.
-
-(* simplify a field equation : generate the crossproduct and simplify
-   polynomials *)
-Theorem Field_simplify_eq_old_correct :
- forall l fe1 fe2 nfe1 nfe2,
- Fnorm fe1 = nfe1 ->
- Fnorm fe2 = nfe2 ->
- NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
- NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
-apply Fnorm_crossproduct; trivial.
-match goal with 
- [ |- NPEeval l ?x == NPEeval l ?y] =>
-    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 cdiv_th get_sign_spec 
-       O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
- end.
-trivial.
-Qed.
-
-Theorem Field_simplify_eq_correct :
- forall n l lpe fe1 fe2,
-    Ninterp_PElist l lpe ->
- forall lmp, Nmk_monpol_list lpe = lmp ->
- forall nfe1, Fnorm fe1 = nfe1 ->
- forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
-simpl in |- *.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite NPEmul_correct in |- *.
-rewrite NPEmul_correct in |- *.
-simpl in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_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 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.
-rewrite Hcrossprod in |- *.
-reflexivity.
-Qed.
-
-Theorem Field_simplify_eq_pow_correct :
- forall n l lpe fe1 fe2,
-    Ninterp_PElist l lpe ->
- forall lmp, Nmk_monpol_list lpe = lmp ->
- forall nfe1, Fnorm fe1 = nfe1 ->
- forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
-simpl in |- *.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite NPEmul_correct in |- *.
-rewrite NPEmul_correct in |- *.
-simpl in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th 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 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.
-rewrite Hcrossprod in |- *.
-reflexivity.
-Qed.
-
-Theorem Field_simplify_eq_pow_in_correct :
- forall n l lpe fe1 fe2,
-    Ninterp_PElist l lpe ->
- forall lmp, Nmk_monpol_list lpe = lmp ->
- forall nfe1, Fnorm fe1 = nfe1 ->
- forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
- FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
- NPphi_pow l np1 ==
- NPphi_pow l np2.
-Proof.
- intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r 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 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_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
-Qed.
-
-Theorem Field_simplify_eq_in_correct :
-forall n l lpe fe1 fe2,
-    Ninterp_PElist l lpe ->
- forall lmp, Nmk_monpol_list lpe = lmp ->
- forall nfe1, Fnorm fe1 = nfe1 ->
- forall nfe2, Fnorm fe2 = nfe2 ->
- forall den, split (denum nfe1) (denum nfe2) = den -> 
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
- FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
- NPphi_dev l np1 ==
- NPphi_dev l np2.
-Proof.
- intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r 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 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_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). 
-Qed.
-
-
-Section Fcons_impl.
-
-Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
-
-Hypothesis PCond_fcons_inv : forall l a l1,
-  PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-
-Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
-  match l with
-  | nil => m
-  | cons a l1 => Fcons a (Fapp l1 m)
-  end.
-
-Lemma fcons_correct : forall l l1,
-  PCond l (Fapp l1 nil) -> PCond l l1.
-induction l1; simpl in |- *; intros.
- trivial.
- elim PCond_fcons_inv with (1 := H); intros.
-   destruct l1; auto.
-Qed.
-
-End Fcons_impl.
-
-Section Fcons_simpl.
-
-(* Some general simpifications of the condition: eliminate duplicates,
-   split multiplications *)
-
-Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
- match l with
-   nil       => cons e nil
- | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1)
- end.
- 
-Theorem PFcons_fcons_inv:
- forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons; auto.
-simpl; auto.
-intros a0 l0.
-generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
-intros H H0 H1; split; auto.
-rewrite H; auto.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-generalize Hp; case l0; simpl; intuition.
-Qed.
-
-(* equality of normal forms rather than syntactic equality *)
-Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
- match l with
-   nil       => cons e nil
- | cons a l1 =>
-     if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1)
- end.
- 
-Theorem PFcons0_fcons_inv:
- forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons0; auto.
-simpl; auto.
-intros a0 l0.
-generalize (ring_correct Rsth Reqe ARth CRmorph 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.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-clear get_sign get_sign_spec. 
-generalize Hp; case l0; simpl; intuition.
-Qed.
-
-Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
- match e with
-   PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l)
- | PEpow e1 _ => Fcons00 e1 l
- | _ => Fcons0 e l
- end.
-
-Theorem PFcons00_fcons_inv:
-  forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl in |- *.
-   apply field_is_integral_domain; trivial.
-   simpl;intros. rewrite pow_th.(rpow_pow_N).
-   destruct (H _ H0);split;auto.
-   destruct n;simpl. apply AFth.(AF_1_neq_0).
-   apply pow_pos_not_0;trivial.
-Qed.
-
-Definition Pcond_simpl_gen := 
-  fcons_correct _ PFcons00_fcons_inv.
-
-
-(* Specific case when the equality test of coefs is complete w.r.t. the
-   field equality: non-zero coefs can be eliminated, and opposite can
-   be simplified (if -1 <> 0) *)
-
-Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
-
-Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) ->
-  (~ phi c1 == phi c2 -> P y) ->
-  P (if ceqb c1 c2 then x else y).
-Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-generalize (@ceqb_complete c1 c2).
-case (c1 ?=! c2); auto; intros.
-apply X0.
-red in |- *; intro.
-absurd (false = true); auto;  discriminate.
-Qed.
-
-Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
- match e with
-   PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
- | PEpow e _ => Fcons1 e l 
- | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
- | PEc c => if ceqb c cO then absurd_PCond else l
- | _ => Fcons0 e l
- end.
-
-Theorem PFcons1_fcons_inv:
-  forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- simpl in |- *; intros c l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H0).
-  split; trivial.
-    rewrite <- (morph0 CRmorph) in |- *; trivial.
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl in |- *.
-   apply field_is_integral_domain; trivial.
- simpl in |- *; intros p H l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H1).
-  destruct (H _ H1).
-    split; trivial.
-    apply ropp_neq_0; trivial.
-    rewrite (morph_opp CRmorph) in H0.
-    rewrite (morph1 CRmorph) in H0.
-    rewrite (morph0 CRmorph) in H0.
-    trivial.
- intros;simpl. destruct (H _ H0);split;trivial.
- rewrite pow_th.(rpow_pow_N). destruct n;simpl.
- apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
-Qed.
-
-Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
- 
-Theorem PFcons2_fcons_inv:
- forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-unfold Fcons2 in |- *; intros l a l1 H; split;
- case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
-intros H1 H2 H3; case H1.
-transitivity (NPEeval l a); trivial.
-apply PExpr_simp_correct.
-Qed.
-
-Definition Pcond_simpl_complete := 
-  fcons_correct _ PFcons2_fcons_inv.
-
-End Fcons_simpl.
-
-End AlmostField.
-
-Section FieldAndSemiField.
-
-  Record field_theory : Prop := mk_field {
-    F_R : ring_theory rO rI radd rmul rsub ropp req;
-    F_1_neq_0 : ~ 1 == 0;
-    Fdiv_def : forall p q, p / q == p * / q;
-    Finv_l : forall p, ~ p == 0 ->  / p * p == 1
-  }.
-
-  Definition F2AF f :=
-    mk_afield
-      (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l).
-
-  Record semi_field_theory : Prop := mk_sfield {
-    SF_SR : semi_ring_theory rO rI radd rmul req;
-    SF_1_neq_0 : ~ 1 == 0;
-    SFdiv_def : forall p q, p / q == p * / q;
-    SFinv_l : forall p, ~ p == 0 ->  / p * p == 1
-  }.
-
-End FieldAndSemiField.
-
-End MakeFieldPol.
-
-  Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth 
-    (sf:semi_field_theory rO rI radd rmul rdiv rinv req)  :=
-    mk_afield _ _
-      (SRth_ARth Rsth sf.(SF_SR))
-      sf.(SF_1_neq_0)
-      sf.(SFdiv_def)
-      sf.(SFinv_l).
-
-
-Section Complete.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x / y " := (rdiv x y).  Notation "/ x" := (rinv x).
-  Notation "x == y" := (req x y) (at level 70, no associativity).
- Variable Rsth : Setoid_Theory R req.
-   Add Setoid R req Rsth as R_setoid3.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext3.  exact (Radd_ext Reqe). Qed.
-   Add Morphism rmul : rmul_ext3.  exact (Rmul_ext Reqe). Qed.
-   Add Morphism ropp : ropp_ext3.  exact (Ropp_ext Reqe). Qed.
-
-Section AlmostField.
-
- Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req.
- Let ARth := AFth.(AF_AR).
- Let rI_neq_rO := AFth.(AF_1_neq_0).
- Let rdiv_def := AFth.(AFdiv_def).
- Let rinv_l := AFth.(AFinv_l).
-
-Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
-
-Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
-
-Lemma add_inj_r : forall p x y,
-   gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
-intros p x y.
-elim p using Pind; simpl in |- *; intros.
- apply S_inj; trivial.
- apply H.
-   apply S_inj.
-   repeat rewrite (ARadd_assoc ARth) in |- *.
-   rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial.
-Qed.
-
-Lemma gen_phiPOS_inj : forall x y,
-  gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
-  x = y.
-intros x y.
-repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
-ElimPcompare x y; intro.
- intros.
-   apply Pcompare_Eq_eq; trivial.
- intro.
-   elim gen_phiPOS_not_0 with (y - x)%positive.
-   apply add_inj_r with x.
-   symmetry  in |- *.
-   rewrite (ARadd_0_r Rsth ARth) in |- *.
-   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
-   rewrite Pplus_minus in |- *; trivial.
-   change Eq with (CompOpp Eq) in |- *.
-   rewrite <- Pcompare_antisym in |- *; trivial.
-   rewrite H in |- *; trivial.
- intro.
-   elim gen_phiPOS_not_0 with (x - y)%positive.
-   apply add_inj_r with y.
-   rewrite (ARadd_0_r Rsth ARth) in |- *.
-   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
-   rewrite Pplus_minus in |- *; trivial.
-Qed.
-
-
-Lemma gen_phiN_inj : forall x y,
-  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
-  x = y.
-destruct x; destruct y; simpl in |- *; intros; trivial.
- elim gen_phiPOS_not_0 with p.
-   symmetry  in |- *.
-   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
- elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
- rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial.
-Qed.
-
-Lemma gen_phiN_complete : forall x y,
-  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
-  Neq_bool x y = true.
-intros.
- replace y with x.
- unfold Neq_bool in |- *.
-   rewrite Ncompare_refl in |- *; trivial.
- apply gen_phiN_inj; trivial.
-Qed.
-
-End AlmostField.
-
-Section Field.
-
- Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req.
- Let Rth := Fth.(F_R).
- Let rI_neq_rO := Fth.(F_1_neq_0).
- Let rdiv_def := Fth.(Fdiv_def).
- Let rinv_l := Fth.(Finv_l).
- Let AFth := F2AF Rsth Reqe Fth.
- Let ARth := Rth_ARth Rsth Reqe Rth.
-
-Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
-intros.
-transitivity (x + (1 + - (1))).
- rewrite (Ropp_def Rth) in |- *.
-   symmetry  in |- *.
-   apply (ARadd_0_r Rsth ARth).
- transitivity (y + (1 + - (1))).
-  repeat rewrite <- (ARplus_assoc ARth) in |- *.
-    repeat rewrite (ARadd_assoc ARth) in |- *.
-    apply (Radd_ext Reqe).
-   repeat rewrite <- (ARadd_comm ARth 1) in |- *.
-     trivial.
-   reflexivity.
-  rewrite (Ropp_def Rth) in |- *.
-    apply (ARadd_0_r Rsth ARth).
-Qed.
-
-
- Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
-
-Let gen_phiPOS_inject :=
-   gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
-
-Lemma gen_phiPOS_discr_sgn : forall x y,
-  ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
-red in |- *; intros.
-apply gen_phiPOS_not_0 with (y + x)%positive.
-rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
-transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
- apply (Radd_ext Reqe); trivial.
-  reflexivity.
-  rewrite (same_gen Rsth Reqe ARth) in |- *.
-    rewrite (same_gen Rsth Reqe ARth) in |- *.
-    trivial.
- apply (Ropp_def Rth).
-Qed.
-
-Lemma gen_phiZ_inj : forall x y,
-  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
-  x = y.
-destruct x; destruct y; simpl in |- *; intros.
- trivial.
- elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   symmetry  in |- *; trivial.
- elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite <- H in |- *.
-   apply (ARopp_zero Rsth Reqe ARth).
- elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   trivial.
- rewrite gen_phiPOS_inject  with (1 := H) in |- *; trivial.
- elim gen_phiPOS_discr_sgn with (1 := H).
- elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite H in |- *.
-   apply (ARopp_zero Rsth Reqe ARth).
- elim gen_phiPOS_discr_sgn with p0 p.
-   symmetry  in |- *; trivial.
- replace p0 with p; trivial.
-   apply gen_phiPOS_inject.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *.
-   rewrite H in |- *; trivial.
-   reflexivity.
-Qed.
-
-Lemma gen_phiZ_complete : forall x y,
-  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
-  Zeq_bool x y = true.
-intros.
- replace y with x.
- unfold Zeq_bool in |- *.
-   rewrite Zcompare_refl in |- *; trivial.
- apply gen_phiZ_inj; trivial.
-Qed.
-
-End Field.
-
-End Complete.
diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v
deleted file mode 100644
index e664b3b7..00000000
--- a/contrib/setoid_ring/InitialRing.v
+++ /dev/null
@@ -1,908 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import ZArith_base.
-Require Import Zpow_def.
-Require Import BinInt.
-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.
-
-(** Z is a ring and a setoid*)
-
-Lemma Zsth : Setoid_Theory Z (@eq Z).
-Proof (Eqsth Z).
- 
-Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z).
-Proof (Eq_ext Zplus Zmult Zopp).
-
-Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z).
-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. trivial. exact Zminus_diag.
-Qed.
-
-(** Two generic morphisms from Z to (abrbitrary) rings, *)
-(**second one is more convenient for proofs but they are ext. equal*)
-Section ZMORPHISM.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-  Variable Rsth : Setoid_Theory R req.
-     Add Setoid R req Rsth as R_setoid3.
-     Ltac rrefl := gen_reflexivity Rsth.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext3.  exact (Radd_ext Reqe). Qed.
-   Add Morphism rmul : rmul_ext3.  exact (Rmul_ext Reqe). Qed.
-   Add Morphism ropp : ropp_ext3.  exact (Ropp_ext Reqe). Qed.
-
- Fixpoint gen_phiPOS1 (p:positive) : R :=
-  match p with
-  | xH => 1
-  | xO p => (1 + 1) * (gen_phiPOS1 p)
-  | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p))
-  end.
-
- Fixpoint gen_phiPOS (p:positive) : R :=
-  match p with
-  | xH => 1 
-  | xO xH => (1 + 1)
-  | xO p => (1 + 1) * (gen_phiPOS p)
-  | xI xH => 1 + (1 +1)
-  | xI p => 1 + ((1 + 1) * (gen_phiPOS p))
-  end.
-
- Definition gen_phiZ1 z :=
-  match z with
-  | Zpos p => gen_phiPOS1 p
-  | Z0 => 0
-  | Zneg p => -(gen_phiPOS1 p)
-  end.
- 
- Definition gen_phiZ z := 
-  match z with
-  | Zpos p => gen_phiPOS p
-  | Z0 => 0
-  | Zneg p => -(gen_phiPOS p)
-  end.
- Notation "[ x ]" := (gen_phiZ x).   
-
- Definition get_signZ z :=
-  match z with
-  | Zneg p => Some (Zpos p) 
-  | _ => None
-  end.
-
- Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ.
- Proof.
-  constructor.
-  destruct c;intros;try discriminate.
-  injection H;clear H;intros H1;subst c'.
-  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 Rsth Reqe ARth.
-   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
- 
- Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
- Proof.
-  induction x;simpl. 
-  rewrite IHx;destruct x;simpl;norm.
-  rewrite IHx;destruct x;simpl;norm.
-  rrefl.
- Qed.
-
- Lemma ARgen_phiPOS_Psucc : forall x,
-   gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
- Proof.
-  induction x;simpl;norm.
-  rewrite IHx;norm.
-  add_push 1;rrefl.
- Qed.
-
- Lemma ARgen_phiPOS_add : forall x y,
-   gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y).
- Proof.
-  induction x;destruct y;simpl;norm.
-  rewrite Pplus_carry_spec.
-  rewrite ARgen_phiPOS_Psucc.
-  rewrite IHx;norm.
-  add_push (gen_phiPOS1 y);add_push 1;rrefl.
-  rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl.
-  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
-  rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl.
-  rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl.
-  add_push 1;rrefl.
-  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
- Qed.
-
- Lemma ARgen_phiPOS_mult :
-   forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y.
- Proof.
-  induction x;intros;simpl;norm.
-  rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm.
-  rewrite IHx;rrefl.
- Qed.
-
- End ALMOST_RING.
-
- 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 Rsth Reqe ARth.
-   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-  
-(*morphisms are extensionaly equal*)
- Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
- Proof.
-  destruct x;simpl; try rewrite (same_gen ARth);rrefl.
- Qed.
- 
- Lemma gen_Zeqb_ok : forall x y, 
-   Zeq_bool x y = true -> [x] == [y].
- Proof.
-  intros x y H.
-  assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1.
-  rewrite H1;rrefl.
- Qed.
-  
- Lemma gen_phiZ1_add_pos_neg : forall x y,
- gen_phiZ1
-    match (x ?= y)%positive Eq with
-    | Eq => Z0
-    | Lt => Zneg (y - x)
-    | Gt => Zpos (x - y)
-    end 
- == gen_phiPOS1 x + -gen_phiPOS1 y.
- Proof.
-  intros x y.
-  assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y).
-  generalize (Pminus_mask_Gt y x).
-  replace Eq with (CompOpp Eq);[intro H1;simpl|trivial].
-  rewrite <- Pcompare_antisym in H1.
-  destruct ((x ?= y)%positive Eq).
-  rewrite H;trivial. rewrite (Ropp_def Rth);rrefl.
-  destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial.
-  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
-  rewrite (ARgen_phiPOS_add ARth);simpl;norm.
-  rewrite (Ropp_def Rth);norm.
-  destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial.
-  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
-  rewrite (ARgen_phiPOS_add ARth);simpl;norm.
-  add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm.
- Qed.
-
- Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
-  match CompOpp x with Eq => be | Lt => bl | Gt => bg end 
-  = match x with Eq => be | Lt => bg | Gt => bl end.
- Proof. destruct x;simpl;intros;trivial. Qed.
-
- Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
- Proof.
-  intros x y; repeat rewrite same_genZ; generalize x y;clear x y.
-  induction x;destruct y;simpl;norm.
-  apply (ARgen_phiPOS_add ARth).
-  apply gen_phiZ1_add_pos_neg.
-  replace Eq with (CompOpp Eq);trivial.
-  rewrite <- Pcompare_antisym;simpl.
-  rewrite match_compOpp.    
-  rewrite (Radd_comm Rth).
-  apply gen_phiZ1_add_pos_neg.
-  rewrite (ARgen_phiPOS_add ARth); norm.
- Qed.
-
- Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y].
- Proof.
-  intros x y;repeat rewrite same_genZ.
-  destruct x;destruct y;simpl;norm;
-  rewrite  (ARgen_phiPOS_mult ARth);try (norm;fail).
-  rewrite (Ropp_opp Rsth Reqe Rth);rrefl.
- Qed.
-
- Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
- Proof. intros;subst;rrefl. Qed.
-
-(*proof that [.] satisfies morphism specifications*)
- Lemma gen_phiZ_morph : 
-  ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) 
-   Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ.
- Proof. 
-  assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) 
-                  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 Zth SRmorph gen_phiZ_ext).
- Qed.
-
-End ZMORPHISM.
-
-(** N is a semi-ring and a setoid*)
-Lemma Nsth : Setoid_Theory N (@eq N).
-Proof (Eqsth N).
-
-Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N).
-Proof (Eq_s_ext Nplus Nmult).
-
-Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N).
-Proof.
- constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc.
- exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc.
- exact Nmult_plus_distr_r. 
-Qed.
-
-Definition Nsub := SRsub Nplus.
-Definition Nopp := (@SRopp N).
-
-Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N).
-Proof (SReqe_Reqe Nseqe).
-
-Lemma Nath : 
- almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N).
-Proof (SRth_ARth Nsth Nth).
- 
-Definition Neq_bool (x y:N) := 
-  match Ncompare x y with
-  | Eq => true
-  | _ => false
-  end.
-
-Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y.
- Proof.
-  intros x y;unfold Neq_bool.
-  assert (H:=Ncompare_Eq_eq x y); 
-   destruct (Ncompare x y);intros;try discriminate.
-  rewrite H;trivial. 
- Qed.
-
-Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y.
- Proof.
-  intros x y;unfold Neq_bool.
-  assert (H:=Ncompare_Eq_eq x y); 
-   destruct (Ncompare x y);intros;try discriminate.
-  rewrite H;trivial. 
- Qed.
-
-(**Same as above : definition of two,extensionaly equal, generic morphisms *)
-(**from N to any semi-ring*)
-Section NMORPHISM.
- Variable R : Type.
- Variable  (rO rI : R) (radd rmul: R->R->R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Variable Rsth : Setoid_Theory R req.
-     Add Setoid R req Rsth as R_setoid4.
-     Ltac rrefl := gen_reflexivity Rsth.
- Variable SReqe : sring_eq_ext radd rmul req.
- Variable SRth : semi_ring_theory 0 1 radd rmul req. 
- Let ARth := SRth_ARth Rsth SRth.
- Let Reqe := SReqe_Reqe SReqe.
- Let ropp := (@SRopp R).
- Let rsub := (@SRsub R radd).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-   Add Morphism radd : radd_ext4.  exact (Radd_ext Reqe). Qed.
-   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 Rsth Reqe ARth.
-
- Definition gen_phiN1 x :=
-  match x with
-  | N0 => 0
-  | Npos x => gen_phiPOS1 1 radd rmul x
-  end. 
-
- Definition gen_phiN x :=
-  match x with
-  | N0 => 0
-  | Npos x => gen_phiPOS 1 radd rmul x
-  end. 
- Notation "[ x ]" := (gen_phiN x).   
-  
- Lemma same_genN : forall x, [x] == gen_phiN1 x.
- Proof.
-  destruct x;simpl. rrefl.
-  rewrite (same_gen Rsth Reqe ARth);rrefl.
- Qed.
-
- Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y].
- Proof.
-  intros x y;repeat rewrite same_genN.
-  destruct x;destruct y;simpl;norm.
-  apply (ARgen_phiPOS_add Rsth Reqe ARth).
- Qed.
- 
- Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y].
- Proof.
-  intros x y;repeat rewrite same_genN.
-  destruct x;destruct y;simpl;norm.
-  apply (ARgen_phiPOS_mult Rsth Reqe ARth).
- Qed.
-
- Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y].
- Proof. exact gen_phiN_add. Qed.
-
-(*gen_phiN satisfies morphism specifications*)
- Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req
-                           N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN.
- Proof.
-  constructor;intros;simpl; try rrefl.
-  apply gen_phiN_add. apply gen_phiN_sub.  apply gen_phiN_mult.
-  rewrite (Neq_bool_ok x y);trivial. rrefl.
- Qed.
-
-End NMORPHISM.
-
-(* Words on N : initial structure for almost-rings. *)
-Definition Nword := list N.
-Definition NwO : Nword := nil.
-Definition NwI : Nword := 1%N :: nil.
-
-Definition Nwcons n (w : Nword) : Nword :=
-  match w, n with
-  | nil, 0%N => nil
-  | _, _ => n :: w
-  end.
-
-Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword :=
-  match w1, w2 with
-  | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2'
-  | nil, _ => w2
-  | _, nil => w1
-  end.
-
-Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w.
-
-Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2).
-
-Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword :=
-  match w with
-  | m :: w' => (n*m)%N :: Nwscal n w'
-  | nil => nil
-  end.
-
-Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword :=
-  match w1 with
-  | 0%N::w1' => Nwopp (Nwmul w1' w2)
-  | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2)
-  | nil => nil
-  end.
-Fixpoint Nw_is0 (w : Nword) : bool :=
-  match w with
-  | nil => true
-  | 0%N :: w' => Nw_is0 w'
-  | _ => false
-  end. 
-
-Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool :=
-  match w1, w2 with
-  | n1::w1', n2::w2' =>
-     if Neq_bool n1 n2 then Nweq_bool w1' w2' else false
-  | nil, _ => Nw_is0 w2
-  | _, nil => Nw_is0 w1
-  end.
-
-Section NWORDMORPHISM.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-  Variable Rsth : Setoid_Theory R req.
-     Add Setoid R req Rsth as R_setoid5.
-     Ltac rrefl := gen_reflexivity Rsth.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext5.  exact (Radd_ext Reqe). Qed.
-   Add Morphism rmul : rmul_ext5.  exact (Rmul_ext Reqe). Qed.
-   Add Morphism ropp : ropp_ext5.  exact (Ropp_ext Reqe). Qed.
-
- Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
-   Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed.
-   Ltac norm := gen_srewrite Rsth Reqe ARth.
-   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-
- Fixpoint gen_phiNword (w : Nword) : R :=
-  match w with
-  | nil => 0
-  | n :: nil => gen_phiN rO rI radd rmul n
-  | N0 :: w' => - gen_phiNword w'
-  | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w'
-  end.
-
- Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0.
-Proof.
-induction w; simpl in |- *; intros; auto.
- reflexivity.
-
- destruct a.
-  destruct w.
-   reflexivity.
-
-   rewrite IHw in |- *; trivial.
-   apply (ARopp_zero Rsth Reqe ARth).
-
-   discriminate.
-Qed.
-
-  Lemma gen_phiNword_cons : forall w n,
-    gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w.
-induction w.
- destruct n; simpl in |- *; norm.
-
- intros.
- destruct n; norm.
-Qed.
-
-  Lemma gen_phiNword_Nwcons : forall w n,
-    gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w.
-destruct w; intros.
- destruct n; norm.
-
- unfold Nwcons in |- *.
- rewrite gen_phiNword_cons in |- *.
- reflexivity.
-Qed.
-
- Lemma gen_phiNword_ok : forall w1 w2,
-   Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2.
-induction w1; intros.
- simpl in |- *.
- rewrite (gen_phiNword0_ok _ H) in |- *.
- reflexivity.
-
- rewrite gen_phiNword_cons in |- *.
- destruct w2.
-  simpl in H.
-  destruct a; try  discriminate.
-  rewrite (gen_phiNword0_ok _ H) in |- *.
-  norm.
-
-  simpl in H.
-  rewrite gen_phiNword_cons in |- *.
-  case_eq (Neq_bool a n); intros.
-   rewrite H0 in H.
-   rewrite <- (Neq_bool_ok _ _ H0) in |- *.
-   rewrite (IHw1 _ H) in |- *.
-   reflexivity.
-
-   rewrite H0 in H;  discriminate H.
-Qed.
-
-
-Lemma Nwadd_ok : forall x y,
-   gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y.
-induction x; intros.
- simpl in |- *.
- norm.
-
- destruct y.
-  simpl Nwadd; norm.
-
-  simpl Nwadd in |- *.
-  repeat rewrite gen_phiNword_cons in |- *.
-  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.
-Qed.
-
-Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x.
-simpl in |- *.
-unfold Nwopp in |- *; simpl in |- *.
-intros.
-rewrite gen_phiNword_Nwcons in |- *; norm.
-Qed.
-
-Lemma Nwscal_ok : forall n x,
-  gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x.
-induction x; intros.
- norm.
-
- simpl Nwscal in |- *.
- repeat rewrite gen_phiNword_cons in |- *.
- rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *
-   by (destruct Reqe; constructor; trivial).
-
-  rewrite IHx in |- *.
-  norm.
-Qed.
-
-Lemma Nwmul_ok : forall x y,
-   gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y.
-induction x; intros.
- norm.
-
- destruct a.
-  simpl Nwmul in |- *.
-  rewrite Nwopp_ok in |- *.
-  rewrite IHx in |- *.
-  rewrite gen_phiNword_cons in |- *.
-  norm.
-
-  simpl Nwmul in |- *.
-  unfold Nwsub in |- *.
-  rewrite Nwadd_ok in |- *.
-  rewrite Nwscal_ok in |- *.
-  rewrite Nwopp_ok in |- *.
-  rewrite IHx in |- *.
-  rewrite gen_phiNword_cons in |- *.
-  norm.
-Qed.
-
-(* Proof that [.] satisfies morphism specifications *)
- Lemma gen_phiNword_morph : 
-  ring_morph 0 1 radd rmul rsub ropp req
-   NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword.
-constructor.
- reflexivity.
-
- reflexivity.
-
- exact Nwadd_ok.
-
- intros.
- unfold Nwsub in |- *.
- rewrite Nwadd_ok in |- *.
- rewrite Nwopp_ok in |- *.
- norm.
-
- exact Nwmul_ok.
-
- exact Nwopp_ok.
-
- exact gen_phiNword_ok.
-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 *)
- Ltac inv_gen_phi_pos rI add mul t :=
-   let rec inv_cst t :=
-   match t with
-     rI => constr:1%positive
-   | (add rI rI) => constr:2%positive
-   | (add rI (add rI rI)) => constr:3%positive
-   | (mul (add rI rI) ?p) => (* 2p *)
-       match inv_cst p with
-         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 => constr:NotConstant
-       | 1%positive => constr:NotConstant
-       | ?p => constr:(xI p)
-       end
-   | _ => constr:NotConstant
-   end in
-   inv_cst t.
-
-(* The (partial) inverse of gen_phiNword *)
- Ltac inv_gen_phiNword rO rI add mul opp t :=
-   match t with
-     rO => constr:NwO
-   | _ =>
-     match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
-     | ?p => constr:(Npos p::nil)
-     end
-   end.
-
-
-(* The inverse of gen_phiN *)
- Ltac inv_gen_phiN rO rI add mul t :=
-   match t with
-     rO => constr:0%N
-   | _ =>
-     match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
-     | ?p => constr:(Npos p)
-     end
-   end.
-
-(* The inverse of gen_phiZ *)
- Ltac inv_gen_phiZ rO rI add mul opp t :=
-   match t with
-     rO => constr:0%Z
-   | (opp ?p) =>
-     match inv_gen_phi_pos rI add mul p with
-       NotConstant => constr:NotConstant
-     | ?p => constr:(Zneg p)
-     end
-   | _ =>
-     match inv_gen_phi_pos rI add mul t with
-       NotConstant => constr:NotConstant
-     | ?p => constr:(Zpos p)
-     end
-   end.
-
-(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above
-   are only optimisations that directly returns the reifid constant
-   instead of resorting to the constant propagation of the simplification
-   algorithm. *) 
-Ltac inv_gen_phi rO rI cO cI t :=
-  match t with
-  | rO => cO
-  | rI => cI
-  end.
-
-(* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:NotConstant.
-
-Ltac coerce_to_almost_ring set ext rspec :=
-  match type of rspec with
-  | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec)
-  | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec)
-  | almost_ring_theory _ _ _ _ _ _ _ => rspec
-  | _ => fail 1 "not a valid ring theory"
-  end.
-
-Ltac coerce_to_ring_ext ext :=
-  match type of ext with
-  | ring_eq_ext _ _ _ _ => ext
-  | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext)
-  | _ => fail 1 "not a valid ring_eq_ext theory"
-  end.
-
-Ltac abstract_ring_morphism set ext rspec :=
-  match type of rspec with
-  | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec)
-  | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec)
-  | almost_ring_theory _ _ _ _ _ _ _ =>
-      constr:(gen_phiNword_morph set ext rspec)
-  | _ => fail 1 "bad ring structure"
-  end.
-
-Record hypo : Type := mkhypo {
-   hypo_type : Type;
-   hypo_proof : hypo_type
- }.
-
-Ltac gen_ring_pow set arth pspec :=
- match pspec with
- | None =>
-   match type of arth with
-   | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
-     constr:(mkhypo (@pow_N_th R rI rmul req set))
-   | _ => fail 1 "gen_ring_pow"
-   end
- | Some ?t => constr:(t)
- end.
-
-Ltac 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 (triv_div_th set reqe arth morph))
- | _ => fail 1 "ring anomaly : default_sign_spec" 
- 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 dspec rk :=
-  let arth := coerce_to_almost_ring set ext rspec in
-  let ext_r := coerce_to_ring_ext ext in
-  let morph :=
-    match rk with
-    | Abstract => abstract_ring_morphism set ext rspec
-    | @Computational ?reqb_ok =>
-        match type of arth with
-        | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ =>
-            constr:(IDmorph rO rI add mul sub opp set _ reqb_ok)
-        | _ => fail 2 "ring anomaly"
-        end
-    | @Morphism ?m =>
-       match type of m with 
-       | ring_morph _ _ _ _ _ _ _  _ _ _ _ _ _  _ _ => m 
-       | @semi_morph _ _ _ _ _ _  _ _ _ _ _  _ _   => 
-           constr:(SRmorph_Rmorph set m) 
-       | _ => fail 2 "ring anomaly"
-       end
-    | _ => fail 1 "ill-formed ring kind"
-    end in
-  let p_spec := gen_ring_pow set arth pspec in
-  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 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 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 => constr:true
-  | S ?p => isnatcst p
-  | _ => constr:false
-  end.
-
-Ltac isPcst t :=
-  match t with
-  | xI ?p => isPcst p
-  | xO ?p => isPcst p
-  | xH => constr:true
-  (* nat -> positive *)
-  | P_of_succ_nat ?n => isnatcst n 
-  | _ => constr:false
-  end.
-
-Ltac isNcst t :=
-  match t with
-    N0 => constr:true
-  | Npos ?p => isPcst p
-  | _ => constr:false
-  end.
-
-Ltac isZcst t :=
-  match t with
-    Z0 => constr:true
-  | Zpos ?p => isPcst p
-  | Zneg ?p => isPcst p
-  (* injection nat -> Z *)
-  | Z_of_nat ?n => isnatcst n
-  (* injection N -> Z *)
-  | Z_of_N ?n => isNcst n
-  (* *)
-  | _ => constr:false
-  end.
-
-
-
-
-
diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v
deleted file mode 100644
index 0ba519fd..00000000
--- a/contrib/setoid_ring/NArithRing.v
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Ring.
-Require Import BinPos BinNat.
-Import InitialRing.
-
-Set Implicit Arguments.
-
-Ltac Ncst t :=
-  match isNcst t with
-    true => t
-  | _ => 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
deleted file mode 100644
index 60641bcf..00000000
--- a/contrib/setoid_ring/RealField.v
+++ /dev/null
@@ -1,134 +0,0 @@
-Require Import Nnat.
-Require Import ArithRing. 
-Require Export Ring Field.
-Require Import Rdefinitions.
-Require Import Rpow_def.
-Require Import Raxioms.
-
-Open Local Scope R_scope.
-
-Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)).
-Proof.
-constructor.
- intro; apply Rplus_0_l.
- exact Rplus_comm.
- symmetry  in |- *; apply Rplus_assoc.
- intro; apply Rmult_1_l.
- exact Rmult_comm.
- symmetry  in |- *; apply Rmult_assoc.
- intros m n p.
-   rewrite Rmult_comm in |- *.
-   rewrite (Rmult_comm n p) in |- *.
-   rewrite (Rmult_comm m p) in |- *.
-   apply Rmult_plus_distr_l.
- reflexivity.
- exact Rplus_opp_r.
-Qed.
-
-Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)).
-Proof.
-constructor.
- exact RTheory.
- exact R1_neq_R0.
- reflexivity.
- exact Rinv_l.
-Qed.
-
-Lemma Rlt_n_Sn : forall x, x < x + 1.
-Proof.
-intro.
-elim archimed with x; intros.
-destruct H0.
- apply Rlt_trans with (IZR (up x)); trivial.
-    replace (IZR (up x)) with (x + (IZR (up x) - x))%R.
-  apply Rplus_lt_compat_l; trivial.
-  unfold Rminus in |- *.
-    rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
-    rewrite <- Rplus_assoc in |- *.
-    rewrite Rplus_opp_r in |- *.
-    apply Rplus_0_l.
- elim H0.
-   unfold Rminus in |- *.
-   rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
-   rewrite <- Rplus_assoc in |- *.
-   rewrite Rplus_opp_r in |- *.
-   rewrite Rplus_0_l in |- *; trivial.
-Qed.
-
-Notation Rset := (Eqsth R).
-Notation Rext := (Eq_ext Rplus Rmult Ropp).
-
-Lemma Rlt_0_2 : 0 < 2.
-apply Rlt_trans with (0 + 1).
- apply Rlt_n_Sn.
- rewrite Rplus_comm in |- *.
-   apply Rplus_lt_compat_l.
-    replace 1 with (0 + 1).
-  apply Rlt_n_Sn.
-  apply Rplus_0_l.
-Qed.
-
-Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0.
-unfold Rgt in |- *.
-induction x; simpl in |- *; intros.
- apply Rlt_trans with (1 + 0).
-  rewrite Rplus_comm in |- *.
-    apply Rlt_n_Sn.
-  apply Rplus_lt_compat_l.
-    rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
-    rewrite Rmult_comm in |- *.
-    apply Rmult_lt_compat_l.
-   apply Rlt_0_2.
-   trivial.
- rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
-   rewrite Rmult_comm in |- *.
-   apply Rmult_lt_compat_l.
-  apply Rlt_0_2.
-  trivial.
-  replace 1 with (0 + 1).
-  apply Rlt_n_Sn.
-  apply Rplus_0_l.
-Qed.
-
-
-Lemma Rgen_phiPOS_not_0 :
-  forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0.
-red in |- *; intros.
-specialize (Rgen_phiPOS x).
-rewrite H in |- *; intro.
-apply (Rlt_asym 0 0); trivial.
-Qed.
-
-Lemma Zeq_bool_complete : forall x y, 
-  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x =
-  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y ->
-  Zeq_bool x y = true.
-Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0.
-
-Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x  (n + m) = pow x n * pow x m.
-Proof.
-  intros x n; elim n; simpl in |- *; auto with real.
-  intros n0 H' m; rewrite H'; auto with real.
-Qed.
-
-Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R))  nat_of_N pow.
-Proof.
- constructor. destruct n. reflexivity.
- simpl. induction p;simpl. 
- rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
- unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
- rewrite Rmult_comm;apply Rmult_1_l.
-Qed.
-
-Ltac Rpow_tac t := 
-  match isnatcst t with
-  | false => constr:(InitialRing.NotConstant)
-  | _ => constr:(N_of_nat t)
-  end. 
-
-Add Field RField : Rfield  
-   (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
-
-
-
- 
diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v
deleted file mode 100644
index d01b1625..00000000
--- a/contrib/setoid_ring/Ring.v
+++ /dev/null
@@ -1,44 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Bool.
-Require Export Ring_theory.
-Require Export Ring_base.
-Require Export InitialRing.
-Require Export Ring_tac.
-
-Lemma BoolTheory :
-  ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
-split; simpl in |- *.
-destruct x; reflexivity.
-destruct x; destruct y; reflexivity.
-destruct x; destruct y; destruct z; reflexivity.
-reflexivity.
-destruct x; destruct y; reflexivity.
-destruct x; destruct y; reflexivity.
-destruct x; destruct y; destruct z; reflexivity.
-reflexivity.
-destruct x; reflexivity.
-Qed.
-
-Definition bool_eq (b1 b2:bool) :=
-  if b1 then b2 else negb b2.
-
-Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2.
-destruct b1; destruct b2; auto.
-Qed.
-
-Ltac bool_cst t :=
-  let t := eval hnf in t in
-  match t with
-    true => constr:true
-  | false => constr:false
-  | _ => constr:NotConstant
-  end.
-
-Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v
deleted file mode 100644
index 956a15fe..00000000
--- a/contrib/setoid_ring/Ring_base.v
+++ /dev/null
@@ -1,15 +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        *)
-(************************************************************************)
-
-(* This module gathers the necessary base to build an instance of the
-   ring tactic. Abstract rings need more theory, depending on
-   ZArith_base. *)
-
-Require Export Ring_theory.
-Require Export Ring_tac.
-Require Import InitialRing.
diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v
deleted file mode 100644
index 945f6c68..00000000
--- a/contrib/setoid_ring/Ring_equiv.v
+++ /dev/null
@@ -1,74 +0,0 @@
-Require Import Setoid_ring_theory.
-Require Import LegacyRing_theory.
-Require Import Ring_theory.
-
-Set Implicit Arguments.
-
-Section Old2New.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-Let Aminus := fun x y => Aplus x (Aopp y).
-
-Lemma ring_equiv1 :
-  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
-Proof.
-destruct R.
-split;  eauto.
-Qed.
-
-End Old2New.
-
-Section New2OldRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma ring_equiv2 :
-   Ring_Theory radd  rmul rI rO ropp reqb.
-Proof.
-elim Rth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
- Definition default_eqb : R -> R -> bool := fun x y => false.
- Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
-Proof.
-discriminate 1.
-Qed.
-
-End New2OldRing.
-
-Section New2OldSemiRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul: R->R->R).
- Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma sring_equiv2 :
-   Semi_Ring_Theory radd rmul rI rO reqb.
-Proof.
-elim SRth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
-End New2OldSemiRing.
diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v
deleted file mode 100644
index d8847036..00000000
--- a/contrib/setoid_ring/Ring_polynom.v
+++ /dev/null
@@ -1,1781 +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        *)
-(************************************************************************)
-
-Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinList.
-Require Import BinPos.
-Require Import BinNat.
-Require Import BinInt.
-Require Export Ring_theory.
-
-Open Local Scope positive_scope.
-Import RingSyntax.
-
-Section MakeRingPol.
- 
- (* 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.
-
- (* 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.
- 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).
-
- (* 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.
- 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:list R) (M: Mon) {struct M} : R :=
-  match M with
-     mon0 => rI
-  | zmon j M1  => Mphi (jump j l) M1
-  | vmon i M1 =>
-     let x := hd 0 l in
-     let xi := pow_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 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 =>
-            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 c M1 in
-                 (mkPinj j1 R, mkPinj j1 S)
-      | 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 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 c (mkZmon xH M1) in
-                 (mkPX R1 i Q1, S1)
-      | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in
-                 (mkPX R1 i Q1, S1)
-      | 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) (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) (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) (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 ((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 ((C * 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 ((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
-    end.
-
- (** Evaluation of a polynomial towards R *)
-
- Fixpoint Pphi(l:list 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 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 <-jump_Pplus;rewrite Pplus_comm;rrefl.
- Qed.
-
- Let pow_pos_Pplus := 
-    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
-
- Lemma mkPX_ok : forall l P i Q, 
-  (mkPX P i Q)@l == P@l*(pow_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 [?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. 
- 
- 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 <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl;rsimpl.
-  rewrite IHP2;simpl.
-  rewrite jump_Pdouble_minus_one;rsimpl.
-  rewrite IHP';rsimpl.
-  destruct P;simpl. 
-  Esimpl2;add_push [c];rrefl.
-  destruct p0;simpl;Esimpl2.
-  rewrite IHP'2;simpl.
-  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;simpl.
-  rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1;rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-  rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_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 jump_Pdouble_minus_one;apply (ARadd_comm ARth).
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
-    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (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 <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl;rsimpl.
-  rewrite IHP2;simpl.
-  rewrite jump_Pdouble_minus_one;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.
-  add_push (P @ (jump p0 (jump p0 (tail l))));rrefl.
-  rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl.
-  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1; rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-   rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_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.
-   apply (ARadd_comm ARth);trivial.
-   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial.
-   apply (ARadd_comm ARth);trivial.
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
-    rewrite IHP'1;rsimpl;add_push (P5 @ (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 symmetriv version *)
-
- Lemma PmulI_ok : 
-  forall P', 
-   (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
-   forall (P : Pol) (p : positive) (l : list R),
-    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
- Proof.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
-  rewrite H1; rewrite H;rrefl.
-  rewrite H1; rewrite H.
-  rewrite Pplus_comm.
-  rewrite jump_Pplus;simpl;rrefl.
-  rewrite H1;rewrite Pplus_comm.
-  rewrite jump_Pplus;rewrite IHP;rrefl.
-  destruct p0;Esimpl2.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
-  rewrite IHP1;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p).
-  rewrite H;rrefl.
- Qed.
-
-(*
- Lemma PmulI_ok : 
-  forall P', 
-   (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
-   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;simpl;rewrite IHP'2;Esimpl.
-   rewrite jump_Pdouble_minus_one;Esimpl.
-   rewrite H;Esimpl.
-   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
-   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
-   rewrite PmulI_ok;trivial.
-   mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl.
- Qed.
-
-(*
-Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
- Proof.
-  destruct P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  rewrite (PmulI_ok P (Pmul_aux_ok P)).
-  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 mkZmon_ok: forall M j l,
-   Mphi l (mkZmon j M) == Mphi l (zmon j M).
- intros M j l; case M; simpl; intros; rsimpl.
- Qed.
- 
- Lemma zmon_pred_ok : forall M j l, 
-    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
- Proof.
-   destruct j; simpl;intros auto; rsimpl.
-   rewrite mkZmon_ok;rsimpl.
-   rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl.
- Qed.
-
- Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
- Proof.
-  destruct M;simpl;intros;rsimpl.
-   rewrite zmon_pred_ok;simpl;rsimpl.
-  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
- Qed.
-
- Lemma 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 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.
-
- 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 (c, M) (jump j l)); case (MFactor P c M);
-        simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
-       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 (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 (c,zmon j M1) l); 
-     case (MFactor P2 c (zmon j M1)).
-     intros R1 S1 H1.
-     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.  
-     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 (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)).
-       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.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       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.
-       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 <- (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 (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.
-       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 (ARmul_comm ARth); rsimpl.
-       repeat (rewrite <- (ARmul_assoc ARth)).
-       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 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
- Proof.
- 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);
-        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,
-    [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.
-   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 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
- Proof.
- 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 (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
-    match LM1 with 
-     cons (M1,P2) LM2 =>  ([fst M1] * Mphi l (snd 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:list R) (pe:PExpr) {struct pe} : R :=
-   match pe with
-   | PEc c => phi c
-   | PEX j => nth 0 j l
-   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
-   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
-   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
-   | PEopp pe1 => - (PEeval l pe1)
-   | 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.
- Proof.
-  destruct p;simpl;intros;Esimpl;trivial.
-  rewrite <-jump_tl;rewrite nth_jump;rrefl.
-  rewrite <- nth_jump.
-  rewrite nth_Pdouble_minus_one;rrefl.
- 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 by trivial. Esimpl.  Qed.
-    
- End POWER.
-
- (** Normalization and rewriting *)
-
- Section NORM_SUBST_REC.
-  Variable n : nat.
-  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.
-
-  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 (intros;rrefl).
-   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
-      repeat rewrite Pmul_ok;rrefl.
-  Qed.
-
- Lemma norm_subst_spec : 
-     forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_subst pe)@l.
- Proof.
-  intros;unfold norm_subst.
-  unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
- Qed. 
- 
- End NORM_SUBST_REC.
-  
- Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop :=
-   match lpe with
-   | nil => True
-   | (me,pe)::lpe => 
-     match lpe with
-     | nil => PEeval l me == PEeval l pe
-     | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
-     end
-  end.
-
-  Fixpoint mon_of_pol (P:Pol) : option (C * Mon) :=
-  match P with
-  | Pc c => if (c ?=! cO) then None else Some (c, mon0)
-  | Pinj j P =>
-    match mon_of_pol P with 
-    | None => None
-    | 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 (c,m) => Some (c, mkVmon i m)
-      end
-    else None
-  end.
-
- Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) :=
-  match lpe with
-  | nil => nil
-  | (me,pe)::lpe =>
-    match mon_of_pol (norm_subst 0 nil me) with
-    | None => mk_monpol_list lpe 
-    | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe 
-    end
-  end.
-
-  Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
-              forall l, [fst m] * Mphi l (snd m) == P@l.
-  Proof.
-    induction P;simpl;intros;Esimpl.  
-    assert (H1 := (morph_eq CRmorph) c cO).
-    destruct (c ?=! cO).
-    discriminate.
-    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
-        | PX _ _ _ => false
-        end with (P3 ?== P0).
-    assert (H := Peq_ok P3 P0).
-    destruct (P3 ?== P0).
-    case_eq (mon_of_pol P2);try intros (cc, pp); intros.
-    inversion H1.
-    simpl.
-    rewrite mkVmon_ok;simpl.
-    rewrite H;trivial;Esimpl.
-     generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl.
-    discriminate.
-    intros;discriminate.
-   Qed.
- 
- Lemma interp_PElist_ok : forall l lpe, 
-         interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l.
- Proof.
-   induction lpe;simpl. trivial.
-   destruct a;simpl;intros.
-   assert (HH:=mon_of_pol_ok (norm_subst 0 nil  p));
-     destruct  (mon_of_pol (norm_subst 0 nil p)).  
-   split.
-   rewrite <- norm_subst_spec 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.
-   apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
- Qed.
-
- Lemma norm_subst_ok : forall n l lpe pe,
-   interp_PElist l lpe ->
-   PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l.
- Proof.
-   intros;apply norm_subst_spec. apply interp_PElist_ok;trivial.
-  Qed.
- 
- Lemma ring_correct : forall n l lpe pe1 pe2,
-   interp_PElist l lpe ->
-   (let lmp := mk_monpol_list lpe in
-   norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true ->
-   PEeval l pe1 == PEeval l pe2.
- Proof.
-  simpl;intros.
-  do 2 (rewrite (norm_subst_ok n l lpe);trivial). 
-  apply Peq_ok;trivial.
- Qed.  
-
-
-
-  (** Generic evaluation of polynomial towards R avoiding parenthesis *)
- Variable get_sign : C -> option C.
- Variable get_sign_spec : sign_theory copp ceqb get_sign.
-
-
- Section EVALUATION.
-
-  (* [mkpow x p] = x^p *)
-  Variable mkpow : R -> positive -> R.
-  (* [mkpow x p] = -(x^p) *)
-  Variable mkopp_pow : R -> positive -> R.
-  (* [mkmult_pow r x p] = r * x^p *)
-  Variable mkmult_pow : R -> R -> positive -> R.
-    
-  Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R :=
-   match lm with
-   | nil => r
-   | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t 
-   end.
-
-  Definition mkmult1 lm :=
-   match lm with
-   | nil => 1
-   | cons (x,p) t => mkmult_rec (mkpow x p) t 
-   end.
-
-  Definition mkmultm1 lm :=
-   match lm with
-   | nil => ropp rI
-   | cons (x,p) t => mkmult_rec (mkopp_pow x p) t 
-   end.
-
-  Definition mkmult_c_pos c lm :=
-   if c ?=! cI then mkmult1 (rev' lm)
-   else mkmult_rec [c] (rev' lm).
-
-  Definition mkmult_c c lm :=
-   match get_sign c with
-   | None => mkmult_c_pos c lm
-   | Some c' => 
-     if c' ?=! cI then mkmultm1 (rev' lm)
-     else mkmult_rec [c] (rev' lm)
-   end.
-      
-  Definition mkadd_mult rP c lm :=
-   match get_sign c with
-   | None => rP + mkmult_c_pos c lm
-   | Some c' => rP - mkmult_c_pos c' lm
-   end.
-
-  Definition add_pow_list (r:R) n l :=
-   match n with 
-   | N0 => l
-   | Npos p => (r,p)::l
-   end.
-
-  Fixpoint add_mult_dev 
-      (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
-   match P with
-   | Pc c => 
-     let lm := add_pow_list (hd 0 fv) n lm in
-     mkadd_mult rP c lm
-   | Pinj j Q => 
-     add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
-   | PX P i Q => 
-     let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
-     if Q ?== P0 then rP 
-     else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
-   end.
-
-  Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) 
-                     (lm:list (R*positive)) {struct P} : R :=
-  (* P@l * (hd 0 l)^n * lm *)						      
-  match P with
-  | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
-  | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
-  | PX P i Q => 
-     let rP := mult_dev P fv (Nplus (Npos i) n) lm in
-     if Q ?== P0 then rP 
-     else 
-       let lmq := add_pow_list (hd 0 fv) n lm in
-       add_mult_dev rP Q (tail fv) N0 lmq
-  end. 
-
- Definition Pphi_avoid fv P := mult_dev P fv N0 nil.
- 
- Fixpoint r_list_pow (l:list (R*positive)) : R :=
-  match l with
-  | nil => rI
-  | cons (r,p) l => pow_pos rmul r p * r_list_pow l 
-  end.
-
-  Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p.
-  Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). 
-  Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p.
-
- Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm.
- Proof.
-   induction lm;intros;simpl;Esimpl.
-   destruct a as (x,p);Esimpl.
-   rewrite IHlm. rewrite mkmult_pow_spec. Esimpl.
-  Qed.
-
- Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm.
- Proof.
-   destruct lm;simpl;Esimpl.
-   destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl.
- Qed.
-
- Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm.
- Proof.
-  destruct lm;simpl;Esimpl.
-  destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl.
- Qed.
-
- Lemma r_list_pow_rev :  forall l, r_list_pow (rev' l) == r_list_pow l.
- Proof.
-   assert 
-    (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
-   induction l;intros;simpl;Esimpl.
-   destruct a;rewrite IHl;Esimpl.
-   rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl.
-  intros;unfold rev'. rewrite H;simpl;Esimpl.
-  Qed.
-
- Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm.
- Proof.
-  intros;unfold mkmult_c_pos;simpl.
-   assert (H := (morph_eq CRmorph) c cI).
-   rewrite <- r_list_pow_rev; destruct (c ?=! cI). 
-  rewrite H;trivial;Esimpl.
-  apply mkmult1_ok.  apply mkmult_rec_ok.
- Qed.
-
- Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm.
- Proof.
-  intros;unfold mkmult_c;simpl.
-  case_eq (get_sign c);intros.
-  assert (H1 := (morph_eq CRmorph) c0  cI).
-  destruct (c0 ?=! cI).
-   rewrite (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.
- apply mkmult_c_pos_ok.
-Qed.
-
- Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm.
- Proof.
-  intros;unfold mkadd_mult.
-  case_eq (get_sign c);intros.
-  rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl.
-  rewrite mkmult_c_pos_ok;Esimpl.
-  rewrite mkmult_c_pos_ok;Esimpl.
- Qed.
-
- Lemma add_pow_list_ok : 
-      forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l.
- Proof.
-   destruct n;simpl;intros;Esimpl.
- Qed.
-
- Lemma add_mult_dev_ok : forall P rP fv n lm, 
-    add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
-  Proof.
-    induction P;simpl;intros.  
-    rewrite mkadd_mult_ok. rewrite  add_pow_list_ok; Esimpl.
-    rewrite IHP. simpl. rewrite  add_pow_list_ok; Esimpl.
-    change (match P3 with
-       | Pc c => c ?=! cO
-       | Pinj _ _ => false
-       | PX _ _ _ => false
-       end) with (Peq P3 P0).
-   change match n with
-    | N0 => Npos p
-    | Npos q => Npos (p + q)
-    end with (Nplus (Npos p) n);trivial.
-   assert (H := Peq_ok P3 P0).
-    destruct (P3 ?== P0).
-    rewrite (H (refl_equal true)).
-   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
-   rewrite  IHP2.
-   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
- Qed.
-
- Lemma mult_dev_ok : forall P fv n lm,    
-    mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
- Proof.
-   induction P;simpl;intros;Esimpl.
-   rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl.
-   rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl.
-  change (match P3 with
-       | Pc c => c ?=! cO
-       | Pinj _ _ => false
-       | PX _ _ _ => false
-       end) with (Peq P3 P0).
-   change match n with
-    | N0 => Npos p
-    | Npos q => Npos (p + q)
-    end with (Nplus (Npos p) n);trivial.
-   assert (H := Peq_ok P3 P0).
-    destruct (P3 ?== P0).
-    rewrite (H (refl_equal true)).
-   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
-   rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok.
-   destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
-  Qed.
-
- Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P  == P@fv.
- Proof.
-   unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl.
- Qed.
-
- End EVALUATION.
-
-  Definition Pphi_pow := 
-   let mkpow x p := 
-      match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in
-   let mkopp_pow x p := ropp (mkpow x p)  in
-   let mkmult_pow r x p := rmul r (mkpow x p) in
-    Pphi_avoid mkpow mkopp_pow mkmult_pow.
-
- Lemma local_mkpow_ok : 
-   forall (r : R) (p : positive),
-    match p with
-    | xI _ => rpow r (Cp_phi (Npos p))
-    | xO _ => rpow r (Cp_phi (Npos p))
-    | 1 => r
-    end == pow_pos rmul r p.
- Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
- 
- Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P  == P@fv.
- Proof.
-  unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
- Qed.
-
- Lemma ring_rw_pow_correct : forall n lH l,  
-      interp_PElist l lH ->
-      forall lmp, mk_monpol_list lH = lmp ->
-      forall pe npe, norm_subst n lmp pe = npe ->
-      PEeval l pe == Pphi_pow l npe.
- Proof.
-  intros n lH l H1 lmp Heq1 pe npe Heq2.
-  rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1.
-  apply norm_subst_ok. trivial.
- Qed.
-
- Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := 
-   match p with
-   | xH => r*x 
-   | xO p => mkmult_pow (mkmult_pow r x p) x p
-   | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p
-   end.
- 
-  Definition mkpow x p :=
-    match p with 
-    | xH => x
-    | xO p => mkmult_pow x x (Pdouble_minus_one p)
-    | xI p => mkmult_pow x x (xO p)
-    end.
- 
-  Definition mkopp_pow x p :=
-    match p with 
-    | xH => -x
-    | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
-    | xI p => mkmult_pow (-x) x (xO p)
-    end.
-
-  Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow.
-
-  Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
-  Proof.
-    induction p;intros;simpl;Esimpl.   
-    repeat rewrite IHp;Esimpl.
-    repeat rewrite IHp;Esimpl.
-  Qed.
-  
- Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
-  Proof.
-    destruct p;simpl;intros;Esimpl.
-    repeat rewrite mkmult_pow_ok;Esimpl.
-    rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1). 
-    rewrite <- pow_pos_Pplus. 
-    rewrite <- Pplus_one_succ_l.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    simpl;Esimpl.
-    trivial.
-  Qed.
- 
-  Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
-  Proof.
-    destruct p;simpl;intros;Esimpl.
-    repeat rewrite mkmult_pow_ok;Esimpl.
-    rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1). 
-    rewrite <- pow_pos_Pplus. 
-    rewrite <- Pplus_one_succ_l.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    simpl;Esimpl.
-    trivial.
-  Qed.
-
- Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv.
-  Proof.
-   unfold Pphi_dev;intros;apply Pphi_avoid_ok.
-   intros;apply mkpow_ok.
-   intros;apply mkopp_pow_ok.
-   intros;apply mkmult_pow_ok.
-  Qed.
-
- Lemma ring_rw_correct : forall n lH l,  
-      interp_PElist l lH ->
-      forall lmp, mk_monpol_list lH = lmp ->
-      forall pe npe, norm_subst n lmp pe = npe ->
-      PEeval l pe == Pphi_dev l npe.
- Proof.
-  intros n lH l H1 lmp Heq1 pe npe Heq2.
-  rewrite  Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1.
-  apply norm_subst_ok. trivial.
- Qed.
-
-
-End MakeRingPol.
-
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
deleted file mode 100644
index ad20fa08..00000000
--- a/contrib/setoid_ring/Ring_tac.v
+++ /dev/null
@@ -1,386 +0,0 @@
-Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinPos.
-Require Import Ring_polynom.
-Require Import BinList.
-Require Import InitialRing.
-  
-
-(* adds a definition id' on the normal form of t and an hypothesis id
-   stating that t = id' (tries to produces a proof as small as possible) *)
-Ltac compute_assertion id  id' t :=
-  let t' := eval vm_compute in t in
-  pose (id' := t');
-  assert (id : t = id');
-  [vm_cast_no_check (refl_equal id')|idtac].
-(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *)
-
-(********************************************************************)
-(* Tacticals to build reflexive tactics *)
-
-Ltac OnEquation req :=
-  match goal with
-  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
-  | _ => fail 1 "Goal is not an equation (of expected equality)"
-  end.
-
-Ltac OnMainSubgoal H ty :=
-  match ty with
-  | _ -> ?ty' =>
-     let subtac := OnMainSubgoal H ty' in
-     fun tac => lapply H; [clear H; intro H; subtac tac | idtac]
-  | _ => (fun tac => tac)
-  end.
-
-Ltac ApplyLemmaThen lemma expr tac :=
-  let nexpr := fresh "expr_nf" in
-  let H := fresh "eq_nf" in
-  let Heq := fresh "thm" in
-  let nf_spec :=
-    match type of (lemma expr) with
-      forall x, ?nf_spec = x -> _ => nf_spec
-    | _ => fail 1 "ApplyLemmaThen: cannot find norm expression"
-    end in
-  compute_assertion H nexpr nf_spec;
-  assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma";
-  clear H;
-  OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr).
-
-Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
-  let npe := fresh "expr_nf" in
-  let H := fresh "eq_nf" in
-  let Heq := fresh "thm" in
-  let npe_spec :=
-    match type of (lemma expr) with
-      forall npe, ?npe_spec = npe -> _ => npe_spec
-    | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
-    end in
-  (compute_assertion H npe npe_spec;
-   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
-   clear H;
-   OnMainSubgoal Heq ltac:(type of Heq)
-     ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)).
-
-(* General scheme of reflexive tactics using of correctness lemma
-   that involves normalisation of one expression *)
-
-Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms :=
-  (* extend the atom list *)
-  let fv := list_fold_left FV_tac fv terms in
-  let RW_tac lemma := 
-     let fcons term CONT_tac cont_arg := 
-      let expr := SYN_tac term fv in
-      (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in
-     (* rewrite steps *)
-     lazy_list_fold_right fcons ltac:(idtac) terms in
-  LEMMA_tac fv RW_tac.
-
-(********************************************************)
-
-
-(* Building the atom list of a ring expression *)
-Ltac FV Cst CstPow add mul sub opp pow t fv :=
- let rec TFV t fv :=
-  match Cst t with
-  | NotConstant =>
-      match t with
-      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
-      | (opp ?t1) => TFV t1 fv
-      | (pow ?t1 ?n) =>
-        match CstPow n with
-        | InitialRing.NotConstant => AddFvTail t fv
-        | _ => TFV t1 fv
-        end
-      | _ => AddFvTail t fv
-      end
-  | _ => fv
-  end
- in TFV t fv.
-
- (* syntaxification of ring expressions *)
-Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := 
- let rec mkP t :=
-    let f :=
-    match Cst t with
-    | InitialRing.NotConstant =>
-        match t with 
-        | (radd ?t1 ?t2) => 
-          fun _ =>
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEadd e1 e2)
-        | (rmul ?t1 ?t2) => 
-          fun _ =>
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEmul e1 e2)
-        | (rsub ?t1 ?t2) => 
-          fun _ => 
-          let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEsub e1 e2)
-        | (ropp ?t1) =>
-          fun _ =>
-          let e1 := mkP t1 in constr:(PEopp e1)
-        | (rpow ?t1 ?n) =>
-          match CstPow n with
-          | InitialRing.NotConstant => 
-            fun _ => let p := Find_at t fv in constr:(PEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
-          end
-        | _ =>
-          fun _ => let p := Find_at t fv in constr:(PEX C p)
-        end
-    | ?c => fun _ => constr:(@PEc C c)
-    end in
-    f ()
- in mkP t.
-
-Ltac ParseRingComponents lemma :=
-  match type of lemma with
-  | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
-      (fun f => f R add mul sub opp pow C)
-  | _ => fail 1 "ring anomaly: bad correctness lemma (parse)"
-  end.
-
-(* ring tactics *)
-
-Ltac relation_carrier req :=
-  let ty := type of req in
-  match eval hnf in ty with
-   ?R -> _ => R
-  | _ => fail 1000 "Equality has no relation type"
-  end.
-
-Ltac FV_hypo_tac mkFV req lH :=
-  let R := relation_carrier req in
-  let FV_hypo_l_tac h :=
-    match h with @mkhypo (req ?pe _) _ => mkFV pe end in
-  let FV_hypo_r_tac h :=
-    match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
-  let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
-  list_fold_right FV_hypo_r_tac fv lH.
-
-Ltac mkHyp_tac C req mkPE lH :=
-  let mkHyp h res := 
-   match h with 
-   | @mkhypo (req ?r1 ?r2) _ =>
-     let pe1 := mkPE r1 in
-     let pe2 := mkPE r2 in
-     constr:(cons (pe1,pe2) res)
-   | _ => fail 1 "hypothesis is not a ring equality"
-   end in
-  list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
-     
-Ltac proofHyp_tac lH :=
-  let get_proof h :=
-    match h with
-    | @mkhypo _ ?p => p
-    end in
-  let rec bh l :=
-    match l with
-    | nil => constr:(I)
-    | cons ?h nil => get_proof h
-    | cons ?h ?tl => 
-      let l := get_proof h in
-      let r := bh tl in  
-      constr:(conj l r)
-    end in
-  bh lH.
-
-Definition ring_subst_niter := (10*10*10)%nat.
- 
-Ltac Ring Cst_tac CstPow_tac lemma1 req n lH :=
-  let Main lhs rhs R radd rmul rsub ropp rpow C :=
-    let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in
-    let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let fv := mkFV lhs fv in
-    let fv := mkFV rhs fv in
-    check_fv fv;
-    let pe1 := mkPol lhs fv in
-    let pe2 := mkPol rhs fv in
-    let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-    let vlpe := fresh "hyp_list" in
-    let vfv := fresh "fv_list" in
-    pose (vlpe := lpe);
-    pose (vfv := fv);
-    (apply (lemma1 n vfv vlpe pe1 pe2)
-      || fail "typing error while applying ring");
-    [ ((let prh := proofHyp_tac lH in exact prh)
-        || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") 
-    | vm_compute;
-      (exact (refl_equal true) || fail "not a valid ring equation")] in
-  ParseRingComponents lemma1 ltac:(OnEquation req Main).
-
-Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
-  let Main R add mul sub opp pow C :=
-    let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in
-    let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in
-    let fv := FV_hypo_tac mkFV req lH in
-    let simpl_ring H := (protect_fv "ring" in H; f H) in
-    let lemma_tac fv RW_tac := 
-      let rr_lemma := fresh "r_rw_lemma" in
-      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
-      let vlpe := fresh "list_hyp" in
-      let vlmp := fresh "list_hyp_norm" in
-      let vlmp_eq := fresh "list_hyp_norm_eq" in
-      let prh := proofHyp_tac lH in
-      pose (vlpe := lpe);
-      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 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 := Get_goal in
-  ring_lookup Ring_gen [] G.
-
-Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
-  let G := Get_goal in
-  ring_lookup Ring_gen [lH] G.
-
-(* Simplification *)
-
-Ltac Ring_simplify_gen f :=
-  fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     let l := fresh "to_rewrite" in
-     pose (l:= rl);
-     generalize (refl_equal l);
-     unfold l at 2;
-     pre(); 
-     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() 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).
-
-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 := 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 := 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.
-
-Tactic Notation (at level 0) 
-  "ring_simplify" constr_list(rl) := 
-  match goal with [|- ?G] => ring_lookup Ring_simplify [] rl G end.
-
-Tactic Notation (at level 0) 
-  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= 
-  let t := type of h in
-  ring_lookup 
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post()) 
-  [lH] rl t. 
-(*  ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *)
-
-Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp).
-
-Tactic Notation (at level 0) 
-  "ring_simplify" constr_list(rl) "in" constr(h):= 
-  let t := type of h in
-  ring_lookup   
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post())
- [] rl t.
-
-Ltac rw_in H Heq := rewrite Heq in H.
-
-Ltac simpl_in H := 
-  let t := type of H in
-   ring_lookup 
-   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
-     pre(); 
-     Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
-     post()) 
-   [] t.
-
-
-*)
diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v
deleted file mode 100644
index 531ab3ca..00000000
--- a/contrib/setoid_ring/Ring_theory.v
+++ /dev/null
@@ -1,608 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Setoid.
-Require Import BinPos.
-Require Import BinNat.
-
-Set Implicit Arguments.
-
-Module RingSyntax.
-Reserved Notation "x ?=! y" (at level 70, no associativity).
-Reserved Notation "x +! y " (at level 50, left associativity).
-Reserved Notation "x -! y" (at level 50, left associativity).
-Reserved Notation "x *! y" (at level 40, left associativity).
-Reserved Notation "-! x" (at level 35, right 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).
-Reserved Notation "x ** y" (at level 40, left associativity).
-Reserved Notation "-- x" (at level 35, right associativity).
-
-Reserved Notation "x == y" (at level 70, no associativity).
-End RingSyntax.
-Import RingSyntax.
-
-Section Power.
- Variable R:Type.
- Variable rI : R.
- Variable rmul : R -> R -> R.
- Variable req : R -> R -> Prop.
- Variable Rsth : Setoid_Theory R req.
- Notation "x * y " := (rmul x y).
- Notation "x == y" := (req x y).
-
- Hypothesis mul_ext : 
-   forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
- Hypothesis mul_comm : forall x y, x * y == y * x.
- Hypothesis mul_assoc  : forall x y z, x * (y * z) == (x * y) * z.
- Add Setoid R req Rsth as R_set_Power.
- Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed.
-
-
- Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
-  match i with
-  | xH => x
-  | xO i => let p := pow_pos x i in rmul p p
-  | xI i => let p := pow_pos x i in rmul x (rmul p p)
-  end.
-
- Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
- Proof.
-  induction j;simpl.
-  rewrite IHj.
-  rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
-  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).
- Qed.
-
- Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j.
- Proof.
-  intro x;induction i;intros.
-  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc.
-  simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc;
-   simpl. apply (Seq_refl _ _ Rsth).
- Qed.
-
- Definition pow_N (x:R) (p:N) := 
-  match p with
-  | N0 => rI
-  | Npos p => pow_pos x p
-  end. 
-
- Definition id_phi_N (x:N) : N := x.
-
- Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n.
- Proof.
-  intros; apply (Seq_refl _ _ Rsth).
- Qed.
-
-End Power.
-
-Section DEFINITIONS.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-
- (** Semi Ring *)
- Record semi_ring_theory : Prop := mk_srt {
-    SRadd_0_l   : forall n, 0 + n == n;
-    SRadd_comm   : forall n m, n + m == m + n ;
-    SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
-    SRmul_1_l   : forall n, 1*n == n;
-    SRmul_0_l   : forall n, 0*n == 0; 
-    SRmul_comm   : forall n m, n*m == m*n;
-    SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
-    SRdistr_l   : forall n m p, (n + m)*p == n*p + m*p
-  }.
-  
- (** Almost Ring *)
-(*Almost ring are no ring : Ropp_def is missing **)
- Record almost_ring_theory : Prop := mk_art {
-    ARadd_0_l   : forall x, 0 + x == x;
-    ARadd_comm   : forall x y, x + y == y + x;
-    ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z;
-    ARmul_1_l   : forall x, 1 * x == x;
-    ARmul_0_l   : forall x, 0 * x == 0;
-    ARmul_comm   : forall x y, x * y == y * x;
-    ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
-    ARdistr_l   : forall x y z, (x + y) * z == (x * z) + (y * z);
-    ARopp_mul_l : forall x y, -(x * y) == -x * y;
-    ARopp_add   : forall x y, -(x + y) == -x + -y;
-    ARsub_def   : forall x y, x - y == x + -y
-  }. 
-
- (** Ring *)
- Record ring_theory : Prop := mk_rt {
-    Radd_0_l    : forall x, 0 + x == x;
-    Radd_comm    : forall x y, x + y == y + x;
-    Radd_assoc  : forall x y z, x + (y + z) == (x + y) + z;
-    Rmul_1_l    : forall x, 1 * x == x;
-    Rmul_comm    : forall x y, x * y == y * x;
-    Rmul_assoc  : forall x y z, x * (y * z) == (x * y) * z;
-    Rdistr_l    : forall x y z, (x + y) * z == (x * z) + (y * z);
-    Rsub_def    : forall x y, x - y == x + -y;
-    Ropp_def    : forall x, x + (- x) == 0
- }.
-
- (** Equality is extensional *)
-  
- Record sring_eq_ext : Prop := mk_seqe {
-    (* SRing operators are compatible with equality *)
-    SRadd_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
-    SRmul_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2
-  }.
-
- Record ring_eq_ext : Prop := mk_reqe {
-    (* Ring operators are compatible with equality *)
-    Radd_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
-    Rmul_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
-    Ropp_ext : forall x1 x2, x1 == x2 ->  -x1 == -x2
-  }.
-
- (** Interpretation morphisms definition*) 
- Section MORPHISM.
- Variable C:Type.
- Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool.
- (* [phi] est un morphisme de [C] dans [R] *) 
- Variable phi : C -> R.
- Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y).
- Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x).
- Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
-
-(*for semi rings*)
- Record semi_morph : Prop := mkRmorph {
-    Smorph0 : [cO] == 0;
-    Smorph1 : [cI] == 1;
-    Smorph_add : forall x y, [x +! y] == [x]+[y];
-    Smorph_mul : forall x y, [x *! y] == [x]*[y];
-    Smorph_eq  : forall x y, x?=!y = true -> [x] == [y] 
-  }.
-
-(* for rings*)
- Record ring_morph : Prop := mkmorph {
-    morph0    : [cO] == 0;
-    morph1    : [cI] == 1;
-    morph_add : forall x y, [x +! y] == [x]+[y];
-    morph_sub : forall x y, [x -! y] == [x]-[y];
-    morph_mul : forall x y, [x *! y] == [x]*[y];
-    morph_opp : forall x, [-!x] == -[x];
-    morph_eq  : forall x y, x?=!y = true -> [x] == [y] 
-  }.
-
- Section SIGN.
-  Variable get_sign : C -> option C.
-  Record sign_theory : Prop := mksign_th {
-    sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true
-  }.
- End SIGN.
-
- Definition get_sign_None (c:C) := @None C.
-
- Lemma get_sign_None_th : sign_theory get_sign_None.
- Proof. constructor;intros;discriminate. Qed.
-
- 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 *)
- Variable Rsth : Setoid_Theory R req.
-   Add Setoid R req Rsth as R_setoid1.
- Variable reqb : R->R->bool.
- Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
- Definition IDphi (x:R) := x.
- Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi.
- Proof.
-  apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi;
-  try apply (Seq_refl _ _ Rsth);auto.
- Qed.
-
- (** Specification of the power function *)
- Section POWER.
-  Variable Cpow : Set.
-  Variable Cp_phi : N -> Cpow.
-  Variable rpow : R -> Cpow -> R. 
-  
-  Record power_theory : Prop := mkpow_th {
-    rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n)
-  }.
-
- End POWER.
-
- Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
-
- 
-End DEFINITIONS.
-
-
-
-Section ALMOST_RING.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
-
- (** Leibniz equality leads to a setoid theory and is extensional*)
- Lemma Eqsth : Setoid_Theory R (@eq R).
- Proof.  constructor;red;intros;subst;trivial. Qed.
-
- Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
- Proof. constructor;intros;subst;trivial. Qed.
-
- Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R).
- Proof. constructor;intros;subst;trivial. Qed.
-
- Variable Rsth : Setoid_Theory R req.
-   Add Setoid R req Rsth as R_setoid2.
-   Ltac sreflexivity := apply (Seq_refl _ _ Rsth).
- 
- Section SEMI_RING.
- Variable SReqe : sring_eq_ext radd rmul req.
-   Add Morphism radd : radd_ext1.  exact (SRadd_ext SReqe). Qed.
-   Add Morphism rmul : rmul_ext1.  exact (SRmul_ext SReqe). Qed.
- Variable SRth : semi_ring_theory 0 1 radd rmul req.
-
- (** Every semi ring can be seen as an almost ring, by taking :
-        -x = x and x - y = x + y *)
- Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
- 
- Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
-
- Lemma SRopp_ext : forall x y, x == y -> -x == -y.
- Proof. intros x y H;exact H. Qed.
-
- Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req.
- Proof.
-  constructor.  exact (SRadd_ext SReqe). exact (SRmul_ext SReqe).
-  exact SRopp_ext.
- Qed.
-
- Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y.
- Proof. intros;sreflexivity. Qed.
-
- Lemma SRopp_add : forall x y, -(x + y) == -x + -y.
- Proof. intros;sreflexivity.  Qed.
-
-  
- Lemma SRsub_def   : forall x y, x - y == x + -y.
- Proof. intros;sreflexivity. Qed.
-
- Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req.
- Proof (mk_art 0 1 radd rmul SRsub SRopp req
-    (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth)
-    (SRmul_1_l SRth) (SRmul_0_l SRth)
-    (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
-    SRopp_mul_l SRopp_add SRsub_def).
- 
- (** Identity morphism for semi-ring equipped with their almost-ring structure*)
- Variable reqb : R->R->bool.
-
- Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
-
- Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req
-                            0 1 radd rmul SRsub SRopp reqb (@IDphi R).
- Proof.
-  apply mkmorph;intros;try sreflexivity.  unfold IDphi;auto.
- Qed.
-
- (* a semi_morph can be extended to a ring_morph for the almost_ring derived
-    from a semi_ring, provided the ring is a setoid (we only need
-    reflexivity) *)
- Variable C : Type.
- Variable (cO cI : C) (cadd cmul: C->C->C).
- Variable (ceqb : C -> C -> bool).
- Variable phi : C -> R.
- Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi.
-
- Lemma SRmorph_Rmorph :
-   ring_morph rO rI radd rmul SRsub SRopp req
-              cO cI cadd cmul cadd (fun x => x) ceqb phi.
- Proof.
- case Smorph; intros; constructor; auto.
- unfold SRopp in |- *; intros.
-  setoid_reflexivity.
- Qed.
-
- End  SEMI_RING.
- 
- Variable Reqe : ring_eq_ext radd rmul ropp req.
-   Add Morphism radd : radd_ext2.  exact (Radd_ext Reqe). Qed.
-   Add Morphism rmul : rmul_ext2.  exact (Rmul_ext Reqe). Qed.
-   Add Morphism ropp : ropp_ext2.  exact (Ropp_ext Reqe). Qed.
- 
- Section RING.
- Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
-
- (** Rings are almost rings*)
- Lemma Rmul_0_l : forall x, 0 * x == 0.
- Proof.
-  intro x; setoid_replace (0*x) with ((0+1)*x + -x).
-  rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth).
-  rewrite (Ropp_def Rth);sreflexivity.
-
-  rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth).
-  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity.
- Qed.
-
- Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y.
- Proof.
-  intros x y;rewrite <-(Radd_0_l Rth (- x * y)).
-  rewrite (Radd_comm Rth).
-  rewrite <-(Ropp_def Rth (x*y)).
-  rewrite (Radd_assoc Rth).
-  rewrite <- (Rdistr_l Rth).
-  rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
-  rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
- Qed.
- 
- Lemma Ropp_add : forall x y, -(x + y) == -x + -y.
- Proof.
-  intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))).
-  rewrite <- ((Ropp_def Rth) x).
-  rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))).
-  rewrite <- ((Ropp_def Rth) y).
-  rewrite ((Radd_comm Rth) x).
-  rewrite ((Radd_comm Rth) y).
-  rewrite <- ((Radd_assoc Rth) (-y)).
-  rewrite <- ((Radd_assoc Rth) (- x)).
-  rewrite ((Radd_assoc Rth)  y).
-  rewrite ((Radd_comm Rth) y).
-  rewrite <- ((Radd_assoc Rth)  (- x)).
-  rewrite ((Radd_assoc Rth) y).
-  rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth).
-  rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
-  apply (Radd_comm Rth).
- Qed.
- 
- Lemma Ropp_opp : forall x, - -x == x.
- Proof.
-  intros x; rewrite <- (Radd_0_l Rth (- -x)).
-  rewrite <- (Ropp_def Rth x).
-  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth).
- Qed.
-
- Lemma  Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
- Proof
-  (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth)
-    (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
-    Ropp_mul_l Ropp_add (Rsub_def Rth)).
-
- (** Every semi morphism between two rings is a morphism*) 
- Variable C : Type.
- Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C).
- Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool).
- Variable phi : C -> R.
-  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).
- Variable Csth : Setoid_Theory C ceq.
- Variable Ceqe : ring_eq_ext cadd cmul copp ceq.
-   Add Setoid C ceq Csth as C_setoid.
-   Add Morphism cadd : cadd_ext.  exact (Radd_ext Ceqe). Qed.
-   Add Morphism cmul : cmul_ext.  exact (Rmul_ext Ceqe). Qed.
-   Add Morphism copp : copp_ext.  exact (Ropp_ext Ceqe). Qed.
- Variable Cth : ring_theory cO cI cadd cmul csub copp ceq.
- Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi.
- Variable phi_ext : forall x y, ceq x y -> [x] == [y].
-   Add Morphism phi : phi_ext1.  exact phi_ext. Qed.
- Lemma Smorph_opp : forall x, [-!x] == -[x].
- Proof.
-  intros x;rewrite <-  (Rth.(Radd_0_l) [-!x]).
-  rewrite <- ((Ropp_def Rth) [x]).
-  rewrite ((Radd_comm Rth) [x]).
-  rewrite <- (Radd_assoc Rth).
-  rewrite <- (Smorph_add Smorph).
-  rewrite (Ropp_def Cth).
-  rewrite (Smorph0 Smorph).
-  rewrite (Radd_comm Rth (-[x])).
-  apply (Radd_0_l Rth);sreflexivity.
- Qed. 
-
- Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y].
- Proof.
-  intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth).
-  rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity.
- Qed.
-
- Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req 
-                                             cO cI cadd cmul csub copp ceqb phi.
- Proof
-  (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi
-        (Smorph0 Smorph) (Smorph1 Smorph) 
-         (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp
-         (Smorph_eq Smorph)).
-
- End 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.
-Proof.
-elim ARth; intros.
-constructor; trivial.
-Qed.
-
- Lemma ARsub_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
- Proof.
-  intros.
-  setoid_replace (x1 - y1) with (x1 + -y1). 
-  setoid_replace (x2 - y2) with (x2 + -y2).
-  rewrite H;rewrite H0;sreflexivity.
-  apply (ARsub_def ARth).
-  apply (ARsub_def ARth).
- Qed.
-   Add Morphism rsub : rsub_ext.  exact ARsub_ext. Qed.
-
- Ltac mrewrite :=
-   repeat first
-     [ rewrite (ARadd_0_l ARth)
-     | rewrite <- ((ARadd_comm ARth) 0)
-     | rewrite (ARmul_1_l ARth)
-     | rewrite <- ((ARmul_comm ARth) 1)
-     | rewrite (ARmul_0_l ARth)
-     | rewrite <- ((ARmul_comm ARth) 0)
-     | rewrite (ARdistr_l ARth)
-     | sreflexivity
-     | match goal with
-       | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
-       end].
- 
- Lemma ARadd_0_r : forall x, (x + 0) == x.
- Proof. intros; mrewrite. Qed.
- 
- Lemma ARmul_1_r   : forall x, x * 1 == x.
- Proof. intros;mrewrite. Qed.
-
- Lemma ARmul_0_r : forall x, x * 0 == 0.
- Proof. intros;mrewrite. Qed.
-
- Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
- Proof.
-  intros;mrewrite. 
-  repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
- Qed.
-
- Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
- Proof.
-  intros;rewrite <-(ARth.(ARadd_assoc) x).
-  rewrite (ARth.(ARadd_comm) x);sreflexivity.
- Qed.
-
- Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
- Proof.
-  intros; repeat rewrite <- (ARadd_assoc ARth);
-   rewrite ((ARadd_comm ARth) x); sreflexivity.
- Qed.
-
- Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x.
- Proof.
-  intros;rewrite <-((ARmul_assoc ARth) x).
-  rewrite ((ARmul_comm ARth) x);sreflexivity.
- Qed.
- 
- Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
- Proof.
-  intros; repeat rewrite <- (ARmul_assoc ARth);
-   rewrite ((ARmul_comm ARth) x); sreflexivity.
- Qed.
-
- Lemma ARopp_mul_r : forall x y,  - (x * y) == x * -y.
- Proof.
-  intros;rewrite ((ARmul_comm ARth) x y);
-   rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth).
- Qed.
-
- Lemma ARopp_zero : -0 == 0.
- Proof.
-  rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth).
-  repeat rewrite ARmul_0_r; sreflexivity.
- Qed.
-
-
-
-End ALMOST_RING.
-
-
-Section AddRing.
-
-(* Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable req : R -> R -> Prop. *)
-
-Inductive ring_kind : Type :=
-| Abstract
-| Computational
-    (R:Type)
-    (req : R -> R -> Prop)
-    (reqb : R -> R -> bool)
-    (_ : forall x y, (reqb x y) = true -> req x y)
-| Morphism
-    (R : Type)
-    (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R)
-    (req : R -> R -> Prop)
-    (C : Type)
-    (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C)
-    (ceqb : C->C->bool)
-    phi
-    (_ : ring_morph rO rI radd rmul rsub ropp req
-                    cO cI cadd cmul csub copp ceqb phi).
-
-
-End AddRing.
-
-
-(** Some simplification tactics*)
-Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
-
-Ltac gen_srewrite Rsth Reqe ARth :=
-  repeat first
-     [ gen_reflexivity Rsth
-     | progress rewrite (ARopp_zero Rsth Reqe ARth)
-     | rewrite (ARadd_0_l ARth)
-     | rewrite (ARadd_0_r Rsth ARth)
-     | rewrite (ARmul_1_l ARth)
-     | rewrite (ARmul_1_r Rsth ARth)
-     | rewrite (ARmul_0_l ARth)
-     | rewrite (ARmul_0_r Rsth ARth)
-     | rewrite (ARdistr_l ARth)
-     | rewrite (ARdistr_r Rsth Reqe ARth)
-     | rewrite (ARadd_assoc ARth)
-     | rewrite (ARmul_assoc ARth)
-     | progress rewrite (ARopp_add ARth)
-     | progress rewrite (ARsub_def ARth)
-     | progress rewrite <- (ARopp_mul_l ARth)
-     | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ].
-
-Ltac gen_add_push add Rsth Reqe ARth x :=
-  repeat (match goal with
-  | |- context [add (add ?y x) ?z] => 
-     progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z)
-  | |- context [add (add x ?y) ?z] => 
-     progress rewrite (ARadd_assoc1 Rsth ARth x y z)
-  end).
-
-Ltac gen_mul_push mul Rsth Reqe ARth x :=
-  repeat (match goal with
-  | |- context [mul (mul ?y x) ?z] => 
-     progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z)
-  | |- context [mul (mul x ?y) ?z] => 
-     progress rewrite (ARmul_assoc1 Rsth ARth x y z)
-  end).
-
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
deleted file mode 100644
index 942915ab..00000000
--- a/contrib/setoid_ring/ZArithRing.v
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Ring.
-Require Import ZArith_base.
-Require Import Zpow_def.
-
-Import InitialRing.
-
-Set Implicit Arguments.
-
-Ltac Zcst t :=
-  match isZcst t with
-    true => t
-  | _ => constr:NotConstant
-  end.
-
-Ltac isZpow_coef t :=
-  match t with 
-  | Zpos ?p => isPcst p
-  | Z0 => constr:true
-  | _ => constr:false
-  end.
-
-Definition N_of_Z x :=
- match x with
- | Zpos p => Npos p
- | _ => N0
- end.
-
-Ltac Zpow_tac t :=
- match isZpow_coef t with
- | true => constr:(N_of_Z t)
- | _ => constr:NotConstant
- end.
-
-Ltac Zpower_neg :=
-  repeat match goal with
-  | [|- ?G] => 
-    match G with 
-    | context c [Zpower _ (Zneg _)] =>
-      let t := context c [Z0] in
-      change t
-    end
-  end.   
-
-Add Ring Zr : Zth
-  (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
-   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
deleted file mode 100644
index 50b7e47b..00000000
--- a/contrib/setoid_ring/newring.ml4
+++ /dev/null
@@ -1,1172 +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        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*)
-
-open Pp
-open Util
-open Names
-open Term
-open Closure
-open Environ
-open Libnames
-open Tactics
-open Rawterm
-open Termops
-open Tacticals
-open Tacexpr
-open Pcoq
-open Tactic
-open Constr
-open Proof_type
-open Coqlib
-open Tacmach
-open Mod_subst
-open Tacinterp
-open Libobject
-open Printer
-open Declare
-open Decl_kinds
-open Entries
-
-(****************************************************************************)
-(* controlled reduction *)
-
-let mark_arg i c = mkEvar(i,[|c|])
-let unmark_arg f c =
-  match destEvar c with
-    | (i,[|c|]) -> f i c
-    | _ -> assert false
-
-type protect_flag = Eval|Prot|Rec
-
-let tag_arg tag_rec map subs i c =
-  match map i with
-      Eval -> mk_clos subs c
-    | Prot -> mk_atom c
-    | Rec -> if i = -1 then mk_clos subs c else tag_rec c
-
-let rec mk_clos_but f_map subs t =
-  match f_map t with
-    | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
-    | None ->
-        (match kind_of_term t with
-            App(f,args) -> mk_clos_app_but f_map subs f args 0
-          | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
-          | _ -> mk_atom t)
-
-and mk_clos_app_but f_map subs f args n =
-  if n >= Array.length args then mk_atom(mkApp(f, args))
-  else
-    let fargs, args' = array_chop n args in
-    let f' = mkApp(f,fargs) in
-    match f_map f' with
-        Some map ->
-          mk_clos_deep
-            (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
-            subs
-            (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
-      | None -> mk_clos_app_but f_map subs f args (n+1)
-
-
-let interp_map l c =
-  try
-    let (im,am) = List.assoc c l in
-    Some(fun i ->
-      if List.mem i im then Eval
-      else if List.mem i am then Prot
-      else if i = -1 then Eval
-      else Rec)
-  with Not_found -> None
-
-let interp_map l t =
-  try Some(List.assoc t l) with Not_found -> None
-
-let protect_maps = ref ([]:(string*(constr->'a)) list)
-let add_map s m = protect_maps := (s,m) :: !protect_maps
-let lookup_map map =
-  try List.assoc map !protect_maps
-  with Not_found ->
-    errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
-
-let protect_red map env sigma c =
-  kl (create_clos_infos betadeltaiota env)
-    (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);;
-
-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((all_occurrences_expr,id),InHyp));;
-
-
-TACTIC EXTEND protect_fv
-  [ "protect_fv" string(map) "in" ident(id) ] -> 
-    [ protect_tac_in map id ]
-| [ "protect_fv" string(map) ] -> 
-    [ protect_tac map ]
-END;;
-
-(****************************************************************************)
-
-let closed_term t l =
-  let l = List.map constr_of_global l in
-  let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
-  if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
-;;
-
-TACTIC EXTEND closed_term
-  [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
-    [ closed_term t l ]
-END
-;;
-
-TACTIC EXTEND echo 
-| [ "echo" constr(t) ] -> 
-  [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
-END;;
-
-(*
-let closed_term_ast l =
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
-   Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
-*)
-let closed_term_ast l =
-  let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
-   Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
-(*
-let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
-*)
-
-(****************************************************************************)
-
-let ic c =
-  let env = Global.env() and sigma = Evd.empty in
-  Constrintern.interp_constr sigma env c
-
-let ty c = Typing.type_of (Global.env()) Evd.empty c
-
-let decl_constant na c =
-  mkConst(declare_constant (id_of_string na) (DefinitionEntry 
-    { const_entry_body = c;
-      const_entry_type = None;
-      const_entry_opaque = true;
-      const_entry_boxed = true}, 
-    IsProof Lemma))
-
-let ltac_call tac (args:glob_tactic_arg list) =
-  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
-let ltac_acall tac (args:glob_tactic_arg list) =
-  TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)
-
-let ltac_lcall tac args =
-  TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
-
-let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
-
-let dummy_goal env = 
-  {Evd.it = Evd.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
-  let res = ref [||] in
-  let get_res ist =
-    let l = List.map (fun id ->  List.assoc id ist.lfun) lid in
-    res := Array.of_list l;
-    TacId[] in
-  let getter =
-    Tacexp(TacFun(List.map(fun id -> Some id) lid,
-                  glob_tactic(tacticIn get_res))) in
-  let _ =
-    Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
-  !res
-
-let constr_of = function
-  | VConstr c -> c
-  | _ -> failwith "Ring.exec_tactic: anomaly"
-
-let stdlib_modules =
-  [["Coq";"Setoids";"Setoid"];
-   ["Coq";"Lists";"List"];
-   ["Coq";"Init";"Datatypes"];
-   ["Coq";"Init";"Logic"];
-  ]
-
-let coq_constant c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
-
-let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
-let coq_cons = coq_constant "cons"
-let coq_nil = coq_constant "nil"
-let 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)
-
-let dest_rel0 t =  
-  match kind_of_term t with
-  | App(f,args) when Array.length args >= 2 ->
-      let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
-      if closed0 rel then
-        (rel,args.(Array.length args - 2),args.(Array.length args - 1))
-      else error "ring: cannot find relation (not closed)"
-  | _ -> error "ring: cannot find relation"
-
-let rec dest_rel t =
-  match kind_of_term t with
-  | Prod(_,_,c) -> dest_rel c
-  | _ -> dest_rel0 t
-
-(****************************************************************************)
-(* Library linking *)
-
-let contrib_name = "setoid_ring"
-
-let cdir = ["Coq";contrib_name]
-let contrib_modules =
-  List.map (fun d -> cdir@d)
-    [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
-     ["Field_tac"]; ["Field_theory"]
-    ]
-
-let my_constant c =
-  lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c)
-
-let new_ring_path =
-  make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"])
-let ltac s =
-  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
-let znew_ring_path =
-  make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"])
-let zltac s =
-  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
-
-let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
-let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;;
-
-(* Ring theory *)
-
-(* almost_ring defs *)
-let coq_almost_ring_theory = my_constant "almost_ring_theory"
-
-(* setoid and morphism utilities *)
-let coq_eq_setoid = my_constant "Eqsth"
-let coq_eq_morph = my_constant "Eq_ext"
-let coq_eq_smorph = my_constant "Eq_s_ext"
-
-(* ring -> almost_ring utilities *)
-let coq_ring_theory = my_constant "ring_theory"
-let coq_mk_reqe = my_constant "mk_reqe"
-
-(* semi_ring -> almost_ring utilities *)
-let coq_semi_ring_theory = my_constant "semi_ring_theory"
-let coq_mk_seqe = my_constant "mk_seqe"
-
-let ltac_inv_morph_gen = zltac"inv_gen_phi"
-let ltac_inv_morphZ = zltac"inv_gen_phiZ"
-let ltac_inv_morphN = zltac"inv_gen_phiN"
-let ltac_inv_morphNword = zltac"inv_gen_phiNword"
-let coq_abstract = my_constant"Abstract"
-let coq_comp = my_constant"Computational"
-let coq_morph = my_constant"Morphism"
-
-(* morphism *)
-let coq_ring_morph = my_constant "ring_morph"
-let coq_semi_morph = my_constant "semi_morph"
-
-(* power function *)
-let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
-let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
-
-(* hypothesis *)
-let coq_mkhypo = my_constant "mkhypo"
-let coq_hypo = my_constant "hypo"
-
-(* Equality: do not evaluate but make recursive call on both sides *)
-let map_with_eq arg_map c =
-  let (req,_,_) = dest_rel c in
-  interp_map
-    ((req,(function -1->Prot|_->Rec))::
-    List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
-
-let _ = add_map "ring"
-  (map_with_eq
-    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
-    coq_nil, (function -1->Eval|_ -> Prot);
-    (* Pphi_dev: evaluate polynomial and coef operations, protect
-       ring operations and make recursive call on the var map *)
-    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
-    pol_cst "Pphi_pow", 
-          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
-    (* PEeval: evaluate morphism and polynomial, protect ring 
-       operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
-
-(****************************************************************************)
-(* Ring database *)
-
-type ring_info =
-    { ring_carrier : types;
-      ring_req : constr;
-      ring_setoid : constr;
-      ring_ext : constr;
-      ring_morph : constr;
-      ring_th : constr;
-      ring_cst_tac : glob_tactic_expr;
-      ring_pow_tac : glob_tactic_expr;
-      ring_lemma1 : constr;
-      ring_lemma2 : constr;
-      ring_pre_tac : glob_tactic_expr;
-      ring_post_tac : glob_tactic_expr }
-
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
-
-let from_carrier = ref Cmap.empty
-let from_relation = ref Cmap.empty
-let from_name = ref Spmap.empty
-
-let ring_for_carrier r = Cmap.find r !from_carrier
-let ring_for_relation rel = Cmap.find rel !from_relation
-let ring_lookup_by_name ref =
-  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name
-
-
-let find_ring_structure env sigma l oname =
-  match oname, l with
-      Some rf, _ ->
-        (try ring_lookup_by_name rf
-        with Not_found ->
-          errorlabstrm "ring"
-            (str "found no ring named "++pr_reference rf))
-    | None, t::cl' ->
-        let ty = Retyping.get_type_of env sigma t in
-        let check c =
-          let ty' = Retyping.get_type_of env sigma c in
-          if not (Reductionops.is_conv env sigma ty ty') then
-            errorlabstrm "ring"
-              (str"arguments of ring_simplify do not have all the same type")
-        in
-        List.iter check cl';
-        (try ring_for_carrier ty
-        with Not_found ->
-          errorlabstrm "ring"
-            (str"cannot find a declared ring structure over"++
-             spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] -> assert false
-(*
-        let (req,_,_) = dest_rel cl in
-        (try ring_for_relation req
-        with Not_found ->
-          errorlabstrm "ring"
-            (str"cannot find a declared ring structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ = 
-  Summary.declare_summary "tactic-new-ring-table"
-    { Summary.freeze_function =
-        (fun () -> !from_carrier,!from_relation,!from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          from_carrier := ct; from_relation := rt; from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          from_carrier := Cmap.empty; from_relation := Cmap.empty;
-          from_name := Spmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
-
-let add_entry (sp,_kn) e =
-(*  let _ = ty e.ring_lemma1 in
-  let _ = ty e.ring_lemma2 in
-*)
-  from_carrier := Cmap.add e.ring_carrier e !from_carrier;
-  from_relation := Cmap.add e.ring_req e !from_relation;
-  from_name := Spmap.add sp e !from_name 
-
-
-let subst_th (_,subst,th) = 
-  let c' = subst_mps subst th.ring_carrier in                   
-  let eq' = subst_mps subst th.ring_req in
-  let set' = subst_mps subst th.ring_setoid in
-  let ext' = subst_mps subst th.ring_ext in
-  let morph' = subst_mps subst th.ring_morph in
-  let th' = subst_mps subst th.ring_th in
-  let thm1' = subst_mps subst th.ring_lemma1 in
-  let thm2' = subst_mps subst th.ring_lemma2 in
-  let tac'= subst_tactic subst th.ring_cst_tac in
-  let pow_tac'= subst_tactic subst th.ring_pow_tac in
-  let pretac'= subst_tactic subst th.ring_pre_tac in
-  let posttac'= subst_tactic subst th.ring_post_tac in
-  if c' == th.ring_carrier &&
-     eq' == th.ring_req &&
-     set' = th.ring_setoid &&
-     ext' == th.ring_ext &&
-     morph' == th.ring_morph &&
-     th' == th.ring_th &&
-     thm1' == th.ring_lemma1 &&
-     thm2' == th.ring_lemma2 &&
-     tac' == th.ring_cst_tac &&
-     pow_tac' == th.ring_pow_tac &&
-     pretac' == th.ring_pre_tac &&
-     posttac' == th.ring_post_tac then th
-  else
-    { ring_carrier = c';
-      ring_req = eq';
-      ring_setoid = set';
-      ring_ext = ext';
-      ring_morph = morph';
-      ring_th = th';
-      ring_cst_tac = tac';
-      ring_pow_tac = pow_tac';
-      ring_lemma1 = thm1';
-      ring_lemma2 = thm2';
-      ring_pre_tac = pretac';
-      ring_post_tac = posttac' }
-
-
-let (theory_to_obj, obj_to_theory) = 
-  let cache_th (name,th) = add_entry name th
-  and export_th x = Some x in
-  declare_object
-    {(default_object "tactic-new-ring-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
-      cache_function = cache_th;
-      subst_function = subst_th;
-      classify_function = (fun (_,x) -> Substitute x);
-      export_function = export_th }
-
-
-let setoid_of_relation env a r =
-  let evm = Evd.empty in
-  try 
-    lapp coq_mk_Setoid
-      [|a ; r ; 
-	Class_tactics.get_reflexive_proof env evm a r ; 
-	Class_tactics.get_symmetric_proof env evm a r ; 
-	Class_tactics.get_transitive_proof env evm a r |]
-  with Not_found ->
-    error "cannot find setoid relation"
-
-let op_morph r add mul opp req m1 m2 m3 =
-  lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
-
-let op_smorph r add mul req m1 m2 =
-  lapp coq_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 *)
-(*               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)
-    | _ ->
-	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, 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,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 ->
-		(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 -> 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
-  match kind_of_term th_typ with
-      App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when f = Lazy.force coq_almost_ring_theory ->
-          (None,r,zero,one,add,mul,Some sub,Some opp,req)
-    | App(f,[|r;zero;one;add;mul;req|])
-        when f = Lazy.force coq_semi_ring_theory ->
-        (Some true,r,zero,one,add,mul,None,None,req)
-    | App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when f = Lazy.force coq_ring_theory ->
-        (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
-    | _ -> error "bad ring structure"
-
-
-let dest_morph env sigma m_spec =
-  let m_typ = Retyping.get_type_of env sigma m_spec in
-  match kind_of_term m_typ with
-      App(f,[|r;zero;one;add;mul;sub;opp;req;
-              c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-        when f = Lazy.force coq_ring_morph ->
-          (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
-    | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
-        when f = Lazy.force coq_semi_morph ->
-        (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
-    | _ -> error "bad morphism structure"
-
-
-type coeff_spec =
-    Computational of constr (* equality test *)
-  | Abstract (* coeffs = Z *)
-  | Morphism of constr (* general morphism *)
-
-
-let reflect_coeff rkind =
-  (* We build an ill-typed terms on purpose... *)
-  match rkind with
-      Abstract -> Lazy.force coq_abstract
-    | Computational c -> lapp coq_comp [|c|]
-    | Morphism m -> lapp coq_morph [|m|]
-
-type cst_tac_spec =
-    CstTac of raw_tactic_expr
-  | Closed of reference list
-
-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 Syntax_def.global_with_alias lc)
-    | None ->
-        (match rk, opp, kind with
-            Abstract, None, _ ->
-              let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
-              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
-          | Abstract, Some opp, Some _ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
-              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Abstract, Some opp, None ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in
-              TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Computational _,_,_ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
-          | Morphism mth,_,_ ->
-              let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
-
-let make_hyp env c =
-  let t = Retyping.get_type_of env Evd.empty c in
-  lapp coq_mkhypo [|t;c|]
-
-let make_hyp_list env lH =
-  let carrier = Lazy.force coq_hypo in
-  List.fold_right 
-    (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
-    (lapp coq_nil [|carrier|])
-
-let interp_power env pow =  
-  let carrier = Lazy.force coq_hypo in
-  match pow with
-  | None -> 
-      let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
-      (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
-  | Some (tac, spec) -> 
-      let tac = 
-        match tac with
-        | CstTac t -> Tacinterp.glob_tactic t
-        | Closed lc ->
-            closed_term_ast (List.map Syntax_def.global_with_alias lc) in
-      let spec = make_hyp env (ic spec) in
-      (tac, lapp coq_Some [|carrier; spec|])
-
-let interp_sign env sign =
-  let carrier = Lazy.force coq_hypo in
-  match sign with
-  | None -> lapp coq_None [|carrier|] 
-  | Some spec -> 
-      let spec = make_hyp env (ic spec) in
-      lapp coq_Some [|carrier;spec|]
-       (* Same remark on ill-typed terms ... *)
-
-let 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
-  let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
-  let (pow_tac, pspec) = interp_power env power in 
-  let sspec = interp_sign env sign in
-  let 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;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
-
-  let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
-  let cst_tac =
-    interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
-  let pretac =
-    match pre with
-        Some t -> Tacinterp.glob_tactic t
-      | _ -> TacId [] in
-  let posttac =
-    match post with
-        Some t -> Tacinterp.glob_tactic t
-      | _ -> TacId [] in
-  let _ =
-    Lib.add_leaf name
-      (theory_to_obj
-        { ring_carrier = r;
-          ring_req = req;
-          ring_setoid = sth;
-          ring_ext = constr_of params.(1);
-          ring_morph = constr_of params.(2);
-          ring_th = constr_of params.(0);
-          ring_cst_tac = cst_tac;
-	  ring_pow_tac = pow_tac;
-          ring_lemma1 = lemma1;
-          ring_lemma2 = lemma2;
-          ring_pre_tac = pretac;
-          ring_post_tac = posttac }) in
-  ()
-
-type ring_mod =
-    Ring_kind of coeff_spec
-  | Const_tac of cst_tac_spec
-  | Pre_tac of raw_tactic_expr
-  | Post_tac of raw_tactic_expr
-  | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
-  | 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
-  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
-  | [ "abstract" ] -> [ Ring_kind Abstract ]
-  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
-  | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
-  | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
-  | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
-  | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
-  | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
-  | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
-  | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
-           [ Pow_spec (Closed l, pow_spec) ]   
-  | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
-           [ Pow_spec (CstTac cst_tac, pow_spec) ]
-  | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
-END
-
-let set_once s r v =
-  if !r = None then r := Some v else error (s^" cannot be set twice")
-
-let process_ring_mods l =
-  let kind = ref None in
-  let set = ref None in
-  let cst_tac = ref None in
-  let pre = ref None in
-  let post = ref None in
-  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
-    | Pre_tac t -> set_once "preprocess tactic" pre t
-    | Post_tac t -> set_once "postprocess tactic" post t
-    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) 
-    | Pow_spec(t,spec) -> set_once "power" power (t,spec)
-    | 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, !div)
-
-VERNAC COMMAND EXTEND AddSetoidRing
-  | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
-    [ 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
-
-(*****************************************************************************)
-(* The tactics consist then only in a lookup in the ring database and
-   call the appropriate ltac. *)
-
-let make_args_list rl t = 
-  match rl with
-  | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
-  | _ -> rl
-
-let make_term_list carrier rl =
-  List.fold_right
-    (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
-    (lapp coq_nil [|carrier|])
-
-
-let ring_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_ring_structure env sigma rl None in
-  let rl = carg (make_term_list e.ring_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let req = carg e.ring_req in
-  let sth = carg e.ring_setoid in
-  let ext = carg e.ring_ext in
-  let morph = carg e.ring_morph in
-  let th = carg e.ring_th in
-  let cst_tac = Tacexp e.ring_cst_tac in
-  let pow_tac = Tacexp e.ring_pow_tac in
-  let lemma1 = carg e.ring_lemma1 in
-  let lemma2 = carg e.ring_lemma2 in
-  let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
-  let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
-  Tacinterp.eval_tactic
-    (TacLetIn
-      (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" 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
-
-
- 
-(***********************************************************************)
-
-let new_field_path =
-  make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"])
-
-let field_ltac s =
-  lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
-
-
-let _ = add_map "field"
-  (map_with_eq
-    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
-    coq_nil, (function -1->Eval|_ -> Prot);
-    (* display_linear: evaluate polynomials and coef operations, protect
-       field operations and make recursive call on the var map *)
-    my_constant "display_linear",
-      (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
-    my_constant "display_pow_linear",
-     (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
-   (* Pphi_dev: evaluate polynomial and coef operations, protect
-       ring operations and make recursive call on the var map *)
-    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
-    pol_cst "Pphi_pow", 
-          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
-    (* PEeval: evaluate morphism and polynomial, protect ring 
-       operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
-    (* FEeval: evaluate morphism, protect field 
-       operations and make recursive call on the var map *)
-    my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
-
-let _ = add_map "field_cond"
-  (map_with_eq
-    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
-     coq_nil, (function -1->Eval|_ -> Prot);
-    (* PCond: evaluate morphism and denum list, protect ring
-       operations and make recursive call on the var map *)
-     my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
-(*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
-
-
-let afield_theory = my_constant "almost_field_theory"
-let field_theory = my_constant "field_theory"
-let sfield_theory = my_constant "semi_field_theory"
-let af_ar = my_constant"AF_AR"
-let f_r = my_constant"F_R"
-let sf_sr = my_constant"SF_SR"
-let dest_field env sigma th_spec =
-  let th_typ = Retyping.get_type_of env sigma th_spec in
-  match kind_of_term th_typ with
-    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when f = Lazy.force afield_theory ->
-        let rth = lapp af_ar
-          [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
-        (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
-    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when f = Lazy.force field_theory ->
-        let rth =
-          lapp f_r
-            [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
-        (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
-    | App(f,[|r;zero;one;add;mul;div;inv;req|])
-        when f = Lazy.force sfield_theory ->
-        let rth = lapp sf_sr
-          [|r;zero;one;add;mul;div;inv;req;th_spec|] in
-        (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
-    | _ -> error "bad field structure"
-
-type field_info =
-    { field_carrier : types;
-      field_req : constr;
-      field_cst_tac : glob_tactic_expr;
-      field_pow_tac : glob_tactic_expr;
-      field_ok : constr;
-      field_simpl_eq_ok : constr;
-      field_simpl_ok : constr;
-      field_simpl_eq_in_ok : constr;
-      field_cond : constr;
-      field_pre_tac : glob_tactic_expr;
-      field_post_tac : glob_tactic_expr }
-
-let field_from_carrier = ref Cmap.empty
-let field_from_relation = ref Cmap.empty
-let field_from_name = ref Spmap.empty
-
-
-let field_for_carrier r = Cmap.find r !field_from_carrier
-let field_for_relation rel = Cmap.find rel !field_from_relation
-let field_lookup_by_name ref =
-  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref)))
-    !field_from_name
-
-
-let find_field_structure env sigma l oname =
-  check_required_library (cdir@["Field_tac"]);
-  match oname, l with
-      Some rf, _ ->
-        (try field_lookup_by_name rf
-        with Not_found ->
-          errorlabstrm "field"
-            (str "found no field named "++pr_reference rf))
-    | None, t::cl' ->
-        let ty = Retyping.get_type_of env sigma t in
-        let check c =
-          let ty' = Retyping.get_type_of env sigma c in
-          if not (Reductionops.is_conv env sigma ty ty') then
-            errorlabstrm "field"
-              (str"arguments of field_simplify do not have all the same type")
-        in
-        List.iter check cl';
-        (try field_for_carrier ty
-        with Not_found ->
-          errorlabstrm "field"
-            (str"cannot find a declared field structure over"++
-             spc()++str"\""++pr_constr ty++str"\""))
-    | None, [] -> assert false
-(*        let (req,_,_) = dest_rel cl in
-        (try field_for_relation req
-        with Not_found ->
-          errorlabstrm "field"
-            (str"cannot find a declared field structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ = 
-  Summary.declare_summary "tactic-new-field-table"
-    { Summary.freeze_function =
-        (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          field_from_carrier := ct; field_from_relation := rt;
-          field_from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
-          field_from_name := Spmap.empty);
-      Summary.survive_module = false;
-      Summary.survive_section = false }
-
-let add_field_entry (sp,_kn) e =
-(*
-  let _ = ty e.field_ok in
-  let _ = ty e.field_simpl_eq_ok in
-  let _ = ty e.field_simpl_ok in
-  let _ = ty e.field_cond in
-*)
-  field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
-  field_from_relation := Cmap.add e.field_req e !field_from_relation;
-  field_from_name := Spmap.add sp e !field_from_name 
-
-let subst_th (_,subst,th) = 
-  let c' = subst_mps subst th.field_carrier in                   
-  let eq' = subst_mps subst th.field_req in
-  let thm1' = subst_mps subst th.field_ok in
-  let thm2' = subst_mps subst th.field_simpl_eq_ok in
-  let thm3' = subst_mps subst th.field_simpl_ok in
-  let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
-  let thm5' = subst_mps subst th.field_cond in
-  let tac'= subst_tactic subst th.field_cst_tac in
-  let pow_tac' = subst_tactic subst th.field_pow_tac in
-  let pretac'= subst_tactic subst th.field_pre_tac in
-  let posttac'= subst_tactic subst th.field_post_tac in
-  if c' == th.field_carrier &&
-     eq' == th.field_req &&
-     thm1' == th.field_ok &&
-     thm2' == th.field_simpl_eq_ok &&
-     thm3' == th.field_simpl_ok &&
-     thm4' == th.field_simpl_eq_in_ok &&
-     thm5' == th.field_cond &&
-     tac' == th.field_cst_tac &&
-     pow_tac' == th.field_pow_tac &&
-     pretac' == th.field_pre_tac &&
-     posttac' == th.field_post_tac then th
-  else
-    { field_carrier = c';
-      field_req = eq';
-      field_cst_tac = tac';
-      field_pow_tac = pow_tac';
-      field_ok = thm1';
-      field_simpl_eq_ok = thm2';
-      field_simpl_ok = thm3';
-      field_simpl_eq_in_ok = thm4';
-      field_cond = thm5';
-      field_pre_tac = pretac';
-      field_post_tac = posttac' }
-
-let (ftheory_to_obj, obj_to_ftheory) = 
-  let cache_th (name,th) = add_field_entry name th
-  and export_th x = Some x in
-  declare_object
-    {(default_object "tactic-new-field-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
-      cache_function = cache_th;
-      subst_function = subst_th;
-      classify_function = (fun (_,x) -> Substitute x);
-      export_function = export_th }
-
-let 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|])
-    | _ ->
-	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 odiv =
-  check_required_library (cdir@["Field_tac"]);
-  let env = Global.env() in
-  let sigma = Evd.empty in
-  let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
-    dest_field env sigma fth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
-  let eqth = Some(sth,ext) in
-  let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in
-  let (pow_tac, pspec) = interp_power env power in 
-  let sspec = interp_sign env sign 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;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
-  let lemma3 = constr_of params.(5) in
-  let lemma4 = constr_of params.(6) in
-  let cond_lemma =
-    match inj with
-      | Some thm -> mkApp(constr_of params.(8),[|thm|])
-      | None -> constr_of params.(7) in
-  let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
-  let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
-  let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
-  let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
-  let cst_tac =
-    interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
-  let pretac =
-    match pre with
-        Some t -> Tacinterp.glob_tactic t
-      | _ -> TacId [] in
-  let posttac =
-    match post with
-        Some t -> Tacinterp.glob_tactic t
-      | _ -> TacId [] in
-  let _ =
-    Lib.add_leaf name
-      (ftheory_to_obj
-        { field_carrier = r;
-          field_req = req;
-          field_cst_tac = cst_tac;
-          field_pow_tac = pow_tac;
-          field_ok = lemma1;
-          field_simpl_eq_ok = lemma2;
-          field_simpl_ok = lemma3;
-          field_simpl_eq_in_ok = lemma4;
-          field_cond = cond_lemma;
-          field_pre_tac = pretac;
-          field_post_tac = posttac }) in  ()
-
-type field_mod =
-    Ring_mod of ring_mod
-  | Inject of Topconstr.constr_expr
-
-VERNAC ARGUMENT EXTEND field_mod
-  | [ ring_mod(m) ] -> [ Ring_mod m ]
-  | [ "completeness" constr(inj) ] -> [ Inject inj ]
-END
-
-let process_field_mods l =
-  let kind = ref None in
-  let set = ref None in
-  let cst_tac = ref None in
-  let pre = ref None in
-  let post = ref None in
-  let inj = ref None in  
-  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) ->
-        set_once "tactic recognizing constants" cst_tac t
-    | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
-    | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
-    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
-    | 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, !div)
-
-VERNAC COMMAND EXTEND AddSetoidField
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> 
-  [ 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 =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_field_structure env sigma rl None in
-  let rl = carg (make_term_list e.field_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let req = carg e.field_req in
-  let cst_tac = Tacexp e.field_cst_tac in
-  let pow_tac = Tacexp e.field_pow_tac in
-  let field_ok = carg e.field_ok in
-  let field_simpl_ok = carg e.field_simpl_ok in
-  let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
-  let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
-  let cond_ok = carg e.field_cond in
-  let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
-  let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
-  Tacinterp.eval_tactic
-    (TacLetIn
-      (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" 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/equations.ml4 b/contrib/subtac/equations.ml4
deleted file mode 100644
index 9d120019..00000000
--- a/contrib/subtac/equations.ml4
+++ /dev/null
@@ -1,1149 +0,0 @@
-(* -*- 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 *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i camlp4use: "pa_extend.cmo" i*) 
-
-(* $Id: subtac_cases.ml 11198 2008-07-01 17:03:43Z msozeau $ *)
-
-open Cases
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Declarations
-open Inductiveops
-open Environ
-open Sign
-open Reductionops
-open Typeops
-open Type_errors
-
-open Rawterm
-open Retyping
-open Pretype_errors
-open Evarutil
-open Evarconv
-open List
-open Libnames
-
-type pat =
-  | PRel of int
-  | PCstr of constructor * pat list
-  | PInac of constr
-
-let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern")
-  
-let mkInac env c =
-  mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |])
-    
-let rec constr_of_pat ?(inacc=true) env = function
-  | PRel i -> mkRel i
-  | PCstr (c, p) -> 
-      let c' = mkConstruct c in
-	mkApp (c', Array.of_list (constrs_of_pats ~inacc env p))
-  | PInac r -> 
-      if inacc then try mkInac env r with _ -> r else r
-      
-and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l
-
-let rec pat_vars = function
-  | PRel i -> Intset.singleton i
-  | PCstr (c, p) -> pats_vars p
-  | PInac _ -> Intset.empty
-
-and pats_vars l = 
-  fold_left (fun vars p -> 
-    let pvars = pat_vars p in
-    let inter = Intset.inter pvars vars in
-      if inter = Intset.empty then
-	Intset.union pvars vars
-      else error ("Non-linear pattern: variable " ^
-		     string_of_int (Intset.choose inter) ^ " appears twice"))
-    Intset.empty l
-
-let rec pats_of_constrs l = map pat_of_constr l
-and pat_of_constr c = 
-  match kind_of_term c with
-  | Rel i -> PRel i
-  | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) ->
-      PInac c
-  | App (f, args) when isConstruct f ->
-      PCstr (destConstruct f, pats_of_constrs (Array.to_list args))
-  | Construct f -> PCstr (f, [])
-  | _ -> PInac c
-
-let inaccs_of_constrs l = map (fun x -> PInac x) l
-
-exception Conflict
-
-let rec pmatch p c =
-  match p, c with
-  | PRel i, t -> [i, t]
-  | PCstr (c, pl), PCstr (c', pl') when c = c' -> pmatches pl pl'
-  | PInac _, _ -> []
-  | _, PInac _ -> []
-  | _, _ -> raise Conflict
-
-and pmatches pl l =
-  match pl, l with
-  | [], [] -> []
-  | hd :: tl, hd' :: tl' -> 
-      pmatch hd hd' @ pmatches tl tl'
-  | _ -> raise Conflict
-      
-let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None
-
-let rec pinclude p c =
-  match p, c with
-  | PRel i, t -> true
-  | PCstr (c, pl), PCstr (c', pl') when c = c' -> pincludes pl pl'
-  | PInac _, _ -> true
-  | _, PInac _ -> true
-  | _, _ -> false
-      
-and pincludes pl l =
-  match pl, l with
-  | [], [] -> true
-  | hd :: tl, hd' :: tl' -> 
-      pinclude hd hd' && pincludes tl tl'
-  | _ -> false
-      
-let pattern_includes pl l = pincludes pl l
-
-(** Specialize by a substitution. *)
-
-let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s)
-
-let subst_rel_subst k s c = 
-  let rec aux depth c =
-    match kind_of_term c with
-    | Rel n -> 
-	let k = n - depth in 
-	  if k >= 0 then 
-	    try lift depth (snd (assoc k s))
-	    with Not_found -> c
-	  else c
-    | _ -> map_constr_with_binders succ aux depth c
-  in aux k c
-    
-let subst_context s ctx =
-  let (_, ctx') = fold_right 
-    (fun (id, b, t) (k, ctx') ->
-      (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx'))
-    ctx (0, [])
-  in ctx'
-
-let subst_rel_context k cstr ctx = 
-  let (_, ctx') = fold_right 
-    (fun (id, b, t) (k, ctx') ->
-      (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx'))
-    ctx (k, [])
-  in ctx'
-
-let rec lift_pat n k p = 
-  match p with
-  | PRel i ->
-      if i >= k then PRel (i + n)
-      else p
-  | PCstr(c, pl) -> PCstr (c, lift_pats n k pl)
-  | PInac r -> PInac (liftn n k r)
-      
-and lift_pats n k = map (lift_pat n k)
-
-let rec subst_pat env k t p = 
-  match p with
-  | PRel i -> 
-      if i = k then t
-      else if i > k then PRel (pred i)
-      else p
-  | PCstr(c, pl) ->
-      PCstr (c, subst_pats env k t pl)
-  | PInac r -> PInac (substnl [constr_of_pat ~inacc:false env t] (pred k) r)
-
-and subst_pats env k t = map (subst_pat env k t)
-
-let rec specialize s p = 
-  match p with
-  | PRel i -> 
-      if mem_assoc i s then
-	let b, t = assoc i s in
-	  if b then PInac t
-	  else PRel (destRel t)
-      else p
-  | PCstr(c, pl) ->
-      PCstr (c, specialize_pats s pl)
-  | PInac r -> PInac (specialize_constr s r)
-
-and specialize_constr s c = subst_rel_subst 0 s c
-and specialize_pats s = map (specialize s)
-
-let specialize_patterns = function
-  | [] -> fun p -> p
-  | s -> specialize_pats s
-
-let specialize_rel_context s ctx =
-  snd (fold_right (fun (n, b, t) (k, ctx) -> 
-    (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx))
-	  ctx (0, []))
-    
-let lift_contextn n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-  liftrec (rel_context_length sign + k) sign
-
-type program = 
-  signature * clause list
-
-and signature = identifier * rel_context * constr
-
-and clause = lhs * (constr, int) rhs
-
-and lhs = rel_context * identifier * pat list
-
-and ('a, 'b) rhs = 
-  | Program of 'a
-  | Empty of 'b
-
-type splitting = 
-  | Compute of clause
-  | Split of lhs * int * inductive_family *
-      unification_result array * splitting option array
-      
-and unification_result = 
-  rel_context * int * constr * pat * substitution option
-
-and substitution = (int * (bool * constr)) list
-
-type problem = identifier * lhs
-
-let rels_of_tele tele = rel_list 0 (List.length tele)
-
-let patvars_of_tele tele = map (fun c -> PRel (destRel c)) (rels_of_tele tele)
-
-let split_solves split prob =
-  match split with
-  | Compute (lhs, rhs) -> lhs = prob
-  | Split (lhs, id, indf, us, ls) -> lhs = prob
-
-let ids_of_constr c = 
-  let rec aux vars c = 
-    match kind_of_term c with
-    | Var id -> Idset.add id vars
-    | _ -> fold_constr aux vars c
-  in aux Idset.empty c
-
-let ids_of_constrs = 
-  fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty
-
-let idset_of_list =
-  fold_left (fun s x -> Idset.add x s) Idset.empty
-
-let intset_of_list =
-  fold_left (fun s x -> Intset.add x s) Intset.empty
-
-let solves split (delta, id, pats as prob) = 
-  split_solves split prob && 
-  Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta)))
-
-let check_judgment ctx c t =
-  ignore(Typing.check (push_rel_context ctx (Global.env ())) Evd.empty c t); true
-
-let check_context env ctx =
-  fold_right
-    (fun (_, _, t as decl) env -> 
-      ignore(Typing.sort_of env Evd.empty t); push_rel decl env)
-    ctx env
-
-let split_context n c =
-  let after, before = list_chop n c in
-    match before with
-    | hd :: tl -> after, hd, tl
-    | [] -> raise (Invalid_argument "split_context")
-	
-let split_tele n (ctx : rel_context) =
-  let rec aux after n l =
-    match n, l with
-    | 0, decl :: before -> before, decl, List.rev after
-    | n, decl :: before -> aux (decl :: after) (pred n) before
-    | _ -> raise (Invalid_argument "split_tele")
-  in aux [] n ctx
-
-let rec add_var_subst env subst n c =
-  if mem_assoc n subst then
-    let t = assoc n subst in
-      if eq_constr t c then subst
-      else unify env subst t c
-  else 
-    let rel = mkRel n in
-      if rel = c then subst
-      else if dependent rel c then raise Conflict
-      else (n, c) :: subst
-    
-and unify env subst x y =
-  match kind_of_term x, kind_of_term y with
-  | Rel n, _ -> add_var_subst env subst n y
-  | _, Rel n -> add_var_subst env subst n x
-  | App (c, l), App (c', l') when eq_constr c c' ->
-      unify_constrs env subst (Array.to_list l) (Array.to_list l')
-  | _, _ -> if eq_constr x y then subst else raise Conflict
-
-and unify_constrs (env : env) subst l l' = 
-  if List.length l = List.length l' then
-    fold_left2 (unify env) subst l l'
-  else raise Conflict
-
-let fold_rel_context_with_binders f ctx init =
-  snd (List.fold_right (fun decl (depth, acc) ->
-    (succ depth, f depth decl acc)) ctx (0, init))
-    
-let dependent_rel_context (ctx : rel_context) k =
-  fold_rel_context_with_binders
-    (fun depth (n,b,t) acc -> 
-      let r = mkRel (depth + k) in
-	acc || dependent r t ||
-	  (match b with
-	  | Some b -> dependent r b
-	  | None -> false))
-    ctx false
-
-let liftn_between n k p c =
-  let rec aux depth c = match kind_of_term c with
-    | Rel i -> 
-	if i <= depth then c
-	else if i-depth > p then c
-	else mkRel (i - n)
-    | _ -> map_constr_with_binders succ aux depth c
-  in aux k c
-    
-let liftn_rel_context n k sign =  
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-    liftrec (k + rel_context_length sign) sign
-
-let substnl_rel_context n l =
-  map_rel_context_with_binders (fun k -> substnl l (n+k-1))
-
-let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list) =
-  let _, s, ctx' =
-    fold_left (fun (k, s, ctx') (n, b, t as decl) ->
-      match b with
-      | None -> (succ k, mkRel k :: s, ctx' @ [decl])
-      | Some t -> (k, lift (pred k) t :: map (substnl [t] (pred k)) s, subst_rel_context 0 t ctx'))
-      (1, [], []) ctx
-  in
-  let s = rev s in
-  let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in
-    s', ctx'
-      
-(* Compute the transitive closure of the dependency relation for a term in a context *)
-
-let rec dependencies_of_rel ctx k =
-  let (n,b,t) = nth ctx (pred k) in
-  let b = Option.map (lift k) b and t = lift k t in
-  let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in
-    Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t))
-      
-and dependencies_of_term ctx t =
-  let rels = free_rels t in
-    Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty
-
-let subst_telescope k cstr ctx = 
-  let (_, ctx') = fold_left
-    (fun (k, ctx') (id, b, t) ->
-      (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx'))
-    (k, []) ctx
-  in rev ctx'
-
-let lift_telescope n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign)
-    | [] -> []
-  in liftrec k sign
-    
-type ('a,'b) either = Inl of 'a | Inr of 'b
-  
-let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list =
-  let rels = dependencies_of_term ctx t in
-  let len = length ctx in
-  let nbdeps = Intset.cardinal rels in
-  let lifting = len - nbdeps in (* Number of variables not linked to t *)
-  let rec aux k n acc m rest s = function
-    | decl :: ctx' ->
-	if Intset.mem k rels then
-	  let rest' = subst_telescope 0 (mkRel (nbdeps + lifting - pred m)) rest in
-	    aux (succ k) (succ n) (decl :: acc) m rest' ((k, Inl n) :: s) ctx'
-	else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx'
-    | [] -> rev acc, rev rest, s
-  in aux 1 1 [] 1 [] [] ctx
-    
-let merge_subst (ctx', rest, s) =
-  let lenrest = length rest in
-    map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s
-
-(* let simplify_subst s =  *)
-(*   fold_left (fun s (k, t) ->  *)
-(*     match kind_of_term t with *)
-(*     | Rel n when n = k -> s *)
-(*     | _ -> (k, t) :: s) *)
-(*     [] s *)
-
-let compose_subst s' s =
-  map (fun (k, (b, t)) -> (k, (b, specialize_constr s' t))) s
-
-let substitute_in_ctx n c ctx =
-  let rec aux k after = function
-    | [] -> []
-    | (name, b, t as decl) :: before ->
-	if k = n then rev after @ (name, Some c, t) :: before
-	else aux (succ k) (decl :: after) before
-  in aux 1 [] ctx
-    
-let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) =
-  match cursubst with
-  | [] -> ctx, substacc
-  | (k, (b, t)) :: rest ->
-      if t = mkRel k then reduce_subst ctx substacc rest
-      else if noccur_between 1 k t then
-	(* The term to substitute refers only to previous variables. *)
-	let t' = lift (-k) t in
-	let ctx' = substitute_in_ctx k t' ctx in
-	  reduce_subst ctx' substacc rest
-      else (* The term refers to variables declared after [k], so we have 
-	      to move these dependencies before [k]. *)
-	let (minctx, ctxrest, subst as str) = strengthen ctx t in
-	  match assoc k subst with
-	  | Inl _ -> error "Occurs check in substituted_context"
-	  | Inr k' ->
-	      let s = merge_subst str in
-	      let ctx' = ctxrest @ minctx in
-	      let rest' =
-		let substsubst (k', (b, t')) =
-		  match kind_of_term (snd (assoc k' s)) with
-		  | Rel k'' -> (k'', (b, specialize_constr s t'))
-		  | _ -> error "Non-variable substituted for variable by strenghtening"
-		in map substsubst ((k, (b, t)) :: rest)
-	      in
-		reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *)
-		  
-		  
-let substituted_context (subst : (int * constr) list) (ctx : rel_context) =
-  let _, subst =
-    fold_left (fun (k, s) _ ->
-      try let t = assoc k subst in
-	    (succ k, (k, (true, t)) :: s)
-      with Not_found ->
-	(succ k, ((k, (false, mkRel k)) :: s)))
-      (1, []) ctx
-  in
-  let ctx', subst' = reduce_subst ctx subst subst in
-    reduce_rel_context ctx' subst'
-    
-let unify_type before ty =
-  try
-    let envb = push_rel_context before (Global.env()) in
-    let IndType (indf, args) = find_rectype envb Evd.empty ty in
-    let ind, params = dest_ind_family indf in
-    let vs = map (Reduction.whd_betadeltaiota envb) args in
-    let cstrs = Inductiveops.arities_of_constructors envb ind in
-    let cstrs = 
-      Array.mapi (fun i ty ->
-	let ty = prod_applist ty params in
-	let ctx, ty = decompose_prod_assum ty in
-	let ctx, ids = 
-	  let ids = ids_of_rel_context ctx in
-	    fold_right (fun (n, b, t as decl) (acc, ids) ->
-	      match n with Name _ -> (decl :: acc), ids
-	      | Anonymous -> let id = next_name_away Anonymous ids in
-			       ((Name id, b, t) :: acc), (id :: ids))
-	      ctx ([], ids)
-	in
-	let env' = push_rel_context ctx (Global.env ()) in
-	let IndType (indf, args) = find_rectype env' Evd.empty ty in
-	let ind, params = dest_ind_family indf in
-	let constr = applist (mkConstruct (ind, succ i), params @ rels_of_tele ctx) in
-	let constrpat = PCstr ((ind, succ i), inaccs_of_constrs params @ patvars_of_tele ctx) in
-	  env', ctx, constr, constrpat, (* params @  *)args)
-	cstrs
-    in
-    let res = 
-      Array.map (fun (env', ctxc, c, cpat, us) -> 
-	let _beforelen = length before and ctxclen = length ctxc in
-	let fullctx = ctxc @ before in
-	  try
-	    let fullenv = push_rel_context fullctx (Global.env ()) in
-	    let vs' = map (lift ctxclen) vs in
-	    let subst = unify_constrs fullenv [] vs' us in
-	    let subst', ctx' = substituted_context subst fullctx in
-	      (ctx', ctxclen, c, cpat, Some subst')
-	  with Conflict -> 
-	    (fullctx, ctxclen, c, cpat, None)) cstrs
-    in Some (res, indf)
-  with Not_found -> (* not an inductive type *)
-    None
-
-let rec id_of_rel n l =
-  match n, l with
-  | 0, (Name id, _, _) :: tl -> id
-  | n, _ :: tl -> id_of_rel (pred n) tl
-  | _, _ -> raise (Invalid_argument "id_of_rel")
-
-let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = 
-  constrs_of_pats ~inacc (push_rel_context ctx env) pats
-      
-let rec valid_splitting (f, delta, t, pats) tree = 
-  split_solves tree (delta, f, pats) && 
-    valid_splitting_tree (f, delta, t) tree
-    
-and valid_splitting_tree (f, delta, t) = function
-  | Compute (lhs, Program rhs) -> 
-      let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in 
-	ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true
-
-  | Compute ((ctx, id, lhs), Empty split) -> 
-      let before, (x, _, ty), after = split_context split ctx in
-      let unify = 
-	match unify_type before ty with
-	| Some (unify, _) -> unify 
-	| None -> assert false
-      in
-	array_for_all (fun (_, _, _, _, x) -> x = None) unify
-	  
-  | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> 
-      let before, (id, _, ty), after = split_tele (pred rel) ctx in
-      let unify, indf' = Option.get (unify_type before ty) in
-	assert(indf = indf');
-	if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false
-	else
-	  let ok, splits = 
-	    Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> 
-	      match subst with
-	      | None -> acc
-	      | Some subst ->
-(* 		  let env' = push_rel_context ctx' (Global.env ()) in *)
-(* 		  let ctx_correct =  *)
-(* 		    ignore(check_context env' (subst_context subst ctxc)); *)
-(* 		    ignore(check_context env' (subst_context subst before)); *)
-(* 		    true *)
-(* 		  in  *)
-		  let newdelta = 
-		    subst_context subst (subst_rel_context 0 cstr 
-					    (lift_contextn ctxlen 0 after)) @ before in
-		  let liftpats = lift_pats ctxlen rel lhs in
-		  let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in
-		    (ok, (f, newdelta, newpats) :: splits))
-	      (true, []) unify
-	  in
-	  let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta 
-	    (constrs_of_pats ~inacc:false (Global.env ()) lhs) 
-	  in
-	  let t' = replace_vars subst t in
-	    ok && for_all 
-	      (fun (f, delta', pats') -> 
-		array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits
-	      
-let valid_tree (f, delta, t) tree = 
-  valid_splitting (f, delta, t, patvars_of_tele delta) tree
-
-let is_constructor c =
-  match kind_of_term (fst (decompose_app c)) with
-  | Construct _ -> true
-  | _ -> false
-
-let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) =
-  let rec find_split_pat curpat patc =
-    match patc with
-    | PRel _ -> None
-    | PCstr (f, args) ->
-	(match curpat with
-	| PCstr (f', args') when f = f' -> (* Already split at this level, continue *)
-	    find_split_pats args' args
-	| PRel i -> (* Split on i *) Some i
-	| PInac c when isRel c -> Some (destRel c)
-	| _ -> None)
-    | PInac _ -> None
-
-  and find_split_pats curpats patcs =
-    assert(List.length curpats = List.length patcs);
-    fold_left2 (fun acc -> 
-      match acc with
-      | None -> find_split_pat | _ -> fun _ _ -> acc)
-      None curpats patcs
-  in find_split_pats curpats patcs
-      
-open Pp
-open Termops
-
-let pr_constr_pat env c =
-  let pr = print_constr_env env c in
-    match kind_of_term c with
-    | App _ -> str "(" ++ pr ++ str ")"
-    | _ -> pr
-
-let pr_pat env c =
-  try 
-    let patc = constr_of_pat env c in
-      try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception"
-  with _ -> str"constr_of_pat raised an exception"
-    
-let pr_context env c =
-  let pr_decl (id,b,_) = 
-    let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in
-    let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in
-      idstr ++ bstr
-  in
-    prlist_with_sep pr_spc pr_decl (List.rev c)
-(*   Printer.pr_rel_context env c *)
-
-let pr_lhs env (delta, f, patcs) =
-  let env = push_rel_context delta env in
-  let ctx = pr_context env delta in
-    (if delta = [] then ctx else str "[" ++ ctx ++ str "]" ++ spc ())
-    ++ pr_id f ++ spc () ++ prlist_with_sep spc (pr_pat env) patcs
-
-let pr_rhs env = function
-  | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var)
-  | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs
-      
-let pr_clause env (lhs, rhs) =
-  pr_lhs env lhs ++ 
-    (let env' = push_rel_context (pi1 lhs) env in
-       pr_rhs env' rhs)
-    
-(* let pr_splitting env = function *)
-(*   | Compute cl -> str "Compute " ++ pr_clause env cl *)
-(*   | Split (lhs, n, indf, results, splits) -> *)
-
-(* let pr_unification_result (ctx, n, c, pat, subst) = *)
-  
-(*       unification_result array * splitting option array *)
-
-let pr_clauses env =
-  prlist_with_sep fnl (pr_clause env)
-
-let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) =
-  pattern_includes patcs patcs'
-    
-let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) =
-  pattern_matches patcs patcs'
-
-let rec split_on env var (delta, f, curpats as lhs) clauses =
-  let before, (id, _, ty), after = split_tele (pred var) delta in
-  let unify, indf = 
-    match unify_type before ty with 
-    | Some r -> r
-    | None -> assert false (* We decided... so it better be inductive *)
-  in
-  let clauses = ref clauses in
-  let splits = 
-    Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) ->
-      match s with
-      | None -> None
-      | Some s -> 
-	  (* ctx' |- s cstr, s cstrpat *)
-	  let newdelta =
-	    subst_context s (subst_rel_context 0 cstr 
-				(lift_contextn ctxlen 1 after)) @ ctx' in
-	  let liftpats = 
-	    (* delta |- curpats -> before; ctxc; id; after |- liftpats *)
-	    lift_pats ctxlen (succ var) curpats 
-	  in
-	  let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *)
-	    lift_pat (pred var) 1 cstrpat
-	  in
-	  let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *)
-	    subst_pats env var liftpat liftpats 
-	  in
-	  let lifts = (* before; ctxc |- s : newdelta ->
-			 before; ctxc; after |- lifts : newdelta ; after *)
-	    map (fun (k,(b,x)) -> (pred var + k, (b, lift (pred var) x))) s
-	  in
-	  let newpats = specialize_patterns lifts substpat in
-	  let newlhs = (newdelta, f, newpats) in
-	  let matching, rest = 
-	    fold_right (fun (lhs, rhs as clause) (matching, rest) -> 
-	      if lhs_includes newlhs lhs then
-		(clause :: matching, rest)
-	      else (matching, clause :: rest))
-	      !clauses ([], [])
-	  in
-	    clauses := rest;
-	    if matching = [] then (
-	      (* Try finding a splittable variable *)
-	      let (id, _) = 
-		fold_right (fun (id, _, ty as decl) (accid, ctx) -> 
-		  match accid with 
-		  | Some _ -> (accid, ctx)
-		  | None -> 
-		      match unify_type ctx ty with
-		      | Some (unify, indf) ->
-			  if array_for_all (fun (_, _, _, _, x) -> x = None) unify then
-			    (Some id, ctx)
-			  else (None, decl :: ctx)
-		      | None -> (None, decl :: ctx))
-		  newdelta (None, [])
-	      in 
-		match id with
-		| None ->
-		    errorlabstrm "deppat"
-	      	      (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++
-	      		  pr_lhs env newlhs)
-		| Some id -> 
-		    Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta))))
-	    ) else (
-	      let splitting = make_split_aux env newlhs matching in
-		Some splitting))
-      unify
-  in
-(*     if !clauses <> [] then *)
-(*       errorlabstrm "deppat" *)
-(* 	(str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *)
-    Split (lhs, var, indf, unify, splits)
-      
-and make_split_aux env lhs clauses =
-  let split = 
-    fold_left (fun acc (lhs', rhs) -> 
-      match acc with 
-      | None -> find_split lhs lhs'
-      | _ -> acc) None clauses
-  in 
-    match split with
-    | Some var -> split_on env var lhs clauses
-    | None ->
-	(match clauses with
-	| [] -> error "No clauses left"
-	| [(lhs', rhs)] ->
-	    (* No need to split anymore, fix the environments so that they are correctly aligned. *)
-	    (match lhs_matches lhs' lhs with
-	    | Some s ->
-		let s = map (fun (x, p) -> x, (true, constr_of_pat ~inacc:false env p)) s in
-		let rhs' = match rhs with
-		  | Program c -> Program (specialize_constr s c)
-		  | Empty i -> Empty (destRel (snd (assoc i s)))
-		in Compute ((pi1 lhs, pi2 lhs, specialize_patterns s (pi3 lhs')), rhs')
-	    | None -> anomaly "Non-matching clauses at a leaf of the splitting tree")
-	| _ ->
-	    errorlabstrm "make_split_aux"
-	      (str "Overlapping clauses:" ++ fnl () ++ pr_clauses env clauses))
-
-let make_split env (f, delta, t) clauses =
-  make_split_aux env (delta, f, patvars_of_tele delta) clauses
-    
-open Evd
-open Evarutil
-
-let lift_substitution n s = map (fun (k, x) -> (k + n, x)) s
-let map_substitution s t = map (subst_rel_subst 0 s) t
-
-let term_of_tree status isevar env (i, delta, ty) ann tree =
-(*   let envrec = match ann with *)
-(*     | None -> [] *)
-(*     | Some (loc, i) ->  *)
-(* 	let (n, t) = lookup_rel_id i delta in *)
-(* 	let t' = lift n t in *)
-	  
-	  
-(*   in *)
-  let rec aux = function
-    | Compute ((ctx, _, pats as lhs), Program rhs) -> 
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in
-	  mkCast(body, DEFAULTcast, typ), typ
-
-    | Compute ((ctx, _, pats as lhs), Empty split) ->
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let split = (Name (id_of_string "split"), 
-		    Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))),
-		    Lazy.force Class_tactics.coq_nat)
-	in
-	let ty' = it_mkProd_or_LetIn ty' ctx in
-	let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in
-	let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in
-	  term, ty'
-	    
-    | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> 
-	let before, decl, after = split_tele (pred rel) ctx in
-	let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in
-	let branches = 
-	  array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> 
-	    match split with
-	    | Some s -> aux s
-	    | None -> 
-		(* dead code, inversion will find a proof of False by splitting on the rel'th hyp *)
-		Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat)
-	    unif sp 
-	in
-	let branches_ctx =
-	  Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt))
-	    branches
-	in
-	let n, branches_lets = 
-	  Array.fold_left (fun (n, lets) (id, b, t) -> 
-	    (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets))
-	    (0, []) branches_ctx
-	in
-	let liftctx = lift_contextn (Array.length branches) 0 ctx in
-	let case =
-	  let ty = it_mkProd_or_LetIn ty' liftctx in
-	  let ty = it_mkLambda_or_LetIn ty branches_lets in
-	  let nbbranches = (Name (id_of_string "branches"), 
-			   Some (Class_tactics.coq_nat_of_int (length branches_lets)),
-			   Lazy.force Class_tactics.coq_nat)
-	  in
-	  let nbdiscr = (Name (id_of_string "target"), 
-			Some (Class_tactics.coq_nat_of_int (length before)),
-			Lazy.force Class_tactics.coq_nat)
-	  in
-	  let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in
-	  let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in
-	    term
-	in       
-	let casetyp = it_mkProd_or_LetIn ty' ctx in
-	  mkCast(case, DEFAULTcast, casetyp), casetyp
-
-  in aux tree
-
-open Topconstr
-open Constrintern
-open Decl_kinds
-
-type equation = constr_expr * (constr_expr, identifier located) rhs
-
-let locate_reference qid =
-  match Nametab.extended_locate qid with
-    | TrueGlobal ref -> true
-    | SyntacticDef kn -> true
-
-let is_global id =
-  try 
-    locate_reference (make_short_qualid id)
-  with Not_found -> 
-    false
-
-let is_freevar ids env x =
-  try
-    if Idset.mem x ids then false
-    else
-      try ignore(Environ.lookup_named x env) ; false
-      with _ -> not (is_global x)
-  with _ -> true
-  
-let ids_of_patc c ?(bound=Idset.empty) l = 
-  let found id bdvars l =
-    if not (is_freevar bdvars (Global.env ()) (snd id)) then l
-    else if List.exists (fun (_, id') -> id' = snd id) l then l 
-    else id :: l 
-  in
-  let rec aux bdvars l c = match c with
-    | CRef (Ident lid) -> found lid bdvars l
-    | CNotation (_, "{ _ : _ | _ }", ((CRef (Ident (_, id))) :: _, _)) when not (Idset.mem id bdvars) ->
-	fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c
-    | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c
-  in aux bound l c
-
-let interp_pats i isevar env impls pat sign recu =
-  let bound = Idset.singleton i in
-  let vars = ids_of_patc pat ~bound [] in
-  let varsctx, env' = 
-    fold_right (fun (loc, id) (ctx, env) ->
-      let decl =
-	let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in
-	  (Name id, None, ty) 
-      in
-	decl::ctx, push_rel decl env)
-      vars ([], env)
-  in
-  let pats =
-    let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in
-    let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in
-      match kind_of_term patt with
-      | App (m, args) -> 
-	  if not (eq_constr m (mkRel (succ (length varsctx)))) then
-	    user_err_loc (constr_loc pat, "interp_pats",
-			 str "Expecting a pattern for " ++ pr_id i)
-	  else Array.to_list args
-      | _ -> user_err_loc (constr_loc pat, "interp_pats",
-			  str "Error parsing pattern: unnexpected left-hand side")
-  in
-    isevar := nf_evar_defs !isevar;
-    (nf_rel_context_evar (Evd.evars_of !isevar) varsctx, 
-    nf_env_evar (Evd.evars_of !isevar) env',
-    rev_map (nf_evar (Evd.evars_of !isevar)) pats)
-      
-let interp_eqn i isevar env impls sign arity recu (pats, rhs) =
-  let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in
-  let rhs' = match rhs with
-    | Program p -> 
-	let ty = nf_isevar !isevar (substl patcs arity) in
-	  Program (interp_casted_constr_evars isevar env' ~impls p ty)
-    | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx))
-  in ((ctx, i, pats_of_constrs (rev patcs)), rhs')	
-
-open Entries
-
-open Tacmach
-open Tacexpr
-open Tactics
-open Tacticals
-
-let contrib_tactics_path =
-  make_dirpath (List.map id_of_string ["Equality";"Program";"Coq"])
-
-let tactics_tac s =
-  make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)
-    
-let equations_tac = lazy 
-  (Tacinterp.eval_tactic 
-      (TacArg(TacCall(dummy_loc, 
-		     ArgArg(dummy_loc, tactics_tac "equations"), []))))
-
-let define_by_eqs with_comp i (l,ann) t nt eqs =
-  let env = Global.env () in
-  let isevar = ref (create_evar_defs Evd.empty) in
-  let (env', sign), impls = interp_context_evars isevar env l in
-  let arity = interp_type_evars isevar env' t in
-  let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in
-  let arity = nf_evar (Evd.evars_of !isevar) arity in
-  let arity = 
-    if with_comp then
-      let compid = add_suffix i "_comp" in
-      let ce =
-	{ const_entry_body = it_mkLambda_or_LetIn arity sign;
-	  const_entry_type = None;
-	  const_entry_opaque = false;
-	  const_entry_boxed = false} 
-      in
-      let c =
-	Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition)
-      in mkApp (mkConst c, rel_vect 0 (length sign))
-    else arity
-  in
-  let env = Global.env () in
-  let ty = it_mkProd_or_LetIn arity sign in
-  let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in
-  let fixdecls = [(Name i, None, ty)] in
-  let fixenv = push_rel_context fixdecls env in
-  let equations = 
-    States.with_heavy_rollback (fun () -> 
-      Option.iter (Command.declare_interning_data data) nt;
-      map (interp_eqn i isevar fixenv data sign arity None) eqs) ()
-  in
-  let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in
-  let arity = nf_evar (Evd.evars_of !isevar) arity in
-  let prob = (i, sign, arity) in
-  let fixenv = nf_env_evar (Evd.evars_of !isevar) fixenv in
-  let fixdecls = nf_rel_context_evar (Evd.evars_of !isevar) fixdecls in
-    (*   let ce = check_evars fixenv Evd.empty !isevar in *)
-    (*   List.iter (function (_, _, Program rhs) -> ce rhs | _ -> ()) equations; *)
-  let is_recursive, env' =
-    let occur_eqn ((ctx, _, _), rhs) =
-      match rhs with
-      | Program c -> dependent (mkRel (succ (length ctx))) c
-      | _ -> false
-    in if exists occur_eqn equations then true, fixenv else false, env
-  in
-  let split = make_split env' prob equations in
-    (* if valid_tree prob split then *)
-  let status = (* if is_recursive then Expand else *) Define false in
-  let t, ty = term_of_tree status isevar env' prob ann split in
-  let undef = undefined_evars !isevar in
-  let t, ty = if is_recursive then 
-    (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls)
-    else t, ty
-  in
-  let obls, t', ty' = 
-    Eterm.eterm_obligations env i !isevar (Evd.evars_of undef) 0 ~status t ty
-  in
-    if is_recursive then
-      ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] 
-		~tactic:(Lazy.force equations_tac)
-		(Command.IsFixpoint [None, CStructRec]))
-    else
-      ignore(Subtac_obligations.add_definition
-		~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls)
-      
-module Gram = Pcoq.Gram
-module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
-
-module DeppatGram =
-struct
-  let gec s = Gram.Entry.create ("Deppat."^s)
-
-  let deppat_equations : equation list Gram.Entry.e = gec "deppat_equations"
-
-  let binders_let2 : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e = gec "binders_let2"
-
-(*   let where_decl : decl_notation Gram.Entry.e = gec "where_decl" *)
-
-end
-
-open Rawterm
-open DeppatGram 
-open Util
-open Pcoq
-open Prim
-open Constr
-open G_vernac
-
-GEXTEND Gram
-  GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2;
- 
-  deppat_equations:
-    [ [ l = LIST1 equation SEP ";" -> l ] ]
-  ;
-
-  binders_let2:
-    [ [ l = binders_let_fixannot -> l ] ]
-  ;
-
-  equation:
-    [ [ c = Constr.lconstr; r=rhs -> (c, r) ] ]
-  ;
-
-  rhs:
-    [ [ ":=!"; id = identref -> Empty id
-      |":="; c = Constr.lconstr -> Program c
-    ] ]
-  ;
-  
-  END
-
-type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type
-
-let (wit_deppat_equations : Genarg.tlevel deppat_equations_argtype),
-  (globwit_deppat_equations : Genarg.glevel deppat_equations_argtype),
-  (rawwit_deppat_equations : Genarg.rlevel deppat_equations_argtype) =
-  Genarg.create_arg "deppat_equations"
-
-type 'a binders_let2_argtype = (local_binder list * (identifier located option * recursion_order_expr), 'a) Genarg.abstract_argument_type
-
-let (wit_binders_let2 : Genarg.tlevel binders_let2_argtype),
-  (globwit_binders_let2 : Genarg.glevel binders_let2_argtype),
-  (rawwit_binders_let2 : Genarg.rlevel binders_let2_argtype) =
-  Genarg.create_arg "binders_let2"
-
-type 'a decl_notation_argtype = (Vernacexpr.decl_notation, 'a) Genarg.abstract_argument_type
-
-let (wit_decl_notation : Genarg.tlevel decl_notation_argtype),
-  (globwit_decl_notation : Genarg.glevel decl_notation_argtype),
-  (rawwit_decl_notation : Genarg.rlevel decl_notation_argtype) =
-  Genarg.create_arg "decl_notation"
-
-let equations wc i l t nt eqs =
-  try define_by_eqs wc i l t nt eqs
-  with e -> msg (Cerrors.explain_exn e)
-
-VERNAC COMMAND EXTEND Define_equations
-| [ "Equations" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs)
-      decl_notation(nt) ] ->
-    [ equations true i l t nt eqs ]
-      END
-
-VERNAC COMMAND EXTEND Define_equations2
-| [ "Equations_nocomp" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs)
-      decl_notation(nt) ] ->
-    [ equations false i l t nt eqs ]
-END
-    
-let rec int_of_coq_nat c = 
-  match kind_of_term c with
-  | App (f, [| arg |]) -> succ (int_of_coq_nat arg)
-  | _ -> 0
-
-let solve_equations_goal destruct_tac tac gl =
-  let concl = pf_concl gl in
-  let targetn, branchesn, targ, brs, b =
-    match kind_of_term concl with
-    | LetIn (Name target, targ, _, b) ->
-	(match kind_of_term b with
-	| LetIn (Name branches, brs, _, b) ->
-	    target, branches, int_of_coq_nat targ, int_of_coq_nat brs, b
-	| _ -> error "Unnexpected goal")
-    | _ -> error "Unnexpected goal"
-  in
-  let branches, b = 
-    let rec aux n c =
-      if n = 0 then [], c
-      else match kind_of_term c with
-      | LetIn (Name id, br, brt, b) -> 
-	  let rest, b = aux (pred n) b in
-	    (id, br, brt) :: rest, b
-      | _ -> error "Unnexpected goal"
-    in aux brs b
-  in 
-  let ids = targetn :: branchesn :: map pi1 branches in
-  let cleantac = tclTHEN (intros_using ids) (thin ids) in
-  let dotac = tclDO (succ targ) intro in
-  let subtacs = 
-    tclTHENS destruct_tac
-      (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches)
-  in tclTHENLIST [cleantac ; dotac ; subtacs] gl
-    
-TACTIC EXTEND solve_equations
-  [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ]
-    END
-
-let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
-let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
-
-let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
-let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
-
-let specialize_hyp id gl =
-  let env = pf_env gl in
-  let ty = pf_get_hyp_typ gl id in
-  let evars = ref (create_evar_defs (project gl)) in
-  let rec aux in_eqs acc ty =
-    match kind_of_term ty with
-    | Prod (_, t, b) -> 
-	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
-	    let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in
-	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; x |]) in
-	      if e_conv env evars pt t then
-		aux true (mkApp (acc, [| p |])) (subst1 p b)
-	      else error "Unconvertible members of an homogeneous equality"
-	| App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) ->
-	    let pt = mkApp (Lazy.force coq_heq, [| eqty; x; eqty; x |]) in
-	    let p = mkApp (Lazy.force coq_heq_refl, [| eqty; x |]) in
-	      if e_conv env evars pt t then
-		aux true (mkApp (acc, [| p |])) (subst1 p b)
-	      else error "Unconvertible members of an heterogeneous equality"
-	| _ -> 
-	    if in_eqs then acc, in_eqs, ty
-	    else 
-	      let e = e_new_evar evars env t in
-		aux false (mkApp (acc, [| e |])) (subst1 e b))
-    | t -> acc, in_eqs, ty
-  in 
-  try 
-    let acc, worked, ty = aux false (mkVar id) ty in
-    let ty = Evarutil.nf_isevar !evars ty in
-      if worked then
-	tclTHENFIRST
-	  (fun g -> Tacmach.internal_cut true id ty g)
-	  (exact_no_check (Evarutil.nf_isevar !evars acc)) gl
-      else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
-  with e -> tclFAIL 0 (Cerrors.explain_exn e) gl
-      
-TACTIC EXTEND specialize_hyp
-[ "specialize_hypothesis" constr(c) ] -> [ 
-  match kind_of_term c with
-  | Var id -> specialize_hyp id
-  | _ -> tclFAIL 0 (str "Not an hypothesis") ]
-END
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
deleted file mode 100644
index 00a69bba..00000000
--- a/contrib/subtac/eterm.ml
+++ /dev/null
@@ -1,221 +0,0 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
-(**
-   - Get types of existentials ;
-   - Flatten dependency tree (prefix order) ;
-   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
-   - Apply term prefixed by quantification on "existentials".
-*)
-
-open Term
-open Sign
-open Names
-open Evd
-open List
-open Pp
-open Util
-open Subtac_utils
-open Proof_type
-
-let trace s = 
-  if !Flags.debug then (msgnl s; msgerr s)
-  else ()
-
-let succfix (depth, fixrels) = 
-  (succ depth, List.map succ fixrels)
-
-type oblinfo =
-  { ev_name: int * identifier;
-    ev_hyps: named_context;
-    ev_status: obligation_definition_status;
-    ev_chop: int option;
-    ev_loc: Util.loc;
-    ev_typ: types;
-    ev_tac: Tacexpr.raw_tactic_expr option;
-    ev_deps: Intset.t }
-    
-(** 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, fixrels) c = match kind_of_term c with
-    | Evar (k, args) ->
-	let { ev_name = (id, idstr) ; 
-	      ev_hyps = hyps ; ev_chop = chop } =
-	  try evar_info k
-	  with Not_found -> 
-	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
-	in
-        seen := Intset.add id !seen;
-	  (* Evar arguments are created in inverse order, 
-	     and we must not apply to defined ones (i.e. LetIn's)
-	  *)
-	let args = 
-	  let n = match chop with None -> 0 | Some c -> c in 
-	  let (l, r) = list_chop n (List.rev (Array.to_list args)) in
-	    List.rev r
-	in
-	let args =
-	  let rec aux hyps args acc =
-	     match hyps, args with
-		 ((_, None, _) :: tlh), (c :: tla) -> 
-		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
-	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
-		   aux tlh tla acc
-	       | [], [] -> acc
-	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
-	  in aux hyps args [] 
-	in
-	  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)
-    | 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, !transparent
-
-      
-(** Substitute variable references in t using De Bruijn indices, 
-  where n binders were passed through. *)
-let subst_vars acc n t = 
-  let var_index id = Util.list_index id acc in
-  let rec substrec depth c = match kind_of_term c with
-    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in 
-    substrec 0 t
-
-(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
-    to a product : forall H1 : t1, ..., forall Hn : tn, concl.
-    Changes evars and hypothesis references to 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, trans = subst_evar_constr evs n t in
-	let t'' = subst_vars acc 0 t' 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', trans' *)
-(* 		else *)
-		  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', 
-		Idset.union trans'' trans'
-	    | None -> 
-		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
-    | [] ->
-	let t', s, trans = subst_evar_constr evs n concl in
-	  subst_vars acc 0 t', s, trans
-  in aux [] 0 (rev hyps)
-
-
-open Tacticals
-    
-let trunc_named_context n ctx = 
-  let len = List.length ctx in
-    list_firstn (len - n) ctx
-  
-let rec chop_product n t = 
-  if n = 0 then Some t
-  else 
-    match kind_of_term t with
-      | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
-      | _ -> None
-
-let evar_dependencies evm ev =
-  let one_step deps = 
-    Intset.fold (fun ev s -> 
-      let evi = Evd.find evm ev in
-	Intset.union (Evarutil.evars_of_evar_info evi) s)
-      deps deps
-  in 
-  let rec aux deps =
-    let deps' = one_step deps in
-      if Intset.equal deps deps' then deps
-      else aux deps'
-  in aux (Intset.singleton ev)
-
-let sort_dependencies evl =
-  List.sort (fun (_, _, deps) (_, _, deps') -> 
-    if Intset.subset deps deps' then (* deps' depends on deps *) -1
-    else if Intset.subset deps' deps then 1
-    else Intset.compare deps deps')
-    evl
-    
-let eterm_obligations env name isevars evm fs ?status t ty = 
-  (* 'Serialize' the evars *)
-  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 evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
-  let sevl = sort_dependencies evl in
-  let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
-  let evn = 
-    let i = ref (-1) in
-      List.rev_map (fun (id, ev) -> incr i; 
-		      (id, (!i, id_of_string
-			      (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))),
-		       ev)) evl
-  in
-  let evts = 
-    (* Remove existential variables in types and build the corresponding products *)
-    fold_right 
-      (fun (id, (n, nstr), ev) l ->
-	 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 -> t, trunc_named_context fs hyps, fs
-	   | None -> evtyp, hyps, 0
-	 in
-	 let loc, k = evar_source id isevars in
-	 let status = match k with QuestionMark o -> Some o | _ -> status in
-	 let status, chop = match status with 
-	   | Some (Define true as stat) ->
-	       if chop <> fs then Define false, None 
-	       else stat, Some chop
-	   | Some s -> s, None
-	   | None -> Define true, None
-	 in
-	 let tac = match ev.evar_extra with 
-	   | Some t -> 
-	       if Dyn.tag t = "tactic" then 
-		 Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t))
-	       else None
-	   | None -> None
-	 in
-	 let info = { ev_name = (n, nstr);
-		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
-		      ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
-	 in (id, info) :: l) 
-      evn []
-  in 
-  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 (_, info) ->
-      let { ev_name = (_, name); ev_status = status;
-	    ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
-      in
-      let status = match status with
-	| Define true when Idset.mem name transparent -> Define false
-	| _ -> status
-      in name, typ, loc, status, deps, tac) evts
-  in Array.of_list (List.rev evars), t', ty
-
-let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
-
-let etermtac (evm, t) = assert(false) (*eterm evm t None *)
diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli
deleted file mode 100644
index 19e8ffe8..00000000
--- a/contrib/subtac/eterm.mli
+++ /dev/null
@@ -1,32 +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        *)
-(************************************************************************)
-
-(*i $Id: eterm.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
-open Environ
-open Tacmach
-open Term
-open Evd
-open Names
-open Util
-open Tacinterp
-
-val mkMetas : int -> constr list
-
-val evar_dependencies : evar_map -> int -> Intset.t
-val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list
-  
-(* 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 -> 
-  ?status:obligation_definition_status -> constr -> types -> 
-  (identifier * types * loc * obligation_definition_status * Intset.t * 
-      Tacexpr.raw_tactic_expr option) array * constr * types
-    (* Obl. name, type as product, location of the original evar, associated tactic,
-       status and dependencies as indexes into the array *)
-
-val etermtac : open_constr -> tactic
diff --git a/contrib/subtac/g_eterm.ml4 b/contrib/subtac/g_eterm.ml4
deleted file mode 100644
index d9dd42cd..00000000
--- a/contrib/subtac/g_eterm.ml4
+++ /dev/null
@@ -1,27 +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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_eterm.ml4 8654 2006-03-22 15:36:58Z msozeau $ *)
-
-open Eterm
-
-TACTIC EXTEND eterm
-  [ "eterm" ] -> [ 
-    (fun gl ->
-       let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in
-         Eterm.etermtac (evm, t) gl) ]
-END
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
deleted file mode 100644
index 7194d435..00000000
--- a/contrib/subtac/g_subtac.ml4
+++ /dev/null
@@ -1,156 +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        *)
-(************************************************************************)
-
-(*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 11576 2008-11-10 19:13:15Z msozeau $ *)
-
-
-open Flags
-open Util
-open Names
-open Nameops
-open Vernacentries
-open Reduction
-open Term
-open Libnames
-open Topconstr
-
-(* We define new entries for programs, with the use of this module
- * Subtac. These entries are named Subtac.<foo>
- *)
-
-module Gram = Pcoq.Gram
-module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
-
-module SubtacGram =
-struct
-  let gec s = Gram.Entry.create ("Subtac."^s)
-		(* types *)
-  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
-
-  let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
-end
-
-open 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 typeclass_constraint Constr.binder subtac_nameopt;
- 
-  subtac_gallina_loc:
-    [ [ g = Vernac.gallina -> loc, g
-    | g = Vernac.gallina_ext -> loc, g ] ]
-    ;
-
-  subtac_nameopt:
-    [ [ "ofb"; id=Prim.ident -> Some (id) 
-      | -> None ] ]
-    ;
-
-  Constr.binder_let:
-    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
-	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
-          [LocalRawAssum ([id], default_binder_kind, typ)]
-    ] ];
-
-  Constr.binder:
-    [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
-          ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)]))
-      | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
-          ([id],default_binder_kind, c)
-      | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
-          (id::lid,default_binder_kind, c)
-    ] ];
-
-  END
-
-
-type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type
-
-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) Genarg.abstract_argument_type
-
-let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
-  (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
-  (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) =
-  Genarg.create_arg "subtac_nameopt"
-
-VERNAC COMMAND EXTEND Subtac
-[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
-  END
-
-VERNAC COMMAND EXTEND Subtac_Obligations
-| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ]
-| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ]
-| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ]      
-| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ]
-| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ]
-| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligation
-| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligation num None (Some (Tacinterp.interp t)) ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligations
-| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" "using" tactic(t) ] -> 
-    [ Subtac_obligations.try_solve_obligations None (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" ] -> 
-    [ Subtac_obligations.try_solve_obligations None None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
-| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> 
-    [ Subtac_obligations.solve_all_obligations (Some (Tacinterp.interp t)) ]
-| [ "Solve" "All" "Obligations" ] -> 
-    [ Subtac_obligations.solve_all_obligations None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Admit_Obligations
-| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] 
-| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] 
-    END
-
-VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ 
-    Coqlib.check_required_library ["Coq";"Program";"Tactics"];
-    Tacinterp.add_tacdef false 
-      [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligation_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
deleted file mode 100644
index c0b64379..00000000
--- a/contrib/subtac/subtac.ml
+++ /dev/null
@@ -1,241 +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        *)
-(************************************************************************)
-
-(* $Id: subtac.ml 12194 2009-06-17 16:38:09Z msozeau $ *)
-
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops 
-open Evarutil
-open Pretype_errors
-open Rawterm
-open Evarconv
-open Pattern
-open Dyn
-open Vernacexpr
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-let require_library dirpath =
-  let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
-    Library.require_library [qualid] None
-
-open Pp
-open Ppconstr
-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 ~status:Expand c typ 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 (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
-          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, _imps = 
-    Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None 
-  in
-  let c = solve_tccs_in_type env id isevars evm c typ in
-    Command.start_proof id kind c hook	
-      
-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;
-  print_subgoals ()
-	  
-let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
-  
-let assumption_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-
-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
-    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 [] nl) idl
-  else
-    errorlabstrm "Command.Assumption"
-	(str "Cannot declare an assumption while in proof editing mode.")
-
-let dump_constraint ty ((loc, n), _, _) =
-  match n with
-    | Name id -> Dumpglob.dump_definition (loc, id) false 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 Dumpglob.dump () then
-	List.iter (fun lid -> 
-	  if global then Dumpglob.dump_definition lid (not global) "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"];
-  let env = Global.env () in
-  let isevars = ref (create_evar_defs Evd.empty) in
-  try
-  match command with
-  | VernacDefinition (defkind, (_, id as lid), expr, hook) -> 
-      check_fresh lid;
-      Dumpglob.dump_definition lid false "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 lid) (Global, DefinitionBody Definition) (bl,t) 
-	    (fun _ _ -> ())
-      | DefineBody (bl, _, c, tycon) -> 
-	  ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
-  | VernacFixpoint (l, b) -> 
-      List.iter (fun ((lid, _, _, _, _), _) -> 
-	check_fresh lid;
-	Dumpglob.dump_definition lid false "fix") l;
-      let _ = trace (str "Building fixpoint") in
-	ignore(Subtac_command.build_recursive l b)
-	  
-  | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) ->
-      Dumpglob.dump_definition id false "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) ->
-      dump_constraint "inst" is;
-      ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
-	
-  | VernacCoFixpoint (l, b) ->
-      if Dumpglob.dump () then 
-	List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "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, Proof_type.LtacLocated (_,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'' -> raise e)
-	
-  | e -> raise e
diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli
deleted file mode 100644
index b51150aa..00000000
--- a/contrib/subtac/subtac.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-val require_library : string -> unit
-val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml
deleted file mode 100644
index bd06407f..00000000
--- a/contrib/subtac/subtac_cases.ml
+++ /dev/null
@@ -1,2032 +0,0 @@
-(* -*- 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 *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: subtac_cases.ml 12194 2009-06-17 16:38:09Z msozeau $ *)
-
-open Cases
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Declarations
-open Inductiveops
-open Environ
-open Sign
-open Reductionops
-open Typeops
-open Type_errors
-
-open Rawterm
-open Retyping
-open Pretype_errors
-open Evarutil
-open Evarconv
-
-open Subtac_utils
-
-(************************************************************************)
-(*            Pattern-matching compilation (Cases)                      *)
-(************************************************************************)
-
-(************************************************************************)
-(* Configuration, errors and warnings *)
-
-open Pp
-
-let mssg_may_need_inversion () =
-  str "Found a matching with no clauses on a term unknown to have an empty inductive type"
-
-(* Utils *)
-let make_anonymous_patvars =
-  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
-
-(* Environment management *)
-let push_rels vars env = List.fold_right push_rel vars env
-
-let push_rel_defs =
-  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
-
-(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
-   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
-
-let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
-
-let rec regeneralize_index i k t = match kind_of_term t with
-  | Rel j when j = i+k -> mkRel (k+1)
-  | Rel j when j < i+k -> t
-  | Rel j when j > i+k -> t
-  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
-
-type alias_constr =
-  | DepAlias
-  | NonDepAlias
-
-let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
-  { uj_val =
-      (match d with
-	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
-	| NonDepAlias ->
-	    if (not (dependent (mkRel 1) j.uj_type))
-	      or (* A leaf: *) isRel deppat
-	    then 
-	      (* The body of pat is not needed to type j - see *)
-	      (* insert_aliases - and both deppat and nondeppat have the *)
-	      (* same type, then one can freely substitute one by the other *)
-	      subst1 nondeppat j.uj_val
-	    else
-	      (* The body of pat is not needed to type j but its value *)
-	      (* is dependent in the type of j; our choice is to *)
-	      (* enforce this dependency *)
-	      mkLetIn (na,deppat,t,j.uj_val));
-    uj_type = subst1 deppat j.uj_type }
-
-(**********************************************************************)
-(* Structures used in compiling pattern-matching *)
-
-type rhs =
-    { rhs_env    : env;
-      avoid_ids  : identifier list;
-      it         : rawconstr;
-    }
-
-type equation =
-    { patterns     : cases_pattern list; 
-      rhs          : rhs;
-      alias_stack  : name list;
-      eqn_loc      : loc;
-      used         : bool ref }
-
-type matrix = equation list
-
-(* 1st argument of IsInd is the original ind before extracting the summary *)
-type tomatch_type =
-  | IsInd of types * inductive_type
-  | NotInd of constr option * types
-
-type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list)
-  | Alias of (constr * constr * alias_constr * constr)
-  | Abstract of rel_declaration
-
-type tomatch_stack = tomatch_status list
-
-(* The type [predicate_signature] types the terms to match and the rhs:
-
-   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
-     if dep<>Anonymous, the term is dependent, let n=|names|, if
-     n<>0 then the type of the pushed term is necessarily an
-     inductive with n real arguments. Otherwise, it may be
-     non inductive, or inductive without real arguments, or inductive
-     originating from a subterm in which case real args are not dependent;
-     it accounts for n+1 binders if dep or n binders if not dep
-   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
-   - [PrCcl] types the right-hand-side
-   - Aliases [Alias] have no trace in [predicate_signature]
-*)
-
-type predicate_signature =
-  | PrLetIn of (name list * name) * predicate_signature
-  | PrProd of predicate_signature
-  | PrCcl of constr
-
-(* We keep a constr for aliases and a cases_pattern for error message *)
-
-type alias_builder =
-  | AliasLeaf
-  | AliasConstructor of constructor
-
-type pattern_history =
-  | Top
-  | MakeAlias of alias_builder * pattern_continuation
-
-and pattern_continuation =
-  | Continuation of int * cases_pattern list * pattern_history
-  | Result of cases_pattern list
-
-let start_history n = Continuation (n, [], Top)
-
-let initial_history = function Continuation (_,[],Top) -> true | _ -> false
-
-let feed_history arg = function
-  | Continuation (n, l, h) when n>=1 ->
-      Continuation (n-1, arg :: l, h)
-  | Continuation (n, _, _) ->
-      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
-  | Result _ -> 
-      anomaly "Exhausted pattern history"
-
-(* This is for non exhaustive error message *)
-
-let rec rawpattern_of_partial_history args2 = function
-  | Continuation (n, args1, h) ->
-      let args3 = make_anonymous_patvars (n - (List.length args2)) in
-      build_rawpattern (List.rev_append args1 (args2@args3)) h
-  | Result pl -> pl
-
-and build_rawpattern args = function
-  | Top -> args
-  | MakeAlias (AliasLeaf, rh) ->
-      assert (args = []);
-      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
-  | MakeAlias (AliasConstructor pci, rh) ->
-      rawpattern_of_partial_history
-	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
-
-let complete_history = rawpattern_of_partial_history []
-
-(* This is to build glued pattern-matching history and alias bodies *)
-
-let rec simplify_history = function
-  | Continuation (0, l, Top) -> Result (List.rev l)
-  | Continuation (0, l, MakeAlias (f, rh)) ->
-      let pargs = List.rev l in
-      let pat = match f with
-	| AliasConstructor pci ->
-	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf -> 
-	    assert (l = []);
-	    PatVar (dummy_loc, Anonymous) in
-      feed_history pat rh
-  | h -> h
-
-(* Builds a continuation expecting [n] arguments and building [ci] applied
-   to this [n] arguments *)
-
-let push_history_pattern n current cont =
-  Continuation (n, [], MakeAlias (current, cont))
-
-(* A pattern-matching problem has the following form:
-
-   env, isevars |- <pred> Cases tomatch of mat end
-
-  where tomatch is some sequence of "instructions" (t1  ... tn)
-
-  and mat is some matrix 
-   (p11 ... p1n -> rhs1)
-   (    ...            )
-   (pm1 ... pmn -> rhsm)
-
-  Terms to match: there are 3 kinds of instructions
-
-  - "Pushed" terms to match are typed in [env]; these are usually just
-    Rel(n) except for the initial terms given by user and typed in [env]
-  - "Abstract" instructions means an abstraction has to be inserted in the
-    current branch to build (this means a pattern has been detected dependent
-    in another one and generalisation is necessary to ensure well-typing)
-  - "Alias" instructions means an alias has to be inserted (this alias
-    is usually removed at the end, except when its type is not the
-    same as the type of the matched term from which it comes -
-    typically because the inductive types are "real" parameters)
-
-  Right-hand-sides:
-
-  They consist of a raw term to type in an environment specific to the
-  clause they belong to: the names of declarations are those of the
-  variables present in the patterns. Therefore, they come with their
-  own [rhs_env] (actually it is the same as [env] except for the names
-  of variables).
-
-*)
-type pattern_matching_problem =
-    { env      : env;
-      isevars  : Evd.evar_defs ref;
-      pred     : predicate_signature option;
-      tomatch  : tomatch_stack;
-      history  : pattern_continuation;
-      mat      : matrix;
-      caseloc  : loc;
-      casestyle: case_style;
-      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
-
-(*--------------------------------------------------------------------------*
- * A few functions to infer the inductive type from the patterns instead of *
- * checking that the patterns correspond to the ind. type of the            *
- * destructurated object. Allows type inference of examples like            *
- *  match n with O => true | _ => false end                                 *
- *  match x in I with C => true | _ => false end                            *
- *--------------------------------------------------------------------------*)
-
-(* Computing the inductive type from the matrix of patterns *)
-
-(* We use the "in I" clause to coerce the terms to match and otherwise
-   use the constructor to know in which type is the matching problem
-
-   Note that insertion of coercions inside nested patterns is done
-   each time the matrix is expanded *)
-
-let rec find_row_ind = function
-    [] -> None
-  | PatVar _ :: l -> find_row_ind l
-  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
-
-let inductive_template isevars env tmloc ind =
-  let arsign = get_full_arity_sign env ind in
-  let hole_source = match tmloc with 
-    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
-    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
-   let (_,evarl,_) =
-    List.fold_right
-      (fun (na,b,ty) (subst,evarl,n) ->
-	match b with
-        | None ->
-	    let ty' = substl subst ty in
-	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
-	    (e::subst,e::evarl,n+1) 
-	| Some b ->
-	    (b::subst,evarl,n+1))
-      arsign ([],[],1) in
-   applist (mkInd ind,List.rev evarl)
-
-
-(************************************************************************)
-(* Utils *)
-
-let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
-  e_new_evar isevars env ~src:src (new_Type ())
-
-let evd_comb2 f isevars x y =
-  let (evd',y) = f !isevars x y in
-  isevars := evd';
-  y
-
-
-module Cases_F(Coercion : Coercion.S) : S = struct
-
-let inh_coerce_to_ind isevars env ty tyi =
-  let expected_typ = inductive_template isevars env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour 
-        un inductif cela doit être égal *)
-  let _ = e_cumul env isevars expected_typ ty in ()
-
-let unify_tomatch_with_patterns isevars env loc typ pats =
-  match find_row_ind pats with
-    | None -> NotInd (None,typ)
-    | Some (_,(ind,_)) ->
-	inh_coerce_to_ind isevars env typ ind;
-	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
-	with Not_found -> NotInd (None,typ)
-
-let find_tomatch_tycon isevars env loc = function
-  (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
-  | None -> empty_tycon
-
-let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
-  let loc = Some (loc_of_rawconstr tomatch) in
-  let tycon = find_tomatch_tycon isevars env loc indopt in
-  let j = typing_fun tycon env tomatch in
-  let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in
-  isevars := evd;
-  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
-  let t =
-    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
-    with Not_found ->
-      unify_tomatch_with_patterns isevars env loc typ pats in
-  (j.uj_val,t)
-
-let coerce_to_indtype typing_fun isevars env matx tomatchl =
-  let pats = List.map (fun r ->  r.patterns) matx in
-  let matx' = match matrix_transpose pats with
-    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
-    | m -> m in
-  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
-
-
-
-let adjust_tomatch_to_pattern pb ((current,typ),deps) =
-  (* Ideally, we could find a common inductive type to which both the
-     term to match and the patterns coerce *)
-  (* In practice, we coerce the term to match if it is not already an
-     inductive type and it is not dependent; moreover, we use only 
-     the first pattern type and forget about the others *)
-  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
-  let typ =
-    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
-    with Not_found -> NotInd (None,typ) in
-  let tomatch = ((current,typ),deps) in
-  match typ with
-  | NotInd (None,typ) ->
-      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
-      (match find_row_ind tm1 with
-	| None -> tomatch
-	| Some (_,(ind,_)) ->
-	    let indt = inductive_template pb.isevars pb.env None ind in
-	    let current =
-	      if deps = [] & isEvar typ then
-	      (* Don't insert coercions if dependent; only solve evars *)
-		let _ = e_cumul pb.env pb.isevars indt typ in
-		current
-	      else
-		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
-		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma = Evd.evars_of !(pb.isevars) in
-	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
-	    ((current,typ),deps))
-  | _ -> tomatch
-
-   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
-let to_mutind env isevars tm c t =
-(*  match c with
-    | Some body -> *) NotInd (c,t)
-(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
-
-let type_of_tomatch = function
-  | IsInd (t,_) -> t
-  | NotInd (_,t) -> t
-
-let mkDeclTomatch na = function
-  | IsInd (t,_) -> (na,None,t)
-  | NotInd (c,t) -> (na,c,t)
-
-let map_tomatch_type f = function
-  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
-  | NotInd (c,t) -> NotInd (Option.map f c, f t)
-
-let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
-let lift_tomatch_type n = liftn_tomatch_type n 1
-
-let lift_tomatch n ((current,typ),info) =
-  ((lift n current,lift_tomatch_type n typ),info)
-
-(**********************************************************************)
-(* Utilities on patterns *)
-
-let current_pattern eqn =
-  match eqn.patterns with
-    | pat::_ -> pat
-    | [] -> anomaly "Empty list of patterns"
-
-let alias_of_pat = function
-  | PatVar (_,name) -> name
-  | PatCstr(_,_,_,name) -> name
-
-let unalias_pat = function
-  | PatVar (c,name) as p ->
-      if name = Anonymous then p else PatVar (c,Anonymous)
-  | PatCstr(a,b,c,name) as p ->
-      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
-
-let remove_current_pattern eqn =
-  match eqn.patterns with
-    | pat::pats ->
-	{ eqn with
-	    patterns = pats;
-	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
-    | [] -> anomaly "Empty list of patterns"
-
-let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
-
-(**********************************************************************)
-(* Well-formedness tests *)
-(* Partial check on patterns *)
-
-exception NotAdjustable
-
-let rec adjust_local_defs loc = function
-  | (pat :: pats, (_,None,_) :: decls) ->
-      pat :: adjust_local_defs loc (pats,decls)
-  | (pats, (_,Some _,_) :: decls) ->
-      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
-  | [], [] -> []
-  | _ -> raise NotAdjustable
-
-let check_and_adjust_constructor env ind cstrs = function 
-  | PatVar _ as pat -> pat
-  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
-      (* Check it is constructor of the right type *)
-      let ind' = inductive_of_constructor cstr in
-      if Closure.mind_equiv env ind' ind then
-	(* Check the constructor has the right number of args *)
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	if List.length args = nb_args_constr then pat
-	else
-	  try 
-	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
-	    in PatCstr (loc, cstr, args', alias)
-	  with NotAdjustable ->
-	    error_wrong_numarg_constructor_loc loc (Global.env())
-	      cstr nb_args_constr
-      else
-	(* Try to insert a coercion *)
-	try
-	  Coercion.inh_pattern_coerce_to loc pat ind' ind
-	with Not_found -> 
-	  error_bad_constructor_loc loc cstr ind
-
-let check_all_variables typ mat =
-  List.iter
-    (fun eqn -> match current_pattern eqn with
-       | PatVar (_,id) -> ()
-       | PatCstr (loc,cstr_sp,_,_) ->
-	   error_bad_pattern_loc loc cstr_sp typ)
-    mat
-
-let check_unused_pattern env eqn =
-  if not !(eqn.used) then 
-    raise_pattern_matching_error
-      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
-
-let set_used_pattern eqn = eqn.used := true
-
-let extract_rhs pb =
-  match pb.mat with 
-    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
-    | eqn::_ ->
-	set_used_pattern eqn;
-	eqn.rhs
-
-(**********************************************************************)
-(* Functions to deal with matrix factorization *)
-
-let occur_in_rhs na rhs =
-  match na with
-    | Anonymous -> false
-    | Name id -> occur_rawconstr id rhs.it
-
-let is_dep_patt eqn = function
-  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
-  | PatCstr _ -> true
-
-let dependencies_in_rhs nargs eqns =
-  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
-  else
-  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
-  let columns = matrix_transpose deps in
-  List.map (List.exists ((=) true)) columns
-
-let dependent_decl a = function
-  | (na,None,t) -> dependent a t
-  | (na,Some c,t) -> dependent a t || dependent a c
-
-(* Computing the matrix of dependencies *)
-
-(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
-   computes for declaration [k+1] in which of declarations in
-   [nextlist] (which corresponds to d(k+2)...dn) it depends;
-   declarations are expressed by index, e.g. in dependency list
-   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
-
-let rec find_dependency_list k n = function
-  | [] -> []
-  | (used,tdeps,d)::rest -> 
-      let deps = find_dependency_list k (n+1) rest in
-      if used && dependent_decl (mkRel n) d
-      then list_add_set (List.length rest + 1) (list_union deps tdeps)
-      else deps
-
-let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
-  let deps = find_dependency_list k 1 nextlist in
-  if is_dep_or_cstr_in_rhs || deps <> []
-  then (k-1,(true ,deps,d)::nextlist)
-  else (k-1,(false,[]  ,d)::nextlist)
-
-let find_dependencies_signature deps_in_rhs typs =
-  let k = List.length deps_in_rhs in
-  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
-  List.map (fun (_,deps,_) -> deps) l
-
-(******)
-
-(* A Pushed term to match has just been substituted by some
-   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
-   match 
-
-   - all terms to match and to push (dependent on t by definition)
-     must have (Rel depth) substituted by t and Rel's>depth lifted by n
-   - all pushed terms to match (non dependent on t by definition) must
-     be lifted by n
-
-  We start with depth=1
-*)
-
-let regeneralize_index_tomatch n =
-  let rec genrec depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = regeneralize_index n depth c in
-      let tm = map_tomatch_type (regeneralize_index n depth) tm in
-      let l = List.map (regeneralize_rel n depth) l in
-      Pushed ((c,tm),l)::(genrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (regeneralize_index n depth) d)
-      ::(genrec (depth+1) rest) in
-  genrec 0
-
-let rec replace_term n c k t = 
-  if t = mkRel (n+k) then lift k c
-  else map_constr_with_binders succ (replace_term n c) k t
-
-let replace_tomatch n c =
-  let rec replrec depth = function
-  | [] -> []
-  | Pushed ((b,tm),l)::rest ->
-      let b = replace_term n c depth b in
-      let tm = map_tomatch_type (replace_term n c depth) tm in
-      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l)::(replrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (replace_term n c depth) d)
-      ::(replrec (depth+1) rest) in
-  replrec 0
-
-let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
-let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
-
-let rec liftn_tomatch_stack n depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = liftn n depth c in
-      let tm = liftn_tomatch_type n depth tm in
-      let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
-      ::(liftn_tomatch_stack n depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (liftn n depth) d)
-      ::(liftn_tomatch_stack n (depth+1) rest)
-
-
-let lift_tomatch_stack n = liftn_tomatch_stack n 1
-
-(* if [current] has type [I(p1...pn u1...um)] and we consider the case
-   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
-   default variable [name] is expected to have which type?
-   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
-
-(************************************************************************)
-(* Some heuristics to get names for variables pushed in pb environment *)
-(* Typical requirement:
-
-   [match y with (S (S x)) => x | x => x end] should be compiled into
-   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
-
-   and [match y with (S (S n)) => n | n => n end] into 
-   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
-
-  i.e. user names should be preserved and created names should not
-  interfere with user names *)
-
-let merge_name get_name obj = function
-  | Anonymous -> get_name obj
-  | na -> na
-
-let merge_names get_name = List.map2 (merge_name get_name)
-
-let get_names env sign eqns =
-  let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
-  (* If any, we prefer names used in pats, from top to bottom *)
-  let names2 = 
-    List.fold_right
-      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
-      eqns names1 in
-  (* Otherwise, we take names from the parameters of the constructor but
-     avoiding conflicts with user ids *)
-  let allvars =
-    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
-  let names4,_ =
-    List.fold_left2
-      (fun (l,avoid) d na ->
-	 let na =
-	   merge_name
-	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
-	     d na 
-	 in
-         (na::l,(out_name na)::avoid))
-      ([],allvars) (List.rev sign) names2 in
-  names4
-
-(************************************************************************)
-(* Recovering names for variables pushed to the rhs' environment *)
-
-let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
-
-let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
-				(n, b, t)) sign
-
-let push_rels_eqn sign eqn =
-  let sign = all_name sign in
-    {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
-
-let push_rels_eqn_with_names sign eqn =
-  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
-  let sign = recover_alias_names alias_of_pat pats sign in
-  push_rels_eqn sign eqn
-
-let build_aliases_context env sigma names allpats pats =
-  (* pats is the list of bodies to push as an alias *)
-  (* They all are defined in env and we turn them into a sign *)
-  (* cuts in sign need to be done in allpats *)
-  let rec insert env sign1 sign2 n newallpats oldallpats = function
-    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
-        (* Anonymous leaves must be considered named and treated in the *)
-        (* next clause because they may occur in implicit arguments *)
-	insert env sign1 sign2
-	  n newallpats (List.map List.tl oldallpats) (pats,names)
-    | (deppat,nondeppat,d,t)::pats, na::names ->
-	let nondeppat = lift n nondeppat in
-	let deppat = lift n deppat in
-	let newallpats =
-	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
-	let oldallpats = List.map List.tl oldallpats in
-	let decl = (na,Some deppat,t) in
-	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
-	  newallpats oldallpats (pats,names)
-    | [], [] -> newallpats, sign1, sign2, env
-    | _ -> anomaly "Inconsistent alias and name lists" in
-  let allpats = List.map (fun x -> [x]) allpats
-  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
-
-let insert_aliases_eqn sign eqnnames alias_rest eqn =
-  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
-    push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
-	    
-
-let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
-  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
-  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
-  (* names2 takes the meet of all needed aliases *)
-  let names2 = 
-    List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
-  (* Only needed aliases are kept by build_aliases_context *)
-  let eqnsnames, sign1, sign2, env =
-    build_aliases_context env sigma [names2] eqnsnames [alias] in
-  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
-  sign2, env, eqns
-
-(**********************************************************************)
-(* Functions to deal with elimination predicate *)
-
-exception Occur
-let noccur_between_without_evar n m term = 
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p       -> if n<=p && p<n+m then raise Occur
-    | Evar (_,cl) -> ()
-    | _             -> iter_constr_with_binders succ occur_rec n c
-  in 
-  try occur_rec n term; true with Occur -> false
-
-(* Inferring the predicate *)
-let prepare_unif_pb typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-
-  (* We may need to invert ci if its parameters occur in typ *)
-  let typ' =
-    if noccur_between_without_evar 1 n typ then lift (-n) typ
-    else (* TODO4-1 *)
-      error "Unable to infer return clause of this pattern-matching problem" in
-  let args = extended_rel_list (-n) cs.cs_args in
-  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
-
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
-  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
-
-
-(* Infering the predicate *)
-(*
-The problem to solve is the following:
-
-We match Gamma |- t : I(u01..u0q) against the following constructors:
-
-  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
-   ...
-  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
-
-Assume the types in the branches are the following
-
-  Gamma, x11...x1p1 |- branch1 : T1
-   ...
-  Gamma, xn1...xnpn |- branchn : Tn
-
-Assume the type of the global case expression is Gamma |- T
-
-The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
-the following n+1 equations:
-
-  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
-   ...
-  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
-  Gamma             |- (phi u01..u0q t)               =  T
-
-Some hints:
-
-- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
-  should be inserted somewhere in Ti.
-
-- If T is undefined, an easy solution is to insert a "match z with (Ci
-  xi1..xipi) => ..." in front of each Ti
-
-- Otherwise, T1..Tn and T must be step by step unified, if some of them
-  diverge, then try to replace the diverging subterm by one of y1..yq or z.
-
-- The main problem is what to do when an existential variables is encountered
-
-let prepare_unif_pb typ cs =
-  let n = cs.cs_nargs in
-  let _,p = decompose_prod_n n typ in
-  let ci = build_dependent_constructor cs in
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
-  (n, cs.cs_concl_realargs, ci, p)
-
-let eq_operator_lift k (n,n') = function
-  | OpRel p, OpRel p' when p > k & p' > k ->
-      if p < k+n or p' < k+n' then false else p - n = p' - n'
-  | op, op' -> op = op'
-
-let rec transpose_args n =
-  if n=0 then []
-  else
-    (Array.map (fun l -> List.hd l) lv)::
-    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
-
-let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
-
-let reloc_operator (k,n) = function OpRel p when p > k -> 
-let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
-  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
-  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
-  then
-    let argvl = transpose_args (List.length args1) pv' in
-    let k' = shift_operator k op1 in
-    let argl = List.map (unify_clauses k') argvl in
-    gather_constr (reloc_operator (k,n1) op1) argl
-*)
-
-let abstract_conclusion typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-  let (sign,p) = decompose_prod_n n typ in
-  lam_it p sign
-
-let infer_predicate loc env isevars typs cstrs indf =
-  (* Il faudra substituer les isevars a un certain moment *)
-  if Array.length cstrs = 0 then (* "TODO4-3" *)
-    error "Inference of annotation for empty inductive types not implemented"
-  else
-    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
-    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
-    let typs =
-      Array.map (local_strong whd_beta (Evd.evars_of !isevars)) typs
-    in
-    let eqns = array_map2 prepare_unif_pb typs cstrs in
-    (* First strategy: no dependencies at all *)
-(*
-    let (mis,_) = dest_ind_family indf in
-    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
-*)
-    let (sign,_) = get_arity env indf in
-    let mtyp =
-      if array_exists is_Type typs then
-	(* Heuristic to avoid comparison between non-variables algebric univs*)
-	new_Type ()
-      else
-	mkExistential env ~src:(loc, Evd.CasesType) isevars
-    in
-    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
-    then
-      (* Non dependent case -> turn it into a (dummy) dependent one *)
-      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-      (true,pred) (* true = dependent -- par défaut *)
-    else
-(*
-      let s = get_sort_of env (evars_of isevars) typs.(0) in
-      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
-      let caseinfo = make_default_case_info mis in
-      let brs = array_map2 abstract_conclusion typs cstrs in
-      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-*)
-      (* "TODO4-2" *)
-      (* We skip parameters *)
-      let cis = 
-	Array.map
-	  (fun cs ->
-	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
-	  cstrs in
-      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
-      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
-(*
-      (true,pred)
-*)
-
-(* Propagation of user-provided predicate through compilation steps *)
-
-let rec map_predicate f k = function
-  | PrCcl ccl -> PrCcl (f k ccl)
-  | PrProd pred ->
-      PrProd (map_predicate f (k+1) pred)
-  | PrLetIn ((names,dep as tm),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      PrLetIn (tm, map_predicate f (k+k') pred)
-
-let rec noccurn_predicate k = function
-  | PrCcl ccl -> noccurn k ccl
-  | PrProd pred -> noccurn_predicate (k+1) pred
-  | PrLetIn ((names,dep),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      noccurn_predicate (k+k') pred
-
-let liftn_predicate n = map_predicate (liftn n)
-
-let lift_predicate n = liftn_predicate n 1
-
-let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
-
-let substnl_predicate sigma = map_predicate (substnl sigma)
-
-(* This is parallel bindings *)
-let subst_predicate (args,copt) pred =
-  let sigma = match copt with
-    | None -> List.rev args
-    | Some c -> c::(List.rev args) in
-  substnl_predicate sigma 0 pred
-
-let specialize_predicate_var (cur,typ) = function
-  | PrProd _ | PrCcl _ ->
-     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
-  | PrLetIn (([],dep),pred) ->
-      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
-  | PrLetIn ((_,dep),pred) ->
-      (match typ with
-        | IsInd (_,IndType (_,realargs)) ->
-           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
-        | _ -> anomaly "specialize_predicate_var")
-
-let ungeneralize_predicate = function
-  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
-  | PrProd pred -> pred
-
-(*****************************************************************************)
-(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
-(* and we want to abstract P over y:t(x) typed in the same context to get    *)
-(*                                                                           *)
-(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
-(*                                                                           *)
-(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
-(* then we have to replace x by x' in t(x) and y by y' in P                  *)
-(*****************************************************************************)
-let generalize_predicate ny d = function
-  | PrLetIn ((names,dep as tm),pred) ->
-      if dep=Anonymous then anomaly "Undetected dependency";
-      let p = List.length names + 1 in
-      let pred = lift_predicate 1 pred in
-      let pred = regeneralize_index_predicate (ny+p+1) pred in
-      PrLetIn (tm, PrProd pred)
-  | PrProd _ | PrCcl _ ->
-      anomaly "generalize_predicate: expects a non trivial pattern"
-
-let rec extract_predicate l = function
-  | pred, Alias (deppat,nondeppat,_,_)::tms ->
-      let tms' = match kind_of_term nondeppat with
-        | Rel i -> replace_tomatch i deppat tms
-        | _ -> (* initial terms are not dependent *) tms in
-      extract_predicate l (pred,tms')
-  | PrProd pred, Abstract d'::tms ->
-      let d' = map_rel_declaration (lift (List.length l)) d' in
-      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
-  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
-      let l = List.rev realargs@l in
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrCcl ccl, [] ->
-      substl l ccl
-  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
-
-let abstract_predicate env sigma indf cur tms = function
-  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
-  | PrLetIn ((names,dep),pred) ->
-      let sign = make_arity_signature env true indf in
-      (* n is the number of real args + 1 *)
-      let n = List.length sign in
-      let tms = lift_tomatch_stack n tms in
-      let tms =
-        match kind_of_term cur with
-          | Rel i -> regeneralize_index_tomatch (i+n) tms
-          | _ -> (* Initial case *) tms in
-      (* Depending on whether the predicate is dependent or not, and has real
-         args or not, we lift it to make room for [sign] *)
-      (* Even if not intrinsically dep, we move the predicate into a dep one *)
-      let sign,k =
-        if names = [] & n <> 1 then
-          (* Real args were not considered *)
-          (if dep<>Anonymous then
-            ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
-          else
-            (sign,n))
-        else
-          (* Real args are OK *)
-          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
-           if dep<>Anonymous then 0 else 1) in
-      let pred = lift_predicate k pred in
-      let pred = extract_predicate [] (pred,tms) in
-      (true, it_mkLambda_or_LetIn_name env pred sign)
-
-let rec known_dependent = function
-  | None -> false
-  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
-  | Some (PrCcl _) -> false
-  | Some (PrProd _) ->
-      anomaly "known_dependent: can only be used when patterns remain"
-
-(* [expand_arg] is used by [specialize_predicate]
-   it replaces gamma, x1...xn, x1...xk |- pred
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
-
-let expand_arg n alreadydep (na,t) deps (k,pred) =
-  (* current can occur in pred even if the original problem is not dependent *)
-  let dep =
-    if alreadydep<>Anonymous then alreadydep
-    else if deps = [] && noccurn_predicate 1 pred then Anonymous
-    else Name (id_of_string "x") in
-  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
-  (* There is no dependency in realargs for subpattern *)
-  (k-1, PrLetIn (([],dep), pred))
-
-
-(*****************************************************************************)
-(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
-(*                                                                           *)
-(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
-(*                                                                           *)
-(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
-(* is considered. Assume each Ti is some Ii(argsi).                          *)
-(* We let e=Ci(x1,...,xn) and replace pred by                                *)
-(*                                                                           *)
-(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
-(*                                                                           *)
-(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
-(*                                                                           *)
-(*****************************************************************************)
-let specialize_predicate tomatchs deps cs = function
-  | (PrProd _ | PrCcl _) ->
-      anomaly "specialize_predicate: a matched pattern must be pushed"
-  | PrLetIn ((names,isdep),pred) ->
-      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
-      let nrealargs = List.length names in
-      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
-      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
-      let n = cs.cs_nargs in
-      let pred' = liftn_predicate n (k+1) pred in
-      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
-      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
-      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
-      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
-      let pred'' = subst_predicate (argsi, copti) pred' in
-      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
-      let pred''' = liftn_predicate n (n+1) pred'' in
-      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
-      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
-
-let find_predicate loc env isevars p typs cstrs current
-  (IndType (indf,realargs)) tms =
-  let (dep,pred) =
-    match p with
-      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
-      | None -> infer_predicate loc env isevars typs cstrs indf in
-  let typ = whd_beta (Evd.evars_of !isevars) (applist (pred, realargs)) in
-  if dep then
-    (pred, whd_beta (Evd.evars_of !isevars) (applist (typ, [current])),
-     new_Type ())
-  else
-    (pred, typ, new_Type ())
-
-(************************************************************************)
-(* Sorting equations by constructor *)
-
-type inversion_problem =
-  (* the discriminating arg in some Ind and its order in Ind *)
-  | Incompatible of int * (int * int)
-  | Constraints of (int * constr) list
-
-let solve_constraints constr_info indt =
-  (* TODO *)
-  Constraints []
-
-let rec irrefutable env = function
-  | PatVar (_,name) -> true
-  | PatCstr (_,cstr,args,_) ->
-      let ind = inductive_of_constructor cstr in
-      let (_,mip) = Inductive.lookup_mind_specif env ind in
-      let one_constr = Array.length mip.mind_user_lc = 1 in
-      one_constr & List.for_all (irrefutable env) args
-
-let first_clause_irrefutable env = function
-  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
-  | _ -> false
-
-let group_equations pb ind current cstrs mat =
-  let mat =
-    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
-  let brs = Array.create (Array.length cstrs) [] in
-  let only_default = ref true in
-  let _ =
-    List.fold_right (* To be sure it's from bottom to top *)
-      (fun eqn () ->
-	 let rest = remove_current_pattern eqn in
-	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor pb.env ind cstrs pat with 
-	   | PatVar (_,name) -> 
-	       (* This is a default clause that we expand *)
-	       for i=1 to Array.length cstrs do
-		 let n = cstrs.(i-1).cs_nargs in
-		 let args = make_anonymous_patvars n in
-		 brs.(i-1) <- (args, rest) :: brs.(i-1)
-	       done
-	   | PatCstr (loc,((_,i)),args,_) ->
-	       (* This is a regular clause *)
-	       only_default := false;
-	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
-  (brs,!only_default)
-
-(************************************************************************)
-(* Here starts the pattern-matching compilation algorithm *)
-
-(* Abstracting over dependent subterms to match *)
-let rec generalize_problem pb = function
-  | [] -> pb
-  | i::l ->
-      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
-      let pb' = generalize_problem pb l in
-      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
-      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
-      { pb with
-	  tomatch = Abstract d :: tomatch;
-          pred = Option.map (generalize_predicate i d) pb'.pred }
-
-(* No more patterns: typing the right-hand-side of equations *)
-let build_leaf pb =
-  let 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
-    pb.typing_function tycon rhs.rhs_env rhs.it
-
-(* Building the sub-problem when all patterns are variables *)
-let shift_problem (current,t) pb =
-  {pb with
-     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = Option.map (specialize_predicate_var (current,t)) pb.pred;
-     history = push_history_pattern 0 AliasLeaf pb.history;
-     mat = List.map remove_current_pattern pb.mat }
-
-(* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps pb eqns const_info =
-  (* We remember that we descend through a constructor *)
-  let alias_type =
-    if Array.length const_info.cs_concl_realargs = 0
-      & not (known_dependent pb.pred) & deps = []
-    then
-      NonDepAlias
-    else 
-      DepAlias
-  in
-  let history = 
-    push_history_pattern const_info.cs_nargs
-      (AliasConstructor const_info.cs_cstr)
-      pb.history in
-
-  (* We find matching clauses *)
-  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
-  let names = get_names pb.env cs_args eqns in
-  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
-  if submat = [] then
-    raise_pattern_matching_error
-      (dummy_loc, pb.env, NonExhaustive (complete_history history));
-  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
-  let _,typs',_ =
-    List.fold_right
-      (fun (na,c,t as d) (env,typs,tms) ->
-	 let tm1 = List.map List.hd tms in
-	 let tms = List.map List.tl tms in
- 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
-      typs (pb.env,[],List.map fst eqns) in
-
-  let dep_sign =
-    find_dependencies_signature
-      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
-
-  (* The dependent term to subst in the types of the remaining UnPushed 
-     terms is relative to the current context enriched by topushs *)
-  let ci = build_dependent_constructor const_info in
-
-  (* We replace [(mkRel 1)] by its expansion [ci] *)
-  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
-  (* This is done in two steps : first from "Gamma |- tms" *)
-  (* into  "Gamma; typs; curalias |- tms" *)
-  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
-
-  let currents =
-    list_map2_i
-      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
-      1 typs' (List.rev dep_sign) in
-
-  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
-  let ind =
-    appvect (
-      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
-      List.map (lift const_info.cs_nargs) const_info.cs_params),
-      const_info.cs_concl_realargs) in
-
-  let cur_alias = lift (List.length sign) current in
-  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
-  let env' = push_rels sign pb.env in
-  let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
-    sign,
-  { pb with
-      env = env';
-      tomatch = List.rev_append currents tomatch;
-      pred = pred';
-      history = history;
-      mat = List.map (push_rels_eqn_with_names sign) submat }
-
-(**********************************************************************
- INVARIANT:
-
-  pb = { env, subst, tomatch, mat, ...}
-  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
-
-  "Pushed" terms and types are relative to env
-  "Abstract" types are relative to env enriched by the previous terms to match
-
-*)
-
-(**********************************************************************)
-(* Main compiling descent *)
-let rec compile pb =
-  match pb.tomatch with
-    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
-    | (Alias x)::rest -> compile_alias pb x rest
-    | (Abstract d)::rest -> compile_generalization pb d rest
-    | [] -> build_leaf pb
-
-and match_current pb tomatch =
-  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
-  match typ with
-    | NotInd (_,typ) ->
-	check_all_variables typ pb.mat;
-	compile (shift_problem ct pb)
-    | IsInd (_,(IndType(indf,realargs) as indt)) ->
-	let mind,_ = dest_ind_family indf in
-	let cstrs = get_constructors pb.env indf in
-	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
-	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
-	  compile (shift_problem ct pb)
-	else
-          let _constraints = Array.map (solve_constraints indt) cstrs in
-
-	  (* We generalize over terms depending on current term to match *)
-	  let pb = generalize_problem pb deps in
-
-	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
-
-	  (* We build the (elementary) case analysis *)
-	  let 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 pb.casestyle in
-	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
-	  let inst = List.map mkRel deps in
-	  { 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 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;
-       mat = List.map (push_rels_eqn [d]) pb.mat } in
-  let j = compile pb in
-  { uj_val = mkLambda_or_LetIn d j.uj_val;
-    uj_type = mkProd_or_LetIn d j.uj_type }
-
-and compile_alias pb (deppat,nondeppat,d,t) rest =
-  let history = simplify_history pb.history in
-  let sign, newenv, mat =
-    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
-  let n = List.length sign in
-
-  (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
-  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
-  let tomatch = lift_tomatch_stack n rest in
-  let tomatch = match kind_of_term nondeppat with
-    | Rel i ->
-	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
-	else replace_tomatch i deppat tomatch
-    | _ -> (* initial terms are not dependent *) tomatch in
-
-  let pb =
-    {pb with
-       env = newenv;
-       tomatch = tomatch;
-       pred = Option.map (lift_predicate n) pb.pred;
-       history = history;
-       mat = mat } in
-  let j = compile pb in
-  List.fold_left mkSpecialLetInJudge j sign
-
-(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
-substituer après par les initiaux *)
-
-(**************************************************************************)
-(* Preparation of the pattern-matching problem                            *)
-
-(* builds the matrix of equations testing that each eqn has n patterns
- * and linearizing the _ patterns.
- * Syntactic correctness has already been done in astterm *)
-let matx_of_eqns env eqns =
-  let build_eqn (loc,ids,lpat,rhs) =
-    let rhs =
-      { rhs_env = env;
-	avoid_ids = ids@(ids_of_named_context (named_context env));
-	it = rhs;
-      } in
-    { patterns = lpat;
-      alias_stack = [];
-      eqn_loc = loc;
-      used = ref false;
-      rhs = rhs }
-  in List.map build_eqn eqns
-
-(************************************************************************)
-(* preparing the elimination predicate if any                          *)
-
-let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
-  let cook (n, l, env, signs) = function
-    | c,IsInd (_,IndType(indf,realargs)) ->
-	let indf' = lift_inductive_family n indf in
-	let sign = make_arity_signature env dep indf' in
-	let p = List.length realargs in
-	if dep then
-	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
-	else
-	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
-    | c,NotInd _ ->
-	(n, l, env, []::signs) in
-  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
-  let names = List.rev (List.map (List.map pi1) signs) in
-  let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
-  let rec build_skeleton env c =
-    (* Don't put into normal form, it has effects on the synthesis of evars *)
- (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
-    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
-    if isEvar c or List.exists (eq_constr c) allargs then
-      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
-        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
-    else
-      map_constr_with_full_binders push_rel build_skeleton env c 
-  in
-    names, build_skeleton env (lift n c)
-  
-(* Here, [pred] is assumed to be in the context built from all *)
-(* realargs and terms to match *)
-let build_initial_predicate isdep allnames pred =
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let rec buildrec n pred = function
-    | [] -> PrCcl pred
-    | names::lnames ->
-        let names' = if isdep then List.tl names else names in
-        let n' = n + List.length names' in
-        let pred, p, user_p =
-          if isdep then 
-            if dependent (mkRel (nar-n')) pred then pred, 1, 1
-            else liftn (-1) (nar-n') pred, 0, 1
-          else pred, 0, 0 in
-        let na =
-          if p=1 then
-            let na = List.hd names in
-            if na = Anonymous then
-              (* peut arriver en raison des evars *)
-              Name (id_of_string "x") (*Hum*)
-            else na
-          else Anonymous in
-        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
-  in buildrec 0 pred allnames
-
-let extract_arity_signature env0 tomatchl tmsign =
-  let get_one_sign n tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) -> 
-	  (match t with
-	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) -> 
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-          let indf' = lift_inductive_family n indf in
-	  let (ind,params) = dest_ind_family indf' in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf') in
-	  (na,None,build_dependent_inductive env0 indf')
-	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
-  let rec buildrec n = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign n tm x in
-	l :: buildrec (n + List.length l) (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec 0 (tomatchl,tmsign))
-
-let extract_arity_signatures env0 tomatchl tmsign =
-  let get_one_sign tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) -> 
-	  (match t with
-	    | None -> [na,bo,typ]
-	    | Some (loc,_,_,_) -> 
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-	  let (ind,params) = dest_ind_family indf in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf) in
-	    (na,None,build_dependent_inductive env0 indf)
-	    ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in
-  let rec buildrec = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign tm x in
-	  l :: buildrec (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec (tomatchl,tmsign))
-
-let inh_conv_coerce_to_tycon loc env isevars j tycon =
-  match tycon with
-    | Some p ->
-	let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
-          isevars := evd';
-          j
-    | None -> j
-
-let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
-	       
-let string_of_name name = 
-  match name with
-    | Anonymous -> "anonymous"
-    | Name n -> string_of_id n
-	
-let id_of_name n = id_of_string (string_of_name n)
-
-let make_prime_id name = 
-  let str = string_of_name name in
-    id_of_string str, id_of_string (str ^ "'")
-
-let prime avoid name = 
-  let previd, id = make_prime_id name in
-    previd, next_ident_away_from id avoid
-
-let make_prime avoid prevname =
-  let previd, id = prime !avoid prevname in
-    avoid := id :: !avoid;
-    previd, id
-
-let eq_id avoid id = 
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away_from hid avoid in
-    hid'
-
-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 hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
-
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) -> 
-      (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
-
-let constr_of_pat env isevars arsign pat avoid = 
-  let rec typ env (ty, realargs) pat avoid = 
-    match pat with
-    | PatVar (l,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
-	  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
-	let IndType (indf, _) = find_rectype env (Evd.evars_of !isevars) (lift (-(List.length realargs)) ty) in
-	let ind, params = dest_ind_family indf in
-	if ind <> cind then error_bad_constructor_loc l cstr ind;
-	let cstrs = get_constructors env indf in
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	assert(nb_args_constr = List.length args);
-	let patargs, args, sign, env, n, m, avoid = 
-	  List.fold_right2
-	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
-	       let pat', sign', arg', typ', argtypargs, n', avoid = 
-		 typ env (lift (n - m) t, []) ua avoid 
-	       in
-	       let args' = arg' :: List.map (lift n') args in
-	       let env' = push_rels sign' env in
-		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid))
-	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid)
-	in
-	let args = List.rev args in
-	let patargs = List.rev patargs in
-	let pat' = PatCstr (l, cstr, patargs, alias) in
-	let cstr = mkConstruct ci.cs_cstr in
-	let app = applistc cstr (List.map (lift (List.length sign)) params) in
-	let app = applistc app args in
-	let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in	
-	let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in
-	  match alias with
-	      Anonymous ->
-		pat', sign, app, apptype, realargs, n, avoid
-	    | Name id ->
-		let sign = (alias, None, lift m ty) :: sign in
-		let avoid = id :: avoid in
-		let sign, i, 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;
-		    let eq_t = mk_eq (lift (succ m) ty)
-		      (mkRel 1) (* alias *)
-		      (lift 1 app) (* aliased term *)
-		    in 
-		    let neq = eq_id avoid id in
-		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
-		  with Reduction.NotConvertible -> sign, 1, avoid
-		in
-		  (* Mark the equality as a hole *)
-		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
-  in 
-  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in 
-    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
-
-
-(* shadows functional version *)
-let eq_id avoid id = 
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away_from hid !avoid in
-    avoid := hid' :: !avoid;
-    hid'
-
-let rels_of_patsign = 
-  List.map (fun ((na, b, t) as x) -> 
-    match b with 
-      | Some t' when kind_of_term t' = Rel 0 -> (na, None, t)
-      | _ -> x)
-
-let vars_of_ctx ctx = 
-  let _, y =
-    List.fold_right (fun (na, b, t)  (prev, vars) -> 
-      match b with 
-	| Some t' when kind_of_term t' = Rel 0 -> 
-	    prev, 
-	    (RApp (dummy_loc, 
-		(RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
-	| _ ->
-	    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", [])
-  in List.rev y
-
-let rec is_included x y = 
-  match x, y with
-    | PatVar _, _ -> true
-    | _, PatVar _ -> true
-    | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias')  ->
-	if i = i' then List.for_all2 is_included args args'
-	else false
-
-(* 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
-	    (* 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
-		| Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *)
-		    if is_included curpat ppat then
-		      (* Length of previous pattern's signature *)
-		      let lens = List.length ppat_sign in
-		      (* Accumulated length of previous pattern's signatures *)
-		      let len' = lens + len in
-		      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 (len' + liftsign) curpat_ty;
-				   liftn (len + liftsign) (succ lens) ppat_c ;
-				   lift len' curpat_c |]) :: 
-			    List.map (lift lens (* Jump over this prevpat signature *)) c)
-		      in Some acc
-		    else None)
-	   (Some ([], 0, 0, [])) eqnpats pats
-	 in match acc with 
-	     None -> c
-	   | Some (sign, len, _, c') ->
-	       let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) 
-		 (lift_rel_context liftsign sign) 
-	       in
-		 conj :: c)
-      [] prevpatterns
-  in match diffs with [] -> None
-    | _ -> Some (mk_conj diffs)
-	
-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))
-      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,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-  liftrec (rel_context_length sign + k) sign
-
-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
-      (fun (branches, eqns, prevpatterns) eqn ->
-	 let _, newpatterns, pats = 
-	   List.fold_left2
-	     (fun (idents, newpatterns, pats) pat arsign -> 
-		let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in
-		  (idents, pat' :: newpatterns, cpat :: pats))
-	      ([], [], []) eqn.patterns sign
-	 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 *)
-	       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) 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
-	 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
-	 let arity =
-	   let args, nargs = 
-	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
-	       (args @ c :: allargs, List.length args + succ n))
-	       pats ([], 0)
-	   in
-	   let args = List.rev args in
-	     substl args (liftn signlen (succ nargs) arity)
-	 in
-	 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
-	 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
-	 let branch = 
-	   let bref = RVar (dummy_loc, branch_name) in
-	     match vars_of_ctx rhs_rels with
-		 [] -> bref
-	       | l -> RApp (dummy_loc, bref, l)
-	 in
-	 let branch = match ineqs with
-	     Some _ -> RApp (dummy_loc, branch, [ hole ])
-	   | None -> branch
-	 in
-	 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
-
-(* Builds the predicate. If the predicate is dependent, its context is
- * made of 1+nrealargs assumptions for each matched term in an inductive
- * type and 1 assumption for each term not _syntactically_ in an
- * inductive type.
-
- * Each matched terms are independently considered dependent or not.
-
- * A type constraint but no annotation case: it is assumed non dependent.
- *)
-  
-let lift_ctx n ctx = 
-  let ctx', _ =
-    List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
-  in ctx'
-
-(* Turn matched terms into variables. *)
-let abstract_tomatch env tomatchs =
-  let prev, ctx, names = 
-    List.fold_left
-      (fun (prev, ctx, names) (c, t) ->
-	 let lenctx =  List.length ctx in
-	 match kind_of_term c with
-	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names
-	   | _ -> 
-	       let name = next_ident_away_from (id_of_string "filtered_var") names in
-		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, 
-	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, 
-	       name :: names)
-      ([], [], []) tomatchs
-  in List.rev prev, ctx
-    
-let is_dependent_ind = function
-    IsInd (_, IndType (indf, args)) when List.length args > 0 -> true
-  | _ -> false
-
-let build_dependent_signature env evars avoid tomatchs arsign =
-  let avoid = ref avoid in
-  let arsign = List.rev arsign in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let eqs, neqs, refls, slift, arsign' = 
-    List.fold_left2 
-      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> 
-	 (* The accumulator:
-	    previous eqs, 
-	    number of previous eqs, 
-	    lift to get outside eqs and in the introduced variables ('as' and 'in'), 
-	    new arity signatures
-	 *)
-	 match ty with
-	     IsInd (ty, IndType (indf, args)) when List.length args > 0 ->
-	       (* 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 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) ->
-		      let argt = Retyping.get_type_of env evars arg in
-		      let eq, refl_arg = 
-			if Reductionops.is_conv env evars argt t then
-			  (mk_eq (lift (nargeqs + slift) argt)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) arg),
-			   mk_eq_refl argt arg)
-			else
-			  (mk_JMeq (lift (nargeqs + slift) t)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) argt)
-			     (lift (nargeqs + nar) arg),
-			   mk_JMeq_refl argt arg)
-		      in
-		      let previd, id = 
-			let name = 
-			  match kind_of_term arg with 
-			      Rel n -> pi1 (Environ.lookup_rel n env)
-			    | _ -> name
-			in
-			  make_prime avoid name 
-		      in
-			(env, succ nargeqs, 
-			 (Name (eq_id avoid previd), None, eq) :: argeqs, 
-			 refl_arg :: refl_args,
-			 pred slift,
-			 (Name id, b, t) :: argsign'))
-		   (env, 0, [], [], slift, []) args argsign
-	       in
-	       let eq = mk_JMeq 
-		 (lift (nargeqs + slift) appt)
-		 (mkRel (nargeqs + slift))
-		 (lift (nargeqs + nar) ty) 
-		 (lift (nargeqs + nar) tm) 
-	       in
-	       let refl_eq = mk_JMeq_refl ty tm in
-	       let previd, id = make_prime avoid appn in
-		 (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, 
-		 succ nargeqs, 
-		 refl_eq :: refl_args,
-		 pred slift, 
-		 (((Name id, appb, appt) :: argsign') :: arsigns))
-		   
-	   | _ -> 
-	       (* Non dependent inductive or not inductive, just use a regular equality *)
-	       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 tomatch_ty = type_of_tomatch ty in
-	       let eq = 
-		 mk_eq (lift nar tomatch_ty)
-		   (mkRel slift) (lift nar tm)
-	       in
-		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, 
-		  (mk_eq_refl tomatch_ty tm) :: refl_args,
-		  pred slift, (arsign' :: []) :: arsigns))
-      ([], 0, [], nar, []) tomatchs arsign
-  in 
-  let arsign'' = List.rev arsign' in
-    assert(slift = 0); (* we must have folded over all elements of the arity signature *)
-    arsign'', allnames, nar, eqs, neqs, refls
-
-(**************************************************************************)
-(* Main entry of the matching compilation                                 *)
-  
-let liftn_rel_context n k sign =  
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-    liftrec (k + rel_context_length sign) sign
-
-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'
-  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')
-     ~init:env' env
-      
-(* 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 prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
-  (* We extract the signature of the arity *)
-  let arsign = extract_arity_signature env tomatchs sign in
-  let newenv = List.fold_right push_rels arsign env in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-    match rtntyp with
-      | Some rtntyp ->
-	  let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in
-	  let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
-	    Some (build_initial_predicate true allnames predccl)
-      | None -> 
-	  match valcon_of_tycon tycon with
-	    | Some ty -> 
-		let pred = 
-		  prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars) tomatchs arsign ty
-		in Some (build_initial_predicate true allnames pred)
-	    | None -> None
-
-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
-  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. *)
-	let avoid = [] in
-	  build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign
-
-      in
-      let tycon, arity = 
-	match valcon_of_tycon tycon with
-	| 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 neqs, arity = 
-	let ctx = context_of_arsign eqs in
-	let neqs = List.length ctx in
-	  neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
-      in
-      let lets, matx = 
-	(* Type the rhs under the assumption of equations *)
-	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 pred = liftn len (succ signlen) arity in
-      let pred = 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) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-	
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = Some pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } 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 = nf_isevar !isevars tycon; }
-	in j
-    else
-      (* We build the elimination predicate if any and check its consistency *)
-      (* with the type of arguments to match *)
-      let tmsign = List.map snd tomatchl in
-      let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in
-
-      (* We push the initial terms to match and push their alias to rhs' envs *)
-      (* names of aliases will be recovered from patterns (hence Anonymous here) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } in
-	
-      let j = compile pb in
-	(* We check for unused patterns *)
-	List.iter (check_unused_pattern env) matx;
-	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
deleted file mode 100644
index 6b8a0981..00000000
--- a/contrib/subtac/subtac_cases.mli
+++ /dev/null
@@ -1,23 +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        *)
-(************************************************************************)
-
-(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
-
-(*i*)
-open Util
-open Names
-open Term
-open Evd
-open Environ
-open Inductiveops
-open Rawterm
-open Evarutil
-(*i*)
-
-(*s Compilation of pattern-matching, subtac style. *)
-module Cases_F(C : Coercion.S) : Cases.S
diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml
deleted file mode 100644
index 9b692d85..00000000
--- a/contrib/subtac/subtac_classes.ml
+++ /dev/null
@@ -1,194 +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        *)
-(************************************************************************)
-
-(*i $Id: subtac_classes.ml 12187 2009-06-13 19:36:59Z 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' = substl subst t in
-      let c = interp_casted_constr_evars isevars env ce t' in
-      isevars := resolve_typeclasses ~onlyargs:true ~fail:true env !isevars;
-      let d = na, Some c, t' in
-	c :: subst, d :: instctx)
-    (subst, []) (List.rev ctx) inst
-
-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 = 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 ?(generalize=true) pri =
-  let env = Global.env() in
-  let isevars = ref (Evd.create_evar_defs Evd.empty) in
-  let tclass =
-    match bk with
-    | Implicit ->
-	Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
-	  ~allow_partial:false (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)
-		  else CHole (Util.dummy_loc, None)
-		in t, avoid
-	    | None -> failwith ("new instance: under-applied typeclass"))
-	  cl
-      | Explicit -> cl
-  in
-  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass 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 = Sign.decompose_prod_assum c' in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in
-      cl, ctx, imps, (List.rev 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' = push_rel_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 subst = List.map (Evarutil.nf_evar sigma) subst in
-  let subst = 
-    let props = 
-      match props with
-      | CRecord (loc, _, fs) -> 
-	  if List.length fs > List.length k.cl_props then 
-	    Classes.mismatched_props env' (List.map snd fs) k.cl_props;
-	  fs
-      | _ -> 
-	  if List.length k.cl_props <> 1 then 
-	    errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body")
-	  else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props]
-    in
-      match k.cl_props with 
-      | [(na,b,ty)] -> 
-	  let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in
-	  let ty' = substl subst ty in
-	  let c = interp_casted_constr_evars isevars env' term ty' in
-	    c :: subst
-      | _ ->
-	  let props, rest = 
-	    List.fold_left
-	      (fun (props, rest) (id,_,_) -> 
-		try 
-		  let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in
-		  let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in
-		    Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (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
-	      fst (type_ctx_instance isevars env' k.cl_props props subst)
-  in
-  let subst = List.fold_left2 
-    (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-    [] subst (k.cl_props @ snd k.cl_context)
-  in
-  let inst_constr, ty_constr = instance_constructor k subst in
-  isevars := Evarutil.nf_evar_defs !isevars;
-  let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx')
-  and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') 
-  in
-    isevars := undefined_evars !isevars;
-    Evarutil.check_evars env Evd.empty !isevars termtype;
-    let hook vis 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 ~enriching: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
-      id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls
-	
diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli
deleted file mode 100644
index 96a51027..00000000
--- a/contrib/subtac/subtac_classes.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        *)
-(************************************************************************)
-
-(*i $Id: subtac_classes.mli 11709 2008-12-20 11:42:15Z 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 ->
-    ('a * Term.constr option * Term.constr) list ->
-    Topconstr.constr_expr list ->
-    Term.constr list ->
-    Term.constr list *
-    ('a * Term.constr option * Term.constr) list
-
-val new_instance : 
-  ?global:bool ->
-  local_binder list ->
-  typeclass_constraint ->
-  constr_expr ->
-  ?generalize:bool ->
-  int option ->
-  identifier * Subtac_obligations.progress
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
deleted file mode 100644
index 1bbbfbb1..00000000
--- a/contrib/subtac/subtac_coercion.ml
+++ /dev/null
@@ -1,504 +0,0 @@
-(* -*- 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 *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(* $Id: subtac_coercion.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
-
-open Util
-open Names
-open Term
-open Reductionops
-open Environ
-open Typeops
-open Pretype_errors
-open Classops
-open Recordops
-open Evarutil
-open Evarconv
-open Retyping
-open Evd
-
-open Global
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-open Pp
-
-let pair_of_array a = (a.(0), a.(1))
-let make_name s = Name (id_of_string s)
-
-let rec disc_subset x = 
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Ind i ->
-	let len = Array.length l in
-	let sig_ = Lazy.force sig_ in
-	  if len = 2 && i = Term.destInd sig_.typ
-	  then
-	    let (a, b) = pair_of_array l in
-	      Some (a, b)
-	  else None
-      | _ -> None)
-  | _ -> None
-      
-and disc_exist env x =
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Construct c ->	       
-	if c = Term.destConstruct (Lazy.force sig_).intro
-	then Some (l.(0), l.(1), l.(2), l.(3))
-	else None
-      | _ -> None)
-  | _ -> None
-      
-module Coercion = struct
-    
-  exception NoSubtacCoercion
-    
-  let disc_proj_exist env x =
-    match kind_of_term x with
-      | App (c, l) ->
-	  (if Term.eq_constr c (Lazy.force sig_).proj1 
-	     && Array.length l = 3 
-	   then disc_exist env l.(2)
-	   else None)
-      | _ -> None
-
-
-  let sort_rel s1 s2 = 
-    match s1, s2 with
-	Prop Pos, Prop Pos -> Prop Pos
-      | Prop Pos, Prop Null -> Prop Null
-      | Prop Null, Prop Null -> Prop Null
-      | Prop Null, Prop Pos -> Prop Pos
-      | Type _, Prop Pos -> Prop Pos
-      | Type _, Prop Null -> Prop Null
-      | _, Type _ -> s2
-
-  let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c
-
-  let lift_args n sign =
-    let rec liftrec k = function
-      | t::sign -> liftn n k t :: (liftrec (k-1) sign)
-      | [] -> []
-    in
-      liftrec (List.length sign) sign
-
-  let rec mu env isevars t =   
-    let isevars = ref isevars in
-    let rec aux v = 
-      let v = hnf env isevars v in
-      match disc_subset v with
-	  Some (u, p) -> 
-	    let f, ct = aux u in
-	      (Some (fun x ->		   
-		       app_opt f (mkApp ((Lazy.force sig_).proj1, 
-					 [| u; p; x |]))),
-	       ct)
-	| None -> (None, v)
-    in aux t
-
-  and coerce loc env isevars (x : Term.constr) (y : Term.constr) 
-      : (Term.constr -> Term.constr) option 
-      =
-    let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in
-    let rec coerce_unify env x y =
-      let x = hnf env isevars x and y = hnf env isevars y in
-	try 
-	  isevars := the_conv_x_leq env x y !isevars;
-	  None
-	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 dest_prod c =
-	match Reductionops.decomp_n_prod env (evars_of !isevars) 1 c with
-	| [(na,b,t)], c -> (na,t), c
-	| _ -> raise NoSubtacCoercion
-      in
-      let rec coerce_application typ typ' c c' l l' =
-	let len = Array.length l in
-	let rec aux tele typ typ' i co = 
-	  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 = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod typ' in
-		aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
-	      with Reduction.NotConvertible ->
-		let (n, eqT), restT = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod 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 evar = make_existential loc env isevars eq in
-		let eq_app x = mkApp (Lazy.force eq_rect,
-				      [| eqT; hdx; pred; x; hdy; evar|]) in
-		  aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
-	  else Some co
-	in 
-	  if isEvar c || isEvar c' then
-	    (* Second-order unification needed. *)
-	    raise NoSubtacCoercion;
-	  aux [] typ typ' 0 (fun x -> x)
-      in
-	match (kind_of_term x, kind_of_term y) with
-	  | Sort s, Sort s' -> 
-	      (match s, s' with
-		   Prop x, Prop y when x = y -> None
-		 | Prop _, Type _ -> None
-		 | Type x, Type y when x = y -> None (* false *)
-		 | _ -> subco ())
-	  | 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
-		(* 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, [| coec1 |])))))
-		  
-	  | App (c, l), App (c', l') ->
-	      (match kind_of_term c, kind_of_term c' with
-		   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 
-			 if i = Term.destInd existS.typ 
-			 then
-			   begin 
-			     let (a, pb), (a', pb') = 
-			       pair_of_array l, pair_of_array l' 
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let rec remove_head a c = 
-			       match kind_of_term c with 
-				 | Lambda (n, t, t') -> c, t'
-				     (*| Prod (n, t, t') -> t'*)
-				 | Evar (k, args) ->
-				     let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in
-				       isevars := evs;
-				       let (n, dom, rng) = destLambda t in
-				       let (domk, args) = destEvar dom in
-					 isevars := evar_define domk a !isevars;
-					 t, rng
-				 | _ -> raise NoSubtacCoercion
-			     in
-			     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
-			     let env' = push_rel (make_name "x", None, a) env in
-			     let c2 = coerce_unify env' b b' in
-			       match c1, c2 with
-				   None, None -> 
-				     None
-				 | _, _ ->
-				     Some 
-				       (fun x ->
-					  let x, y = 
-					    app_opt c1 (mkApp (existS.proj1,
-							       [| a; pb; x |])),
-					    app_opt c2 (mkApp (existS.proj2, 
-							       [| a; pb; x |]))
-					  in
-					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
-			   end
-			 else 
-			   begin 
-			     let (a, b), (a', b') = 
-			       pair_of_array l, pair_of_array l' 
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let c2 = coerce_unify env b b' in
-			       match c1, c2 with
-				   None, None -> None
-				 | _, _ ->
-				     Some 
-				       (fun x ->
-					  let x, y = 
-					    app_opt c1 (mkApp (prod.proj1,
-							       [| a; b; x |])),
-					    app_opt c2 (mkApp (prod.proj2, 
-							       [| a; b; x |]))
-					  in
-					    mkApp (prod.intro, [| a'; b'; x ; y |]))
-			   end
-		       else
-			 if i = i' && len = Array.length l' then
-			   let evm = evars_of !isevars in
-			     (try 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 ( *)
-			 coerce_application lam_type lam_type' c c' l l'
-(* 			 ) else subco () *)
-		     else subco ()
-		 | _ -> subco ())
-	  | _, _ ->  subco ()
-
-    and subset_coerce env isevars x y =
-      match disc_subset x with
-	  Some (u, p) -> 
-	    let c = coerce_unify env u y in
-	    let f x = 
-	      app_opt c (mkApp ((Lazy.force sig_).proj1, 
-				[| u; p; x |]))
-	    in Some f
-	| None ->
-	    match disc_subset y with
-		Some (u, p) ->
-		  let c = coerce_unify env x u in
-		    Some 
-		      (fun x ->
-			 let cx = app_opt c x in
-			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
-			 in
-			   (mkApp 
-			      ((Lazy.force sig_).intro, 
-			       [| u; p; cx; evar |])))
-	      | None -> 
-		  raise NoSubtacCoercion
-		    (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
-		  None*)
-    in coerce_unify env x y
-
-  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
-	
-  (* Taken from pretyping/coercion.ml *)
-
-  (* Typing operations dealing with coercions *)
-
-  (* Here, funj is a coercion therefore already typed in global context *)
-  let apply_coercion_args env argl funj =
-    let rec apply_rec acc typ = function
-      | [] -> { uj_val = applist (j_val funj,argl);
-		uj_type = typ }
-      | h::restl ->
-	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
-  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) -> 
-		(* Typage garanti par l'appel à app_coercion*)
-		apply_rec (h::acc) (subst1 h c2) restl
-	    | _ -> anomaly "apply_coercion_args"
-    in 
-      apply_rec [] funj.uj_type argl
-
-  (* appliquer le chemin de coercions de patterns p *)
-  exception NoCoercion
-
-  let apply_pattern_coercion loc pat p =
-    List.fold_left
-      (fun pat (co,n) ->
-	 let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
-	   Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
-      pat p
-
-  (* raise Not_found if no coercion found *)
-  let inh_pattern_coerce_to loc pat ind1 ind2 =
-    let p = lookup_pattern_path_between (ind1,ind2) in
-      apply_pattern_coercion loc pat p
-
-  (* appliquer le chemin de coercions p à hj *)
-
-  let apply_coercion env sigma p hj typ_cl =
-    try 
-      fst (List.fold_left
-             (fun (ja,typ_cl) i -> 
-		let fv,isid = coercion_value i in
-		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
-		let jres = apply_coercion_args env argl fv in
-		  (if isid then 
-		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else 
-		     jres),
-		jres.uj_type)
-             (hj,typ_cl) p)
-    with _ -> anomaly "apply_coercion"
-
-  let inh_app_fun env isevars j = 
-    let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
-      match kind_of_term t with
-	| Prod (_,_,_) -> (isevars,j)
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',t) = define_evar_as_product isevars ev in
-	      (isevars',{ uj_val = j.uj_val; uj_type = t })
-	| _ ->
-       	    (try
-      	       let t,p =
-		 lookup_path_to_fun_from env (evars_of isevars) j.uj_type in
-		 (isevars,apply_coercion env (evars_of isevars) p j t)
-	     with Not_found ->
-	       try 
-		 let coercef, t = mu env isevars t in
-		   (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
-	       with NoSubtacCoercion | NoCoercion ->
-		 (isevars,j))
-
-  let inh_tosort_force loc env isevars j =
-    try
-      let t,p = lookup_path_to_sort_from env (evars_of isevars) j.uj_type in
-      let j1 = apply_coercion env (evars_of isevars) p j t in 
-	(isevars,type_judgment env (j_nf_evar (evars_of isevars) j1))
-    with Not_found ->
-      error_not_a_type_loc loc env (evars_of isevars) j
-
-  let inh_coerce_to_sort loc env isevars j =
-    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
-      match kind_of_term typ with
-	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',s) = define_evar_as_sort isevars ev in
-	      (isevars',{ utj_val = j.uj_val; utj_type = s })
-	| _ ->
-	    inh_tosort_force loc env isevars j
-
-  let inh_coerce_to_base loc env isevars j =
-    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
-    let ct, typ' = mu env isevars typ in
-      isevars, { uj_val = app_opt ct j.uj_val; 
-		 uj_type = typ' }
-
-  let inh_coerce_to_prod loc env isevars t =
-    let typ = whd_betadeltaiota env (evars_of isevars) (snd t) in
-    let _, typ' = mu env isevars typ in
-      isevars, (fst t, typ')
-	
-  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 t2,t1,p = lookup_path_between env (evars_of evd) (t,c1) in
-	  match v with
-	      Some v -> 
-		let j = apply_coercion env (evars_of evd) p
-		  {uj_val = v; uj_type = t} t2 in
-		  Some j.uj_val, j.uj_type
-	    | None -> None, t
-      with Not_found -> raise NoCoercion 
-    in
-      try (the_conv_x_leq env t' c1 evd, v')
-      with Reduction.NotConvertible -> raise NoCoercion
-
-
-  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 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_gen rigidonly loc env evd cj ((n, t) as _tycon) =
-    let evd = nf_evar_defs evd in
-    match n with
-	None ->
-	  let (evd', val') = 
-	    try 
-	      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 evd in
-		try
-		  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) ->
-	  (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) =
-    let nabsinit, nabs =
-      match abs with
-	  None -> 0, 0
-	| Some (init, cur) -> init, cur
-    in
-      try 
-	let rels, rng = Reductionops.decomp_n_prod env (evars_of isevars) 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 1 (succ nabs) rng then (
-	  let env', t, t' =
-	    let env' = push_rel_context rels env in
-	      env', rng, lift nabs t'
-	  in
-	    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')
-	    with NoSubtacCoercion ->
-	      let sigma = evars_of isevars in
-		error_cannot_coerce env' sigma (t, t'))
-	else isevars
-      with _ -> isevars
-end
diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli
deleted file mode 100644
index 5678c10e..00000000
--- a/contrib/subtac/subtac_coercion.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open Term
-val disc_subset : types -> (types * types) option
-
-module Coercion : Coercion.S
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
deleted file mode 100644
index c8c7ff72..00000000
--- a/contrib/subtac/subtac_command.ml
+++ /dev/null
@@ -1,466 +0,0 @@
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Dyn
-open Libobject
-open Pattern
-open Matching
-open Pp
-open Rawterm
-open Sign
-open Tacred
-open Util
-open Names
-open Nameops
-open Libnames
-open Nametab
-open Pfedit
-open Proof_type
-open Refiner
-open Tacmach
-open Tactic_debug
-open Topconstr
-open Term
-open Termops
-open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
-open Genarg
-open Decl_kinds
-open Mod_subst
-open Printer
-open Inductiveops
-open Syntax_def
-open Environ
-open Tactics
-open Tacticals
-open Tacinterp
-open Vernacexpr
-open Notation
-open Evd
-open Evarutil
-
-module SPretyping = Subtac_pretyping.Pretyping
-open Subtac_utils
-open Pretyping
-open Subtac_obligations
-
-(*********************************************************************)
-(* Functions to parse and interpret constructions *)
-
-let evar_nf isevars c =
-  isevars := Evarutil.nf_evar_defs !isevars;
-  Evarutil.nf_isevar !isevars c
-
-let interp_gen kind isevars env 
-               ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
-               c =
-  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_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
-  let c' = SPretyping.pretype_gen isevars env ([], []) (OfType None) c in
-    evar_nf isevars c'
-
-let interp_constr_judgment isevars env c =
-  let j = 
-    SPretyping.understand_judgment_tcc isevars env
-      (Constrintern.intern_constr (Evd.evars_of !isevars) env c) 
-  in
-    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
-
-let locate_if_isevar loc na = function
-  | RHole _ -> 
-      (try match na with
-	| Name id ->  Reserve.find_reserved_type id
-	| Anonymous -> raise Not_found 
-      with Not_found -> RHole (loc, Evd.BinderType na))
-  | x -> x
-
-let interp_binder sigma env na t =
-  let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in
-    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 false (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 *)
-
-let list_chop_hd i l = match list_chop i l with
-  | (l1,x::l2) -> (l1,x,l2)
-  | (x :: [], l2) -> ([], x, [])
-  | _ -> assert(false)
-
-let collect_non_rec env = 
-  let rec searchrec lnonrec lnamerec ldefrec larrec nrec = 
-    try
-      let i = 
-        list_try_find_i
-          (fun i f ->
-             if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
-             then i else failwith "try_find_i")
-          0 lnamerec 
-      in
-      let (lf1,f,lf2) = list_chop_hd i lnamerec in
-      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
-      let (lar1,ar,lar2) = list_chop_hd i larrec in
-      let newlnv = 
-	try 
-	  match list_chop i nrec with 
-            | (lnv1,_::lnv2) -> (lnv1@lnv2)
-	    | _ -> [] (* nrec=[] for cofixpoints *)
-        with Failure "list_chop" -> []
-      in 
-      searchrec ((f,def,ar)::lnonrec) 
-	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
-    with Failure "try_find_i" -> 
-      (List.rev lnonrec,
-       (Array.of_list lnamerec, Array.of_list ldefrec,
-        Array.of_list larrec, Array.of_list nrec))
-  in 
-  searchrec [] 
-
-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, 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
-    | [] -> []
-  in aux n l
-
-let rec gen_rels = function
-    0 -> []
-  | n -> mkRel n :: gen_rels (pred n)
-
-let split_args n rel = match list_chop ((List.length rel) - n) rel with
-    (l1, x :: l2) -> l1, x, l2
-  | _ -> assert(false)
-
-let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
-  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 pr c = my_print_constr env c in
-  let prr = Printer.pr_rel_context env in
-  let _prn = Printer.pr_named_context env in
-  let _pr_rel env = Printer.pr_rel_context env in
-(*   let _ =  *)
-(*     try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++  *)
-(* 		 Ppconstr.pr_binders bl ++ str " : " ++  *)
-(* 		 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ *)
-(* 		 Ppconstr.pr_constr_expr body) *)
-(*     with _ -> () *)
-    (*   in *)
-  let (env', binders_rel), 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
-  let envwf = push_rel_context before env in
-  let wf_rel, wf_rel_fun, measure_fn = 
-    let rconstr_body, rconstr = 
-      let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in
-       let env = push_rel_context [arg] envwf in
-       let capp = interp_constr isevars env app in
- 	 capp, mkLambda (argname, argtyp, capp)
-     in
-      trace (str"rconstr_body: " ++ pr rconstr_body);
-       if measure then
- 	let lt_rel = constr_of_global (Lazy.force lt_ref) in
- 	let name s = Name (id_of_string s) in
- 	let wf_rel_fun lift x y = (* lift to before_env *)
-	  trace (str"lifter rconstr_body:" ++ pr (liftn lift 2 rconstr_body));
- 	  mkApp (lt_rel, [| subst1 x (liftn lift 2 rconstr_body); 
- 			    subst1 y (liftn lift 2 rconstr_body) |])
-	in
- 	let wf_rel = 
- 	  mkLambda (name "x", argtyp,
- 		    mkLambda (name "y", lift 1 argtyp,
- 			      wf_rel_fun 0 (mkRel 2) (mkRel 1)))
- 	in
- 	  wf_rel, wf_rel_fun , Some rconstr
-       else rconstr, (fun lift x y -> mkApp (rconstr, [|x; y|])), None
-  in
-  let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |])
-  in
-  let argid' = id_of_string (string_of_id argid ^ "'") in
-  let wfarg len = (Name argid', None,
-  		   mkSubset (Name argid') (lift len argtyp) 
-		     (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1))))
-  in
-  let top_bl = after @ (arg :: before) in
-  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 proj = (Lazy.force sig_).Coqlib.proj1 in
-  let projection = 
-    mkApp (proj, [| argtyp ;
-		    (mkLambda (Name argid', argtyp,
-			       (wf_rel_fun 1 (mkRel 1) (mkRel 3)))) ;
-		    mkRel 1
-		 |])
-  in
-  let intern_arity = it_mkProd_or_LetIn top_arity after in
-  (* 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_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
-  let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in
-  let fun_env = push_rel_context fun_bl intern_before_env 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 _ =
-    try trace ((* str "Fun bl: " ++ prr fun_bl ++ spc () ++ *)
-		 str "Intern bl" ++ prr intern_bl ++ spc ())
-(* 		 str "Top bl" ++ prr top_bl ++ spc () ++ *)
-(* 		 str "Intern arity: " ++ pr intern_arity ++ *)
-(* 		 str "Top arity: " ++ pr top_arity ++ spc () ++ *)
-(* 		   str "Intern body " ++ pr intern_body_lam) *)
-    with _ -> ()
-  in
-  let 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_global (Lazy.force fix_sub_ref), 
-		 [| argtyp ;
-		    wf_rel ;
-		    make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
-		    lift lift_cst prop ;
-		    lift lift_cst intern_body_lam |])
-      | Some f ->
-	  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 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 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
-    
-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 check_evars env initial_sigma evd c =
-  let sigma = evars_of evd in
-  let c = nf_evar sigma c in
-  let rec proc_rec c =
-    match kind_of_term c with
-      | Evar (evk,args) ->
-          assert (Evd.mem sigma evk);
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk evd in
-	      (match k with
-	      | QuestionMark _ -> ()
-	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
-		    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
-let interp_recursive fixkind l boxed =
-  let env = Global.env() in
-  let fixl, ntnl = List.split l in
-  let kind = if fixkind <> Command.IsCoFixpoint then Fixpoint else CoFixpoint 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
-  let env_rec = push_named_context rec_sign env in
-
-  (* Get interpretation metadatas *)
-  let impls = Command.compute_interning_datas env Constrintern.Recursive [] 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_state_protection (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;
-  Command.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
-  let evm = Evd.evars_of isevars in
-  (* Solve remaining evars *)
-  let rec collect_evars id def typ imps = 
-      (* 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 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 = 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 -> 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
deleted file mode 100644
index 3a6a351b..00000000
--- a/contrib/subtac/subtac_command.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-open Pretyping
-open Evd
-open Environ
-open Term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-
-val interp_gen :
-  typing_constraint ->
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  ?allow_patvar:bool ->
-  ?ltacvars:ltac_sign ->
-  constr_expr -> constr
-val interp_constr :
-  evar_defs ref ->
-  env -> constr_expr -> constr
-val interp_type_evars :
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  constr_expr -> constr
-val interp_casted_constr_evars :
-  evar_defs ref ->
-  env ->
-  ?impls:full_implicits_env ->
-  constr_expr -> types -> constr
-val interp_open_constr :
-  evar_defs ref -> env -> constr_expr -> constr
-val interp_constr_judgment :
-  evar_defs ref ->
-  env ->
-  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_errors.ml b/contrib/subtac/subtac_errors.ml
deleted file mode 100644
index 3bbfe22b..00000000
--- a/contrib/subtac/subtac_errors.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Util
-open Pp
-open Printer
-
-type term_pp = Pp.std_ppcmds
-
-type subtyping_error = 
-  | UncoercibleInferType of loc * term_pp * term_pp
-  | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-
-type typing_error = 
-  | NonFunctionalApp of loc * term_pp * term_pp * term_pp
-  | NonConvertible of loc * term_pp * term_pp
-  | NonSigma of loc * term_pp
-  | IllSorted of loc * term_pp
-
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-  
-exception Debug_msg of string
-
-let typing_error e = raise (Typing_error e)
-let subtyping_error e = raise (Subtyping_error e)
diff --git a/contrib/subtac/subtac_errors.mli b/contrib/subtac/subtac_errors.mli
deleted file mode 100644
index 8d75b9c0..00000000
--- a/contrib/subtac/subtac_errors.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-type term_pp = Pp.std_ppcmds
-type subtyping_error =
-    UncoercibleInferType of Util.loc * term_pp * term_pp
-  | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-type typing_error =
-    NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp
-  | NonConvertible of Util.loc * term_pp * term_pp
-  | NonSigma of Util.loc * term_pp
-  | IllSorted of Util.loc * term_pp
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-exception Debug_msg of string
-val typing_error : typing_error -> 'a
-val subtyping_error : subtyping_error -> 'a
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
deleted file mode 100644
index 3dcd43d2..00000000
--- a/contrib/subtac/subtac_obligations.ml
+++ /dev/null
@@ -1,596 +0,0 @@
-(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
-open Printf
-open Pp
-open Subtac_utils
-open Command
-open Environ
-
-open Term
-open Names
-open Libnames
-open Summary
-open Libobject
-open Entries
-open Decl_kinds
-open Util
-open Evd
-open Declare
-open Proof_type
-
-let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
-let pperror cmd = Util.errorlabstrm "Program" cmd
-let error s = pperror (str s)
-
-exception NoObligations of identifier option
-
-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 * loc * obligation_definition_status * Intset.t
-			 * Tacexpr.raw_tactic_expr option) array
-  
-type obligation =
-    { obl_name : identifier;
-      obl_type : types;
-      obl_location : loc;
-      obl_body : constr option;
-      obl_status : obligation_definition_status;
-      obl_deps : Intset.t;
-      obl_tac : Tacexpr.raw_tactic_expr option;
-    }
-
-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_fixkind : Command.fixpoint_kind option ;
-  prg_implicits : (Topconstr.explicitation * (bool * bool)) list;
-  prg_notations : notations ;
-  prg_kind : definition_kind;
-  prg_hook : Tacexpr.declaration_hook;
-}
-
-let assumption_message id =
-  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 (Tacexpr.TacId [])
-
-let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t
-
-(* 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 get_obligation_body expand obl =
-  let c = Option.get obl.obl_body in
-    if expand && obl.obl_status = Expand then 
-      match kind_of_term c with
-      | Const c -> constant_value (Global.env ()) c
-      | _ -> c
-    else c
-
-let subst_deps expand obls deps t =
-  let subst =
-    Intset.fold
-      (fun x acc ->
-	let xobl = obls.(x) in
-	let oblb = 
-	  try get_obligation_body expand xobl
-	  with _ -> assert(false)
-	in (xobl.obl_name, oblb) :: acc)
-      deps []
-  in(*  Termops.it_mkNamedProd_or_LetIn t subst *)
-    Term.replace_vars subst t
-    
-let subst_deps_obl obls obl =
-  let t' = subst_deps false obls obl.obl_deps obl.obl_type in
-    { obl with obl_type = t' }
-
-module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
-
-let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
-
-let map_cardinal m = 
-  let i = ref 0 in 
-    ProgMap.iter (fun _ _ -> incr i) m;
-    !i
-
-exception Found of program_info
-
-let map_first m = 
-  try
-    ProgMap.iter (fun _ v -> raise (Found v)) m;
-    assert(false)
-  with Found x -> x
-    
-let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
-
-let 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.tactics_call "obligation_tactic" [])
-
-let _ = 
-  Summary.declare_summary "program-tcc-table"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
-
-let progmap_union = ProgMap.fold ProgMap.add
-
-let cache (_, (infos, tac)) =
-  from_prg := infos;
-  set_default_tactic tac
-
-let (input,output) = 
-  declare_object
-    { (default_object "Program state") with
-      cache_function = cache;
-      load_function = (fun _ -> cache);
-      open_function = (fun _ -> cache);
-      classify_function = (fun _ -> Dispose);
-      export_function = (fun x -> Some x) }
-    
-open Evd
-	  
-let rec intset_to = function
-    -1 -> Intset.empty
-  | n -> Intset.add n (intset_to (pred n))
-  
-let subst_body expand prg = 
-  let obls, _ = prg.prg_obligations in
-  let ints = intset_to (pred (Array.length obls)) in
-    subst_deps expand obls ints prg.prg_body,
-  subst_deps expand obls ints (Termops.refresh_universes prg.prg_type)
-    
-let declare_definition prg =
-  let body, typ = subst_body false 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 typ;
-      const_entry_opaque = false;
-      const_entry_boxed = boxed} 
-  in
-    (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 prg.prg_implicits;
-	  print_message (Subtac_utils.definition_message prg.prg_name);
-	  prg.prg_hook local 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 reduce_fix =
-  Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
-
-let declare_mutual_definition l =
-  let len = List.length l in
-  let first = List.hd l in
-  let fixdefs, fixtypes, fiximps = 
-    list_split3
-      (List.map (fun x -> 
-	let subs, typ = (subst_body false x) in
-	  snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l)
-  in
-(*   let fixdefs = List.map reduce_fix fixdefs in *)
-  let fixkind = Option.get first.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 (local,boxed,kind) = first.prg_kind in
-  let fixnames = first.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 ([],[])) first.prg_notations;
-    Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames);
-    let gr = List.hd kns in
-    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
-      first.prg_hook local gr; kn
-      
-let declare_obligation obl body =
-  match obl.obl_status with
-  | Expand -> { obl with obl_body = Some body }
-  | Define opaque ->
-      let ce = 
-	{ const_entry_body = body;
-	  const_entry_type = Some obl.obl_type;
-	  const_entry_opaque = 
-	    (if get_proofs_transparency () then false 
-	      else opaque) ;
-	  const_entry_boxed = false} 
-      in
-      let constant = Declare.declare_constant obl.obl_name 
-	(DefinitionEntry ce,IsProof Property)
-      in
-	print_message (Subtac_utils.definition_message obl.obl_name);
-	{ obl with obl_body = Some (mkConst constant) }
-	  
-let red = Reductionops.nf_betaiota Evd.empty
-
-let init_prog_info n b t deps fixkind notations obls impls kind hook =
-  let obls' = 
-    Array.mapi
-      (fun i (n, t, l, o, d, tac) ->
-	 debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d));
-         { obl_name = n ; obl_body = None; 
-	   obl_location = l; obl_type = red t; obl_status = o;
-	   obl_deps = d; obl_tac = tac })
-      obls
-  in
-    { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
-      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
-    match name with
-	Some n -> 
-	  (try ProgMap.find n prg_infos
-	   with Not_found -> raise (NoObligations (Some n)))
-      | None -> 
-	  (let n = map_cardinal prg_infos in
-	     match n with 
-		 0 -> raise (NoObligations None)
-	       | 1 -> map_first prg_infos
-	       | _ -> error "More than one program with unsolved obligations")
-
-let get_prog_err n = 
-  try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
-
-let obligations_solved prg = (snd prg.prg_obligations) = 0
-
-let update_state s = 
-(*   msgnl (str "Updating obligations info"); *)
-  Lib.add_anonymous_leaf (input s)
-
-type progress = 
-    | Remain of int 
-    | Dependent
-    | Defined of global_reference
-	  
-let obligations_message rem =
-  if rem > 0 then
-    if rem = 1 then
-      Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
-    else
-      Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
-  else
-    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;
-    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 []
-
-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 =
-  match o with
-  | Define false | Expand -> Subtac_utils.goal_kind
-  | _ -> Subtac_utils.goal_proof_kind
-
-let not_transp_msg = 
-  str "Obligation should be transparent but was declared opaque." ++ spc () ++
-    str"Use 'Defined' instead."
-
-let warn_not_transp () = ppwarn not_transp_msg
-let error_not_transp () = pperror not_transp_msg
-
-let rec solve_obligation prg num =
-  let user_num = succ num in
-  let obls, rem = prg.prg_obligations in
-  let obl = obls.(num) in
-    if obl.obl_body <> None then
-      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")    
-    else
-      match deps_remaining obls obl.obl_deps with
-      | [] ->
-	  let obl = subst_deps_obl obls obl in
-	    Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
-	      (fun strength gr -> 
-		let cst = match gr with ConstRef cst -> cst | _ -> assert false in
-		let obl = 
-		  let transparent = evaluable_constant cst (Global.env ()) in
-		  let body =
-		    match obl.obl_status with
-		    | Expand ->
-			if not transparent then error_not_transp ()
-			else constant_value (Global.env ()) cst
-		    | Define opaque ->
-			if not opaque && not transparent then error_not_transp ()
-			else Libnames.constr_of_global gr
-		  in { obl with obl_body = Some body }
-		in
-		let obls = Array.copy obls in
-		let _ = obls.(num) <- obl in
-		  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) None)
-		  | _ -> ());
-	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
-		      Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
-	    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))
-	  
-and subtac_obligation (user_num, name, typ) =
-  let num = pred user_num in
-  let prg = get_prog_err name in
-  let obls, rem = prg.prg_obligations in
-    if num < Array.length obls then
-      let obl = obls.(num) in
-	match obl.obl_body with
-	    None -> solve_obligation prg num
-	  | Some r -> error "Obligation already solved"
-    else error (sprintf "Unknown obligation number %i" (succ num))
-      
-   
-and solve_obligation_by_tac prg obls i tac =
-  let obl = obls.(i) in
-  match obl.obl_body with 
-      Some _ -> false
-    | None -> 
-	(try
-	    if deps_remaining obls obl.obl_deps = [] then
-	     let obl = subst_deps_obl obls obl in
-	     let tac = 
-	       match tac with
-	       | Some t -> t
-	       | None -> 
-		   match obl.obl_tac with
-		   | Some t -> Tacinterp.interp t
-		   | None -> !default_tactic
-	     in
-	     let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
-	       obls.(i) <- declare_obligation obl t;
-	       true
-	    else false
-	  with
-	    | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	    | 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
-  let rem = ref rem in
-  let obls' = Array.copy obls in
-  let _ = 
-    Array.iteri (fun i x -> 
-		   if solve_obligation_by_tac prg obls' i tac then
-		     decr rem)
-      obls'
-  in
-    update_obls prg obls' !rem
-
-and solve_obligations n tac = 
-  let prg = get_prog_err n in
-    solve_prg_obligations prg tac
-
-and solve_all_obligations tac = 
-  ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
-      
-and try_solve_obligation n prg tac = 
-  let prg = get_prog prg in 
-  let obls, rem = prg.prg_obligations in
-  let obls' = Array.copy obls in
-    if solve_obligation_by_tac prg obls' n tac then
-      ignore(update_obls prg obls' (pred rem));
-
-and try_solve_obligations n tac = 
-  try ignore (solve_obligations n tac) with NoObligations _ -> ()
-
-and auto_solve_obligations n tac : progress =
-  Flags.if_verbose msgnl (str "Solving obligations automatically...");
-  try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent
-      
-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
-  let showed = ref 5 in
-    if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
-    Array.iteri (fun i x -> 
-		   match x.obl_body with 
-		   | None -> 
-		       if !showed > 0 then (
-			 decr showed;
-			 msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
-				   str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ 
-				   hov 1 (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) ?tactic ?(hook=fun _ _ -> ()) 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 (
-    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 _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
-      from_prg := ProgMap.add n prg !from_prg; 
-      let res = auto_solve_obligations (Some n) tactic in
-	match res with
-	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
-	| _ -> res)
-	
-let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) 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, imps, obls) ->
-	let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind hook in
-	  ProgMap.add n prg acc)
-      !from_prg l
-  in
-    from_prg := upd;
-    let _defined = 
-      List.fold_left (fun finished x -> 
-	if finished then finished 
-	else
-	  let res = auto_solve_obligations (Some x) tactic in
-	    match res 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
-    Array.iteri (fun i x -> 
-		 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,false), IsAssumption Conjectural) in
-			 assumption_message x.obl_name;
-			 obls.(i) <- { x with obl_body = Some (mkConst kn) }
-		   | Some _ -> ())
-      obls;
-    ignore(update_obls prg obls 0)
-
-exception Found of int
-
-let array_find f arr = 
-  try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
-    raise Not_found
-  with Found i -> i
-
-let next_obligation n =
-  let prg = get_prog_err n in
-  let obls, rem = prg.prg_obligations in
-  let i = 
-    try array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
-    with Not_found -> anomaly "Could not find a solvable obligation."
-  in solve_obligation prg i
-      			
-let default_tactic () = !default_tactic
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
deleted file mode 100644
index 766af2fa..00000000
--- a/contrib/subtac/subtac_obligations.mli
+++ /dev/null
@@ -1,63 +0,0 @@
-open Names
-open Util
-open Libnames
-open Evd
-open Proof_type
-
-type obligation_info = 
-  (identifier * Term.types * loc * 
-      obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array
-    (* ident, type, location, (opaque or transparent, expand or define),
-       dependencies, tactic to solve it *)
-
-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
-
-val add_definition : Names.identifier ->  Term.constr -> Term.types -> 
-  ?implicits:(Topconstr.explicitation * (bool * bool)) list ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?tactic:Proof_type.tactic ->
-  ?hook:Tacexpr.declaration_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 *
-      (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> 
-  ?tactic:Proof_type.tactic ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?hook:Tacexpr.declaration_hook -> 
-  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 option -> progress
-(* Number of remaining obligations to be solved for this program *)
-
-val solve_all_obligations : Proof_type.tactic option -> unit 
-
-val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit
-
-val try_solve_obligations : Names.identifier option -> Proof_type.tactic 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
-
-exception NoObligations of Names.identifier option
-
-val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds
-
diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml
deleted file mode 100644
index 3ae7c95d..00000000
--- a/contrib/subtac/subtac_pretyping.ml
+++ /dev/null
@@ -1,137 +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        *)
-(************************************************************************)
-
-(* $Id: subtac_pretyping.ml 12187 2009-06-13 19:36:59Z msozeau $ *)
-
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops 
-open Evarutil
-open Pretype_errors
-open Rawterm
-open Evarconv
-open Pattern
-open Dyn
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion)
-
-open Pretyping
-
-let _ = Pretyping.allow_anonymous_refs := true
-
-type recursion_info = {
-  arg_name: name;
-  arg_type: types; (* A *)
-  args_after : rel_context;
-  wf_relation: constr; (* R : A -> A -> Prop *)
-  wf_proof: constr; (* : well_founded R *)
-  f_type: types; (* f: A -> Set *)
-  f_fulltype: types; (* Type with argument and wf proof product first *)
-}
-
-let my_print_rec_info env t = 
-  str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
-  str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
-  str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
-  str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
-  str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
-  str "Full type: " ++ my_print_constr env t.f_fulltype
-(*   trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *)
-(* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
-(* 	   str " in environment: " ++ my_print_env env); *)
-
-let merge_evms x y = 
-  Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
-
-let interp env isevars c tycon = 
-  let j = pretype tycon env isevars ([],[]) c 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 ~split:true ~fail:true 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 =
-  let rec aux i = function
-      (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl
-    | [] -> raise Not_found
-  in aux 0 l
-
-open Vernacexpr
-
-let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env
-let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type (evars_of evd) env
-
-let env_with_binders env isevars l =
-  let rec aux ((env, rels) as acc) = function
-      Topconstr.LocalRawDef ((loc, name), def) :: tl -> 
-	let rawdef = coqintern_constr !isevars env def in
-	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, k, typ) :: tl ->
-	let rawtyp = coqintern_type !isevars env typ in
-	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
-	let acc = 
-	  List.fold_left (fun (env, rels) (loc, name) -> 
-			    let reldecl = (name, None, coqtyp) in
-			      (push_rel reldecl env, 
-			       reldecl :: rels))
-	    (env, rels) bl
-	in aux acc tl
-    | [] -> acc
-  in aux (env, []) l
-
-let subtac_process env isevars id bl c tycon =
-  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 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 evm = non_instanciated_map env isevars (evars_of !isevars) in
-  let ty = nf_isevar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
-    evm, coqc, ty, imps
-
-open Subtac_obligations
-
-let subtac_proof kind hook 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 evm' = Subtac_utils.evars_of_term evm evm' coqt in
-  let evars, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
-    add_definition id def ty ~implicits:imps ~kind ~hook evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli
deleted file mode 100644
index ba0b7cd2..00000000
--- a/contrib/subtac/subtac_pretyping.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-open Term
-open Environ
-open Names
-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 * manual_explicitation list
-
-val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> 
-  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
deleted file mode 100644
index 00d37f35..00000000
--- a/contrib/subtac/subtac_pretyping_F.ml
+++ /dev/null
@@ -1,641 +0,0 @@
-(* -*- 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 *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: subtac_pretyping_F.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
-
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Nameops
-open Classops
-open List
-open Recordops 
-open Evarutil
-open Pretype_errors
-open Rawterm
-open Evarconv
-open Pattern
-open Dyn
-open Pretyping
-
-(************************************************************************)
-(* This concerns Cases *)
-open Declarations
-open Inductive
-open Inductiveops
-
-module SubtacPretyping_F (Coercion : Coercion.S) = struct
-
-  module Cases = Subtac_cases.Cases_F(Coercion)
-
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  let allow_anonymous_refs = ref true
-
-  let evd_comb0 f isevars =
-    let (evd',x) = f !isevars in
-      isevars := evd';
-      x
-
-  let evd_comb1 f isevars x =
-    let (evd',y) = f !isevars x in
-      isevars := evd';
-      y
-
-  let evd_comb2 f isevars x y =
-    let (evd',z) = f !isevars x y in
-      isevars := evd';
-      z
-
-  let evd_comb3 f isevars x y z =
-    let (evd',t) = f !isevars x y z in
-      isevars := evd';
-      t
-	
-  let mt_evd = Evd.empty
-    
-  (* 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 *)
-  (* et autoriser des ? à rester dans le résultat de l'unification *)
-  
-  let evar_type_fixpoint loc env isevars lna lar vdefj =
-    let lt = Array.length vdefj in 
-      if Array.length lar = lt then 
-	for i = 0 to lt-1 do 
-          if not (e_cumul env isevars (vdefj.(i)).uj_type
-		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env (evars_of !isevars)
-              i lna vdefj lar
-	done
-
-  let check_branches_message loc env isevars c (explft,lft) = 
-    for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env isevars lft.(i) explft.(i)) then 
-	let sigma = evars_of !isevars in
-	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
-    done
-
-  (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon loc env isevars j = function
-    | None -> j_nf_isevar !isevars j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
-
-  let push_rels vars env = List.fold_right push_rel vars env
-
-  (*
-    let evar_type_case isevars env ct pt lft p c =
-    let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
-    in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
-  *)
-
-  let strip_meta id = (* For Grammar v7 compatibility *)
-    let s = string_of_id id in
-      if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
-      else id
-
-  let pretype_id loc env (lvar,unbndltacvars) id =
-    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 = lift n typ }
-      with Not_found ->
-	try
-	  List.assoc id lvar
-	with Not_found ->
-	  try
-	    let (_,_,typ) = lookup_named id env in
-	      { uj_val  = mkVar id; uj_type = typ }
-	  with Not_found ->
-	    try (* To build a nicer ltac error message *)
-	      match List.assoc id unbndltacvars with
-		| None -> user_err_loc (loc,"",
-					str "variable " ++ pr_id id ++ str " should be bound to a term")
-		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-	    with Not_found ->
-	      error_var_not_found_loc loc id
-
-  (* make a dependent predicate from an undependent one *)
-
-  let make_dep_of_undep env (IndType (indf,realargs)) pj =
-    let n = List.length realargs in
-    let rec decomp n p =
-      if n=0 then p else
-	match kind_of_term p with
-	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
-    in
-    let sign,s = decompose_prod_n n pj.uj_type in
-    let ind = build_dependent_inductive env indf in
-    let s' = mkProd (Anonymous, ind, s) in
-    let ccl = lift 1 (decomp n pj.uj_val) in
-    let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
-
-  (*************************************************************************)
-  (* Main pretyping function                                               *)
-
-  let pretype_ref isevars env ref = 
-    let c = constr_of_global ref in
-      make_judge c (Retyping.get_type_of env Evd.empty c)
-
-  let pretype_sort = function
-    | RProp c -> judge_of_prop_contents c
-    | RType _ -> judge_of_new_Type ()
-
-  (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [(evars_of isevars)] and *)
-  (* the type constraint tycon *)
-  let rec pretype (tycon : type_constraint) env isevars lvar c = 
-(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
-(* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
-(*     with _ -> () *)
-(*     in *)
-    match c with
-    | RRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env isevars
-	  (pretype_ref isevars env ref)
-	  tycon
-
-    | RVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env isevars
-	  (pretype_id loc env lvar id)
-	  tycon
-
-    | REvar (loc, ev, instopt) ->
-	(* Ne faudrait-il pas s'assurer que hyps est bien un
-	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find (evars_of !isevars) ev) in
-	let args = match instopt with
-          | None -> instance_from_named_context hyps
-          | Some inst -> failwith "Evar subtitutions not implemented" in
-	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
-	  inh_conv_coerce_to_tycon loc env isevars j tycon
-
-    | RPatVar (loc,(someta,n)) -> 
-	anomaly "Found a pattern variable in a rawterm to type"
-	  
-    | RHole (loc,k) ->
-	let ty =
-          match tycon with 
-            | Some (None, ty) -> ty
-            | None | Some _ ->
-		e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
-	  { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
-
-    | RRec (loc,fixkind,names,bl,lar,vdef) ->
-	let rec type_bl env ctxt = function
-            [] -> ctxt
-          | (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,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
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
-	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
-	let larj =
-          array_map2
-            (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
-            ctxtv lar in
-	let lara = Array.map (fun a -> a.utj_val) larj in
-	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
-	let nbfix = Array.length lar in
-	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 ->
-	      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 ftys = Array.map (nf_evar (evars_of !isevars)) ftys in
-	let fdefs = Array.map (fun x -> nf_evar (evars_of !isevars) (j_val x)) vdefj in
-	let fixj = match fixkind with
-	  | RFix (vn,i) ->
-	      (* 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 -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
-		vn)
-	      in 
-	      let fixdecls = (names,ftys,fdefs) 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,fdefs)) in
-	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
-	      make_judge (mkCoFix cofix) ftys.(i) in
-	inh_conv_coerce_to_tycon loc env isevars fixj tycon
-
-    | RSort (loc,s) ->
-	inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
-
-    | RApp (loc,f,args) -> 
-	let length = List.length args in 
-	let ftycon =
-	  let ty = 
-	    if length > 0 then
-	      match tycon with
-	      | None -> None
-	      | Some (None, ty) -> mk_abstr_tycon length ty
-	      | Some (Some (init, cur), ty) ->
-		  Some (Some (length + init, length + cur), ty)
- 	    else tycon
-	  in 
-	    match ty with
-	    | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty
-	    | _ -> None
-	in
-	let fj = pretype ftycon env isevars lvar f in
- 	let floc = loc_of_rawconstr f in
-	let rec apply_rec env n resj tycon = function
-	  | [] -> resj
-	  | c::rest ->
-	      let argloc = loc_of_rawconstr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
-              let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
-      		match kind_of_term resty with
-		  | Prod (na,c1,c2) ->
-		      Option.iter (fun ty -> isevars :=
-			Coercion.inh_conv_coerces_to loc env !isevars resty ty) tycon;
-		      let evd, (_, _, tycon) = split_tycon loc env !isevars tycon in
-		      isevars := evd;
-		      let hj = pretype (mk_tycon (nf_isevar !isevars c1)) env isevars lvar c in
-		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-		      let typ' = nf_isevar !isevars typ in
-			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
-
-		  | _ ->
-		      let hj = pretype empty_tycon env isevars lvar c in
-			error_cant_apply_not_functional_loc 
-			  (join_loc floc argloc) env (evars_of !isevars)
-	      		  resj [hj]
-	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
-	  | App (f,args) when isInd f or isConst f ->
-	      let sigma = evars_of !isevars in
-	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
-	      let t = Retyping.get_type_of env sigma c in
-	      make_judge c t
-	  | _ -> resj in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
-
-    | RLambda(loc,name,k,c1,c2)      ->
-	let tycon' = evd_comb1 
-	  (fun evd tycon -> 
-	    match tycon with 
-	    | None -> evd, tycon 
-	    | Some ty -> 
-		let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
-		  evd, Some ty') 
-	  isevars tycon 
-	in
-	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
-	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
-	let resj = judge_of_abstraction env name j j' in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
-
-    | 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
-	let j' = pretype_type empty_valcon env' isevars lvar c2 in
-	let resj =
-	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
-	  inh_conv_coerce_to_tycon loc env isevars resj tycon
-	    
-    | RLetIn(loc,name,c1,c2)      ->
-	let j = pretype empty_tycon env isevars lvar c1 in
-	let t = refresh_universes j.uj_type in
-	let var = (name,Some j.uj_val,t) in
-        let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) isevars lvar c2 in
-	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
-	    uj_type = subst1 j.uj_val j'.uj_type }
-
-    | RLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env isevars lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj 
-	in
-	let cstrs = get_constructors env indf in
-	if Array.length cstrs <> 1 then
-          user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
-	let cs = cstrs.(0) in
-	  if List.length nal <> cs.cs_nargs then
-            user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
-	let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
-          (List.rev nal) cs.cs_args in
-	let env_f = push_rels fsign env in
-	  (* Make dependencies from arity signature impossible *)
-	let arsgn =
-	  let arsgn,_ = get_arity env indf in
-	    if not !allow_anonymous_refs then
-	      List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	    else arsgn
-	in
-	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	    let nar = List.length arsgn in
-	      (match po with
-		 | Some p ->
-		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p isevars lvar p in
-		     let ccl = nf_evar (evars_of !isevars) pj.utj_val in
-		     let psign = make_arity_signature env true indf in (* with names *)
-		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst = 
-		       (Array.to_list cs.cs_concl_realargs)
-		       @[build_dependent_constructor cs] in
-		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env (evars_of !isevars) lp inst in
-		     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let v =
-		       let mis,_ = dest_ind_family indf 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 }
-
-		 | None -> 
-		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f isevars lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar (evars_of !isevars) fj.uj_type in
-		     let ccl =
-		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl 
-		       else
-			 error_cant_find_case_type_loc loc env (evars_of !isevars) 
-			   cj.uj_val in
-		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
-		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|] ) 
-		     in
-		       { uj_val = v; uj_type = ccl })
-
-    | RIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env isevars lvar c in
-	let (IndType (indf,realargs)) = 
-	  try find_rectype env (evars_of !isevars) cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_rawconstr c in
-	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
-	let cstrs = get_constructors env indf in 
-	  if Array.length cstrs <> 2 then
-            user_err_loc (loc,"",
-			  str "If is only for inductive types with two constructors");
-
-	  let arsgn = 
-	    let arsgn,_ = get_arity env indf in
-	      if not !allow_anonymous_refs then
-		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn 
-	      else arsgn
-	  in
-	  let nar = List.length arsgn in
-	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	  let pred,p = match po with
-	    | Some p ->
-		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p isevars lvar p in
-		let ccl = nf_evar (evars_of !isevars) pj.utj_val in
-		let pred = it_mkLambda_or_LetIn ccl psign in
-		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
-								     uj_type = typ} tycon 
-		in
-		  jtyp.uj_val, jtyp.uj_type
-	    | None -> 
-		let p = match tycon with
-		  | Some (None, ty) -> ty
-		  | None | Some _ ->
-                      e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
-		in
-		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar (evars_of !isevars) pred in
-	  let p = nf_evar (evars_of !isevars) p in
-	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
-	  let f cs b =
-	    let n = rel_context_length cs.cs_args in
-	    let pi = lift n pred in (* liftn n 2 pred ? *)
-	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn = 
-	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args 
-	      else 
-		List.map 
-		  (fun (n, b, t) ->
-		     match n with
-                         Name _ -> (n, b, t)
-                       | Anonymous -> (Name (id_of_string "H"), b, t))
-		cs.cs_args
-	    in
-	    let env_c = push_rels csgn env in 
-(* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
-	    let bj = pretype (mk_tycon pi) env_c isevars lvar b in
-	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
-	  let b1 = f cstrs.(0) b1 in
-	  let b2 = f cstrs.(1) b2 in
-	  let v =
-	    let mis,_ = dest_ind_family indf 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,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) ->
-	let cj =
-	  match k with
-	      CastCoerce ->
-		let cj = pretype empty_tycon env isevars lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj
-	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env isevars lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
-		  (* User Casts are for helping pretyping, experimentally not to be kept*)
-		  (* ... except for Correctness *)
-		let v = mkCast (cj.uj_val, k, tj.utj_val) in
-		  { uj_val = v; uj_type = tj.utj_val }
-	in
-	  inh_conv_coerce_to_tycon loc env isevars cj tycon
-
-    | RDynamic (loc,d) ->
-	if (tag d) = "constr" then
-	  let c = constr_out d in
-	  let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
-	    j
-	      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
-	else
-	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
-
-  (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
-  and pretype_type valcon env isevars lvar = function
-    | RHole loc ->
-	(match valcon with
-	   | Some v ->
-               let s =
-		 let sigma = evars_of !isevars in
-		 let t = Retyping.get_type_of env sigma v in
-		   match kind_of_term (whd_betadeltaiota env sigma t) with
-                     | Sort s -> s
-                     | Evar v when is_Type (existential_type sigma v) -> 
-			 evd_comb1 (define_evar_as_sort) isevars v
-                     | _ -> anomaly "Found a type constraint which is not a type"
-               in
-		 { utj_val = v;
-		   utj_type = s }
-	   | None ->
-	       let s = new_Type_sort () in
-		 { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
-		   utj_type = s})
-    | c ->
-	let j = pretype empty_tycon env isevars lvar c in
-	let loc = loc_of_rawconstr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
-	  match valcon with
-	    | None -> tj
-	    | Some v ->
-		if e_cumul env isevars v tj.utj_val then tj
-		else
-		  error_unexpected_type_loc
-                    (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
-
-  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...
-  *)
-
-  let understand_judgment sigma env c =
-    let isevars = ref (create_evar_defs sigma) in
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let j = j_nf_evar (evars_of !isevars) j in
-    let isevars,_ = consider_remaining_unif_problems env !isevars in
-      check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-      j
-
-  let understand_judgment_tcc isevars env c =
-    let j = pretype empty_tycon env isevars ([],[]) c in
-    let sigma = evars_of !isevars in
-    let j = j_nf_evar sigma j in
-      j
-
-  (* Raw calls to the unsafe inference machine: boolean says if we must
-     fail on unresolved evars; the unsafe_judgment list allows us to
-     extend env with some bindings *)
-
-  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 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 =
-    snd (ise_pretype_gen true sigma env ([],[]) kind c)
-
-  let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
-
-  let understand_type sigma env 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 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
-
-module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
deleted file mode 100644
index 2ee2018e..00000000
--- a/contrib/subtac/subtac_utils.ml
+++ /dev/null
@@ -1,474 +0,0 @@
-open Evd
-open Libnames
-open Coqlib
-open Term
-open Names
-open Util
-
-let ($) f x = f x
-
-(****************************************************************************)
-(* Library linking *)
-
-let contrib_name = "Program"
-
-let subtac_dir = [contrib_name]
-let fix_sub_module = "Wf"
-let utils_module = "Utils"
-let fixsub_module = subtac_dir @ [fix_sub_module]
-let utils_module = subtac_dir @ [utils_module]
-let init_constant dir s = gen_constant contrib_name dir s
-let init_reference dir s = gen_reference contrib_name dir s
-
-let fixsub = lazy (init_constant fixsub_module "Fix_sub")
-let ex_pi1 = lazy (init_constant utils_module "ex_pi1")
-let ex_pi2 = lazy (init_constant utils_module "ex_pi2")
-
-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 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"
-
-let make_ref s = Qualid (dummy_loc, qualid_of_string s)
-let sig_ref = make_ref "Init.Specif.sig"
-let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
-let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
-
-let build_sig () = 
-  { proj1 = init_constant ["Init"; "Specif"] "proj1_sig";
-    proj2 = init_constant ["Init"; "Specif"] "proj2_sig";
-    elim = init_constant ["Init"; "Specif"] "sig_rec";
-    intro = init_constant ["Init"; "Specif"] "exist";
-    typ = init_constant ["Init"; "Specif"] "sig" }
-
-let sig_ = lazy (build_sig ())
-
-let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
-let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
-let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
-let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal")
-let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
-let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal")
-
-let not_ref = lazy (init_constant ["Init"; "Logic"] "not")
-
-let and_typ = lazy (Coqlib.build_coq_and ())
-
-let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep")
-let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
-let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
-let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
-
-let jmeq_ind () =   
-  check_required_library ["Coq";"Logic";"JMeq"]; 
-  init_constant ["Logic";"JMeq"] "JMeq"
-
-let jmeq_rec () = 
-  check_required_library ["Coq";"Logic";"JMeq"]; 
-  init_constant ["Logic";"JMeq"] "JMeq_rec"
-
-let jmeq_refl () = 
-  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")
-
-let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1")
-let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2")
-
-let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool")
-let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool")
-let natind = lazy (init_constant ["Init"; "Datatypes"] "nat")
-let intind = lazy (init_constant ["ZArith"; "binint"] "Z")
-let existSind = lazy (init_constant ["Init"; "Specif"] "sigS")
-  
-let existS = lazy (build_sigma_type ())
-
-let prod = lazy (build_prod ())
-
-
-(* orders *)
-let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded")
-let fix = lazy (init_constant ["Init"; "Wf"] "Fix")
-let acc = lazy (init_constant ["Init"; "Wf"] "Acc")
-let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv")
-
-let extconstr = Constrextern.extern_constr true (Global.env ())
-let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
-
-open Pp
-
-let my_print_constr = Termops.print_constr_env
-let my_print_constr_expr = Ppconstr.pr_constr_expr
-let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
-let my_print_context = Termops.print_rel_context
-let my_print_named_context = Termops.print_named_context
-let my_print_env = Termops.print_env
-let my_print_rawconstr = Printer.pr_rawconstr_env
-let my_print_evardefs = Evd.pr_evar_defs
-
-let my_print_tycon_type = Evarutil.pr_tycon_type
-
-let debug_level = 2
-
-let debug_on = true
-
-let debug n s = 
-  if debug_on then
-    if !Flags.debug && n >= debug_level then
-      msgnl s
-    else ()
-  else ()
-
-let debug_msg n s = 
-  if debug_on then
-    if !Flags.debug  && n >= debug_level then s
-    else mt ()
-  else mt ()
-
-let trace s = 
-  if debug_on then
-    if !Flags.debug  && debug_level > 0 then msgnl s
-    else ()
-  else ()
-
-let rec pp_list f = function
-    [] -> mt()
-  | x :: y -> f x ++ spc () ++ pp_list f y
-
-let wf_relations = Hashtbl.create 10
-
-let std_relations () = 
-  let add k v = Hashtbl.add wf_relations k v in
-    add (init_constant ["Init"; "Peano"] "lt")
-      (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf"))
-      
-let std_relations = Lazy.lazy_from_fun std_relations
-
-type binders = Topconstr.local_binder list
-
-let app_opt c e = 
-  match c with
-      Some constr -> constr e
-    | None -> e	
-
-let print_args env args = 
-  Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
-
-let make_existential loc ?(opaque = Define true) env isevars c =
-  let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in
-  let (key, args) = destEvar evar in
-    (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
-		  print_args env args ++ str " for type: "++ 
-		  my_print_constr env c) with _ -> ());
-    evar
-
-let make_existential_expr loc env c =
-  let key = Evarutil.new_untyped_evar () in
-  let evar = Topconstr.CEvar (loc, key, None) in
-    debug 2 (str "Constructed evar " ++ int key);
-    evar
-
-let string_of_hole_kind = function
-  | ImplicitArg _ -> "ImplicitArg"
-  | BinderType _ -> "BinderType"
-  | QuestionMark _ -> "QuestionMark"
-  | CasesType -> "CasesType"
-  | InternalHole -> "InternalHole"
-  | TomatchTypeParameter _ -> "TomatchTypeParameter"
-  | GoalEvar -> "GoalEvar"
-  | ImpossibleCase -> "ImpossibleCase"
-
-let evars_of_term evc init c = 
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n)
-    | Evar (n, _) -> assert(false)
-    | _ -> fold_constr evrec acc c
-  in 
-    evrec init c
-
-let non_instanciated_map env evd evm =
-  List.fold_left 
-    (fun evm (key, evi) -> 
-       let (loc,k) = evar_source key !evd in
-	 debug 2 (str "evar " ++ int key ++ str " has kind " ++ 
-		    str (string_of_hole_kind k));
-	 match k with 
-	     QuestionMark _ -> Evd.add evm key evi
-	   | _ ->
-	       debug 2 (str " and is an implicit");
-	       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
-let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
-
-let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
-let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
-
-let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
-let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
-
-open Tactics
-open Tacticals
-
-let id x = x
-let filter_map f l = 
-  let rec aux acc = function
-      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
-		     | None -> aux acc tl)
-    | [] -> List.rev acc
-  in aux [] l
-
-let build_dependent_sum l =
-  let rec aux names conttac conttype = function
-      (n, t) :: ((_ :: _) as tl) ->
-	let hyptype = substl names t in
-	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
-	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
-	   with _ -> ());
-	let tac = assert_tac (Name n) hyptype in
-	let conttac = 
-	  (fun cont -> 
-	     conttac
-	     (tclTHENS tac
-		([intros;
-		  (tclTHENSEQ 
-		     [constructor_tac false (Some 1) 1 
-			(Rawterm.ImplicitBindings [inj_open (mkVar n)]);
-		      cont]);
-		 ])))
-	in
-	let conttype = 
-	  (fun typ -> 
-	     let tex = mkLambda (Name n, t, typ) in
-	       conttype
-		 (mkApp (Lazy.force ex_ind, [| t; tex |])))
-	in
-	  aux (mkVar n :: names) conttac conttype tl
-    | (n, t) :: [] -> 
-	(conttac intros, conttype t)
-    | [] -> raise (Invalid_argument "build_dependent_sum")
-  in aux [] id id (List.rev l)       
-	  
-open Proof_type
-open Tacexpr
-
-let mkProj1 a b c = 
-  mkApp (Lazy.force proj1, [| a; b; c |])
-
-let mkProj2 a b c = 
-  mkApp (Lazy.force proj2, [| a; b; c |])
-
-let mk_ex_pi1 a b c =
-  mkApp (Lazy.force ex_pi1, [| a; b; c |])
-
-let mk_ex_pi2 a b c =
-  mkApp (Lazy.force ex_pi2, [| a; b; c |])
-    
-let mkSubset name typ prop = 
-  mkApp ((Lazy.force sig_).typ,
-	 [| typ; mkLambda (name, typ, prop) |])
-
-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 (jmeq_ind (), [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (jmeq_refl (), [| typ; x |])
-
-let unsafe_fold_right f = function
-    hd :: tl -> List.fold_right f tl hd
-  | [] -> raise (Invalid_argument "unsafe_fold_right")
-
-let mk_conj l =
-  let conj_typ = Lazy.force and_typ in
-    unsafe_fold_right
-      (fun c conj ->
-	 mkApp (conj_typ, [| c ; conj |]))
-      l
-
-let mk_not c =
-  let notc = Lazy.force not_ref in
-    mkApp (notc, [| c |])
-
-let and_tac l hook =
-  let andc = Coqlib.build_coq_and () in      
-  let rec aux ((accid, goal, tac, extract) as acc) = function
-    | [] -> (* Singleton *) acc
-	
-    | (id, x, elgoal, eltac) :: tl ->
-	let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
-	let proj = fun c -> mkProj2 goal elgoal c in
-	let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
-	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', 
-	       (id, x, elgoal, proj) :: extract) tl
-
-  in
-  let and_proof_id, and_goal, and_tac, and_extract = 
-    match l with
-      | [] -> raise (Invalid_argument "and_tac: empty list of goals")
-      | (hdid, x, hdg, hdt) :: tl -> 
-	  aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
-  in
-  let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
-    Command.start_proof and_proofid goal_kind and_goal
-      (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
-    trace (str "Started and proof");
-    Pfedit.by and_tac;
-    trace (str "Applied and tac")
-      
-
-let destruct_ex ext ex = 
-  let rec aux c acc = 
-    match kind_of_term c with
-	App (f, args) ->
-	  (match kind_of_term f with
-	       Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 ->
-		 let (dom, rng) = 
-		   try (args.(0), args.(1))
-		   with _ -> assert(false)
-		 in
-		 let pi1 = (mk_ex_pi1 dom rng acc) in
-		 let rng_body = 
-		   match kind_of_term rng with
-		       Lambda (_, _, t) -> subst1 pi1 t
-		     | t -> rng
-		 in
-		   pi1 :: aux rng_body (mk_ex_pi2 dom rng acc)
-	     | _ -> [acc])
-      | _ -> [acc]
-  in aux ex ext
-
-open Rawterm
-	
-let id_of_name = function
-    Name n -> n
-  | Anonymous -> raise (Invalid_argument "id_of_name")
-
-let definition_message id =
-  Nameops.pr_id id ++ str " is defined"
-    
-let recursive_message v =
-  match Array.length v with
-    | 0 -> error "no recursive definition"
-    | 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 =
-  let id = id_of_string "H" in
-  try
-    Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
-    (fun _ _ -> ());
-    Pfedit.by (tclCOMPLETE t);
-    let _,(const,_,_,_) = Pfedit.cook_proof ignore in
-      Pfedit.delete_current_proof (); const.Entries.const_entry_body
-  with e ->
-    Pfedit.delete_current_proof();
-    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
-    [] -> ""
-  | x :: [] -> f x
-  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
-
-let string_of_intset d = 
-  string_of_list "," string_of_int (Intset.elements d)
-
-(**********************************************************)
-(* Pretty-printing *)
-open Printer
-open Ppconstr
-open Nameops
-open Termops
-open Evd
-
-let pr_meta_map evd =
-  let ml = meta_list evd in
-  let pr_name = function
-      Name id -> str"[" ++ pr_id id ++ str"]"
-    | _ -> mt() in
-  let pr_meta_binding = function
-    | (mv,Cltyp (na,b)) ->
-      	hov 0 
-	  (pr_meta mv ++ pr_name na ++ str " : " ++
-           print_constr b.rebus ++ fnl ())
-    | (mv,Clval(na,b,_)) ->
-      	hov 0 
-	  (pr_meta mv ++ pr_name na ++ str " := " ++
-             print_constr (fst b).rebus ++ fnl ())
-  in
-  prlist pr_meta_binding ml    
-
-let pr_idl idl = prlist_with_sep pr_spc pr_id idl
-
-let pr_evar_info evi =
-  let phyps = 
-    (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
-    Printer.pr_named_context (Global.env()) (evar_context evi)
-  in
-  let pty = print_constr evi.evar_concl in
-  let pb =
-    match evi.evar_body with
-      | Evar_empty -> mt ()
-      | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
-  in
-  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
-
-let pr_evar_map sigma =
-  h 0 
-    (prlist_with_sep pr_fnl
-      (fun (ev,evi) ->
-        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
-      (to_list sigma))
-
-let pr_constraints pbs =
-  h 0
-    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
-      print_constr t1 ++ spc() ++
-      str (match pbty with
-	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++ 
-      spc() ++ print_constr t2) pbs)
-
-let pr_evar_defs evd =
-  let pp_evm =
-    let evars = evars_of evd in
-    if evars = empty then mt() else
-      str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
-  let pp_met =
-    if meta_list evd = [] then mt() else
-      str"METAS:"++brk(0,1)++pr_meta_map evd in
-  v 0 (pp_evm ++ pp_met)
-
-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 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
deleted file mode 100644
index 9c014286..00000000
--- a/contrib/subtac/subtac_utils.mli
+++ /dev/null
@@ -1,133 +0,0 @@
-open Term
-open Libnames
-open Coqlib
-open Environ
-open Pp
-open Evd
-open Decl_kinds
-open Topconstr
-open Rawterm
-open Util
-open Evarutil
-open Names
-open Sign
-
-val ($) : ('a -> 'b) -> 'a -> 'b
-val contrib_name : string
-val subtac_dir : string list
-val fix_sub_module : string
-val fixsub_module : string list
-val init_constant : string list -> string -> constr
-val init_reference : string list -> string -> global_reference
-val fixsub : constr lazy_t
-val well_founded_ref : global_reference lazy_t
-val acc_ref : global_reference lazy_t
-val acc_inv_ref : global_reference lazy_t
-val fix_sub_ref : global_reference lazy_t
-val fix_measure_sub_ref : global_reference lazy_t
-val lt_ref : global_reference lazy_t
-val lt_wf_ref : global_reference lazy_t
-val refl_ref : global_reference lazy_t
-val sig_ref : reference
-val proj1_sig_ref : reference
-val proj2_sig_ref : reference
-val build_sig : unit -> coq_sigma_data
-val sig_ : coq_sigma_data lazy_t
-
-val eq_ind : constr lazy_t
-val eq_rec : constr lazy_t
-val eq_rect : constr lazy_t
-val eq_refl : constr lazy_t
-
-val not_ref : constr lazy_t
-val and_typ : constr lazy_t
-
-val eqdep_ind : constr lazy_t
-val eqdep_rec : constr lazy_t
-
-val jmeq_ind : unit -> constr
-val jmeq_rec : unit -> constr
-val jmeq_refl : unit -> constr
-
-val boolind : constr lazy_t
-val sumboolind : constr lazy_t
-val natind : constr lazy_t
-val intind : constr lazy_t
-val existSind : constr lazy_t
-val existS : coq_sigma_data lazy_t
-val prod : coq_sigma_data lazy_t
-
-val well_founded : constr lazy_t
-val fix : constr lazy_t
-val acc : constr lazy_t
-val acc_inv : constr lazy_t
-val extconstr : constr -> constr_expr
-val extsort : sorts -> constr_expr
-
-val my_print_constr : env -> constr -> std_ppcmds
-val my_print_constr_expr : constr_expr -> std_ppcmds
-val my_print_evardefs : evar_defs -> std_ppcmds
-val my_print_context : env -> std_ppcmds
-val my_print_rel_context : env -> rel_context -> std_ppcmds
-val my_print_named_context : env -> std_ppcmds
-val my_print_env : env -> std_ppcmds
-val my_print_rawconstr : env -> rawconstr -> std_ppcmds
-val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
-
-
-val debug : int -> std_ppcmds -> unit
-val debug_msg : int -> std_ppcmds -> std_ppcmds
-val trace : std_ppcmds -> unit
-val wf_relations : (constr, constr lazy_t) Hashtbl.t
-
-type binders = local_binder list
-val app_opt : ('a -> 'a) option -> 'a -> 'a
-val print_args : env -> constr array -> std_ppcmds
-val make_existential : loc -> ?opaque:obligation_definition_status -> 
-  env -> evar_defs ref -> types -> constr
-val make_existential_expr : loc -> 'a -> 'b -> constr_expr
-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 * goal_object_kind
-val global_proof_kind : logical_kind
-val goal_proof_kind : locality * goal_object_kind
-val global_fix_kind : logical_kind
-val goal_fix_kind : locality * goal_object_kind
-
-val mkSubset : name -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_eq : types -> constr -> constr -> types
-val mk_eq_refl : types -> constr -> constr
-val mk_JMeq : types -> constr -> types -> constr -> types
-val mk_JMeq_refl : types -> constr -> constr
-val mk_conj : types list -> types
-val mk_not : types -> types
-
-val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
-val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->  
-  ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
-
-val destruct_ex : constr -> constr -> constr list
-
-val id_of_name : name -> identifier
-
-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
-
-val string_of_list : string -> ('a -> string) -> 'a list -> string
-val string_of_intset : Intset.t -> string
-
-val pr_evar_defs : evar_defs -> Pp.std_ppcmds
-
-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
deleted file mode 100644
index da612c43..00000000
--- a/contrib/subtac/test/ListDep.v
+++ /dev/null
@@ -1,49 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import List.
-Require Import Coq.Program.Program.
-
-Set Implicit Arguments.
-
-Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
-
-Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
-Proof.
-  intros.
-  inversion H.
-  split.
-  intros.
-  apply H0.
-  auto with datatypes.
-  auto with arith.
-Qed.
-
-Section Map_DependentRecursor.
-  Variable U V : Set.
-  Variable l : list U.
-  Variable f : { x : U | In x l } -> V.
-
-  Obligations Tactic := unfold sub_list in * ; 
-    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
-	f x :: tl'
-    end.
-    
-  Next Obligation.
-    destruct_call map_rec.
-    simpl in *.
-    subst l'.
-    simpl ; auto with arith.
-  Qed.
-      
-  Program Definition map : list V := map_rec l.
-    
-End Map_DependentRecursor.
-
-Extraction map.
-Extraction map_rec.
-
diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v
deleted file mode 100644
index 05fc0803..00000000
--- a/contrib/subtac/test/ListsTest.v
+++ /dev/null
@@ -1,99 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import Coq.Program.Program.
-Require Import List.
-
-Set Implicit Arguments.
-
-Section Accessors.
-  Variable A : Set.
-
-  Program Definition myhd : forall (l : list A | length l <> 0), A :=  
-    fun l =>
-      match l with
-        | nil => !
-        | hd :: tl => hd
-      end.
-
-  Program Definition mytail (l : list A | length l <> 0) : list A :=
-    match l with
-      | nil => !
-      | hd :: tl => tl
-    end.
-End Accessors.
-
-Program Definition test_hd : nat := myhd (cons 1 nil).
-
-(*Eval compute in test_hd*)
-(*Program Definition test_tail : list A := mytail nil.*)
-
-Section app.
-  Variable A : Set.
-
-  Program Fixpoint app (l : list A) (l' : list A) { struct l } :
-    { r : list A | length r = length l + length l' } :=
-    match l with
-      | nil => l'
-      | hd :: tl => hd :: (tl ++ l')
-    end 
-    where "x ++ y" := (app x y).
-
-  Next Obligation.
-    intros.
-    destruct_call app ; program_simpl.
-  Defined.
-  
-  Program Lemma app_id_l : forall l : list A, l = nil ++ l.
-  Proof.
-    simpl ; auto.
-  Qed.
-  
-  Program Lemma app_id_r : forall l : list A, l = l ++ nil.
-  Proof.
-    induction l ; simpl in * ; auto. 
-    rewrite <- IHl ; auto.
-  Qed.
-
-End app.
-
-Extraction app.
-
-Section Nth.
-
-  Variable A : Set.
-
-  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := 
-    match n, l with
-      | 0, hd :: _ => hd
-      | S n', _ :: tl => nth tl n'
-      | _, nil => !
-    end.
-
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith. 
-  Defined.
-
-  Next Obligation.
-  Proof.
-    inversion H.
-  Qed.
-
-  Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := 
-    match l, n with
-      | hd :: _, 0 => hd
-      | _ :: tl, S n' => nth' tl n'
-      | nil, _ => !
-    end.
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith. 
-  Defined.
-
-  Next Obligation.
-  Proof.
-    intros.
-    inversion H.
-  Defined.
-
-End Nth.
-
diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v
deleted file mode 100644
index ac49ca96..00000000
--- a/contrib/subtac/test/Mutind.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Require Import List.
-
-Program Fixpoint f a : { x : nat | x > 0 } := 
-  match a with
-  | 0 => 1
-  | S a' => g a a'
-  end
-with g a b : { x : nat | x > 0 } := 
-  match b with
-  | 0 => 1
-  | S b' => f b'
-  end.
-
-Check f.
-Check g.
-
-
-
-
-
diff --git a/contrib/subtac/test/Test1.v b/contrib/subtac/test/Test1.v
deleted file mode 100644
index 14b80854..00000000
--- a/contrib/subtac/test/Test1.v
+++ /dev/null
@@ -1,16 +0,0 @@
-Program Definition test (a b : nat) : { x : nat | x = a + b } := 
-  ((a + b) : { x : nat | x = a + b }).
-Proof.
-intros.
-reflexivity.
-Qed.
-
-Print test.
-
-Require Import List.
-
-Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
-  match l with
-    nil => 1
-    | a :: l => a
-  end.
diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v
deleted file mode 100644
index 501aa798..00000000
--- a/contrib/subtac/test/euclid.v
+++ /dev/null
@@ -1,24 +0,0 @@
-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).
-
-Next Obligation.
-  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).
-
-Eval lazy beta zeta delta iota in test_euclid.
-
-Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
-  (a & S a).
-
-Check testsig.
diff --git a/contrib/subtac/test/id.v b/contrib/subtac/test/id.v
deleted file mode 100644
index 9ae11088..00000000
--- a/contrib/subtac/test/id.v
+++ /dev/null
@@ -1,46 +0,0 @@
-Require Coq.Arith.Arith.
-
-Require Import Coq.subtac.Utils.
-Program Fixpoint id (n : nat) : { x : nat | x = n } :=
-  match n with
-  | O => O
-  | S p => S (id p)
-  end.
-intros ; auto.
-
-pose (subset_simpl (id p)).
-simpl in e.
-unfold p0.
-rewrite e.
-auto.
-Defined.
-
-Check id.
-Print id.
-Extraction id.
-
-Axiom le_gt_dec : forall n m, { n <= m } + { n > m }.
-Require Import Omega.
-
-Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } :=
-  if le_gt_dec n 0 then 0
-  else S (id_if (pred n)).
-intros.
-auto with arith.
-intros.
-pose (subset_simpl (id_if (pred n))).
-simpl in e.
-rewrite e.
-induction n ; auto with arith.
-Defined.
-
-Print id_if_instance.
-Extraction id_if_instance.
-
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-
-Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} :=
-  (a & a).
-intros.
-auto.
-Qed.
diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v
deleted file mode 100644
index 4f938f4f..00000000
--- a/contrib/subtac/test/measure.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.Program.Program.
-
-Fixpoint size (a : nat) : nat :=
-  match a with
-  0 => 1
-  | S n => S (size n)
-  end.
-
-Program Fixpoint test_measure (a : nat) {measure size a}  : nat :=
-  match a with
-  | S (S n) => S (test_measure n)
-  | 0 | S 0 => a
-  end.
-
-Check test_measure.
-Print test_measure.
\ No newline at end of file
diff --git a/contrib/subtac/test/rec.v b/contrib/subtac/test/rec.v
deleted file mode 100644
index aaefd8cc..00000000
--- a/contrib/subtac/test/rec.v
+++ /dev/null
@@ -1,65 +0,0 @@
-Require Import Coq.Arith.Arith.
-Require Import Lt.
-Require Import Omega.
-
-Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
-(*Proof.
-  intros.
-  elim (le_lt_dec y x) ; intros ; auto with arith.
-Defined.
-*)
-Require Import Coq.subtac.FixSub.
-Require Import Wf_nat.
-
-Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
-auto with arith.
-Qed.
-
-Program Fixpoint id_struct (a : nat) : nat :=
-  match a with
-  0 => 0
-  | S n => S (id_struct n)
-  end.
-
-Check struct_rec.
-
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-
-Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-intros.
-apply preda_lt_a ; auto.
-
-Defined.
-
-Extraction wfrec.
-Extraction Inline proj1_sig.
-Extract Inductive bool => "bool" [ "true" "false" ].
-Extract Inductive sumbool => "bool" [ "true" "false" ].
-Extract Inlined Constant lt_ge_dec => "<".
-
-Extraction wfrec.
-Extraction Inline lt_ge_dec le_lt_dec.
-Extraction wfrec.
-
-
-Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
-  match a with
-   S n => S (structrec n)
-   | 0 => 0
-   end.
-intros.
-unfold n0.
-omega.
-Defined.
-
-Print structrec.
-Extraction structrec.
-Extraction structrec.
-
-Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
-Print structrec_fun.
diff --git a/contrib/subtac/test/take.v b/contrib/subtac/test/take.v
deleted file mode 100644
index 2e17959c..00000000
--- a/contrib/subtac/test/take.v
+++ /dev/null
@@ -1,34 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import JMeq.
-Require Import List.
-Require Import Program.
-
-Set Implicit Arguments.
-Obligations Tactic := idtac.
-
-Print cons.
-
-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.
-Solve All Obligations.
-Next Obligation.
-  destruct_call take ; program_simpl.
-Defined.
-
-Next Obligation.
-  intros.
-  inversion H.
-Defined.
-
-
-
-
diff --git a/contrib/subtac/test/wf.v b/contrib/subtac/test/wf.v
deleted file mode 100644
index 49fec2b8..00000000
--- a/contrib/subtac/test/wf.v
+++ /dev/null
@@ -1,48 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.subtac.Utils.
-
-Ltac one_simpl_hyp :=
- match goal with
- | [H : (`exist _ _ _) = _ |- _] => simpl in H
- | [H : _ = (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) < _ |- _] => simpl in H
- | [H : _ < (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) <= _ |- _] => simpl in H
- | [H : _ <= (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) > _ |- _] => simpl in H
- | [H : _ > (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) >= _ |- _] => simpl in H
- | [H : _ >= (`exist _ _ _) |- _] => simpl in H
- end.
-
-Ltac one_simpl_subtac :=
-  destruct_exists ;
-  repeat one_simpl_hyp ; simpl.
-
-Ltac simpl_subtac :=  do 3 one_simpl_subtac ; simpl.
-
-Require Import Omega.
-Require Import Wf_nat.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
-  { 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).
-destruct b ; simpl_subtac.
-omega.
-simpl_subtac.
-assert(x0 * S q' = x0 + x0 * q').
-rewrite <- mult_n_Sm.
-omega.
-rewrite H2 ; omega.
-simpl_subtac.
-split ; auto with arith.
-omega.
-apply lt_wf.
-Defined.
-
-Check euclid_evars_proof.
\ No newline at end of file
diff --git a/contrib/xml/COPYRIGHT b/contrib/xml/COPYRIGHT
deleted file mode 100644
index c8d231fd..00000000
--- a/contrib/xml/COPYRIGHT
+++ /dev/null
@@ -1,25 +0,0 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This Coq module has been developed by Claudio Sacerdoti Coen
-<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI.
-
-Project HELM (for Hypertextual Electronic Library of Mathematics) is a
-project developed at the Department of Computer Science, University of Bologna;
-http://helm.cs.unibo.it
-
-Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces)
-is a UE IST project that generalizes and extends the HELM project;
-http://mowgli.cs.unibo.it
-
-The author is interested in any possible usage of the module.
-So, if you plan to use the module, please send him an e-mail.
-
-The licensing policy applied to the module is the same as for the whole Coq
-distribution.
diff --git a/contrib/xml/README b/contrib/xml/README
deleted file mode 100644
index a45dd31a..00000000
--- a/contrib/xml/README
+++ /dev/null
@@ -1,254 +0,0 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This module provides commands to export a piece of Coq library in XML format.
-Only the information relevant to proof-checking and proof-rendering is exported,
-i.e. only the CIC proof objects (lambda-terms).
-
-This document is tructured in the following way:
- 1. User documentation
-   1.1. New vernacular commands available
-   1.2. New coqc/coqtop flags and suggested usage
-   1.3. How to exploit the XML files
- 2. Technical informations
-   2.1. Inner-types
-   2.2. CIC with Explicit Named Substitutions
-   2.3. The CIC with Explicit Named Substitutions XML DTD
-
-================================================================================
-                            USER DOCUMENTATION
-================================================================================
-
-=======================================
-1.1. New vernacular commands available:
-=======================================
-
-The new commands are:
-
- Print XML qualid.                 It prints in XML (to standard output) the
-                                   object whose qualified name is qualid and
-                                   its inner-types (see Sect. 2.1).
-                                   The inner-types are always printed
-                                   in their own XML file. If the object is a
-                                   constant, its type and body are also printed
-                                   as two distinct XML files.
-                                   The object printed is always the most
-                                   discharged form of the object (see
-                                   the Section command of the Coq manual).
-
- Print XML File "filename" qualid. Similar to "Print XML qualid". The generated
-                                   files are stored on the hard-disk using the
-                                   base file name "filename".
-
- Show XML Proof.                   It prints in XML the current proof in
-                                   progress. Its inner-types are also printed.
-
- Show XML File "filename" Proof.   Similar to "Show XML Proof". The generated
-                                   files are stored on the hard-disk using
-                                   the base file name "filename".
-
- The verbosity of the previous commands is raised if the configuration
- parameter verbose of xmlcommand.ml is set to true at compile time.
-
-==============================================
-1.2. New coqc/coqtop flags and suggested usage
-==============================================
-
- The following flag has been added to coqc and coqtop:
-
-  -xml     export XML files either to the hierarchy rooted in
-           the directory $COQ_XML_LIBRARY_ROOT (if the environment
-           variable is set) or to stdout (if unset)
-
- If the flag is set, every definition or declaration is immediately
- exported to XML. The XML files describe the user-provided non-discharged
- form of the definition or declaration. 
-
-
- The coq_makefile utility has also been modified to easily allow XML
- exportation:
-
-   make COQ_XML=-xml   (or, equivalently, setting the environment
-                        variable COQ_XML)
-
-
- The suggested usage of the module is the following:
-
-   1. add to your own contribution a valid Make file and use coq_makefile
-      to generate the Makefile from the Make file.
-      *WARNING:* Since logical names are used to structure the XML hierarchy,
-      always add to the Make file at least one "-R" option to map physical
-      file names to logical module paths. See the Coq manual for further
-      informations on the -R flag.
-   2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy
-      must be physically rooted.
-   3. compile your contribution with "make COQ_XML=-xml"
-
-
-=================================
-1.3. How to exploit the XML files
-=================================
-
- Once the information is exported to XML, it becomes possible to implement
- services that are completely Coq-independent. Projects HELM and MoWGLI
- already provide rendering, searching and data mining functionalities.
-
- In particular, the standard library and contributions of Coq can be
- browsed and searched on the HELM web site:
-
-                  http://helm.cs.unibo.it/library.html
-
-
- If you want to publish your own contribution so that it is included in the
- HELM library, use the MoWGLI prototype upload form:
-
-                  http://mowgli.cs.unibo.it
-
-
-================================================================================
-                            TECHNICAL INFORMATIONS
-================================================================================
-
-==========================
-2.1. Inner-types
-==========================
-
-In order to do proof-rendering (for example in natural language),
-some redundant typing information is required, i.e. the type of
-at least some of the subterms of the bodies and types. So, each
-new command described in section 1.1 print not only
-the object, but also another XML file in which you can find
-the type of all the subterms of the terms of the printed object
-which respect the following conditions:
-
- 1. It's sort is Prop or CProp (the "sort"-like definition used in
-    CoRN to type computationally relevant predicative propositions).
- 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL,
-    VAR, MUTCONSTR or CONST.
- 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA,
-    i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is
-    printed.
-
-The rationale for the 3rd condition is that the type of the inner LAMBDAs
-could be easily computed starting from the type of the outer LAMBDA; moreover,
-the types of the inner LAMBDAs requires a lot of disk/memory space: removing
-the 3rd condition leads to XML file that are two times as big as the ones
-exported appling the 3rd condition.
-
-==========================================
-2.2. CIC with Explicit Named Substitutions
-==========================================
-
-The exported files are and XML encoding of the lambda-terms used by the
-Coq system. The implementative details of the Coq system are hidden as much
-as possible, so that the XML DTD is a straightforward encoding of the  
-Calculus of (Co)Inductive Constructions.
-
-Nevertheless, there is a feature of the Coq system that can not be
-hidden in a completely satisfactory way: discharging. In Coq it is possible
-to open a section, declare variables and use them in the rest of the section
-as if they were axiom declarations. Once the section is closed, every definition
-and theorem in the section is discharged by abstracting it over the section
-variables. Variable declarations as well as section declarations are entirely
-dropped. Since we are interested in an XML encoding of definitions and
-theorems as close as possible to those directly provided the user, we
-do not want to export discharged forms. Exporting non-discharged theorem
-and definitions together with theorems that rely on the discharged forms
-obliges the tools that work on the XML encoding to implement discharging to
-achieve logical consistency. Moreover, the rendering of the files can be
-misleading, since hyperlinks can be shown between occurrences of the discharge
-form of a definition and the non-discharged definition, that are different
-objects.
-
-To overcome the previous limitations, Claudio Sacerdoti Coen developed in his
-PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions
-with Explicit Named Substitutions, that is a slight extension of CIC where
-discharging is not necessary. The DTD of the exported XML files describes
-constants, inductive types and variables of the Calculus of (Co)Inductive
-Constructions with Explicit Named Substitions. The conversion to the new
-calculus is performed during the exportation phase.
-
-The following example shows a very small Coq development together with its
-version in CIC with Explicit Named Substitutions.
-
-# CIC version: #
-Section S.
- Variable A : Prop.
-
- Definition impl := A -> A.
-
- Theorem t : impl.           (* uses the undischarged form of impl *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t' : (impl False).   (* uses the discharged form of impl *) 
- Proof.
-  exact (t False).           (* uses the discharged form of t *)
- Qed.
-
-# Corresponding CIC with Explicit Named Substitutions version: #
-Section S.
- Variable A : Prop.
-
- Definition impl(A) := A -> A.   (* theorems and definitions are
-                                    explicitly abstracted over the
-                                    variables. The name is sufficient
-                                    to completely describe the abstraction *)
-
- Theorem t(A) : impl.            (* impl where A is not instantiated *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t'() : impl{False/A}.    (* impl where A is instantiated with False
-                                    Notice that t' does not depend on A     *) 
- Proof.
-  exact t{False/A}.              (* t where A is instantiated with False *)
- Qed.
-
-Further details on the typing and reduction rules of the calculus can be
-found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency
-of the calculus is also proved.
-
-======================================================
-2.3. The CIC with Explicit Named Substitutions XML DTD
-======================================================
-
-A copy of the DTD can be found in the file "cic.dtd".
-
-<ConstantType>     is the root element of the files that correspond to
-                   constant types.
-<ConstantBody>     is the root element of the files that correspond to
-                   constant bodies. It is used only for closed definitions and
-                   theorems (i.e. when no metavariable occurs in the body
-                   or type of the constant)
-<CurrentProof>     is the root element of the file that correspond to
-                   the body of a constant that depends on metavariables
-                   (e.g. unfinished proofs)
-<Variable>         is the root element of the files that correspond to variables
-<InductiveTypes>   is the root element of the files that correspond to blocks
-                   of mutually defined inductive definitions
-
-The elements
- <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>,
- <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX>
-are used to encode the constructors of CIC. The sort or type attribute of the
-element, if present, is respectively the sort or the type of the term, that
-is a sort because of the typing rules of CIC.
-
-The element <instantiate> correspond to the application of an explicit named
-substitution to its first argument, that is a reference to a definition
-or declaration in the environment.
-
-All the other elements are just syntactic sugar.
diff --git a/contrib/xml/acic.ml b/contrib/xml/acic.ml
deleted file mode 100644
index 032ddbeb..00000000
--- a/contrib/xml/acic.ml
+++ /dev/null
@@ -1,108 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-open Names
-open Term
-
-(* Maps fron \em{unshared} [constr] to ['a]. *)
-module CicHash =
- Hashtbl.Make
-  (struct
-    type t = Term.constr
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-type id = string  (* the type of the (annotated) node identifiers *)
-type uri = string
-
-type 'constr context_entry =
-   Decl of 'constr             (* Declaration *)
- | Def  of 'constr * 'constr   (* Definition; the second argument (the type) *)
-                               (* is not present in the DTD, but is needed   *)
-                               (* to use Coq functions during exportation.   *)
-
-type 'constr hypothesis = identifier * 'constr context_entry
-type context = constr hypothesis list
-
-type conjecture = existential_key * context * constr
-type metasenv = conjecture list
-
-(* list of couples section path -- variables defined in that section *)
-type params = (string * uri list) list
-
-type obj =
-   Constant of string *                            (* id,           *)
-    constr option * constr *                       (*  value, type, *)
-    params                                         (*  parameters   *)
- | Variable of
-    string * constr option * constr *              (* name, body, type *)
-    params                                         (*  parameters   *)
- | CurrentProof of
-    string * metasenv *                            (*  name, conjectures, *)
-    constr * constr                                (*  value, type        *)
- | InductiveDefinition of
-    inductiveType list *                           (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and inductiveType = 
- identifier * bool * constr *                 (* typename, inductive, arity *)
-  constructor list                            (*  constructors              *)
-and constructor =
- identifier * constr                          (* id, type *)
-
-type aconstr =
-  | ARel       of id * int * id * identifier
-  | AVar       of id * uri
-  | AEvar      of id * existential_key * aconstr list
-  | ASort      of id * sorts
-  | ACast      of id * aconstr * aconstr
-  | AProds     of (id * name * aconstr) list * aconstr
-  | ALambdas   of (id * name * aconstr) list * aconstr
-  | ALetIns    of (id * name * aconstr) list * aconstr
-  | AApp       of id * aconstr list
-  | AConst     of id * explicit_named_substitution * uri
-  | AInd       of id * explicit_named_substitution * uri * int
-  | AConstruct of id * explicit_named_substitution * uri * int * int
-  | ACase      of id * uri * int * aconstr * aconstr * aconstr list
-  | AFix       of id * int * ainductivefun list
-  | ACoFix     of id * int * acoinductivefun list
-and ainductivefun = 
- id * identifier * int * aconstr * aconstr
-and acoinductivefun = 
- id * identifier * aconstr * aconstr
-and explicit_named_substitution = id option * (uri * aconstr) list
-
-type acontext = (id * aconstr hypothesis) list
-type aconjecture = id * existential_key * acontext * aconstr
-type ametasenv = aconjecture list
-
-type aobj =
-   AConstant of id * string *                      (* id,           *)
-    aconstr option * aconstr *                     (*  value, type, *)
-    params                                         (*  parameters   *)
- | AVariable of id *
-    string * aconstr option * aconstr *            (* name, body, type *)
-    params                                         (*  parameters   *)
- | ACurrentProof of id *
-    string * ametasenv *                           (*  name, conjectures, *)
-    aconstr * aconstr                              (*  value, type        *)
- | AInductiveDefinition of id *
-    anninductiveType list *                        (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and anninductiveType = 
- id * identifier * bool * aconstr *           (* typename, inductive, arity *)
-  annconstructor list                         (*  constructors              *)
-and annconstructor =
- identifier * aconstr                         (* id, type *)
diff --git a/contrib/xml/acic2Xml.ml4 b/contrib/xml/acic2Xml.ml4
deleted file mode 100644
index 64dc8a05..00000000
--- a/contrib/xml/acic2Xml.ml4
+++ /dev/null
@@ -1,363 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC codice cut & paste da cicPp e xmlcommand *)
-
-exception ImpossiblePossible;;
-exception NotImplemented;;
-let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";;
-let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";;
-
-let rec find_last_id =
- function
-    [] -> Util.anomaly "find_last_id: empty list"
-  | [id,_,_] -> id
-  | _::tl -> find_last_id tl
-;;
-
-let export_existential = string_of_int
-
-let print_term ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module N = Names in
-  let module X = Xml in
-    function
-       A.ARel (id,n,idref,b) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "REL"
-          ["value",(string_of_int n) ; "binder",(N.string_of_id b) ;
-           "id",id ; "idref",idref; "sort",sort]
-     | A.AVar (id,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
-     | A.AEvar (id,n,l) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "META" 
-	   ["no",(export_existential n) ; "id",id ; "sort",sort]
-          (List.fold_left
-            (fun i t ->
-              [< i ; X.xml_nempty "substitution" [] (aux t) >]
-            ) [< >] (List.rev l))
-     | A.ASort (id,s) ->
-        let string_of_sort =
-         match Term.family_of_sort s with
-            Term.InProp -> "Prop"
-          | Term.InSet  -> "Set"
-          | Term.InType -> "Type"
-        in
-         X.xml_empty "SORT" ["value",string_of_sort ; "id",id]
-     | A.AProds (prods,t) ->
-        let last_id = find_last_id prods in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "PROD" ["type",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] prods ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ACast (id,v,t) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "CAST" ["id",id ; "sort",sort]
-          [< X.xml_nempty "term" [] (aux v) ;
-             X.xml_nempty "type" [] (aux t)
-          >]
-     | A.ALambdas (lambdas,t) ->
-        let last_id = find_last_id lambdas in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LAMBDA" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] lambdas ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ALetIns (letins,t) ->
-        let last_id = find_last_id letins in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LETIN" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("sort",sort)::
-                  match binder with
-                     Names.Anonymous -> assert false
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "def" attrs (aux s) ; i >]
-              ) [< >] letins ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.AApp (id,li) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "APPLY" ["id",id ; "sort",sort]
-          [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li)
-          >]
-     | A.AConst (id,subst,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs = ["uri", uri ; "id",id ; "sort",sort] in
-         aux_subst (X.xml_empty "CONST" attrs) subst
-     | A.AInd (id,subst,uri,i) ->
-        let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in
-         aux_subst (X.xml_empty "MUTIND" attrs) subst
-     | A.AConstruct (id,subst,uri,i,j) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs =
-         ["uri", uri ;
-          "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
-          "id",id ; "sort",sort]
-        in
-         aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst
-     | A.ACase (id,uri,typeno,ty,te,patterns) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "MUTCASE"
-          ["uriType", uri ;
-           "noType", (string_of_int typeno) ;
-           "id", id ; "sort",sort]
-          [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
-             X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
-             List.fold_left
-              (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >])
-              [<>] patterns
-          >]
-     | A.AFix (id, no, funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "FIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ai,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "FixFunction"
-                    ["id",id ; "name", (Names.string_of_id fi) ;
-                     "recIndex", (string_of_int ai)]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
-     | A.ACoFix (id,no,funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "COFIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "CofixFunction"
-                    ["id",id ; "name", Names.string_of_id fi]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
- and aux_subst target (id,subst) =
-  if subst = [] then
-   target
-  else
-   Xml.xml_nempty "instantiate"
-    (match id with None -> [] | Some id -> ["id",id])
-    [< target ;
-       List.fold_left
-        (fun i (uri,arg) ->
-          [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >]
-        ) [<>] subst
-    >]
- in
-  aux
-;;
-
-let param_attribute_of_params params =
- List.fold_right
-  (fun (path,l) i ->
-    List.fold_right
-     (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i'
-     ) l "" ^ match i with "" -> "" | i' -> " " ^ i'
-  ) params ""
-;;
-
-let print_object uri ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module X = Xml in
-    function
-       A.ACurrentProof (id,n,conjectures,bo,ty) ->
-        let xml_for_current_proof_body =
-(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
-(*CSC: I think so. Not implemented yet.                                       *)
-         X.xml_nempty "CurrentProof" ["of",uri ; "id", id]
-          [< List.fold_left
-              (fun i (cid,n,canonical_context,t) ->
-                [< i ;
-                   X.xml_nempty "Conjecture"
-                    ["id", cid ; "no",export_existential n]
-                    [< List.fold_left
-                        (fun i (hid,t) ->
-                          [< (match t with
-                                n,A.Decl t ->
-                                 X.xml_nempty "Decl"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                              | n,A.Def (t,_) ->
-                                 X.xml_nempty "Def"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                             ) ;
-                             i
-                          >]
-                        ) [< >] canonical_context ;
-                       X.xml_nempty "Goal" []
-                        (print_term ids_to_inner_sorts t)
-                    >]
-                >])
-              [<>] (List.rev conjectures) ;
-             X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
-        in
-        let xml_for_current_proof_type =
-         X.xml_nempty "ConstantType" ["name",n ; "id", id]
-          (print_term ids_to_inner_sorts ty)
-        in
-        let xmlbo =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n");
-            xml_for_current_proof_body
-         >] in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata
-             ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n");
-            xml_for_current_proof_type
-         >]
-        in
-         xmlty, Some xmlbo
-     | A.AConstant (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-        let xmlbo =
-         match bo with
-            None -> None
-          | Some bo ->
-             Some
-              [< X.xml_cdata
-                  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-                 X.xml_cdata
-                  ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
-                 X.xml_nempty "ConstantBody"
-                  ["for",uri ; "params",params' ; "id", id]
-                  [< print_term ids_to_inner_sorts bo >]
-              >]
-        in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n");
-             X.xml_nempty "ConstantType"
-              ["name",n ; "params",params' ; "id", id]
-              [< print_term ids_to_inner_sorts ty >]
-         >]
-        in
-         xmlty, xmlbo
-     | A.AVariable (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ;
-            X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id]
-             [< (match bo with
-                    None -> [<>]
-                  | Some bo ->
-                     X.xml_nempty "body" []
-                      (print_term ids_to_inner_sorts bo)
-                ) ;
-                X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
-             >]
-         >], None
-     | A.AInductiveDefinition (id,tys,params,nparams) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
-             dtdname ^ "\">\n") ;
-            X.xml_nempty "InductiveDefinition"
-             ["noParams",string_of_int nparams ;
-              "id",id ;
-              "params",params']
-             [< (List.fold_left
-                  (fun i (id,typename,finite,arity,cons) ->
-                    [< i ;
-                       X.xml_nempty "InductiveType"
-                        ["id",id ; "name",Names.string_of_id typename ;
-                         "inductive",(string_of_bool finite)
-                        ]
-                        [< X.xml_nempty "arity" []
-                            (print_term ids_to_inner_sorts arity) ;
-                           (List.fold_left
-                            (fun i (name,lc) ->
-                              [< i ;
-                                 X.xml_nempty "Constructor"
-                                  ["name",Names.string_of_id name]
-                                  (print_term ids_to_inner_sorts lc)
-                              >]) [<>] cons
-                           )
-                        >]
-                    >]
-                  ) [< >] tys
-                )
-             >]
-         >], None
- in
-  aux
-;;
-
-let print_inner_types curi ids_to_inner_sorts ids_to_inner_types =
- let module C2A = Cic2acic in
- let module X = Xml in
-  [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-     X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n");
-      X.xml_nempty "InnerTypes" ["of",curi]
-       (Hashtbl.fold
-         (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
-           [< x ;
-              X.xml_nempty "TYPE" ["of",id]
-               [< X.xml_nempty "synthesized" []
-                   (print_term ids_to_inner_sorts synty) ;
-                  match expty with
-                     None -> [<>]
-                   | Some expty' ->
-                      X.xml_nempty "expected" []
-                       (print_term ids_to_inner_sorts expty')
-               >]
-           >]
-         ) ids_to_inner_types [<>]
-       )
-  >]
-;;
diff --git a/contrib/xml/cic.dtd b/contrib/xml/cic.dtd
deleted file mode 100644
index c8035cab..00000000
--- a/contrib/xml/cic.dtd
+++ /dev/null
@@ -1,259 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM 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 General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-<!-- DTD FOR CIC OBJECTS: -->
-
-<!-- CIC term declaration -->
-
-<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST|
-                  LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'>
-
-<!-- CIC sorts -->
-
-<!ENTITY % sort '(Prop|Set|Type|CProp)'>
-
-<!-- CIC sequents -->
-
-<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
-
-<!-- CIC objects: -->
-
-<!ELEMENT ConstantType %term;>
-<!ATTLIST ConstantType
-          name       CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT ConstantBody %term;>
-<!ATTLIST ConstantBody
-          for        CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT CurrentProof (Conjecture*,body)>
-<!ATTLIST CurrentProof
-          of         CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT InductiveDefinition (InductiveType+)>
-<!ATTLIST InductiveDefinition
-          noParams NMTOKEN #REQUIRED
-          params   CDATA   #REQUIRED
-          id       ID      #REQUIRED>
-
-<!ELEMENT Variable (body?,type)>
-<!ATTLIST Variable
-          name   CDATA #REQUIRED
-          params CDATA #REQUIRED
-          id     ID    #REQUIRED>
-
-<!ELEMENT Sequent %sequent;>
-<!ATTLIST Sequent
-          no  NMTOKEN #REQUIRED
-          id  ID      #REQUIRED>
-
-<!-- Elements used in CIC objects, which are not terms: -->
-
-<!ELEMENT InductiveType (arity,Constructor*)>
-<!ATTLIST InductiveType
-          name      CDATA        #REQUIRED
-          inductive (true|false) #REQUIRED
-          id        ID           #REQUIRED>
-
-<!ELEMENT Conjecture %sequent;>
-<!ATTLIST Conjecture
-          no NMTOKEN #REQUIRED
-          id ID      #REQUIRED>
-
-<!ELEMENT Constructor %term;>
-<!ATTLIST Constructor
-          name CDATA #REQUIRED>
-
-<!ELEMENT Decl %term;>
-<!ATTLIST Decl
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Def %term;>
-<!ATTLIST Def
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Hidden EMPTY>
-<!ATTLIST Hidden
-          id ID #REQUIRED>
-
-<!ELEMENT Goal %term;>
-
-<!-- CIC terms: -->
-
-<!ELEMENT LAMBDA (decl*,target)>
-<!ATTLIST LAMBDA
-          sort %sort; #REQUIRED>
-
-<!ELEMENT LETIN (def*,target)>
-<!ATTLIST LETIN
-          sort %sort; #REQUIRED>
-
-<!ELEMENT PROD (decl*,target)>
-<!ATTLIST PROD
-          type %sort; #REQUIRED>
-
-<!ELEMENT CAST (term,type)>
-<!ATTLIST CAST
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT REL EMPTY>
-<!ATTLIST REL
-          value  NMTOKEN #REQUIRED
-          binder CDATA   #REQUIRED
-          id     ID      #REQUIRED
-          idref  IDREF   #REQUIRED
-          sort   %sort;  #REQUIRED>
-
-<!ELEMENT SORT EMPTY>
-<!ATTLIST SORT
-          value CDATA #REQUIRED
-          id    ID    #REQUIRED>
-
-<!ELEMENT APPLY (%term;)+>
-<!ATTLIST APPLY
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT VAR EMPTY>
-<!ATTLIST VAR
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!-- The substitutions are ordered by increasing DeBrujin  -->
-<!-- index. An empty substitution means that that index is -->
-<!-- not accessible.                                       -->
-<!ELEMENT META (substitution*)>
-<!ATTLIST META
-          no              NMTOKEN #REQUIRED
-          id              ID      #REQUIRED
-          sort            %sort;  #REQUIRED>
-
-<!ELEMENT IMPLICIT EMPTY>
-<!ATTLIST IMPLICIT
-          id ID #REQUIRED>
-
-<!ELEMENT CONST EMPTY>
-<!ATTLIST CONST
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT MUTIND EMPTY>
-<!ATTLIST MUTIND
-          uri    CDATA   #REQUIRED
-          noType NMTOKEN #REQUIRED
-          id     ID      #REQUIRED>
-
-<!ELEMENT MUTCONSTRUCT EMPTY>
-<!ATTLIST MUTCONSTRUCT
-          uri      CDATA   #REQUIRED
-          noType   NMTOKEN #REQUIRED
-          noConstr NMTOKEN #REQUIRED
-          id       ID      #REQUIRED
-          sort     %sort;  #REQUIRED>
-
-<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)>
-<!ATTLIST MUTCASE
-          uriType CDATA   #REQUIRED
-          noType  NMTOKEN #REQUIRED
-          id      ID      #REQUIRED
-          sort    %sort;  #REQUIRED>
-
-<!ELEMENT FIX (FixFunction+)>
-<!ATTLIST FIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!ELEMENT COFIX (CofixFunction+)>
-<!ATTLIST COFIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!-- Elements used in CIC terms: -->
-
-<!ELEMENT FixFunction (type,body)>
-<!ATTLIST FixFunction
-          name     CDATA   #REQUIRED
-          id       ID      #REQUIRED
-          recIndex NMTOKEN #REQUIRED>
-
-<!ELEMENT CofixFunction (type,body)>
-<!ATTLIST CofixFunction
-          id       ID      #REQUIRED
-          name     CDATA   #REQUIRED>
-
-<!ELEMENT substitution ((%term;)?)>
-
-<!-- Explicit named substitutions: -->
-
-<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)>
-<!ATTLIST instantiate
-          id ID #IMPLIED>
-
-<!-- Sintactic sugar for CIC terms and for CIC objects: -->
-
-<!ELEMENT arg %term;>
-<!ATTLIST arg
-          relUri CDATA #REQUIRED>
-
-<!ELEMENT decl %term;>
-<!ATTLIST decl
-          id     ID     #REQUIRED
-          type   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-          
-<!ELEMENT def %term;>
-<!ATTLIST def
-          id     ID     #REQUIRED
-          sort   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-
-<!ELEMENT target %term;>
-
-<!ELEMENT term %term;>
-
-<!ELEMENT type  %term;>
-
-<!ELEMENT arity %term;>
-
-<!ELEMENT patternsType  %term;>
-
-<!ELEMENT inductiveTerm  %term;>
-
-<!ELEMENT pattern  %term;>
-
-<!ELEMENT body  %term;>
diff --git a/contrib/xml/cic2Xml.ml b/contrib/xml/cic2Xml.ml
deleted file mode 100644
index 08d3a850..00000000
--- a/contrib/xml/cic2Xml.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-let print_xml_term ch env sigma cic =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let seed = ref 0 in
-  let acic =
-   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids 
-    ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
-    env [] sigma (Unshare.unshare cic) None in
-  let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
-  Xml.pp_ch xml ch
-;;
-
-Tacinterp.declare_xml_printer print_xml_term
-;;
diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
deleted file mode 100644
index 13e5e6d5..00000000
--- a/contrib/xml/cic2acic.ml
+++ /dev/null
@@ -1,974 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Utility Functions *)
-
-exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
-let get_module_path_of_section_path path =
- let dirpath = fst (Libnames.repr_path path) in
- let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
-  match
-   List.filter
-    (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
-  with
-     [] -> 
-       Pp.warning ("Modules not supported: reference to "^
-         Libnames.string_of_path path^" will be wrong");
-       dirpath
-   | [modul] -> modul
-   | _ -> 
-       raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
-;;
-
-(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *)
-(*CSC: not exist two modules whose dir_paths are one a prefix of the other *)
-let remove_module_dirpath_from_dirpath ~basedir dir =
- let module Ln = Libnames in
-  if Ln.is_dirpath_prefix_of basedir dir then
-   let ids = Names.repr_dirpath dir in
-   let rec remove_firsts n l =
-    match n,l with
-       (0,l) -> l
-     | (n,he::tl) -> remove_firsts (n-1) tl
-     | _ -> assert false
-   in
-    let ids' =
-     List.rev
-      (remove_firsts
-        (List.length (Names.repr_dirpath basedir))
-        (List.rev ids))
-    in
-     ids'
-  else Names.repr_dirpath dir
-;;
-
-
-let get_uri_of_var v pvars =
- let module D = Decls in
- let module N = Names in
-  let rec search_in_open_sections =
-   function
-      [] -> Util.error ("Variable "^v^" not found")
-    | he::tl as modules ->
-       let dirpath = N.make_dirpath modules in
-        if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then
-         modules
-        else
-         search_in_open_sections tl
-  in
-   let path =
-    if List.mem v pvars then
-      []
-    else
-      search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
-   in
-    "cic:" ^
-     List.fold_left
-      (fun i x -> "/" ^ N.string_of_id x ^ i) "" path
-;;
-
-type tag =
-   Constant of Names.constant
- | Inductive of Names.kernel_name
- | Variable of Names.kernel_name
-;;
-
-type etag =
-   TConstant
- | TInductive
- | TVariable
-;;
-
-let etag_of_tag =
- function
-    Constant _ -> TConstant
-  | Inductive _ -> TInductive
-  | Variable _ -> TVariable
-
-let ext_of_tag =
- function
-    TConstant -> "con"
-  | TInductive -> "ind"
-  | TVariable -> "var"
-;;
-
-exception FunctorsXMLExportationNotImplementedYet;;
-
-let subtract l1 l2 =
- let l1' = List.rev (Names.repr_dirpath l1) in
- let l2' = List.rev (Names.repr_dirpath l2) in
-  let rec aux =
-   function
-      he::tl when tl = l2' -> [he]
-    | he::tl -> he::(aux tl)
-    | [] -> assert (l2' = []) ; []
-  in
-   Names.make_dirpath (List.rev (aux l1'))
-;;
-
-(*CSC: Dead code to be removed
-let token_list_of_kernel_name ~keep_sections kn tag =
- let module N = Names in
-  let (modpath,dirpath,label) = Names.repr_kn kn in
-  let token_list_of_dirpath dirpath =
-   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
-  let rec token_list_of_modpath =
-   function
-      N.MPdot (path,label) ->
-       token_list_of_modpath path @ [N.string_of_label label]
-    | N.MPfile dirpath -> token_list_of_dirpath dirpath
-    | N.MPself self ->
-       if self = Names.initial_msid then
-        [ "Top" ]
-       else
-        let module_path =
-          let f = N.string_of_id (N.id_of_msid self) in
-          let _,longf = 
-            System.find_file_in_path (Library.get_load_path ()) (f^".v") in
-          let ldir0 = Library.find_logical_path (Filename.dirname longf) in
-          let id = Names.id_of_string (Filename.basename f) in
-           Libnames.extend_dirpath ldir0 id
-        in
-          token_list_of_dirpath module_path
-    | N.MPbound _ -> raise FunctorsXMLExportationNotImplementedYet
-  in
-   token_list_of_modpath modpath @
-    (if keep_sections then token_list_of_dirpath dirpath else []) @
-    [N.string_of_label label ^ "." ^ (ext_of_tag tag)]
-;;
-*)
-
-let token_list_of_path dir id tag =
- let module N = Names in
-  let token_list_of_dirpath dirpath =
-   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
-  token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)]
-
-let token_list_of_kernel_name tag =
- let module N = Names in
- let module LN = Libnames in
- let id,dir = match tag with
-   | Variable kn -> 
-       N.id_of_label (N.label kn), Lib.cwd ()
-   | Constant con -> 
-       N.id_of_label (N.con_label con),
-       Lib.remove_section_part (LN.ConstRef con)
-   | Inductive kn ->
-       N.id_of_label (N.label kn),
-       Lib.remove_section_part (LN.IndRef (kn,0))
- in
- token_list_of_path dir id (etag_of_tag tag)
-;;
-
-let uri_of_kernel_name tag =
-  let tokens = token_list_of_kernel_name tag in
-   "cic:/" ^ String.concat "/" tokens
-
-let uri_of_declaration id tag =
- let module LN = Libnames in
- let dir = LN.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) in
- let tokens = token_list_of_path dir id tag in
-  "cic:/" ^ String.concat "/" tokens
-
-(* Special functions for handling of CCorn's CProp "sort" *)
-
-type sort =
-   Coq_sort of Term.sorts_family
- | CProp
-;;
-
-let prerr_endline _ = ();;
-
-let family_of_term ty =
- match Term.kind_of_term ty with
-    Term.Sort s -> Coq_sort (Term.family_of_sort s)
-  | Term.Const _ -> CProp  (* I could check that the constant is CProp *)
-  | _ -> Util.anomaly "family_of_term"
-;;
-
-module CPropRetyping =
- struct
-  module T = Term
-
-  let outsort env sigma t =
-   family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t)
-
-  let rec subst_type env sigma typ = function
-  | [] -> typ
-  | h::rest ->
-      match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with
-        | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
-        | _ -> Util.anomaly "Non-functional construction"
-
-                                                                                
-  let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar =
-    match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
-      | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b
-      | T.Sort s -> Coq_sort (T.family_of_sort s)
-      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
-  in concl_of_arity env ft
-                                                                                
-let typeur sigma metamap =
-  let rec type_of env cstr=
-    match Term.kind_of_term cstr with
-    | T.Meta n ->
-          (try T.strip_outer_cast (List.assoc n metamap)
-           with Not_found -> Util.anomaly "type_of: this is not a well-typed term")
-    | T.Rel n ->
-        let (_,_,ty) = Environ.lookup_rel n env in
-        T.lift n ty
-    | T.Var id ->
-        (try
-          let (_,_,ty) = Environ.lookup_named id env in
-          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 -> 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)
-          with Not_found -> Util.anomaly "type_of: Bad recursive type" in
-        let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in
-        (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with
-          | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c]))
-          | _ -> t)
-    | T.Lambda (name,c1,c2) ->
-          T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2)
-    | T.LetIn (name,b,c1,c2) ->
-         T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2)
-    | T.Fix ((_,i),(_,tys,_)) -> tys.(i)
-    | T.CoFix (i,(_,tys,_)) -> tys.(i)
-    | T.App(f,args)->
-        T.strip_outer_cast
-          (subst_type env sigma (type_of env f) (Array.to_list args))
-    | T.Cast (c,_, t) -> t
-    | T.Sort _ | T.Prod _ ->
-       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.type1_univ (* ERROR HERE *)
-        | CProp -> T.mkConst DoubleTypeInference.cprop
-                                                                                
-  and sort_of env t =
-    match Term.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) ->
-       (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with
-          | _, (Coq_sort T.InProp as s) -> s
-          | Coq_sort T.InProp, (Coq_sort T.InSet as s)
-          | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s
-          | Coq_sort T.InType, (Coq_sort T.InSet as s)
-          | CProp, (Coq_sort T.InSet as s) when
-              Environ.engagement env = Some Declarations.ImpredicativeSet -> s
-          | Coq_sort T.InType, Coq_sort T.InSet
-          | CProp, Coq_sort T.InSet -> Coq_sort T.InType
-          | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*)
-          | _, (CProp as s) -> s)
-    | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-                                                                                
-  and sort_family_of env t =
-    match T.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2
-    | T.App(f,args) ->
-       sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-                                                                                
-  in type_of, sort_of, sort_family_of
-
-  let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
-  let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
-
- end
-;;
-
-let get_sort_family_of env evar_map ty =
- CPropRetyping.get_sort_family_of env evar_map ty
-;;
-
-let type_as_sort env evar_map ty =
-(* CCorn code *)
- family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty)
-;;
-
-let is_a_Prop =
- function
-    "Prop"
-  | "CProp" -> true
-  | _ -> false
-;;
-
-(* Main Functions *)
-
-type anntypes =
- {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option}
-;;
-
-let gen_id seed =
- let res = "i" ^ string_of_int !seed in
-  incr seed ;
-  res
-;;
-
-let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids =
- fun father t ->
-  let res = gen_id seed in
-   Hashtbl.add ids_to_father_ids res father ;
-   Hashtbl.add ids_to_terms res t ;
-   Acic.CicHash.add constr_to_ids t res ;
-   res
-;;
-
-let source_id_of_id id = "#source#" ^ id;;
-
-let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
- ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
- ?(fake_dependent_products=false) env idrefs evar_map t expectedty
-=
- let module D = DoubleTypeInference in
- let module E = Environ in
- let module N = Names in
- let module A = Acic in
- let module T = Term in
-  let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in
-   (* CSC: do you have any reasonable substitute for 503? *)
-   let terms_to_types = Acic.CicHash.create 503 in
-    D.double_type_of env evar_map t expectedty terms_to_types ;
-    let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env
-     idrefs ?(subst=None,[]) tt
-    =
-     let fresh_id'' = fresh_id' father tt in
-     let aux' = aux computeinnertypes (Some fresh_id'') [] in
-      let string_of_sort_family =
-       function
-          Coq_sort T.InProp -> "Prop"
-        | Coq_sort T.InSet  -> "Set"
-        | Coq_sort T.InType -> "Type"
-        | CProp -> "CProp"
-      in
-      let string_of_sort t =
-       string_of_sort_family
-        (type_as_sort env evar_map t)
-      in
-       let ainnertypes,innertype,innersort,expected_available =
-        let {D.synthesized = synthesized; D.expected = expected} =
-         if computeinnertypes then
-try
-          Acic.CicHash.find terms_to_types tt
-with _ ->
-(*CSC: Warning: it really happens, for example in Ring_theory!!! *)
-Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
-         else
-          (* We are already in an inner-type and Coscoy's double *)
-          (* type inference algorithm has not been applied.      *)
-          (* We need to refresh the universes because we are doing *)
-          (* type inference on an already inferred type.           *)
-          {D.synthesized =
-            Reductionops.nf_beta evar_map
-             (CPropRetyping.get_type_of env evar_map
-              (Termops.refresh_universes tt)) ;
-           D.expected = None}
-        in
-(* Debugging only:
-print_endline "TERMINE:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ;
-print_endline "TIPO:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ;
-print_endline "ENVIRONMENT:" ; flush stdout ;
-Pp.ppnl (Printer.pr_context_of env) ; flush stdout ;
-print_endline "FINE_ENVIRONMENT" ; flush stdout ;
-*)
-         let innersort =
-          let synthesized_innersort =
-           get_sort_family_of env evar_map synthesized
-          in
-           match expected with
-              None -> synthesized_innersort
-            | Some ty ->
-              let expected_innersort =
-               get_sort_family_of env evar_map ty
-              in
-               match expected_innersort, synthesized_innersort with
-                  CProp, _
-                | _, CProp -> CProp
-                | _, _ -> expected_innersort
-         in
-(* Debugging only:
-print_endline "PASSATO" ; flush stdout ;
-*)
-          let ainnertypes,expected_available =
-           if computeinnertypes then
-            let annexpected,expected_available =
-               match expected with
-                  None -> None,false
-                | Some expectedty' ->
-                   Some (aux false (Some fresh_id'') [] env idrefs expectedty'),
-                    true
-            in
-             Some
-              {annsynthesized =
-                aux false (Some fresh_id'') [] env idrefs synthesized ;
-               annexpected = annexpected
-              }, expected_available
-           else
-            None,false
-          in
-           ainnertypes,synthesized, string_of_sort_family innersort,
-            expected_available
-       in
-        let add_inner_type id =
-         match ainnertypes with
-            None -> ()
-          | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes
-        in
-
-         (* explicit_substitute_and_eta_expand_if_required h t t'         *)
-         (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit   *)
-         (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = [])  *)
-         (* check if [h] is a term that requires an explicit named        *)
-         (* substitution and, in that case, uses the first arguments of   *)
-         (* [t] as the actual arguments of the substitution. If there     *)
-         (* are not enough parameters in the list [t], then eta-expansion *)
-         (* is performed.                                                 *)
-         let
-          explicit_substitute_and_eta_expand_if_required h t t'
-           compute_result_if_eta_expansion_not_required
-         =
-          let subst,residual_args,uninst_vars =
-           let variables,basedir =
-             try
-               let g = Libnames.global_of_constr h in
-               let sp =
-                match g with
-                   Libnames.ConstructRef ((induri,_),_)
-                 | Libnames.IndRef (induri,_) ->
-                    Nametab.sp_of_global (Libnames.IndRef (induri,0))
-                 | Libnames.VarRef id ->
-                    (* Invariant: variables are never cooked in Coq *)
-                    raise Not_found
-                 | _ -> Nametab.sp_of_global g
-               in
-               Dischargedhypsmap.get_discharged_hyps sp,
-               get_module_path_of_section_path sp
-             with Not_found ->
-                (* no explicit substitution *)
-                [], Libnames.dirpath_of_string "dummy"
-           in
-           (* returns a triple whose first element is  *)
-           (* an explicit named substitution of "type" *)
-           (* (variable * argument) list, whose        *)
-           (* second element is the list of residual   *)
-           (* arguments and whose third argument is    *) 
-           (* the list of uninstantiated variables     *)
-           let rec get_explicit_subst variables arguments =
-            match variables,arguments with
-               [],_ -> [],arguments,[]
-             | _,[] -> [],[],variables
-             | he1::tl1,he2::tl2 ->
-                let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in
-                let (he1_sp, he1_id) = Libnames.repr_path he1 in
-                let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in
-                let he1'' =
-                 String.concat "/"
-                  (List.map Names.string_of_id (List.rev he1')) ^ "/"
-                 ^ (Names.string_of_id he1_id) ^ ".var" 
-                in
-                 (he1'',he2)::subst, extra_args, uninst
-           in
-            get_explicit_subst variables t'
-          in
-           let uninst_vars_length = List.length uninst_vars in
-            if uninst_vars_length > 0 then
-             (* Not enough arguments provided. We must eta-expand! *)
-             let un_args,_ =
-              T.decompose_prod_n uninst_vars_length
-               (CPropRetyping.get_type_of env evar_map tt)
-             in
-              let eta_expanded =
-               let arguments =
-                List.map (T.lift uninst_vars_length) t @
-                 Termops.rel_list 0 uninst_vars_length
-               in
-                Unshare.unshare
-                 (T.lamn uninst_vars_length un_args
-                  (T.applistc h arguments))
-              in
-               D.double_type_of env evar_map eta_expanded
-                None terms_to_types ;
-               Hashtbl.remove ids_to_inner_types fresh_id'' ;
-               aux' env idrefs eta_expanded
-            else
-             compute_result_if_eta_expansion_not_required subst residual_args
-         in
-
-          (* Now that we have all the auxiliary functions we  *)
-          (* can finally proceed with the main case analysis. *) 
-          match T.kind_of_term tt with
-             T.Rel n ->
-              let id =
-               match List.nth (E.rel_context env) (n - 1) with
-                  (N.Name id,_,_)   -> id
-                | (N.Anonymous,_,_) -> Nameops.make_ident "_" None
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.ARel (fresh_id'', n, List.nth idrefs (n-1), id)
-           | T.Var id ->
-	      let pvars = Termops.ids_of_named_context (E.named_context env) in
-	      let pvars = List.map N.string_of_id pvars in
-              let path = get_uri_of_var (N.string_of_id id) pvars in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.AVar
-                (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var")
-           | T.Evar (n,l) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              A.AEvar
-               (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l))
-           | T.Meta _ -> Util.anomaly "Meta met during exporting to XML"
-           | T.Sort s -> A.ASort (fresh_id'', s)
-           | T.Cast (v,_, t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t)
-           | T.Prod (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  if not fake_dependent_products && T.noccurn 1 t then
-                   N.Anonymous
-                  else
-                   N.Name
-                    (Nameops.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id''
-                (string_of_sort innertype) ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let new_passed_prods =
-                let father_is_prod =
-                 match father with
-                    None -> false
-                  | Some father' ->
-                     match
-                      Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                     with
-                        T.Prod _ -> true
-                      | _ -> false
-                in
-                 (fresh_id'', n', aux' env idrefs s)::
-                  (if father_is_prod then
-                    passed_lambdas_or_prods_or_letins
-                   else [])
-               in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Prod _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_prods
-                       new_env new_idrefs t
-                   | _ ->
-                     A.AProds (new_passed_prods, aux' new_env new_idrefs t))
-           | T.Lambda (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  N.Name (Nameops.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let father_is_lambda =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.Lambda _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort &&
-                   ((not father_is_lambda) || expected_available)
-                then add_inner_type fresh_id'' ;
-                let new_passed_lambdas =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_lambda then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Lambda _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_lambdas
-                       new_env new_idrefs t
-                   | _ ->
-                     let t' = aux' new_env new_idrefs t in
-                      (* eta-expansion for explicit named substitutions *)
-                      (* can create nested Lambdas. Here we perform the *)
-                      (* flattening.                                    *)
-                      match t' with
-                         A.ALambdas (lambdas, t'') ->
-                          A.ALambdas (lambdas@new_passed_lambdas, t'')
-                       | _ ->
-                         A.ALambdas (new_passed_lambdas, t')
-                 )
-           | T.LetIn (n,s,t,d) ->
-              let id =
-               match n with
-                   N.Anonymous -> N.id_of_string "_X"
-                 | N.Name id -> id
-              in
-              let n' =
-               N.Name (Nameops.next_ident_away id (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcesort =
-                get_sort_family_of env evar_map
-                 (CPropRetyping.get_type_of env evar_map s)
-               in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort_family sourcesort) ;
-               let father_is_letin =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.LetIn _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort then
-                 add_inner_type fresh_id'' ;
-                let new_passed_letins =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_letin then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', Some s, t) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term d with
-                     T.LetIn _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_letins
-                       new_env new_idrefs d
-                   | _ -> A.ALetIns
-                           (new_passed_letins, aux' new_env new_idrefs d))
-           | T.App (h,t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let
-               compute_result_if_eta_expansion_not_required subst residual_args
-              =
-               let residual_args_not_empty = residual_args <> [] in
-               let h' =
-                if residual_args_not_empty then
-                 aux' env idrefs ~subst:(None,subst) h
-                else
-                 aux' env idrefs ~subst:(Some fresh_id'',subst) h
-               in
-                (* maybe all the arguments were used for the explicit *)
-                (* named substitution                                 *)
-                if residual_args_not_empty then
-                 A.AApp (fresh_id'', h'::residual_args)
-                else
-                 h'
-              in
-               let t' =
-                Array.fold_right (fun x i -> (aux' env idrefs x)::i) t []
-               in
-                explicit_substitute_and_eta_expand_if_required h
-                 (Array.to_list t) t'
-                 compute_result_if_eta_expansion_not_required
-           | T.Const kn ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn)))
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Ind (kn,i) ->
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Construct ((kn,i),j) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConstruct
-                (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Case ({T.ci_ind=(kn,i)},ty,term,a) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let a' =
-               Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
-              in
-               A.ACase
-                (fresh_id'', (uri_of_kernel_name (Inductive kn)), i,
-                  aux' env idrefs ty, aux' env idrefs term, a')
-           | T.Fix ((ai,i),(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Nameops.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.AFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi,ai) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi', ai,
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                   (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f'
-                  ) []
-                 )
-           | T.CoFix (i,(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Nameops.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.ACoFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi',
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                    (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f'
-                  ) []
-                 )
-    in
-     aux computeinnertypes None [] env idrefs t
-;;
-
-(* Obsolete [HH 1/2009]
-let acic_of_cic_context metasenv context t =
- let ids_to_terms = Hashtbl.create 503 in
- let constr_to_ids = Acic.CicHash.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let seed = ref 0 in
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types metasenv context t,
-   ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
-;;
-*)
-
-let acic_object_of_cic_object sigma obj =
- let module A = Acic in
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let ids_to_conjectures = Hashtbl.create 11 in
-  let ids_to_hypotheses = Hashtbl.create 127 in
-  let hypotheses_seed = ref 0 in
-  let conjectures_seed = ref 0 in
-  let seed = ref 0 in
-  let acic_term_of_cic_term_context' =
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types in
-(*CSC: is this the right env to use? Hhmmm. There is a problem: in    *)
-(*CSC: Global.env () the object we are exporting is already defined,  *)
-(*CSC: either in the environment or in the named context (in the case *)
-(*CSC: of variables. Is this a problem?                               *)
-  let env = Global.env () in
-  let acic_term_of_cic_term' ?fake_dependent_products =
-   acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in
-(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *)
-(*CSC: a modified version of the already existent fresh_id function    *)
-  let fresh_id () =
-   let res = "i" ^ string_of_int !seed in
-    incr seed ;
-    res
-  in
-   let aobj =
-    match obj with
-      A.Constant (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           None -> None
-         | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty))
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AConstant (fresh_id (),id,abo,aty,params)
-    | A.Variable (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
-         | None -> None
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AVariable (fresh_id (),id,abo,aty,params)
-    | A.CurrentProof (id,conjectures,bo,ty) ->
-       let aconjectures =
-        List.map
-         (function (i,canonical_context,term) as conjecture ->
-           let cid = "c" ^ string_of_int !conjectures_seed in
-            Hashtbl.add ids_to_conjectures cid conjecture ;
-            incr conjectures_seed ;
-            let canonical_env,idrefs',acanonical_context =
-             let rec aux env idrefs =
-              function
-                 [] -> env,idrefs,[]
-               | ((n,decl_or_def) as hyp)::tl ->
-                  let hid = "h" ^ string_of_int !hypotheses_seed in
-                  let new_idrefs = hid::idrefs in
-                   Hashtbl.add ids_to_hypotheses hid hyp ;
-                   incr hypotheses_seed ;
-                   match decl_or_def with
-                       A.Decl t ->
-                        let final_env,final_idrefs,atl =
-                         aux (Environ.push_rel (Names.Name n,None,t) env)
-                          new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                          final_env,final_idrefs,(hid,(n,A.Decl at))::atl
-                     | A.Def (t,ty) ->
-                        let final_env,final_idrefs,atl =
-                         aux
-                          (Environ.push_rel (Names.Name n,Some t,ty) env)
-                           new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                         let dummy_never_used =
-                          let s = "dummy_never_used" in
-                           A.ARel (s,99,s,Names.id_of_string s)
-                         in
-                          final_env,final_idrefs,
-                           (hid,(n,A.Def (at,dummy_never_used)))::atl
-             in
-              aux env [] canonical_context
-            in
-             let aterm =
-              acic_term_of_cic_term_context' canonical_env idrefs' sigma term
-               None
-             in
-              (cid,i,List.rev acanonical_context,aterm)
-         ) conjectures in
-       let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in
-       let aty = acic_term_of_cic_term_context' env [] sigma ty None in
-        A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty)
-    | A.InductiveDefinition (tys,params,paramsno) ->
-       let env' =
-        List.fold_right
-         (fun (name,_,arity,_) env ->
-           Environ.push_rel (Names.Name name, None, arity) env
-         ) (List.rev tys) env in
-       let idrefs = List.map (function _ -> gen_id seed) tys in
-       let atys =
-        List.map2
-         (fun id (name,inductive,ty,cons) ->
-           let acons =
-            List.map
-             (function (name,ty) ->
-               (name,
-                 acic_term_of_cic_term_context' ~fake_dependent_products:true
-                  env' idrefs Evd.empty ty None)
-             ) cons
-           in
-            let aty =
-             acic_term_of_cic_term' ~fake_dependent_products:true ty None
-            in
-             (id,name,inductive,aty,acons)
-         ) (List.rev idrefs) tys
-       in
-       A.AInductiveDefinition (fresh_id (),atys,params,paramsno)
-   in
-    aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts,
-     ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses
-;;
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
deleted file mode 100644
index 17d1d5da..00000000
--- a/contrib/xml/doubleTypeInference.ml
+++ /dev/null
@@ -1,272 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *)
-type types = {synthesized : Term.types ; expected : Term.types option};;
-
-let prerr_endline _ = ();;
-
-let cprop =
- let module N = Names in
-  N.make_con
-   (N.MPfile
-     (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
-   (N.make_dirpath [])
-   (N.mk_label "CProp")
-;;
-
-let whd_betadeltaiotacprop env _evar_map ty =
- let module R = Rawterm in
- let module C = Closure in
- let module CR = C.RedFlags in
- (*** CProp is made Opaque ***)
- let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in
- C.whd_val (C.create_clos_infos flags env) (C.inject ty)
-;;
-
-
-(* Code similar to the code in the Typing module, but:   *)
-(*  - the term is already assumed to be well typed       *)
-(*  - some checks have been removed                      *)
-(*  - both the synthesized and expected types of every   *)
-(*    node are computed (Coscoy's double type inference) *)
-
-let assumption_of_judgment env sigma j =
-  Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment env sigma j =
-  Typeops.type_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment_cprop env sigma j =
-  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 *)
-;;
-
-let double_type_of env sigma cstr expectedty subterms_to_types =
- (*CSC: the code is inefficient because judgments are created just to be   *)
- (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *)
- (*CSC: functions used do checks that we do not need                       *)
- let rec execute env sigma cstr expectedty =
-  let module T = Term in
-  let module E = Environ in
-   (* the type part is the synthesized type *)
-   let judgement =
-    match T.kind_of_term cstr with
-       T.Meta n ->
-        Util.error
-         "DoubleTypeInference.double_type_of: found a non-instanciated goal"
- 
-     | T.Evar ((n,l) as ev) ->
-        let ty = Unshare.unshare (Evd.existential_type sigma ev) in
-        let jty = execute env sigma ty None in
-        let jty = assumption_of_judgment env sigma jty in
-        let evar_context = 
-	  E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
-         let rec iter actual_args evar_context =
-          match actual_args,evar_context with
-             [],[] -> ()
-           | he1::tl1,(n,_,ty)::tl2 ->
-              (* for side-effects *)
-              let _ = execute env sigma he1 (Some ty) in
-              let tl2' =
-               List.map
-                (function (m,bo,ty) ->
-                  (* Warning: the substitution should be performed also on bo *)
-                  (* This is not done since bo is not used later yet          *)
-                  (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty))
-                ) tl2
-              in
-               iter tl1 tl2'
-           | _,_ -> assert false
-         in
-          (* for side effects only *)
-          iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
-          E.make_judge cstr jty
-	
-     | T.Rel n -> 
-        Typeops.judge_of_relative env n
-
-     | T.Var id -> 
-        Typeops.judge_of_variable env id
-	  
-     | T.Const c ->
-        E.make_judge cstr (Typeops.type_of_constant env c)
-	  
-     | T.Ind ind ->
-        E.make_judge cstr (Inductiveops.type_of_inductive env ind)
-	  
-     | T.Construct cstruct -> 
-        E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
-	  
-     | T.Case (ci,p,c,lf) ->
-        let expectedtype =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in 
-        let cj = execute env sigma c (Some expectedtype) in
-        let pj = execute env sigma p None in
-        let (expectedtypes,_,_) =
-         let indspec = Inductive.find_rectype env cj.Environ.uj_type in
-          Inductive.type_case_branches env indspec pj cj.Environ.uj_val
-        in
-        let lfj =
-         execute_array env sigma lf
-          (Array.map (function x -> Some x) expectedtypes) in
-        let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
-         j
-  
-     | T.Fix ((vn,i as vni),recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let fix = (vni,recdef') in
-        E.make_judge (T.mkFix fix) tys.(i)
-	  
-     | T.CoFix (i,recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let cofix = (i,recdef') in
-        E.make_judge (T.mkCoFix cofix) tys.(i)
-	  
-     | T.Sort (T.Prop c) -> 
-        Typeops.judge_of_prop_contents c
-
-     | T.Sort (T.Type u) ->
-(*CSC: In case of need, I refresh the universe. But exportation of the   *)
-(*CSC: right universe level information is destroyed. It must be changed *)
-(*CSC: again once Judicael will introduce his non-bugged algebraic       *)
-(*CSC: universes.                                                        *)
-(try
-        Typeops.judge_of_type u
- with _ -> (* Successor of a non universe-variable universe anomaly *)
- (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
-  Typeops.judge_of_type (Termops.new_univ ())
-)
-
-     | T.App (f,args) ->
-        let expected_head = 
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in 
-        let j = execute env sigma f (Some expected_head) in
-        let expected_args =
-         let rec aux typ =
-          function
-             [] -> []
-           | hj::restjl ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with
-                 T.Prod (_,c1,c2) ->
-                  (Some (Reductionops.nf_beta sigma c1)) ::
-                   (aux (T.subst1 hj c2) restjl)
-               | _ -> assert false
-         in
-          Array.of_list (aux j.Environ.uj_type (Array.to_list args))
-        in
-        let jl = execute_array env sigma args expected_args in
-        let (j,_) = Typeops.judge_of_apply env j jl in
-         j
-	    
-     | T.Lambda (name,c1,c2) -> 
-        let j = execute env sigma c1 None in
-        let var = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,var.E.utj_val) env in
-        let expectedc2type =
-         match expectedty with
-            None -> None
-          | Some ety ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with
-                 T.Prod (_,_,expected_target_type) ->
-                  Some (Reductionops.nf_beta sigma expected_target_type)
-               | _ -> assert false
-        in
-        let j' = execute env1 sigma c2 expectedc2type in 
-         Typeops.judge_of_abstraction env1 name var j'
-	  
-     | T.Prod (name,c1,c2) ->
-        let j = execute env sigma c1 None in
-        let varj = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,varj.E.utj_val) env in
-        let j' = execute env1 sigma c2 None in
-        (match type_judgment_cprop env1 sigma j' with
-            Some varj' -> Typeops.judge_of_product env name varj varj'
-          | None ->
-             (* CProp found *)
-             { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val);
-               Environ.uj_type = T.mkConst cprop })
-
-     | T.LetIn (name,c1,c2,c3) ->
-(*CSC: What are the right expected types for the source and *)
-(*CSC: target of a LetIn? None used.                        *)
-        let j1 = execute env sigma c1 None in
-        let j2 = execute env sigma c2 None in
-        let j2 = type_judgment env sigma j2 in
-        let env1 =
-         E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env
-        in
-         let j3 = execute env1 sigma c3 None in
-          Typeops.judge_of_letin env name j1 j2 j3
-  
-     | T.Cast (c,k,t) ->
-        let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in
-        let tj = execute env sigma t None in
-	let tj = type_judgment env sigma tj in
-        let j, _ = Typeops.judge_of_cast env cj k tj in
-	 j
-    in
-     let synthesized = E.j_type judgement in
-     let synthesized' = Reductionops.nf_beta sigma synthesized in
-      let types,res =
-       match expectedty with
-          None ->
-           (* No expected type *)
-           {synthesized = synthesized' ; expected = None}, synthesized
-        | Some ty when Term.eq_constr synthesized' ty ->
-           (* The expected type is synthactically equal to the    *)
-           (* synthesized type. Let's forget it.                  *)
-           (* Note: since eq_constr is up to casts, it is better  *)
-           (* to keep the expected type, since it can bears casts *)
-           (* that change the innersort to CProp                  *)
-           {synthesized = ty ; expected = None}, ty
-        | Some expectedty' ->
-           {synthesized = synthesized' ; expected = Some expectedty'},
-           expectedty'
-      in
-(*CSC: debugging stuff to be removed *)
-if Acic.CicHash.mem subterms_to_types cstr then
- (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ;
-       Acic.CicHash.add subterms_to_types cstr types ;
-       E.make_judge cstr res
-
-
- and execute_recdef env sigma (names,lar,vdef) =
-   let length = Array.length lar in
-   let larj =
-    execute_array env sigma lar (Array.make length None) in
-   let lara = Array.map (assumption_of_judgment env sigma) larj in
-   let env1 = Environ.push_rec_types (names,lara,vdef) env in
-   let expectedtypes =
-    Array.map (function i -> Some (Term.lift length i)) lar
-   in
-   let vdefj = execute_array env1 sigma vdef expectedtypes in
-   let vdefv = Array.map Environ.j_val vdefj in
-   (names,lara,vdefv)
-
- and execute_array env sigma v expectedtypes =
-   let jl =
-    execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes)
-   in
-    Array.of_list jl
-
- and execute_list env sigma =
-  List.map2 (execute env sigma)
-
-in
- ignore (execute env sigma cstr expectedty)
-;;
diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli
deleted file mode 100644
index 2e14b558..00000000
--- a/contrib/xml/doubleTypeInference.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/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-type types = { synthesized : Term.types; expected : Term.types option; } 
-
-val cprop : Names.constant
-
-val whd_betadeltaiotacprop :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
-
-val double_type_of :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option ->
-   types Acic.CicHash.t -> unit
diff --git a/contrib/xml/dumptree.ml4 b/contrib/xml/dumptree.ml4
deleted file mode 100644
index 407f86b3..00000000
--- a/contrib/xml/dumptree.ml4
+++ /dev/null
@@ -1,152 +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        *)
-(************************************************************************)
-
-(** 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/proof2aproof.ml b/contrib/xml/proof2aproof.ml
deleted file mode 100644
index 30dc7b71..00000000
--- a/contrib/xml/proof2aproof.ml
+++ /dev/null
@@ -1,176 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Note: we can not use the Set module here because we _need_ physical *)
-(* equality and there exists no comparison function compatible with    *)
-(* physical equality.                                                  *)
-
-module S =
- struct
-  let empty = []
-  let mem = List.memq
-  let add x l = x::l
- end
-;;
-
-(* evar reduction that preserves some terms *)
-let nf_evar sigma ~preserve =
- let module T = Term in
-  let rec aux t =
-   if preserve t then t else
-    match T.kind_of_term t with
-     | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
-     | T.Construct _ -> t
-     | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
-     | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
-     | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
-     | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
-     | T.App (c,l) ->
-        let c' = aux c in
-        let l' = Array.map aux l in
-         (match T.kind_of_term c' with
-             T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-           | T.Cast (he,_,_) ->
-              (match T.kind_of_term he with
-                  T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-                | _ -> T.mkApp (c', l')
-              )
-           | _ -> T.mkApp (c', l'))
-     | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
-	aux (Evd.existential_value sigma (e,l))
-     | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
-     | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
-     | T.Fix (ln,(lna,tl,bl)) ->
-         T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-     | T.CoFix(ln,(lna,tl,bl)) ->
-         T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-   in
-    aux
-;;
-
-(* Unshares a proof-tree.                                                  *)
-(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
-let rec unshare_proof_tree =
- let module PT = Proof_type in
-  function {PT.open_subgoals = status ; 
-	    PT.goal = goal ; 
-	    PT.ref = ref} ->
-   let unshared_ref =
-    match ref with
-       None -> None
-     | Some (rule,pfs) ->
-        let unshared_rule =
-         match rule with
-             PT.Nested (cmpd, pf) ->
-               PT.Nested (cmpd, unshare_proof_tree pf)
-	   | other -> other
-	in
-         Some (unshared_rule, List.map unshare_proof_tree pfs)
-   in
-    {PT.open_subgoals = status ; 
-     PT.goal = goal ; 
-     PT.ref = unshared_ref}
-;;
-
-module ProofTreeHash =
- Hashtbl.Make
-  (struct
-    type t = Proof_type.proof_tree
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-
-let extract_open_proof sigma pf =
- let module PT = Proof_type in
- let module L = Logic in
-  let evd = ref (Evd.create_evar_defs sigma) in
-  let proof_tree_to_constr = ProofTreeHash.create 503 in
-  let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in
-  let unshared_constrs = ref S.empty in
-  let rec proof_extractor vl node =
-   let constr =
-    match node with
-       {PT.ref=Some(PT.Prim _,_)} as pf ->
-        L.prim_extractor proof_extractor vl pf
-	  
-     | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
-	 let sgl,v = Refiner.frontier hidden_proof in
-	 let flat_proof = v spfl in
-         ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
-	 proof_extractor vl flat_proof
-	  
-     | {PT.ref=None;PT.goal=goal} ->
-	 let visible_rels =
-           Util.map_succeed
-             (fun id ->
-                (* Section variables are in the [id] list but are not *)
-                (* lambda abstracted in the term [vl]                 *)
-                try let n = Logic.proof_variable_index id vl in (n,id)
-	        with Not_found -> failwith "caught")
-(*CSC: the above function must be modified such that when it is found  *)
-(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used  *)
-(*CSC: as the evar_instance. Ordering the instance becomes useless (it *)
-(*CSC: will already be ordered.                                        *)
-             (Termops.ids_of_named_context 
-		(Environ.named_context_of_val goal.Evd.evar_hyps)) in
-	 let sorted_rels =
-	   Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in
-	 let context =
-	   let l = 
-             List.map
-               (fun (_,id) -> Sign.lookup_named id 
-		   (Environ.named_context_of_val goal.Evd.evar_hyps))
-               sorted_rels in
-	   Environ.val_of_named_context l
-         in
-(*CSC: the section variables in the right order must be added too *)
-         let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in
-    (*     let env = Global.env_of_context context in *)
-	 let evd',evar =
-           Evarutil.new_evar_instance context !evd goal.Evd.evar_concl
-             evar_instance in
-         evd := evd' ;
-         evar
-	  
-     | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor"
-   in
-    let unsharedconstr =
-     let evar_nf_constr =
-      nf_evar (Evd.evars_of !evd)
-        ~preserve:(function e -> S.mem e !unshared_constrs) constr
-     in
-      Unshare.unshare
-       ~already_unshared:(function e -> S.mem e !unshared_constrs)
-       evar_nf_constr
-    in
-(*CSC: debugging stuff to be removed *)
-if ProofTreeHash.mem proof_tree_to_constr node then
- Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ")
- (Tactic_printer.print_proof (Evd.evars_of !evd) [] node)) ;
-     ProofTreeHash.add proof_tree_to_constr node unsharedconstr ;
-     unshared_constrs := S.add unsharedconstr !unshared_constrs ;
-     unsharedconstr
-  in
-  let unshared_pf = unshare_proof_tree pf in
-  let pfterm = proof_extractor [] unshared_pf in
-   (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
-    unshared_pf)
-;;
-
-let extract_open_pftreestate pts =
-  extract_open_proof (Refiner.evc_of_pftreestate pts)
-   (Tacmach.proof_of_pftreestate pts)
-;;
diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4
deleted file mode 100644
index 7503d632..00000000
--- a/contrib/xml/proofTree2Xml.ml4
+++ /dev/null
@@ -1,210 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
-
-let std_ppcmds_to_string s =
-   Pp.msg_with Format.str_formatter s;
-   Format.flush_str_formatter ()
-;;
-
-let idref_of_id id = "v" ^ id;;
-
-(* Transform a constr to an Xml.token Stream.t *)
-(* env is a named context                      *)
-(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *)
-let constr_to_xml obj sigma env =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-
-  (* named_context holds section variables and local variables *)
-  let named_context = Environ.named_context env  in
-  (* real_named_context holds only the section variables *)
-  let real_named_context = Environ.named_context (Global.env ()) in
-  (* named_context' holds only the local variables *)
-  let named_context' =
-   List.filter (function n -> not (List.mem n real_named_context)) named_context
-  in
-  let idrefs =
-   List.map
-    (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in
-  let rel_context = Sign.push_named_to_rel_context named_context' [] in
-  let rel_env =
-   Environ.push_rel_context rel_context
-    (Environ.reset_with_named_context 
-	(Environ.val_of_named_context real_named_context) env) in
-  let obj' =
-   Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
-  let seed = ref 0 in
-   try
-    let annobj =
-     Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids
-      ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env
-      idrefs sigma (Unshare.unshare obj') None
-    in
-     Acic2Xml.print_term ids_to_inner_sorts annobj
-   with e ->
-    Util.anomaly
-     ("Problem during the conversion of constr into XML: " ^
-      Printexc.to_string e)
-(* CSC: debugging stuff
-Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ;
-Pp.ppnl (Pp.str "ENVIRONMENT:") ;
-Pp.ppnl (Printer.pr_context_of rel_env) ;
-Pp.ppnl (Pp.str "TERM:") ;
-Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ;
-Pp.ppnl (Pp.str "RAW-TERM:") ;
-Pp.ppnl (Printer.pr_lconstr obj') ;
-Xml.xml_empty "MISSING TERM" [] (*; raise e*)
-*)
-;;
-
-let first_word s =
-   try let i = String.index s ' ' in
-       String.sub s 0 i
-   with _ -> s
-;;
-
-let string_of_prim_rule x = match x with
-  | Proof_type.Intro _-> "Intro"
-  | Proof_type.Cut _ -> "Cut"
-  | Proof_type.FixRule _ -> "FixRule"
-  | Proof_type.Cofix _ -> "Cofix"
-  | Proof_type.Refine _ -> "Refine"
-  | Proof_type.Convert_concl _ -> "Convert_concl"
-  | Proof_type.Convert_hyp _->"Convert_hyp"
-  | Proof_type.Thin _ -> "Thin"
-  | Proof_type.ThinBody _-> "ThinBody"
-  | Proof_type.Move (_,_,_) -> "Move"
-  | Proof_type.Order _ -> "Order"
-  | Proof_type.Rename (_,_) -> "Rename"
-  | Proof_type.Change_evars -> "Change_evars"
-
-let
- print_proof_tree curi sigma pf proof_tree_to_constr
-  proof_tree_to_flattened_proof_tree constr_to_ids
-=
- let module PT = Proof_type in
- let module L = Logic in
- let module X = Xml in
- let module T = Tacexpr in
-  let ids_of_node node =
-   let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in
-(*
-let constr =
- try
-    Proof2aproof.ProofTreeHash.find proof_tree_to_constr node
- with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated
-no lambda-term: ") (Refiner.print_script true (Evd.empty)
-(Global.named_context ()) node)) ; assert false (* Closed bug, should not
-happen any more *)
-in
-*)
-   try
-    Some (Acic.CicHash.find constr_to_ids constr)
-   with _ ->
-Pp.ppnl (Pp.(++) (Pp.str
-"The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
-(Printer.pr_lconstr constr)) ;
-    None
-  in
-  let rec aux node old_hyps =
-   let of_attribute =
-    match ids_of_node node with
-       None -> []
-     | Some id -> ["of",id]
-   in
-    match node with
-       {PT.ref=Some(PT.Prim tactic_expr,nodes)} ->
-         let tac = string_of_prim_rule tactic_expr in
-         let of_attribute = ("name",tac)::of_attribute in
-          if nodes = [] then
-           X.xml_empty "Prim" of_attribute
-          else
-           X.xml_nempty "Prim" of_attribute
-            (List.fold_left
-              (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
-
-     | {PT.goal=goal;
-        PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
-         (* [hidden_proof] is the proof of the tactic;                     *)
-         (* [nodes] are the proof of the subgoals generated by the tactic; *)
-         (* [flat_proof] if the proof-tree obtained substituting [nodes]   *)
-         (*  for the holes in [hidden_proof]                               *)
-        let flat_proof =
-         Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
-        in begin
-        match tactic_expr with
-        | T.TacArg (T.Tacexp _) -> 
-            (* We don't need to keep the level of abstraction introduced at *)
-            (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
-            aux flat_proof old_hyps
-        | _ ->
-         (****** la tactique employee *)
-	 let prtac = Pptactic.pr_tactic (Global.env()) in
-         let tac = std_ppcmds_to_string (prtac tactic_expr) in
-         let tacname= first_word tac in
-         let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
-
-         (****** le but *)
-         let {Evd.evar_concl=concl;
-              Evd.evar_hyps=hyps}=goal in
-
-         let env = Global.env_of_context hyps in
-
-         let xgoal =
-          X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
-
-         let rec build_hyps =
-          function
-           | [] -> xgoal
-           | (id,c,tid)::hyps1 ->
-              let id' = Names.string_of_id id in
-               [< build_hyps hyps1;
-                  (X.xml_nempty "Hypothesis"
-                    ["id",idref_of_id id' ; "name",id']
-                    (constr_to_xml tid sigma env))
-               >] in
-         let old_names = List.map (fun (id,c,tid)->id) old_hyps in
-	 let nhyps = Environ.named_context_of_val hyps in
-         let new_hyps =
-          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in
-
-         X.xml_nempty "Tactic" of_attribute
-          [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
-        end
-
-     | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
-         Util.anomaly "Not Implemented" 
-
-     | {PT.ref=Some(PT.Daimon,_)} ->
-         X.xml_empty "Hidden_open_goal" of_attribute
-
-     | {PT.ref=None;PT.goal=goal} ->
-         X.xml_empty "Open_goal" of_attribute
-  in
-   [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-      X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
-      X.xml_nempty "ProofTree" ["of",curi] (aux pf [])
-   >]
-;;
-
-
-(* Hook registration *)
-(* CSC: debranched since it is bugged
-Xmlcommand.set_print_proof_tree print_proof_tree;;
-*)
diff --git a/contrib/xml/theoryobject.dtd b/contrib/xml/theoryobject.dtd
deleted file mode 100644
index 953fe009..00000000
--- a/contrib/xml/theoryobject.dtd
+++ /dev/null
@@ -1,62 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM 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 General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-
-
-<!-- Notice: the markup described in this DTD is meant to be embedded -->
-<!-- in foreign markup (e.g. XHTML)                                   -->
-
-<!ENTITY % theorystructure
-  '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'>
-
-<!ELEMENT ht:SECTION (%theorystructure;)>
-<!ATTLIST ht:SECTION
-          uri CDATA #REQUIRED>
-
-<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)>
-
-<!-- Theory Items -->
-
-<!ELEMENT ht:AXIOM (Axiom)>
-<!ATTLIST ht:AXIOM
-          uri CDATA #REQUIRED
-          as (Axiom|Declaration) #REQUIRED>
-
-<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)>
-<!ATTLIST ht:DEFINITION
-          uri CDATA #REQUIRED
-          as (Definition|InteractiveDefinition|Inductive|CoInductive
-             |Record) #REQUIRED>
-
-<!ELEMENT ht:THEOREM (type)>
-<!ATTLIST ht:THEOREM
-          uri CDATA #REQUIRED
-          as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED>
-
-<!ELEMENT ht:VARIABLE (Variable)>
-<!ATTLIST ht:VARIABLE
-          uri CDATA #REQUIRED
-          as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED>
diff --git a/contrib/xml/unshare.ml b/contrib/xml/unshare.ml
deleted file mode 100644
index f30f8230..00000000
--- a/contrib/xml/unshare.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-let unshare ?(already_unshared = function _ -> false) t =
- let obj = Obj.repr t in
-  let rec aux obj =
-   if already_unshared (Obj.obj obj) then
-    obj
-   else
-    (if Obj.is_int obj then
-      obj
-     else if Obj.is_block obj then
-      begin
-       let tag = Obj.tag obj in
-        if tag < Obj.no_scan_tag then
-         begin
-          let size = Obj.size obj in
-           let new_obj = Obj.new_block 0 size in
-            Obj.set_tag new_obj tag ;
-            for i = 0 to size - 1 do
-             Obj.set_field new_obj i (aux (Obj.field obj i))
-            done ;
-            new_obj
-         end
-        else if tag = Obj.string_tag then
-         obj
-        else
-         raise CanNotUnshare
-      end
-     else
-      raise CanNotUnshare
-    )
-  in
-   Obj.obj (aux obj)
-;;
diff --git a/contrib/xml/unshare.mli b/contrib/xml/unshare.mli
deleted file mode 100644
index 31ba9037..00000000
--- a/contrib/xml/unshare.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a
diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4
deleted file mode 100644
index 5b217119..00000000
--- a/contrib/xml/xml.ml4
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* the type token for XML cdata, empty elements and not-empty elements *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token = Str of string
-           | Empty of string * (string * string) list
-	   | NEmpty of string * (string * string) list * token Stream.t
-;;
-
-(* currified versions of the constructors make the code more readable *)
-let xml_empty name attrs = [< 'Empty(name,attrs) >]
-let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
-let xml_cdata str = [< 'Str str >]
-
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-let pp_ch strm channel =
- let rec pp_r m =
-  parser
-    [< 'Str a ; s >] ->
-      print_spaces m ;
-      fprint_string (a ^ "\n") ;
-      pp_r m s
-  | [< 'Empty(n,l) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string "/>\n" ;
-      pp_r m s
-  | [< 'NEmpty(n,l,c) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string ">\n" ;
-      pp_r (m+1) c ;
-      print_spaces m ;
-      fprint_string ("</" ^ n ^ ">\n") ;
-      pp_r m s
-  | [< >] -> ()
- and print_spaces m =
-  for i = 1 to m do fprint_string "  " done
- and fprint_string str =
-  output_string channel str
- in
-  pp_r 0 strm
-;;
-
-
-let pp strm fn =
-  match fn with
-     Some filename ->
-      let filename = filename ^ ".xml" in
-      let ch = open_out filename in
-       pp_ch strm ch;
-       close_out ch ;
-       print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n");
-       flush stdout
-   | None ->
-       pp_ch strm stdout
-;;
-
diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli
deleted file mode 100644
index 38a4e01c..00000000
--- a/contrib/xml/xml.mli
+++ /dev/null
@@ -1,40 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*i $Id: xml.mli 6681 2005-02-04 18:20:16Z herbelin $ i*)
-
-(* Tokens for XML cdata, empty elements and not-empty elements           *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token =
-  | Str of string
-  | Empty of string * (string * string) list
-  | NEmpty of string * (string * string) list * token Stream.t
-
-(* currified versions of the token constructors make the code more readable *)
-val xml_empty : string -> (string * string) list -> token Stream.t
-val xml_nempty :
-  string -> (string * string) list -> token Stream.t -> token Stream.t
-val xml_cdata : string -> token Stream.t
-
-val pp_ch : token Stream.t -> out_channel -> unit
-
-(* The pretty printer for streams of token                                  *)
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-val pp : token Stream.t -> string option -> unit
diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
deleted file mode 100644
index f4719594..00000000
--- a/contrib/xml/xmlcommand.ml
+++ /dev/null
@@ -1,708 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* CONFIGURATION PARAMETERS *)
-
-let verbose = ref false;;
-
-(* HOOKS *)
-let print_proof_tree, set_print_proof_tree =
- let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in
-  (fun () -> !print_proof_tree),
-   (fun f ->
-     print_proof_tree :=
-     fun
-      curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree
-      constr_to_ids
-     ->
-      Some
-       (f curi sigma0 pf proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids))
-;;
-
-(* UTILITY FUNCTIONS *)
-
-let print_if_verbose s = if !verbose then print_string s;;
-
-(* Next exception is used only inside print_coq_object and tag_of_string_tag *)
-exception Uninteresting;;
-
-(* NOT USED anymore, we back to the V6 point of view with global parameters 
-
-(* Internally, for Coq V7, params of inductive types are associated     *)
-(* not to the whole block of mutual inductive (as it was in V6) but to  *)
-(* each member of the block; but externally, all params are required    *)
-(* to be the same; the following function checks that the parameters    *)
-(* of each inductive of a same block are all the same, then returns     *)
-(* this number; it fails otherwise                                      *)
-let extract_nparams pack =
- let module D = Declarations in
- let module U = Util in
- let module S = Sign in
-
-  let {D.mind_nparams=nparams0} = pack.(0) in
-  let arity0 = pack.(0).D.mind_user_arity in
-  let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in
-  for i = 1 to Array.length pack - 1 do
-    let {D.mind_nparams=nparamsi} = pack.(i) in
-    let arityi = pack.(i).D.mind_user_arity in
-    let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in
-    if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block"
-  done;
-  nparams0
-
-*)
-
-(* could_have_namesakes sp = true iff o is an object that could be cooked and *)
-(* than that could exists in cooked form with the same name in a super        *)
-(* section of the actual section                                              *)
-let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
- let module DK = Decl_kinds in
- let module D = Declare in
-  let tag = Libobject.object_tag o in
-   print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
-   match tag with
-      "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*)
-;;
-
-(* filter_params pvars hyps *)
-(* filters out from pvars (which is a list of lists) all the variables *)
-(* that does not belong to hyps (which is a simple list)               *)
-(* It returns a list of couples relative section path -- list of       *)
-(* variable names.                                                     *)
-let filter_params pvars hyps =
- let rec aux ids =
-  function
-     [] -> []
-   | (id,he)::tl ->
-      let ids' = id::ids in
-      let ids'' =
-       "cic:/" ^
-        String.concat "/" (List.rev (List.map Names.string_of_id ids')) in
-      let he' =
-       ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in
-      let tl' = aux ids' tl in
-       match he' with
-          _,[] -> tl'
-        | _,_  -> he'::tl'
- in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
-   aux (Names.repr_dirpath modulepath) (List.rev pvars)
-;;
-
-type variables_type = 
-   Definition of string * Term.constr * Term.types
- | Assumption of string * Term.constr
-;;
-
-(* The computation is very inefficient, but we can't do anything *)
-(* better unless this function is reimplemented in the Declare   *)
-(* module.                                                       *)
-let search_variables () =
- let module N = Names in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
-   let rec aux =
-    function
-       [] -> []
-     | 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 (Decls.last_section_hyps dirpath) in
-           [he,t]
-        in
-         one_section_variables @ aux tl
-   in
-    aux
-     (Cic2acic.remove_module_dirpath_from_dirpath
-       ~basedir:modulepath cwd)
-;;
-
-(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *)
-
-let rec join_dirs cwd =
- function
-    []  -> cwd
-  | he::tail ->
-      (try
-        Unix.mkdir cwd 0o775
-       with _ -> () (* Let's ignore the errors on mkdir *)
-      ) ;
-     let newcwd = cwd ^ "/" ^ he in
-      join_dirs newcwd tail
-;;
-
-let filename_of_path xml_library_root tag =
- let module N = Names in
-  match xml_library_root with
-     None -> None  (* stdout *)
-   | Some xml_library_root' ->
-      let tokens = Cic2acic.token_list_of_kernel_name tag in
-       Some (join_dirs xml_library_root' tokens)
-;;
-
-let body_filename_of_filename =
- function
-    Some f -> Some (f ^ ".body")
-  | None   -> None
-;;
-
-let types_filename_of_filename =
- function
-    Some f -> Some (f ^ ".types")
-  | None   -> None
-;;
-
-let prooftree_filename_of_filename =
- function
-    Some f -> Some (f ^ ".proof_tree")
-  | None   -> None
-;;
-
-let theory_filename xml_library_root =
- let module N = Names in
-  match xml_library_root with
-    None -> None  (* stdout *)
-  | Some xml_library_root' ->
-     let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in
-     (* theory from A/B/C/F.v goes into A/B/C/F.theory *)
-     let alltoks = List.rev toks in
-       Some (join_dirs xml_library_root' alltoks ^ ".theory")
-
-let print_object uri obj sigma proof_tree_infos filename =
- (* function to pretty print and compress an XML file *)
-(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *)
- let pp xml filename =
-  Xml.pp xml filename ;
-  match filename with
-     None -> ()
-   | Some fn ->
-      let fn' =
-       let rec escape s n =
-        try
-         let p = String.index_from s n '\'' in
-          String.sub s n (p - n) ^ "\\'" ^ escape s (p+1)
-        with Not_found -> String.sub s n (String.length s - n)
-       in
-        escape fn 0
-      in
-       ignore (Unix.system ("gzip " ^ fn' ^ ".xml"))
- in
-  let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) =
-   Cic2acic.acic_object_of_cic_object sigma obj in
-  let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in
-  let xmltypes =
-   Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in
-  pp xml filename ;
-  begin
-   match xml' with
-      None -> ()
-    | Some xml' -> pp xml' (body_filename_of_filename filename)
-  end ;
-  pp xmltypes (types_filename_of_filename filename) ;
-  match proof_tree_infos with
-     None -> ()
-   | Some (sigma0,proof_tree,proof_tree_to_constr,
-           proof_tree_to_flattened_proof_tree) ->
-      let xmlprooftree =
-       print_proof_tree ()
-        uri sigma0 proof_tree proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids
-      in
-       match xmlprooftree with
-          None -> ()
-        | Some xmlprooftree ->
-           pp xmlprooftree (prooftree_filename_of_filename filename)
-;;
-
-let string_list_of_named_context_list =
- List.map
-  (function (n,_,_) -> Names.string_of_id n)
-;;
-
-(* Function to collect the variables that occur in a term. *)
-(* Used only for variables (since for constants and mutual *)
-(* inductive types this information is already available.  *)
-let find_hyps t =
- let module T = Term in
-  let rec aux l t =
-   match T.kind_of_term t with
-      T.Var id when not (List.mem id l) ->
-       let (_,bo,ty) = Global.lookup_named id in
-        let boids = 
-         match bo with
-            Some bo' -> aux l bo'
-          | None -> l
-        in
-         id::(aux boids ty)
-    | T.Var _
-    | T.Rel _
-    | T.Meta _
-    | T.Evar _
-    | T.Sort _ -> l
-    | T.Cast (te,_, ty) -> aux (aux l te) ty
-    | T.Prod (_,s,t) -> aux (aux l s) t
-    | T.Lambda (_,s,t) -> aux (aux l s) t
-    | T.LetIn (_,s,_,t) -> aux (aux l s) t
-    | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl
-    | T.Const con ->
-       let hyps = (Global.lookup_constant con).Declarations.const_hyps in
-        map_and_filter l hyps @ l
-    | T.Ind ind
-    | T.Construct (ind,_) ->
-       let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in
-        map_and_filter l hyps @ l
-    | T.Case (_,t1,t2,b) ->
-       Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b
-    | T.Fix (_,(_,tys,bodies))
-    | T.CoFix (_,(_,tys,bodies)) ->
-       let r = Array.fold_left (fun i x -> aux i x) l tys in
-        Array.fold_left (fun i x -> aux i x) r bodies
-  and map_and_filter l =
-   function
-      [] -> []
-    | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl)
-    | _::tl -> map_and_filter l tl
-  in
-   aux [] t
-;;
-
-(* Functions to construct an object *)
-
-let mk_variable_obj id body typ =
- let hyps,unsharedbody =
-  match body with
-     None -> [],None
-   | Some bo -> find_hyps bo, Some (Unshare.unshare bo)
- in
-  let hyps' = find_hyps typ @ hyps in
-  let hyps'' = List.map Names.string_of_id hyps' in
-  let variables = search_variables () in
-  let params = filter_params variables hyps'' in
-   Acic.Variable
-    (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 ty in
- let metasenv =
-  List.map
-   (function
-     (n, {Evd.evar_concl = evar_concl ;
-          Evd.evar_hyps = evar_hyps}
-      ) ->
-       (* We map the named context to a rel context and every Var to a Rel *)
-       let final_var_ids,context =
-        let rec aux var_ids =
-         function
-            [] -> var_ids,[]
-          | (n,None,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let t' = Term.subst_vars var_ids t in
-               final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl'
-          | (n,Some b,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let b' = Term.subst_vars var_ids b in
-               (* t will not be exported to XML. Thus no unsharing performed *)
-               final_var_ids,(n, Acic.Def  (Unshare.unshare b',t))::tl'
-        in
-         aux [] (List.rev (Environ.named_context_of_val evar_hyps))
-       in
-        (* We map the named context to a rel context and every Var to a Rel *)
-        (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl))
-   ) (Evarutil.non_instantiated evar_map)
- in
-  let id' = Names.string_of_id id in
-   if metasenv = [] then
-    let ids =
-     Names.Idset.union
-      (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in
-    let hyps0 = Environ.keep_hyps env ids in
-    let hyps = string_list_of_named_context_list hyps0 in
-    (* Variables are the identifiers of the variables in scope *)
-    let variables = search_variables () in
-    let params = filter_params variables hyps in
-     if is_a_variable then
-      Acic.Variable (id',Some bo,unshared_ty,params)
-     else
-      Acic.Constant (id',Some bo,unshared_ty,params)
-   else
-    Acic.CurrentProof (id',metasenv,bo,unshared_ty)
-;;
-
-let mk_constant_obj id bo ty variables hyps =
- let hyps = string_list_of_named_context_list hyps in
- let ty = Unshare.unshare ty in
- let params = filter_params variables hyps in
-  match bo with
-     None ->
-      Acic.Constant (Names.string_of_id id,None,ty,params)
-   | Some c ->
-      Acic.Constant
-       (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)),
-         ty,params)
-;;
-
-let mk_inductive_obj sp mib packs variables nparams hyps finite =
- let module D = Declarations in
-  let hyps = string_list_of_named_context_list hyps in
-  let params = filter_params variables hyps in
-(*  let nparams = extract_nparams packs in *)
-   let tys =
-    let tyno = ref (Array.length packs) in
-    Array.fold_right
-     (fun p i ->
-       decr tyno ;
-       let {D.mind_consnames=consnames ;
-            D.mind_typename=typename } = p
-       in
-        let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
-        let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
-        let cons =
-         (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
-          (Array.mapi
-           (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
-          []
-         )
-        in
-         (typename,finite,Unshare.unshare arity,cons)::i
-     ) packs []
-   in
-    Acic.InductiveDefinition (tys,params,nparams)
-;;
-
-(* The current channel for .theory files *)
-let theory_buffer = Buffer.create 4000;;
-
-let theory_output_string ?(do_not_quote = false) s = 
-  (* prepare for coqdoc post-processing *)
-  let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
-  print_if_verbose s;
-   Buffer.add_string theory_buffer s
-;;
-
-let kind_of_global_goal = function
-  | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition"
-  | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k
-  | Decl_kinds.Local, _ -> assert false
-
-let kind_of_inductive isrecord kn =
- "DEFINITION",
- if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
- then if isrecord then "Record" else "Inductive"
- else "CoInductive"
-;;
-
-let kind_of_variable id =
-  let module DK = Decl_kinds in
-  match Decls.variable_kind id with
-    | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
-    | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
-    | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
-    | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition"
-    | DK.IsProof _ -> "VARIABLE","LocalFact"
-    | _ -> Util.anomaly "Unsupported variable kind"
-;;
-
-let kind_of_constant kn = 
-  let module DK = Decl_kinds in
-  match Decls.constant_kind kn with
-    | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
-    | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
-    | DK.IsAssumption DK.Conjectural ->
-        Pp.warning "Conjecture not supported in dtd (used Declaration instead)";
-        "AXIOM","Declaration"
-    | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
-    | DK.IsDefinition DK.Example -> 
-        Pp.warning "Example not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Coercion ->
-        Pp.warning "Coercion not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.SubClass ->
-        Pp.warning "SubClass not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CanonicalStructure ->
-        Pp.warning "CanonicalStructure not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Fixpoint ->
-        Pp.warning "Fixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CoFixpoint ->
-        Pp.warning "CoFixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Scheme ->
-        Pp.warning "Scheme not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.StructureComponent ->
-        Pp.warning "StructureComponent not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | 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 _ ->
-        Pp.warning "Unsupported theorem kind (used Theorem instead)";
-        "THEOREM",DK.string_of_theorem_kind DK.Theorem
-;;
-
-let kind_of_global r =
-  let module Ln = Libnames in
-  let module DK = Decl_kinds in
-  match r with
-  | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> 
-      let isrecord =
-	try let _ = Recordops.lookup_projections kn in true
-        with Not_found -> false in
-      kind_of_inductive isrecord (fst kn)
-  | Ln.VarRef id -> kind_of_variable id
-  | Ln.ConstRef kn -> kind_of_constant kn
-;;
-
-let print_object_kind uri (xmltag,variation) =
-  let s =
-    Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation
-  in
-  theory_output_string s
-;;
-
-(* print id dest                                                          *)
-(*  where sp   is the qualified identifier (section path) of a            *)
-(*             definition/theorem, variable or inductive definition       *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose identifier is id on dest     *)
-(* Note: it is printed only (and directly) the most cooked available      *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-let print internal glob_ref kind xml_library_root =
- let module D = Declarations in
- let module De = Declare in
- let module G = Global in
- let module N = Names in
- let module Nt = Nametab in
- let module T = Term in
- let module X = Xml in
- let module Ln = Libnames in
-  (* Variables are the identifiers of the variables in scope *)
-  let variables = search_variables () in
-  let tag,obj =
-   match glob_ref with
-      Ln.VarRef id ->
-       (* 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 id)
-       in
-       let (_,body,typ) = G.lookup_named id in
-        Cic2acic.Variable kn,mk_variable_obj id body typ
-    | Ln.ConstRef kn ->
-       let id = N.id_of_label (N.con_label kn) in
-       let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} =
-        G.lookup_constant kn in
-       let typ = Typeops.type_of_constant_type (Global.env()) typ in
-        Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
-    | Ln.IndRef (kn,_) ->
-       let mib = G.lookup_mind kn in
-       let {D.mind_nparams=nparams;
-	    D.mind_packets=packs ;
-            D.mind_hyps=hyps;
-            D.mind_finite=finite} = mib in
-          Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
-    | Ln.ConstructRef _ ->
-       Util.error ("a single constructor cannot be printed in XML")
-  in
-  let fn = filename_of_path xml_library_root tag in
-  let uri = Cic2acic.uri_of_kernel_name tag in
-   if not internal then print_object_kind uri kind;
-   print_object uri obj Evd.empty None fn
-;;
-
-let print_ref qid fn =
-  let ref = Nametab.global qid in
-  print false ref (kind_of_global ref) fn
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-let show_pftreestate internal fn (kind,pftst) id =
- let pf = Tacmach.proof_of_pftreestate pftst in
- let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in
- let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree,
-     unshared_pf
- =
-  Proof2aproof.extract_open_pftreestate pftst in
- let env = Global.env () in
- let obj =
-  mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in
- let uri =
-  match kind with
-     Decl_kinds.Local, _ ->
-      let uri =
-       "cic:/" ^ String.concat "/"
-        (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable)
-      in
-      let kind_of_var = "VARIABLE","LocalFact" in
-       if not internal then print_object_kind uri kind_of_var;
-      uri
-   | Decl_kinds.Global, _ ->
-      let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in
-       if not internal then print_object_kind uri (kind_of_global_goal kind);
-       uri
- in
-  print_object uri obj evar_map
-   (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr,
-    proof_tree_to_flattened_proof_tree)) fn
-;;
-
-let show fn =
- let pftst = Pfedit.get_pftreestate () in
- let (id,kind,_,_) = Pfedit.current_proof_statement () in
-  show_pftreestate false fn (kind,pftst) id
-;;
-
-
-(* Let's register the callbacks *)
-let xml_library_root =
-  try
-   Some (Sys.getenv "COQ_XML_LIBRARY_ROOT")
-  with Not_found -> None
-;;
-
-let proof_to_export = ref None (* holds the proof-tree to export *)
-;;
-
-let _ =
-  Pfedit.set_xml_cook_proof
-   (function pftreestate -> proof_to_export := Some pftreestate)
-;;
-
-let _ =
-  Declare.set_xml_declare_variable
-   (function (sp,kn) ->
-     let id = Libnames.basename sp in
-     print false (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
-     proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_constant
-   (function (internal,kn) ->
-     match !proof_to_export with
-        None ->
-          print internal (Libnames.ConstRef kn) (kind_of_constant kn) 
-	    xml_library_root
-      | Some pftreestate ->
-         (* It is a proof. Let's export it starting from the proof-tree *)
-         (* I saved in the Pfedit.set_xml_cook_proof callback.          *)
-        let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
-         show_pftreestate internal fn pftreestate 
-	  (Names.id_of_label (Names.con_label kn)) ;
-         proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_inductive
-   (function (isrecord,(sp,kn)) ->
-      print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) 
-        xml_library_root)
-;;
-
-let _ =
-  Vernac.set_xml_start_library
-   (function () ->
-     Buffer.reset theory_buffer;
-     theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n";
-     theory_output_string ("<!DOCTYPE html [\n" ^
-      "<!ENTITY % xhtml-lat1.ent    SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^
-      "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^
-      "<!ENTITY % xhtml-symbol.ent  SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^
-      "%xhtml-lat1.ent;\n" ^
-      "%xhtml-special.ent;\n" ^
-      "%xhtml-symbol.ent;\n" ^
-      "]>\n\n");
-     theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n";
-     theory_output_string "<head></head>\n<body>\n")
-;;
-
-let _ =
-  Vernac.set_xml_end_library
-   (function () ->
-      theory_output_string "</body>\n</html>\n";
-      let ofn = theory_filename xml_library_root in
-       begin
-        match ofn with
-           None ->
-             Buffer.output_buffer stdout theory_buffer ;
-         | Some fn ->
-            let ch = open_out (fn ^ ".v") in
-             Buffer.output_buffer ch theory_buffer ;
-             close_out ch;
-            (* dummy glob file *)
-            let ch = open_out (fn ^ ".glob") in
-             close_out ch
-       end ;
-       Option.iter 
-	(fun fn ->
-	  let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in
-	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
-          let command cmd =
-           if Sys.command cmd <> 0 then
-            Util.anomaly ("Error executing \"" ^ cmd ^ "\"")
-          in
-           command (coqdoc^options^" -o "^fn^".xml "^fn^".v");
-           command ("rm "^fn^".v "^fn^".glob");
-           print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n"))
-       ofn)
-;;
-
-let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
-
-let uri_of_dirpath dir =
-  "/" ^ String.concat "/" 
-    (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
-;;
-
-let _ =
-  Lib.set_xml_open_section
-    (fun _ ->
-      let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in
-      theory_output_string ("<ht:SECTION uri=\""^s^"\">"))
-;;
-
-let _ =
-  Lib.set_xml_close_section
-    (fun _ -> theory_output_string "</ht:SECTION>")
-;;
-
-let _ =
-  Library.set_xml_require
-    (fun d -> theory_output_string 
-      (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
-       (uri_of_dirpath d) (Names.string_of_dirpath d)))
-;;
diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli
deleted file mode 100644
index 7c0d31a1..00000000
--- a/contrib/xml/xmlcommand.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*i $Id: xmlcommand.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-(* print_global qid fn                                                    *)
-(*  where qid  is a long name denoting a definition/theorem or            *)
-(*             an inductive definition                                    *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose name is ref on dest          *)
-(* Note: it is printed only (and directly) the most discharged available  *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-val print_ref : Libnames.reference -> string option -> unit
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-val show : string option -> unit
-
-(* set_print_proof_tree f                                      *)
-(*  sets a callback function f to export the proof_tree to XML *)
-val set_print_proof_tree :
-    (string ->
-     Evd.evar_map ->
-     Proof_type.proof_tree ->
-     Term.constr Proof2aproof.ProofTreeHash.t ->
-     Proof_type.proof_tree Proof2aproof.ProofTreeHash.t ->
-     string Acic.CicHash.t -> Xml.token Stream.t) ->
-    unit
diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4
deleted file mode 100644
index 496debe1..00000000
--- a/contrib/xml/xmlentries.ml4
+++ /dev/null
@@ -1,40 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: xmlentries.ml4 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Util;;
-open Vernacinterp;;
-
-open Extend;;
-open Genarg;;
-open Pp;;
-open Pcoq;;
-
-(* File name *)
-
-VERNAC ARGUMENT EXTEND filename
-| [ "File" string(fn) ] -> [ Some fn ]
-| [ ] -> [ None ]
-END
-
-(* Print XML and Show XML *)
-
-VERNAC COMMAND EXTEND Xml
-| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ]
-
-| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ]
-END